1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc. 2 * 3 * This library is free software; you can redistribute it and/or 4 * modify it under the terms of the GNU Lesser General Public 5 * License as published by the Free Software Foundation; either 6 * version 2.1 of the License, or (at your option) any later version. 7 * 8 * This library is distributed in the hope that it will be useful, 9 * but WITHOUT ANY WARRANTY; without even the implied warranty of 10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 11 * Lesser General Public License for more details. 12 * 13 * You should have received a copy of the GNU Lesser General Public 14 * License along with this library; if not, write to the Free Software 15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 16 */ 17 18 19 20 21 #if 0 22 23 /* This whole file is not being compiled. See futures.h for the 24 reason. 25 */ 26 27 #ifdef HAVE_CONFIG_H 28 # include <config.h> 29 #endif 30 31 #include "libguile/_scm.h" 32 #include "libguile/eval.h" 33 #include "libguile/ports.h" 34 #include "libguile/validate.h" 35 #include "libguile/stime.h" 36 #include "libguile/threads.h" 37 38 #include "libguile/futures.h" 39 40 #define LINK(list, obj) \ 41 do { \ 42 SCM_SET_FUTURE_NEXT (obj, list); \ 43 list = obj; \ 44 } while (0) 45 46 #define UNLINK(list, obj) \ 47 do { \ 48 obj = list; \ 49 list = SCM_FUTURE_NEXT (list); \ 50 } while (0) 51 52 scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; 53 54 static SCM futures = SCM_EOL; 55 static SCM young = SCM_EOL; 56 static SCM old = SCM_EOL; 57 static SCM undead = SCM_EOL; 58 59 static long last_switch; 60 61 #ifdef SCM_FUTURES_DEBUG 62 static int n_dead = 0; 63 64 static SCM 65 count (SCM ls) 66 { 67 int n = 0; 68 while (!scm_is_null (ls)) 69 { 70 ++n; 71 ls = SCM_FUTURE_NEXT (ls); 72 } 73 return scm_from_int (n); 74 } 75 76 extern SCM scm_future_cache_status (void); 77 78 SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0, 79 (), 80 "Return a list containing number of futures, youngs, olds, undeads and deads.") 81 #define FUNC_NAME s_scm_future_cache_status 82 { 83 int nd = n_dead; 84 n_dead = 0; 85 return scm_list_5 (count (futures), 86 count (young), 87 count (old), 88 count (undead), 89 scm_from_int (nd)); 90 } 91 #undef FUNC_NAME 92 93 #endif 94 95 SCM *scm_loc_sys_thread_handler; 96 97 SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0, 98 (SCM thunk), 99 "Make a future evaluating THUNK.") 100 #define FUNC_NAME s_scm_make_future 101 { 102 SCM_VALIDATE_THUNK (1, thunk); 103 return scm_i_make_future (thunk); 104 } 105 #undef FUNC_NAME 106 107 static char *s_future = "future"; 108 109 static void 110 cleanup (scm_t_future *future) 111 { 112 scm_i_pthread_mutex_destroy (&future->mutex); 113 scm_i_pthread_cond_destroy (&future->cond); 114 scm_gc_free (future, sizeof (*future), s_future); 115 #ifdef SCM_FUTURES_DEBUG 116 ++n_dead; 117 #endif 118 } 119 120 static SCM 121 future_loop (scm_t_future *future) 122 { 123 scm_i_scm_pthread_mutex_lock (&future->mutex); 124 do { 125 if (future->status == SCM_FUTURE_SIGNAL_ME) 126 scm_i_pthread_cond_broadcast (&future->cond); 127 future->status = SCM_FUTURE_COMPUTING; 128 future->data = (SCM_CLOSUREP (future->data) 129 ? scm_i_call_closure_0 (future->data) 130 : scm_call_0 (future->data)); 131 scm_i_scm_pthread_cond_wait (&future->cond, &future->mutex); 132 } while (!future->die_p); 133 future->status = SCM_FUTURE_DEAD; 134 scm_i_pthread_mutex_unlock (&future->mutex); 135 return SCM_UNSPECIFIED; 136 } 137 138 static SCM 139 future_handler (scm_t_future *future, SCM key, SCM args) 140 { 141 future->status = SCM_FUTURE_DEAD; 142 scm_i_pthread_mutex_unlock (&future->mutex); 143 return scm_apply_1 (*scm_loc_sys_thread_handler, key, args); 144 } 145 146 static SCM 147 alloc_future (SCM thunk) 148 { 149 scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future); 150 SCM future; 151 f->data = SCM_BOOL_F; 152 scm_i_pthread_mutex_init (&f->mutex, NULL); 153 scm_i_pthread_cond_init (&f->cond, NULL); 154 f->die_p = 0; 155 f->status = SCM_FUTURE_TASK_ASSIGNED; 156 scm_i_scm_pthread_mutex_lock (&future_admin_mutex); 157 SCM_NEWSMOB2 (future, scm_tc16_future, futures, f); 158 SCM_SET_FUTURE_DATA (future, thunk); 159 futures = future; 160 scm_i_pthread_mutex_unlock (&future_admin_mutex); 161 scm_spawn_thread ((scm_t_catch_body) future_loop, 162 SCM_FUTURE (future), 163 (scm_t_catch_handler) future_handler, 164 SCM_FUTURE (future)); 165 return future; 166 } 167 168 static void 169 kill_future (SCM future) 170 { 171 SCM_FUTURE (future)->die_p = 1; 172 LINK (undead, future); 173 } 174 175 SCM 176 scm_i_make_future (SCM thunk) 177 { 178 SCM future; 179 scm_i_scm_pthread_mutex_lock (&future_admin_mutex); 180 while (1) 181 { 182 if (!scm_is_null (old)) 183 UNLINK (old, future); 184 else if (!scm_is_null (young)) 185 UNLINK (young, future); 186 else 187 { 188 scm_i_pthread_mutex_unlock (&future_admin_mutex); 189 return alloc_future (thunk); 190 } 191 if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future))) 192 kill_future (future); 193 else if (!SCM_FUTURE_ALIVE_P (future)) 194 { 195 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future)); 196 cleanup (SCM_FUTURE (future)); 197 } 198 else 199 break; 200 } 201 LINK (futures, future); 202 scm_i_pthread_mutex_unlock (&future_admin_mutex); 203 SCM_SET_FUTURE_DATA (future, thunk); 204 SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED); 205 scm_i_pthread_cond_signal (SCM_FUTURE_COND (future)); 206 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future)); 207 return future; 208 } 209 210 static SCM 211 future_mark (SCM ptr) { 212 return SCM_FUTURE_DATA (ptr); 213 } 214 215 static int 216 future_print (SCM exp, SCM port, scm_print_state *pstate) 217 { 218 int writingp = SCM_WRITINGP (pstate); 219 scm_puts ("#<future ", port); 220 SCM_SET_WRITINGP (pstate, 1); 221 scm_iprin1 (SCM_FUTURE_DATA (exp), port, pstate); 222 SCM_SET_WRITINGP (pstate, writingp); 223 scm_putc ('>', port); 224 return !0; 225 } 226 227 SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0, 228 (SCM future), 229 "If the future @var{x} has not been computed yet, compute and\n" 230 "return @var{x}, otherwise just return the previously computed\n" 231 "value.") 232 #define FUNC_NAME s_scm_future_ref 233 { 234 SCM res; 235 SCM_VALIDATE_FUTURE (1, future); 236 scm_i_scm_pthread_mutex_lock (SCM_FUTURE_MUTEX (future)); 237 if (SCM_FUTURE_STATUS (future) != SCM_FUTURE_COMPUTING) 238 { 239 SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_SIGNAL_ME); 240 scm_i_scm_pthread_cond_wait (SCM_FUTURE_COND (future), 241 SCM_FUTURE_MUTEX (future)); 242 } 243 if (!SCM_FUTURE_ALIVE_P (future)) 244 { 245 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future)); 246 SCM_MISC_ERROR ("requesting result from failed future ~A", 247 scm_list_1 (future)); 248 } 249 res = SCM_FUTURE_DATA (future); 250 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future)); 251 return res; 252 } 253 #undef FUNC_NAME 254 255 static void 256 kill_futures (SCM victims) 257 { 258 while (!scm_is_null (victims)) 259 { 260 SCM future; 261 UNLINK (victims, future); 262 kill_future (future); 263 scm_i_pthread_cond_signal (SCM_FUTURE_COND (future)); 264 } 265 } 266 267 static void 268 cleanup_undead () 269 { 270 SCM next = undead, *nextloc = &undead; 271 while (!scm_is_null (next)) 272 { 273 if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next))) 274 goto next; 275 else if (SCM_FUTURE_ALIVE_P (next)) 276 { 277 scm_i_pthread_cond_signal (SCM_FUTURE_COND (next)); 278 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next)); 279 next: 280 SCM_SET_GC_MARK (next); 281 nextloc = SCM_FUTURE_NEXTLOC (next); 282 next = *nextloc; 283 } 284 else 285 { 286 SCM future; 287 UNLINK (next, future); 288 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future)); 289 cleanup (SCM_FUTURE (future)); 290 *nextloc = next; 291 } 292 } 293 } 294 295 static void 296 mark_futures (SCM futures) 297 { 298 while (!scm_is_null (futures)) 299 { 300 SCM_SET_GC_MARK (futures); 301 futures = SCM_FUTURE_NEXT (futures); 302 } 303 } 304 305 static void * 306 scan_futures (void *dummy1, void *dummy2, void *dummy3) 307 { 308 SCM next, *nextloc; 309 310 long now = scm_c_get_internal_run_time (); 311 if (now - last_switch > SCM_TIME_UNITS_PER_SECOND) 312 { 313 /* switch out old (> 1 sec), unused futures */ 314 kill_futures (old); 315 old = young; 316 young = SCM_EOL; 317 last_switch = now; 318 } 319 else 320 mark_futures (young); 321 322 next = futures; 323 nextloc = &futures; 324 while (!scm_is_null (next)) 325 { 326 if (!SCM_GC_MARK_P (next)) 327 goto free; 328 keep: 329 nextloc = SCM_FUTURE_NEXTLOC (next); 330 next = *nextloc; 331 } 332 goto exit; 333 while (!scm_is_null (next)) 334 { 335 if (SCM_GC_MARK_P (next)) 336 { 337 *nextloc = next; 338 goto keep; 339 } 340 free: 341 { 342 SCM future; 343 UNLINK (next, future); 344 SCM_SET_GC_MARK (future); 345 LINK (young, future); 346 } 347 } 348 *nextloc = SCM_EOL; 349 exit: 350 cleanup_undead (); 351 mark_futures (old); 352 return 0; 353 } 354 355 scm_t_bits scm_tc16_future; 356 357 void 358 scm_init_futures () 359 { 360 last_switch = scm_c_get_internal_run_time (); 361 362 scm_loc_sys_thread_handler 363 = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F)); 364 365 scm_tc16_future = scm_make_smob_type ("future", 0); 366 scm_set_smob_mark (scm_tc16_future, future_mark); 367 scm_set_smob_print (scm_tc16_future, future_print); 368 369 scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0); 370 #include "libguile/futures.x" 371 } 372 373 #endif 374 375 /* 376 Local Variables: 377 c-file-style: "gnu" 378 End: 379 */ 380