1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
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.
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.
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
23 /* This whole file is not being compiled. See futures.h for the
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"
38 #include "libguile/futures.h"
40 #define LINK(list, obj) \
42 SCM_SET_FUTURE_NEXT (obj, list); \
46 #define UNLINK(list, obj) \
49 list = SCM_FUTURE_NEXT (list); \
52 scm_i_pthread_mutex_t future_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
54 static SCM futures
= SCM_EOL
;
55 static SCM young
= SCM_EOL
;
56 static SCM old
= SCM_EOL
;
57 static SCM undead
= SCM_EOL
;
59 static long last_switch
;
61 #ifdef SCM_FUTURES_DEBUG
62 static int n_dead
= 0;
68 while (!scm_is_null (ls
))
71 ls
= SCM_FUTURE_NEXT (ls
);
73 return scm_from_int (n
);
76 extern SCM
scm_future_cache_status (void);
78 SCM_DEFINE (scm_future_cache_status
, "future-cache-status", 0, 0, 0,
80 "Return a list containing number of futures, youngs, olds, undeads and deads.")
81 #define FUNC_NAME s_scm_future_cache_status
85 return scm_list_5 (count (futures
),
95 SCM
*scm_loc_sys_thread_handler
;
97 SCM_DEFINE (scm_make_future
, "make-future", 1, 0, 0,
99 "Make a future evaluating THUNK.")
100 #define FUNC_NAME s_scm_make_future
102 SCM_VALIDATE_THUNK (1, thunk
);
103 return scm_i_make_future (thunk
);
107 static char *s_future
= "future";
110 cleanup (scm_t_future
*future
)
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
121 future_loop (scm_t_future
*future
)
123 scm_i_scm_pthread_mutex_lock (&future
->mutex
);
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
;
139 future_handler (scm_t_future
*future
, SCM key
, SCM args
)
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
);
147 alloc_future (SCM thunk
)
149 scm_t_future
*f
= scm_gc_malloc (sizeof (*f
), s_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
);
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
);
160 scm_i_pthread_mutex_unlock (&future_admin_mutex
);
161 scm_spawn_thread ((scm_t_catch_body
) future_loop
,
163 (scm_t_catch_handler
) future_handler
,
164 SCM_FUTURE (future
));
169 kill_future (SCM future
)
171 SCM_FUTURE (future
)->die_p
= 1;
172 LINK (undead
, future
);
176 scm_i_make_future (SCM thunk
)
179 scm_i_scm_pthread_mutex_lock (&future_admin_mutex
);
182 if (!scm_is_null (old
))
183 UNLINK (old
, future
);
184 else if (!scm_is_null (young
))
185 UNLINK (young
, future
);
188 scm_i_pthread_mutex_unlock (&future_admin_mutex
);
189 return alloc_future (thunk
);
191 if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future
)))
192 kill_future (future
);
193 else if (!SCM_FUTURE_ALIVE_P (future
))
195 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future
));
196 cleanup (SCM_FUTURE (future
));
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
));
211 future_mark (SCM ptr
) {
212 return SCM_FUTURE_DATA (ptr
);
216 future_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
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
);
227 SCM_DEFINE (scm_future_ref
, "future-ref", 1, 0, 0,
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"
232 #define FUNC_NAME s_scm_future_ref
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
)
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
));
243 if (!SCM_FUTURE_ALIVE_P (future
))
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
));
249 res
= SCM_FUTURE_DATA (future
);
250 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future
));
256 kill_futures (SCM victims
)
258 while (!scm_is_null (victims
))
261 UNLINK (victims
, future
);
262 kill_future (future
);
263 scm_i_pthread_cond_signal (SCM_FUTURE_COND (future
));
270 SCM next
= undead
, *nextloc
= &undead
;
271 while (!scm_is_null (next
))
273 if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next
)))
275 else if (SCM_FUTURE_ALIVE_P (next
))
277 scm_i_pthread_cond_signal (SCM_FUTURE_COND (next
));
278 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next
));
280 SCM_SET_GC_MARK (next
);
281 nextloc
= SCM_FUTURE_NEXTLOC (next
);
287 UNLINK (next
, future
);
288 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future
));
289 cleanup (SCM_FUTURE (future
));
296 mark_futures (SCM futures
)
298 while (!scm_is_null (futures
))
300 SCM_SET_GC_MARK (futures
);
301 futures
= SCM_FUTURE_NEXT (futures
);
306 scan_futures (void *dummy1
, void *dummy2
, void *dummy3
)
310 long now
= scm_c_get_internal_run_time ();
311 if (now
- last_switch
> SCM_TIME_UNITS_PER_SECOND
)
313 /* switch out old (> 1 sec), unused futures */
320 mark_futures (young
);
324 while (!scm_is_null (next
))
326 if (!SCM_GC_MARK_P (next
))
329 nextloc
= SCM_FUTURE_NEXTLOC (next
);
333 while (!scm_is_null (next
))
335 if (SCM_GC_MARK_P (next
))
343 UNLINK (next
, future
);
344 SCM_SET_GC_MARK (future
);
345 LINK (young
, future
);
355 scm_t_bits scm_tc16_future
;
360 last_switch
= scm_c_get_internal_run_time ();
362 scm_loc_sys_thread_handler
363 = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F
));
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
);
369 scm_c_hook_add (&scm_before_sweep_c_hook
, scan_futures
, 0, 0);
370 #include "libguile/futures.x"