← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/futures.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libguile/futures.c
 
1
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006 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
#include "libguile/_scm.h"
 
28
#include "libguile/eval.h"
 
29
#include "libguile/ports.h"
 
30
#include "libguile/validate.h"
 
31
#include "libguile/stime.h"
 
32
#include "libguile/threads.h"
 
33
 
 
34
#include "libguile/futures.h"
 
35
 
 
36
#define LINK(list, obj)                         \
 
37
do {                                            \
 
38
  SCM_SET_FUTURE_NEXT (obj, list);              \
 
39
  list = obj;                                   \
 
40
} while (0)
 
41
 
 
42
#define UNLINK(list, obj)                       \
 
43
do {                                            \
 
44
  obj = list;                                   \
 
45
  list = SCM_FUTURE_NEXT (list);                \
 
46
} while (0)
 
47
     
 
48
scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
49
 
 
50
static SCM futures = SCM_EOL;
 
51
static SCM young = SCM_EOL;
 
52
static SCM old = SCM_EOL;
 
53
static SCM undead = SCM_EOL;
 
54
 
 
55
static long last_switch;
 
56
 
 
57
#ifdef SCM_FUTURES_DEBUG
 
58
static int n_dead = 0;
 
59
 
 
60
static SCM
 
61
count (SCM ls)
 
62
{
 
63
  int n = 0;
 
64
  while (!scm_is_null (ls))
 
65
    {
 
66
      ++n;
 
67
      ls = SCM_FUTURE_NEXT (ls);
 
68
    }
 
69
  return scm_from_int (n);
 
70
}
 
71
 
 
72
extern SCM scm_future_cache_status (void);
 
73
 
 
74
SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0,
 
75
            (),
 
76
            "Return a list containing number of futures, youngs, olds, undeads and deads.")
 
77
#define FUNC_NAME s_scm_future_cache_status
 
78
{
 
79
  int nd = n_dead;
 
80
  n_dead = 0;
 
81
  return scm_list_5 (count (futures),
 
82
                     count (young),
 
83
                     count (old),
 
84
                     count (undead),
 
85
                     scm_from_int (nd));
 
86
}
 
87
#undef FUNC_NAME
 
88
 
 
89
#endif
 
90
 
 
91
SCM *scm_loc_sys_thread_handler;
 
92
 
 
93
SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0,
 
94
            (SCM thunk),
 
95
            "Make a future evaluating THUNK.")
 
96
#define FUNC_NAME s_scm_make_future
 
97
{
 
98
  SCM_VALIDATE_THUNK (1, thunk);
 
99
  return scm_i_make_future (thunk);
 
100
}
 
101
#undef FUNC_NAME
 
102
 
 
103
static char *s_future = "future";
 
104
 
 
105
static void
 
106
cleanup (scm_t_future *future)
 
107
{
 
108
  scm_i_pthread_mutex_destroy (&future->mutex);
 
109
  scm_i_pthread_cond_destroy (&future->cond);
 
110
  scm_gc_free (future, sizeof (*future), s_future);
 
111
#ifdef SCM_FUTURES_DEBUG
 
112
  ++n_dead;
 
113
#endif
 
114
}
 
115
 
 
116
static SCM
 
117
future_loop (scm_t_future *future)
 
118
{
 
119
  scm_i_scm_pthread_mutex_lock (&future->mutex);
 
120
  do {
 
121
    if (future->status == SCM_FUTURE_SIGNAL_ME)
 
122
      scm_i_pthread_cond_broadcast (&future->cond);
 
123
    future->status = SCM_FUTURE_COMPUTING;
 
124
    future->data = (SCM_CLOSUREP (future->data)
 
125
                    ? scm_i_call_closure_0 (future->data)
 
126
                    : scm_call_0 (future->data));
 
127
    scm_i_scm_pthread_cond_wait (&future->cond, &future->mutex);
 
128
  } while (!future->die_p);
 
129
  future->status = SCM_FUTURE_DEAD;
 
130
  scm_i_pthread_mutex_unlock (&future->mutex);
 
131
  return SCM_UNSPECIFIED;
 
132
}
 
