aboutsummaryrefslogtreecommitdiffstats
path: root/continue.c
blob: f08f4bcd61d9a5a4f631a445bf1209a5c75d6634 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.
 */

/* "continue.c" Scheme Continuations for C.
   Author: Aubrey Jaffer */

/* "setjump.h" contains definitions for the `other' field (type
   CONTINUATION_OTHER) the struct Continuation.  "setjump.h" must
   #include "continue.h".  CONTINUATION_OTHER defaults to `long' */

#define IN_CONTINUE_C
#ifdef USE_CONTINUE_H
# include "continue.h"
#else
# include "setjump.h"
#endif

/* For platforms with short integers, we use thrown_value instead of
   the value returned from setjump so that any (long) value can be
   returned.  */

#ifdef SHORT_INT
long thrown_value;
#endif

/* stack_size() returns the number of units of size STACKITEM which
   fit between @var{start} and the current top of stack.  No check is
   done in this routine to ensure that @var{start} is actually in the
   current stack segment.  */

long stack_size(start)
     STACKITEM *start;
{
  STACKITEM stack;
#ifdef STACK_GROWS_UP
  return &stack - start;
#else
  return start - &stack;
#endif /* def STACK_GROWS_UP */
}

/* make_root_continuation() allocates (malloc) storage for a
   CONTINUATION near the current extent of stack.  This newly
   allocated CONTINUATION is returned if successful, 0 if not.  After
   make_root_continuation() returns, the calling routine still needs
   to `setjump(new_continuation->jmpbuf)' in order to complete the
   capture of this continuation.  */

CONTINUATION *make_root_continuation(stack_base)
     STACKITEM *stack_base;
{
  CONTINUATION *cont;
  cont = (CONTINUATION *)malloc(sizeof(CONTINUATION));
  if (!cont) return 0;
  cont->length = 0;
  cont->stkbse = stack_base;
  cont->parent = cont;
  return cont;
}

/* make_continuation() allocates storage for the current continuation,
   copying (or encapsulating) the stack state from parent_cont->stkbse
   to the current top of stack.  The newly allocated CONTINUATION is
   returned if successful, 0 if not.  After make_continuation()
   returns, the calling routine still needs to
   `setjump(new_continuation->jmpbuf)' in order to complete the capture
   of this continuation.  */

/* Note: allocating local (stack) storage for the CONTINUATION would
	 not work; Think about it.  */

CONTINUATION *make_continuation(parent_cont)
     CONTINUATION *parent_cont;
{
  CONTINUATION *cont;
#ifdef CHEAP_CONTINUATIONS
  cont = (CONTINUATION *)malloc(sizeof(CONTINUATION));
  if (!cont) return 0;
  cont->length = 0;
  cont->stkbse = parent_cont->stkbse;
#else
  long j;
  register STACKITEM *src, *dst;
  FLUSH_REGISTER_WINDOWS;
  j = stack_size(parent_cont->stkbse);
  cont = (CONTINUATION *)malloc((sizeof(CONTINUATION) + j*sizeof(STACKITEM)));
  if (!cont) return 0;
  cont->length = j;
  cont->stkbse = parent_cont->stkbse;
  src = cont->stkbse;
# ifdef STACK_GROWS_UP
  src += parent_cont->length;
# else
  src -= parent_cont->length + cont->length;
# endif/* ndef STACK_GROWS_UP */
  dst = (STACKITEM *)(cont + 1);
  for (j = cont->length; 0 <= --j; ) *dst++ = *src++;
#endif /* ndef CHEAP_CONTINUATIONS */
  cont->parent = parent_cont;
  return cont;
}

/* free_continuation() is trivial, but who knows what the future
   holds.  */

void free_continuation(cont)
     CONTINUATION *cont;
{
  free(cont);
}

/* Final routine involved in throw()ing to a continuation.  After
   ensuring that there is sufficient room on the stack for the saved
   continuation, dynthrow() copies the continuation onto the stack and
   longjump()s into it.  The routine does not return.  */

