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
|
/* "continue.c" Scheme Continuations for C.
* 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 Lesser General Public License as
* published by the Free Software Foundation, either version 3 of the
* License, 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
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program. If not, see
* <http://www.gnu.org/licenses/>.
*/
/* 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. */
#ifndef __ia64__
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;
}
#endif
/* 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 SCM 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
#ifndef __ia64__
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 */
#endif
/* 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);
}
|
