libguile/control.c

   1 /* Copyright (C) 2010, 2011, 2012, 2013  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 <alloca.h>
  24
  25 #include "libguile/_scm.h"
  26 #include "libguile/control.h"
  27 #include "libguile/programs.h"
  28 #include "libguile/instructions.h"
  29 #include "libguile/vm.h"
  30
  31 \f
  32
  33 #define PROMPT_ESCAPE_P(p)                              \
  34   (SCM_DYNSTACK_TAG_FLAGS (SCM_DYNSTACK_TAG (p))        \
  35    & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
  36
  37 \f
  38
  39
  40 /* Only to be called if the SCM_I_SETJMP returns 1 */
  41 SCM
  42 scm_i_prompt_pop_abort_args_x (SCM vm)
  43 {
  44   size_t i, n;
  45   SCM vals = SCM_EOL;
  46
  47   n = scm_to_size_t (SCM_VM_DATA (vm)->sp[0]);
  48   for (i = 0; i < n; i++)
  49     vals = scm_cons (SCM_VM_DATA (vm)->sp[-(i + 1)], vals);
  50
  51   /* The abort did reset the VM's registers, but then these values
  52      were pushed on; so we need to pop them ourselves. */
  53   SCM_VM_DATA (vm)->sp -= n + 1;
  54   /* FIXME NULLSTACK */
  55
  56   return vals;
  57 }
  58
  59
  60 static const scm_t_uint32 compose_continuation_code[] =
  61   {
  62     SCM_PACK_OP_24 (compose_continuation, 0)
  63   };
  64
  65
  66 static SCM
  67 make_partial_continuation (SCM vm_cont)
  68 {
  69   scm_t_bits nfree = 1;
  70   scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
  71   SCM ret;
  72
  73   ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
  74   SCM_SET_CELL_WORD_1 (ret, compose_continuation_code);
  75   SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vm_cont);
  76
  77   return ret;
  78 }
  79
  80 static SCM
  81 reify_partial_continuation (SCM vm,
  82                             SCM *saved_fp,
  83                             SCM *saved_sp,
  84                             scm_t_uint32 *saved_ip,
  85                             scm_i_jmp_buf *saved_registers,
  86                             scm_t_dynstack *dynstack,
  87                             scm_i_jmp_buf *current_registers)
  88 {
  89   SCM vm_cont;
  90   scm_t_uint32 flags;
  91   SCM *bottom_fp;
  92
  93   flags = SCM_F_VM_CONT_PARTIAL;
  94   /* If we are aborting to a prompt that has the same registers as those
  95      of the abort, it means there are no intervening C frames on the
  96      stack, and so the continuation can be relocated elsewhere on the
  97      stack: it is rewindable.  */
  98   if (saved_registers && saved_registers == current_registers)
  99     flags |= SCM_F_VM_CONT_REWINDABLE;
 100
 101   /* Walk the stack down until we find the first frame after saved_fp.
 102      We will save the stack down to that frame.  It used to be that we
 103      could determine the stack bottom in O(1) time, but that's no longer
 104      the case, since the thunk application doesn't occur where the
 105      prompt is saved.  */
 106   for (bottom_fp = SCM_VM_DATA (vm)->fp;
 107        SCM_FRAME_DYNAMIC_LINK (bottom_fp) > saved_fp;
 108        bottom_fp = SCM_FRAME_DYNAMIC_LINK (bottom_fp));
 109
 110   if (SCM_FRAME_DYNAMIC_LINK (bottom_fp) != saved_fp)
 111     abort();
 112
 113   /* Capture from the top of the thunk application frame up to the end. */
 114   vm_cont = scm_i_vm_capture_stack (&SCM_FRAME_LOCAL (bottom_fp, 0),
 115                                     SCM_VM_DATA (vm)->fp,
 116                                     SCM_VM_DATA (vm)->sp,
 117                                     SCM_VM_DATA (vm)->ip,
 118                                     dynstack,
 119                                     flags);
 120
 121   return make_partial_continuation (vm_cont);
 122 }
 123
 124 void
 125 scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
 126              scm_i_jmp_buf *current_registers)
 127 {
 128   SCM cont;
 129   scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
 130   scm_t_bits *prompt;
 131   scm_t_dynstack_prompt_flags flags;
 132   scm_t_ptrdiff fp_offset, sp_offset;
 133   SCM *fp, *sp;
 134   scm_t_uint32 *ip;
 135   scm_i_jmp_buf *registers;
 136   size_t i;
 137
 138   prompt = scm_dynstack_find_prompt (dynstack, tag,
 139                                      &flags, &fp_offset, &sp_offset, &ip,
 140                                      &registers);
 141
 142   if (!prompt)
 143     scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
 144
 145   fp = SCM_VM_DATA (vm)->stack_base + fp_offset;
 146   sp = SCM_VM_DATA (vm)->stack_base + sp_offset;
 147
 148   /* Only reify if the continuation referenced in the handler. */
 149   if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
 150     cont = SCM_BOOL_F;
 151   else
 152     {
 153       scm_t_dynstack *captured;
 154
 155       captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
 156       cont = reify_partial_continuation (vm, fp, sp, ip, registers, captured,
 157                                          current_registers);
 158     }
 159
 160   /* Unwind.  */
 161   scm_dynstack_unwind (dynstack, prompt);
 162
 163   /* Unwinding may have changed the current thread's VM, so use the
 164      new one.  */
 165   vm = scm_the_vm ();
 166
 167   /* Restore VM regs */
 168   SCM_VM_DATA (vm)->fp = fp;
 169   SCM_VM_DATA (vm)->sp = sp;
 170   SCM_VM_DATA (vm)->ip = ip;
 171
 172   /* Since we're jumping down, we should always have enough space.  */
 173   if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
 174     abort ();
 175
 176   /* Push vals */
 177   *(++(SCM_VM_DATA (vm)->sp)) = cont;
 178   for (i = 0; i < n; i++)
 179     *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
 180   if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
 181     *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
 182
 183   /* Jump! */
 184   SCM_I_LONGJMP (*registers, 1);
 185
 186   /* Shouldn't get here */
 187   abort ();
 188 }
 189
 190 SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
 191             (SCM tag, SCM args),
 192             "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
 193             "values in the list, @var{args}.")
 194 #define FUNC_NAME s_scm_abort_to_prompt_star
 195 {
 196   SCM *argv;
 197   size_t i;
 198   long n;
 199
 200   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
 201   argv = alloca (sizeof (SCM)*n);
 202   for (i = 0; i < n; i++, args = scm_cdr (args))
 203     argv[i] = scm_car (args);
 204
 205   scm_c_abort (scm_the_vm (), tag, n, argv, NULL);
 206
 207   /* Oh, what, you're still here? The abort must have been reinstated. Actually,
 208      that's quite impossible, given that we're already in C-land here, so...
 209      abort! */
 210
 211   abort ();
 212 }
 213 #undef FUNC_NAME
 214
 215 void
 216 scm_init_control (void)
 217 {
 218 #include "libguile/control.x"
 219 }
 220
 221 /*
 222   Local Variables:
 223   c-file-style: "gnu"
 224   End:
 225 */