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_RTL_24 (scm_rtl_op_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_rtl_program | (nfree << 16) | flags, nfree + 2);
  74   SCM_SET_CELL_WORD_1 (ret, compose_continuation_code);
  75   SCM_RTL_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, SCM *saved_sp, scm_t_uint8 *saved_ip,
  83                             scm_i_jmp_buf *saved_registers,
  84                             scm_t_dynstack *dynstack,
  85                             scm_i_jmp_buf *current_registers)
  86 {
  87   SCM vm_cont;
  88   scm_t_uint32 flags;
  89   SCM *bottom_fp;
  90
  91   flags = SCM_F_VM_CONT_PARTIAL;
  92   /* If we are aborting to a prompt that has the same registers as those
  93      of the abort, it means there are no intervening C frames on the
  94      stack, and so the continuation can be relocated elsewhere on the
  95      stack: it is rewindable.  */
  96   if (saved_registers && saved_registers == current_registers)
  97     flags |= SCM_F_VM_CONT_REWINDABLE;
  98
  99   /* Walk the stack down until we find the first frame after saved_fp.
 100      We will save the stack down to that frame.  It used to be that we
 101      could determine the stack bottom in O(1) time, but that's no longer
 102      the case, since the thunk application doesn't occur where the
 103      prompt is saved.  */
 104   for (bottom_fp = SCM_VM_DATA (vm)->fp;
 105        SCM_FRAME_DYNAMIC_LINK (bottom_fp) > saved_fp;
 106        bottom_fp = SCM_FRAME_DYNAMIC_LINK (bottom_fp));
 107
 108   if (SCM_FRAME_DYNAMIC_LINK (bottom_fp) != saved_fp)
 109     abort();
 110
 111   /* Capture from the top of the thunk application frame up to the end. Set an
 112      MVRA only, as the post-abort code is in an MV context. */
 113   vm_cont = scm_i_vm_capture_stack (bottom_fp - 1,
 114                                     SCM_VM_DATA (vm)->fp,
 115                                     SCM_VM_DATA (vm)->sp,
 116                                     NULL,
 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 *fp, *sp;
 133   scm_t_uint8 *ip;
 134   scm_i_jmp_buf *registers;
 135   size_t i;
 136
 137   prompt = scm_dynstack_find_prompt (dynstack, tag,
 138                                      &flags, &fp, &sp, &ip, &registers);
 139
 140   if (!prompt)
 141     scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
 142
 143   /* Only reify if the continuation referenced in the handler. */
 144   if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
 145     cont = SCM_BOOL_F;
 146   else
 147     {
 148       scm_t_dynstack *captured;
 149
 150       captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
 151       cont = reify_partial_continuation (vm, fp, sp, ip, registers, captured,
 152                                          current_registers);
 153     }
 154
 155   /* Unwind.  */
 156   scm_dynstack_unwind (dynstack, prompt);
 157
 158   /* Unwinding may have changed the current thread's VM, so use the
 159      new one.  */
 160   vm = scm_the_vm ();
 161
 162   /* Restore VM regs */
 163   SCM_VM_DATA (vm)->fp = fp;
 164   SCM_VM_DATA (vm)->sp = sp;
 165   SCM_VM_DATA (vm)->ip = ip;
 166
 167   /* Since we're jumping down, we should always have enough space.  */
 168   if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
 169     abort ();
 170
 171   /* Push vals */
 172   *(++(SCM_VM_DATA (vm)->sp)) = cont;
 173   for (i = 0; i < n; i++)
 174     *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
 175   if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
 176     *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
 177
 178   /* Jump! */
 179   SCM_I_LONGJMP (*registers, 1);
 180
 181   /* Shouldn't get here */
 182   abort ();
 183 }
 184
 185 SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
 186             (SCM tag, SCM args),
 187             "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
 188             "values in the list, @var{args}.")
 189 #define FUNC_NAME s_scm_abort_to_prompt_star
 190 {
 191   SCM *argv;
 192   size_t i;
 193   long n;
 194
 195   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
 196   argv = alloca (sizeof (SCM)*n);
 197   for (i = 0; i < n; i++, args = scm_cdr (args))
 198     argv[i] = scm_car (args);
 199
 200   scm_c_abort (scm_the_vm (), tag, n, argv, NULL);
 201
 202   /* Oh, what, you're still here? The abort must have been reinstated. Actually,
 203      that's quite impossible, given that we're already in C-land here, so...
 204      abort! */
 205
 206   abort ();
 207 }
 208 #undef FUNC_NAME
 209
 210 void
 211 scm_init_control (void)
 212 {
 213 #include "libguile/control.x"
 214 }
 215
 216 /*
 217   Local Variables:
 218   c-file-style: "gnu"
 219   End:
 220 */