133
 
 
134
static SCM
 
135
future_handler (scm_t_future *future, SCM key, SCM args)
 
136
{
 
137
  future->status = SCM_FUTURE_DEAD;
 
138
  scm_i_pthread_mutex_unlock (&future->mutex);
 
139
  return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
 
140
}
 
141
 
 
142
static SCM
 
143
alloc_future (SCM thunk)
 
144
{
 
145
  scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future);
 
146
  SCM future;
 
147
  f->data = SCM_BOOL_F;
 
148
  scm_i_pthread_mutex_init (&f->mutex, NULL);
 
149
  scm_i_pthread_cond_init (&f->cond, NULL);
 
150
  f->die_p = 0;
 
151
  f->status = SCM_FUTURE_TASK_ASSIGNED;
 
152
  scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
 
153
  SCM_NEWSMOB2 (future, scm_tc16_future, futures, f);
 
154
  SCM_SET_FUTURE_DATA (future, thunk);
 
155
  futures = future;
 
156
  scm_i_pthread_mutex_unlock (&future_admin_mutex);
 
157
  scm_spawn_thread ((scm_t_catch_body) future_loop,
 
158
                    SCM_FUTURE (future),
 
159
                    (scm_t_catch_handler) future_handler,
 
160
                    SCM_FUTURE (future));
 
161
  return future;
 
162
}
 
163
 
 
164
static void
 
165
kill_future (SCM future)
 
166
{
 
167
  SCM_FUTURE (future)->die_p = 1;
 
168
  LINK (undead, future);
 
169
}
 
170
 
 
171
SCM
 
172
scm_i_make_future (SCM thunk)
 
173
{
 
174
  SCM future;
 
175
  scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
 
176
  while (1)
 
177
    {
 
178
      if (!scm_is_null (old))
 
179
        UNLINK (old, future);
 
180
      else if (!scm_is_null (young))
 
181
        UNLINK (young, future);
 
182
      else
 
183
        {
 
184
          scm_i_pthread_mutex_unlock (&future_admin_mutex);
 
185
          return alloc_future (thunk);
 
186
        }
 
187
      if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
 
188
        kill_future (future);
 
189
      else if (!SCM_FUTURE_ALIVE_P (future))
 
190
        {
 
191
          scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 
192
          cleanup (SCM_FUTURE (future));
 
193
        }
 
194
      else
 
195
        break;
 
196
    }
 
197
  LINK (futures, future);
 
198
  scm_i_pthread_mutex_unlock (&future_admin_mutex);
 
199
  SCM_SET_FUTURE_DATA (future, thunk);
 
200
  SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED);
 
201
  scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
 
202
  scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 
203
  return future;
 
204
}
 
205
 
 
206
static SCM
 
207
future_mark (SCM ptr) {
 
208
  return SCM_FUTURE_DATA (ptr);
 
209
}
 
210
 
 
211
static int 
 
212
future_print (SCM exp, SCM port, scm_print_state *pstate)
 
213
{
 
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);
 
220
  return !0;
 
221
}
 
222
 
 
223
SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
 
224
            (SCM future),
 
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"
 
227
            "value.")
 
228
#define FUNC_NAME s_scm_future_ref
 
229
{
 
230
  SCM res;
 
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)
 
234
    {
 
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));
 
238
    }
 
239
  if (!SCM_FUTURE_ALIVE_P (future))
 
240
    {
 
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));
 
244
    }
 
245
  res = SCM_FUTURE_DATA (future);
 
246
  scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 
247
  return res;
 
248
}
 
249
#undef FUNC_NAME
 
250
 
 
251
static void
 
252
kill_futures (SCM victims)
 
