libguile/control.c

   1 /* Copyright (C) 2010  Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include "libguile/_scm.h"
  24 #include "libguile/control.h"
  25 #include "libguile/objcodes.h"
  26 #include "libguile/instructions.h"
  27 #include "libguile/vm.h"
  28
  29 \f
  30
  31 SCM
  32 scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p,
  33                    scm_t_int64 vm_cookie)
  34 {
  35   scm_t_bits tag;
  36   SCM ret;
  37   struct scm_prompt_registers *regs;
  38
  39   tag = scm_tc7_prompt;
  40   if (escape_only_p)
  41     tag |= SCM_F_PROMPT_ESCAPE;
  42   ret = scm_words (tag, 5);
  43
  44   regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
  45   regs->fp = SCM_VM_DATA (vm)->fp;
  46   regs->sp = SCM_VM_DATA (vm)->sp;
  47   regs->ip = SCM_VM_DATA (vm)->ip;
  48   regs->cookie = vm_cookie;
  49
  50   SCM_SET_CELL_OBJECT (ret, 1, k);
  51   SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
  52   SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());
  53
  54   return ret;
  55 }
  56
  57 #ifdef WORDS_BIGENDIAN
  58 #define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
  59 #define META_HEADER(meta)         0, 0, 0, meta, 0, 0, 0, 0
  60 #else
  61 #define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
  62 #define META_HEADER(meta)         meta, 0, 0, 0, 0,      0, 0, 0
  63 #endif
  64
  65 #define ROUND_UP(len,align) (((len-1)|(align-1))+1)
  66 #define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
  67
  68 #ifdef SCM_ALIGNED
  69 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
  70 static const type sym[]
  71 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
  72 static SCM_ALIGNED (alignment) const type sym[]
  73 #else
  74 #define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
  75 static type *sym
  76 #define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)                  \
  77 SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
  78                sym = ALIGN_PTR (type, sym, alignment);                  \
  79                memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
  80 static type *sym = NULL;                                                \
  81 static const type sym##__unaligned[]
  82 #endif
  83
  84 #define STATIC_OBJCODE_TAG                                      \
  85   SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
  86
  87 #define SCM_STATIC_OBJCODE(sym)                                         \
  88   SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode);      \
  89   SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = {            \
  90     { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) },                 \
  91     { SCM_BOOL_F, SCM_PACK (0) }                                        \
  92   };                                                                    \
  93   static const SCM sym = SCM_PACK (sym##__cells);                       \
  94   SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
  95
  96
  97 SCM_STATIC_OBJCODE (cont_objcode) = {
  98   /* Like in continuations.c, but with partial-cont-call. */
  99   OBJCODE_HEADER (8, 19),
 100   /* leave args on the stack */
 101   /* 0 */ scm_op_object_ref, 0, /* push scm_vm_cont object */
 102   /* 2 */ scm_op_object_ref, 1, /* push internal winds */
 103   /* 4 */ scm_op_object_ref, 2, /* push external winds */
 104   /* 6 */ scm_op_partial_cont_call, /* and go! */
 105   /* 7 */ scm_op_nop, /* pad to 8 bytes */
 106   /* 8 */
 107
 108   /* We could put some meta-info to say that this proc is a continuation. Not sure
 109      how to do that, though. */
 110   META_HEADER (19),
 111   /* 0 */ scm_op_make_eol, /* bindings */
 112   /* 1 */ scm_op_make_eol, /* sources */
 113   /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 7, /* arity: from ip 0 to ip 7 */
 114   /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
 115   /* 7 */ scm_op_make_int8_0, /* 0 optionals */
 116   /* 8 */ scm_op_make_true, /* and a rest arg */
 117   /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
 118   /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
 119   /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
 120   /* 18 */ scm_op_return /* and return */
 121   /* 19 */
 122 };
 123
 124
 125 static SCM
 126 reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
 127                             scm_t_int64 cookie)
 128 {
 129   SCM vm_cont, dynwinds, intwinds = SCM_EOL, ret;
 130   scm_t_uint32 flags;
 131
 132   /* No need to reify if the continuation is never referenced in the handler. */
 133   if (SCM_PROMPT_ESCAPE_P (prompt))
 134     return SCM_BOOL_F;
 135
 136   dynwinds = scm_i_dynwinds ();
 137   while (!scm_is_eq (dynwinds, extwinds))
 138     {
 139       intwinds = scm_cons (scm_car (dynwinds), intwinds);
 140       dynwinds = scm_cdr (dynwinds);
 141     }
 142
 143   flags = SCM_F_VM_CONT_PARTIAL;
 144   if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
 145     flags |= SCM_F_VM_CONT_REWINDABLE;
 146
 147   /* NULL RA and MVRA, as those get set when the cont is reinstated */
 148   vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp,
 149                                     SCM_VM_DATA (vm)->fp,
 150                                     SCM_VM_DATA (vm)->sp,
 151                                     NULL, NULL,
 152                                     flags);
 153
 154   ret = scm_make_program (cont_objcode,
 155                           scm_vector (scm_list_3 (vm_cont, intwinds, extwinds)),
 156                           SCM_BOOL_F);
 157   SCM_SET_CELL_WORD_0 (ret,
 158                        SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION);
 159   return ret;
 160 }
 161
 162 SCM
 163 scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
 164 {
 165   SCM cont, winds, prompt = SCM_BOOL_F;
 166   long delta;
 167   size_t i;
 168
 169   /* Search the wind list for an appropriate prompt.
 170      "Waiter, please bring us the wind list." */
 171   for (winds = scm_i_dynwinds (), delta = 0;
 172        scm_is_pair (winds);
 173        winds = SCM_CDR (winds), delta++)
 174     {
 175       SCM elt = SCM_CAR (winds);
 176       if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag))
 177         {
 178           prompt = elt;
 179           break;
 180         }
 181     }
 182
 183   /* If we didn't find anything, print a message and abort the process
 184      right here.  If you don't want this, establish a catch-all around
 185      any code that might throw up. */
 186   if (scm_is_false (prompt))
 187     {
 188       /* FIXME: jump to default */
 189       /* scm_handle_by_message (NULL, key, args); */
 190       abort ();
 191     }
 192
 193   cont = reify_partial_continuation (vm, prompt, winds, cookie);
 194
 195   /* Unwind once more, beyond the prompt. */
 196   winds = SCM_CDR (winds), delta++;
 197
 198   /* Unwind */
 199   scm_dowinds (winds, delta);
 200
 201   /* Restore VM regs */
 202   SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
 203   SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;
 204   SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip;
 205
 206   /* Since we're jumping down, we should always have enough space */
 207   if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
 208     abort ();
 209
 210   /* Push vals */
 211   *(++(SCM_VM_DATA (vm)->sp)) = cont;
 212   for (i = 0; i < n; i++)
 213     *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
 214   *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
 215
 216   /* Jump! */
 217   SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1);
 218
 219   /* Shouldn't get here */
 220   abort ();
 221 }
 222
 223 SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
 224             "Abort to the nearest prompt with tag @var{tag}.")
 225 #define FUNC_NAME s_scm_at_abort
 226 {
 227   SCM *argv;
 228   size_t i, n;
 229
 230   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
 231   argv = alloca (sizeof (SCM)*n);
 232   for (i = 0; i < n; i++, args = scm_cdr (args))
 233     argv[i] = scm_car (args);
 234
 235   scm_c_abort (scm_the_vm (), tag, n, argv, -1);
 236
 237   /* Oh, what, you're still here? The abort must have been reinstated. Actually,
 238      that's quite impossible, given that we're already in C-land here, so...
 239      abort! */
 240
 241   abort ();
 242 }
 243 #undef FUNC_NAME
 244
 245 void scm_init_control (void)
 246 {
 247 #include "control.x"
 248 }
 249
 250 /*
 251   Local Variables:
 252   c-file-style: "gnu"
 253   End:
 254 */