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
));
212 future_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
214 int writingp
= SCM_WRITINGP (pstate
);
215 scm_puts ("#<future ", port
);
216 SCM_SET_WRITINGP (pstate
, 1);
217 scm_iprin1 (SCM_FUTURE_DATA (exp
), port
, pstate
);
218 SCM_SET_WRITINGP (pstate
, writingp
);
219 scm_putc ('>', port
);
223 SCM_DEFINE (scm_future_ref
, "future-ref", 1, 0, 0,
225 "If the future @var{x} has not been computed yet, compute and\n"
226 "return @var{x}, otherwise just return the previously computed\n"
228 #define FUNC_NAME s_scm_future_ref
231 SCM_VALIDATE_FUTURE (1, future
);
232 scm_i_scm_pthread_mutex_lock (SCM_FUTURE_MUTEX (future
));
233 if (SCM_FUTURE_STATUS (future
) != SCM_FUTURE_COMPUTING
)
235 SCM_SET_FUTURE_STATUS (future
, SCM_FUTURE_SIGNAL_ME
);
236 scm_i_scm_pthread_cond_wait (SCM_FUTURE_COND (future
),
237 SCM_FUTURE_MUTEX (future
));
239 if (!SCM_FUTURE_ALIVE_P (future
))
241 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future
));
242 SCM_MISC_ERROR ("requesting result from failed future ~A",
243 scm_list_1 (future
));
245 res
= SCM_FUTURE_DATA (future
);
246 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future
));
252 kill_futures (SCM victims
)
254 while (!scm_is_null (victims
))
257 UNLINK (victims
, future
);
258 kill_future (future
);
259 scm_i_pthread_cond_signal (SCM_FUTURE_COND (future
));
266 SCM next
= undead
, *nextloc
= &undead
;
267 while (!scm_is_null (next
))
269 if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next
)))
271 else if (SCM_FUTURE_ALIVE_P (next
))
273 scm_i_pthread_cond_signal (SCM_FUTURE_COND (next
));
274 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next
));
276 SCM_SET_GC_MARK (next
);
277 nextloc
= SCM_FUTURE_NEXTLOC (next
);
283 UNLINK (next
, future
);
284 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future
));
285 cleanup (SCM_FUTURE (future
));
292 mark_futures (SCM futures
)
294 while (!scm_is_null (futures
))
296 SCM_SET_GC_MARK (futures
);
297 futures
= SCM_FUTURE_NEXT (futures
);
302 scan_futures (void *dummy1
, void *dummy2
, void *dummy3
)
306 long now
= scm_c_get_internal_run_time ();
307 if (now
- last_switch
> SCM_TIME_UNITS_PER_SECOND
)
309 /* switch out old (> 1 sec), unused futures */
316 mark_futures (young
);
320 while (!scm_is_null (next
))
322 if (!SCM_GC_MARK_P (next
))
325 nextloc
= SCM_FUTURE_NEXTLOC (next
);
329 while (!scm_is_null (next
))
331 if (SCM_GC_MARK_P (next
))
339 UNLINK (next
, future
);
340 SCM_SET_GC_MARK (future
);
341 LINK (young
, future
);
351 scm_t_bits scm_tc16_future
;
356 last_switch
= scm_c_get_internal_run_time ();
358 scm_loc_sys_thread_handler
359 = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F
));
361 scm_tc16_future
= scm_make_smob_type ("future", 0);
362 scm_set_smob_print (scm_tc16_future
, future_print
);
364 scm_c_hook_add (&scm_before_sweep_c_hook
, scan_futures
, 0, 0);
365 #include "libguile/futures.x"