253
{
 
254
  while (!scm_is_null (victims))
 
255
    {
 
256
      SCM future;
 
257
      UNLINK (victims, future);
 
258
      kill_future (future);
 
259
      scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
 
260
    }
 
261
}
 
262
 
 
263
static void
 
264
cleanup_undead ()
 
265
{
 
266
  SCM next = undead, *nextloc = &undead;
 
267
  while (!scm_is_null (next))
 
268
    {
 
269
      if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next)))
 
270
        goto next;
 
271
      else if (SCM_FUTURE_ALIVE_P (next))
 
272
        {
 
273
          scm_i_pthread_cond_signal (SCM_FUTURE_COND (next));
 
274
          scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
 
275
        next:
 
276
          SCM_SET_GC_MARK (next);
 
277
          nextloc = SCM_FUTURE_NEXTLOC (next);
 
278
          next = *nextloc;
 
279
        }
 
280
      else
 
281
        {
 
282
          SCM future;
 
283
          UNLINK (next, future);
 
284
          scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 
285
          cleanup (SCM_FUTURE (future));
 
286
          *nextloc = next;
 
287
        }
 
288
    }
 
289
}
 
290
 
 
291
static void
 
292
mark_futures (SCM futures)
 
293
{
 
294
  while (!scm_is_null (futures))
 
295
    {
 
296
      SCM_SET_GC_MARK (futures);
 
297
      futures = SCM_FUTURE_NEXT (futures);
 
298
    }
 
299
}
 
300
 
 
301
static void *
 
302
scan_futures (void *dummy1, void *dummy2, void *dummy3)
 
303
{
 
304
  SCM next, *nextloc;
 
305
  
 
306
  long now = scm_c_get_internal_run_time ();
 
307
  if (now - last_switch > SCM_TIME_UNITS_PER_SECOND)
 
308
    {
 
309
      /* switch out old (> 1 sec), unused futures */
 
310
      kill_futures (old);
 
311
      old = young;
 
312
      young = SCM_EOL;
 
313
      last_switch = now;
 
314
    }
 
315
  else
 
316
    mark_futures (young);    
 
317
 
 
318
  next = futures;
 
319
  nextloc = &futures;
 
320
  while (!scm_is_null (next))
 
321
    {
 
322
      if (!SCM_GC_MARK_P (next))
 
323
        goto free;
 
324
    keep:
 
325
      nextloc = SCM_FUTURE_NEXTLOC (next);
 
326
      next = *nextloc;
 
327
    }
 
328
  goto exit;
 
329
  while (!scm_is_null (next))
 
330
    {
 
331
      if (SCM_GC_MARK_P (next))
 
332
        {
 
333
          *nextloc = next;
 
334
          goto keep;
 
335
        }
 
336
    free:
 
337
      {
 
338
        SCM future;
 
339
        UNLINK (next, future);
 
340
        SCM_SET_GC_MARK (future);
 
341
        LINK (young, future);
 
342
      }
 
343
    }
 
344
  *nextloc = SCM_EOL;
 
345
 exit:
 
346
  cleanup_undead ();
 
347
  mark_futures (old);
 
348
  return 0;
 
349
}
 
350
 
 
351
scm_t_bits scm_tc16_future;
 
352
 
 
353
void
 
354
scm_init_futures ()
 
355
{
 
356
  last_switch = scm_c_get_internal_run_time ();
 
357
  
 
358
  scm_loc_sys_thread_handler
 
359
    = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F));
 
360
 
 
361
  scm_tc16_future = scm_make_smob_type ("future", 0);
 
362
  scm_set_smob_mark (scm_tc16_future, future_mark);
 
363
  scm_set_smob_print (scm_tc16_future, future_print);
 
364
 
 
365
  scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0);
 
366
#include "libguile/futures.x"
 
367
}
 
368
 
 
369
#endif
 
370
 
 
371
/*
 
372
  Local Variables:
 
373
  c-file-style: "gnu"
 
374
  End:
 
375
*/