diff options
Diffstat (limited to 'SCM/continue.c')
| -rw-r--r-- | SCM/continue.c | 242 |
1 files changed, 242 insertions, 0 deletions
diff --git a/SCM/continue.c b/SCM/continue.c new file mode 100644 index 0000000..1f8c6de --- /dev/null +++ b/SCM/continue.c @@ -0,0 +1,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); +} |