libguile/continuations.c

   1 /*      Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include "_scm.h"
  49 #include "root.h"
  50 #include "stackchk.h"
  51 #ifdef DEBUG_EXTENSIONS
  52 #include "debug.h"
  53 #endif
  54 #include "dynwind.h"
  55
  56 #include "continuations.h"
  57 \f
  58
  59 /* {Continuations}
  60  */
  61
  62 static char s_cont[] = "continuation";
  63
  64
  65 SCM
  66 scm_make_cont (SCM *answer)
  67 {
  68   long j;
  69   SCM cont;
  70
  71 #ifdef CHEAP_CONTINUATIONS
  72   SCM_NEWCELL (cont);
  73   *answer = cont;
  74   SCM_ENTER_A_SECTION;
  75   SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (scm_contregs), s_cont));
  76   SCM_DYNENV (cont) = scm_dynwinds;
  77   SCM_THROW_VALUE = SCM_EOL;
  78   SCM_BASE (cont) = SCM_BASE (rootcont);
  79   SCM_SEQ (cont) = SCM_SEQ (rootcont);
  80   SCM_SETCAR (cont, scm_tc7_contin);
  81   SCM_EXIT_A_SECTION;
  82 #else
  83   register SCM_STACKITEM *src, *dst;
  84
  85 #if 0
  86   {
  87     SCM winds;
  88
  89     for (winds = scm_dynwinds; winds != SCM_EOL; winds = SCM_CDR (winds))
  90       {
  91         if (SCM_INUMP (SCM_CAR (winds)))
  92           {
  93             scm_relocate_chunk_to_heap (SCM_CAR (winds));
  94           }
  95       }
  96   }
  97 #endif
  98
  99   SCM_NEWCELL (cont);
 100   *answer = cont;
 101   SCM_ENTER_A_SECTION;
 102   SCM_FLUSH_REGISTER_WINDOWS;
 103   j = scm_stack_size (SCM_BASE (scm_rootcont));
 104   SCM_SETJMPBUF (cont,
 105              scm_must_malloc ((long) (sizeof (scm_contregs) + j * sizeof (SCM_STACKITEM)),
 106                               s_cont));
 107   SCM_DYNENV (cont) = scm_dynwinds;
 108   SCM_THROW_VALUE (cont) = SCM_EOL;
 109   src = SCM_BASE (cont) = SCM_BASE (scm_rootcont);
 110   SCM_SEQ (cont) = SCM_SEQ (scm_rootcont);
 111   SCM_SETLENGTH (cont, j, scm_tc7_contin);
 112   SCM_EXIT_A_SECTION;
 113 #ifndef SCM_STACK_GROWS_UP
 114   src -= SCM_LENGTH (cont);
 115 #endif /* ndef SCM_STACK_GROWS_UP */
 116   dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs));
 117   for (j = SCM_LENGTH (cont); 0 <= --j;)
 118     *dst++ = *src++;
 119 #endif /* def CHEAP_CONTINUATIONS */
 120 #ifdef DEBUG_EXTENSIONS
 121   SCM_DFRAME (cont) = scm_last_debug_frame;
 122 #endif
 123   return cont;
 124 }
 125
 126 /* Grow the stack so that there is room */
 127 /* to copy in the continuation.  Then */
 128 #ifndef CHEAP_CONTINUATIONS
 129
 130 static void
 131 grow_throw (SCM *a)
 132 {                               /* retry the throw. */
 133   SCM growth[100];
 134   growth[0] = a[0];
 135   growth[1] = a[1];
 136   growth[2] = a[2] + 1;
 137   growth[3] = (SCM) a;
 138   scm_dynthrow (growth);
 139 }
 140 #endif /* ndef CHEAP_CONTINUATIONS */
 141
 142
 143 void
 144 scm_dynthrow (SCM *a)
 145 {
 146   SCM cont = a[0], val = a[1];
 147 #ifndef CHEAP_CONTINUATIONS
 148   register long j;
 149   register SCM_STACKITEM *src, *dst = SCM_BASE (scm_rootcont);
 150 #ifdef SCM_STACK_GROWS_UP
 151   if (a[2] && (a - ((SCM *) a[3]) < 100))
 152 #else
 153   if (a[2] && (((SCM *) a[3]) - a < 100))
 154 #endif
 155     fputs ("grow_throw: check if SCM growth[100]; being optimized out\n",
 156            stderr);
 157   /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n",
 158                           a[2], (((SCM *)a[3]) - a)); */
 159 #ifdef SCM_STACK_GROWS_UP
 160   if (SCM_PTR_GE (dst + SCM_LENGTH (cont), (SCM_STACKITEM *) & a))
 161     grow_throw (a);
 162 #else
 163   dst -= SCM_LENGTH (cont);
 164   if (SCM_PTR_LE (dst, (SCM_STACKITEM *) & a))
 165     grow_throw (a);
 166 #endif /* def SCM_STACK_GROWS_UP */
 167   SCM_FLUSH_REGISTER_WINDOWS;
 168   src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs));
 169   for (j = SCM_LENGTH (cont); 0 <= --j;)
 170     *dst++ = *src++;
 171 #ifdef sparc                    /* clear out stack up to this stackframe */
 172   /* maybe this would help, maybe not */
 173 /*      bzero((void *)&a, sizeof(SCM_STACKITEM) * (((SCM_STACKITEM *)&a) -
 174                                                (dst - SCM_LENGTH(cont)))) */
 175 #endif
 176 #endif /* ndef CHEAP_CONTINUATIONS */
 177 #ifdef DEBUG_EXTENSIONS
 178   scm_last_debug_frame = SCM_DFRAME (cont);
 179 #endif
 180   SCM_THROW_VALUE(cont) = val;
 181   longjmp (SCM_JMPBUF (cont), 1);
 182 }
 183
 184
 185 SCM
 186 scm_call_continuation (SCM cont, SCM val)
 187 {
 188   SCM a[3];
 189   a[0] = cont;
 190   a[1] = val;
 191   a[2] = 0;
 192   if (   (SCM_SEQ (cont) != SCM_SEQ (scm_rootcont))
 193       || (SCM_BASE (cont) != SCM_BASE (scm_rootcont)))  /* base compare not needed */
 194     scm_wta (cont, "continuation from wrong top level", s_cont);
 195
 196   scm_dowinds (SCM_DYNENV (cont),
 197                scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont)));
 198
 199   scm_dynthrow (a);
 200   return SCM_UNSPECIFIED; /* not reached */
 201 }
 202
 203
 204
 205 void
 206 scm_init_continuations ()
 207 {
 208 #include "continuations.x"
 209 }
 210
 211
 212 /*
 213   Local Variables:
 214   c-file-style: "gnu"
 215   End:
 216 */