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);
}
|