/* If you use conservative GC and your Sparc(SUN-4) heap is growing
   out of control:

   You are experiencing a GC problem peculiar to the Sparc.  The
   problem is that contin doesn't know how to clear register windows.
   Every location which is not reused still gets marked at GC time.
   This causes lots of stuff which should be collected to not be.
   This will be a problem with any *conservative* GC until we find
   what instruction will clear the register windows.  This problem is
   exacerbated by using lots of make-CONTINUATION.

   Possibly adding the following before the thrown_value = val; line
   might help to clear out unused stack above the continuation (a
   small part of the problem).

#ifdef sparc
  bzero((void *)&a, sizeof(STACKITEM) *
	(((STACKITEM *)&a) - (dst - cont->length)))
#endif

   Let me know if you try it.  */

/* SCM_GROWTH is how many `long's to grow the stack by when we need room. */
#define SCM_GROWTH 100

void dynthrow(a)
     long *a;
{
  register CONTINUATION *cont = (CONTINUATION *)(a[0]);
  long val = a[1];
#ifndef CHEAP_CONTINUATIONS
  register long j;
  register STACKITEM *src, *dst = cont->stkbse;
# ifdef STACK_GROWS_UP
#  ifndef hpux
  if (a[2] && (a - ((long *)a[3]) < SCM_GROWTH))
    puts("grow_throw: check if long growth[]; being optimized out");
#  endif
  /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
  if PTR_GE(dst + (cont->length), (STACKITEM *)&a) grow_throw(a);
# else
#  ifndef hpux
  if (a[2] && (((long *)a[3]) - a < SCM_GROWTH))
    puts("grow_throw: check if long growth[]; being optimized out");
#  endif
  /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
  dst -= cont->length;
  if PTR_LE(dst, (STACKITEM *)&a) grow_throw(a);
# endif/* def STACK_GROWS_UP */
  FLUSH_REGISTER_WINDOWS;
  src = (STACKITEM *)(cont + 1);
  for (j = cont->length;0 <= --j;) *dst++ = *src++;
#endif /* ndef CHEAP_CONTINUATIONS */
#ifdef SHORT_INT
  thrown_value = val;
  longjump(cont->jmpbuf, 1);
#else
  longjump(cont->jmpbuf, val);
#endif
}

/* grow_throw() grows the stack by SCM_GROWTH long words.  If the
   "sizeof growth" assignment is not sufficient to restrain your
   overly optimistic compiler, the stack will grow by much less and
   grow_throw() and dynthrow() will waste time calling each other.  To
   fix this you will have to compile grow_throw() in a separate file
   so the compiler won't be able to guess that the growth array isn't
   all used.  */

#ifndef CHEAP_CONTINUATIONS
void grow_throw(a)		/* Grow the stack so that there is room */
     long *a;			/* to copy in the continuation.  Then */
{				/* retry the throw.  */
  long growth[SCM_GROWTH];
  growth[0] = a[0];
  growth[1] = a[1];
  growth[2] = a[2] + 1;
  growth[3] = (long) a;
  growth[SCM_GROWTH-1] = sizeof growth;
  dynthrow(growth);
}
#endif /* ndef CHEAP_CONTINUATIONS */

/* throw_to_continuation() restores the stack in effect when
   @var{cont} was made and resumes @var{cont}'s processor state.  If
   the stack cannot be resotred because @var{cont} and @var{root_cont}
   do not have the same stkbase, @code{throw_to_continuation()
   returns.  */

/* Note: If 2 or more @var{cont}s share a parent continuation and if
   the values of stack allocated variables in that parent continuation
   are changed, the results are unspecified.  This is because the
   parent continuation may or may not be reloaded, depending on what
   other throws have intervened.  */

void throw_to_continuation(cont, val, root_cont)
     CONTINUATION *cont;
     long val;
     CONTINUATION *root_cont;
{
  long a[3];
  a[0] = (long)cont;
  a[1] = val;
  a[2] = 0;
  if (cont->stkbse != root_cont->stkbse)
    return;			/* Stale continuation */
  dynthrow(a);
}