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. */
 112   vm_cont = scm_i_vm_capture_stack (&SCM_FRAME_LOCAL (bottom_fp, 0),
 113                                     SCM_VM_DATA (vm)->fp,
 114                                     SCM_VM_DATA (vm)->sp,
 115                                     SCM_VM_DATA (vm)->ip,
 116                                     dynstack,
 117                                     flags);
 118
 119   return make_partial_continuation (vm_cont);
 120 }
 121
 122 void
 123 scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
 124              scm_i_jmp_buf *current_registers)
 125 {
 126   SCM cont;
 127   scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
 128   scm_t_bits *prompt;
 129   scm_t_dynstack_prompt_flags flags;
 130   SCM *fp, *sp;
 131   scm_t_uint8 *ip;
 132   scm_i_jmp_buf *registers;
 133   size_t i;
 134
 135   prompt = scm_dynstack_find_prompt (dynstack, tag,
 136                                      &flags, &fp, &sp, &ip, &registers);
 137
 138   if (!prompt)
 139     scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
 140
 141   /* Only reify if the continuation referenced in the handler. */
 142   if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
 143     cont = SCM_BOOL_F;
 144   else
 145     {
 146       scm_t_dynstack *captured;
 147
 148       captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
 149       cont = reify_partial_continuation (vm, fp, sp, ip, registers, captured,
 150                                          current_registers);
 151     }
 152
 153   /* Unwind.  */
 154   scm_dynstack_unwind (dynstack, prompt);
 155
 156   /* Unwinding may have changed the current thread's VM, so use the
 157      new one.  */
 158   vm = scm_the_vm ();
 159
 160   /* Restore VM regs */
 161   SCM_VM_DATA (vm)->fp = fp;
 162   SCM_VM_DATA (vm)->sp = sp;
 163   SCM_VM_DATA (vm)->ip = ip;
 164
 165   /* Since we're jumping down, we should always have enough space.  */
 166   if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
 167     abort ();
 168
 169   /* Push vals */
 170   *(++(SCM_VM_DATA (vm)->sp)) = cont;
 171   for (i = 0; i < n; i++)
 172     *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
 173   if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
 174     *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
 175
 176   /* Jump! */
 177   SCM_I_LONGJMP (*registers, 1);
 178
 179   /* Shouldn't get here */
 180   abort ();
 181 }
 182
 183 SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
 184             (SCM tag, SCM args),
 185             "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
 186             "values in the list, @var{args}.")
 187 #define FUNC_NAME s_scm_abort_to_prompt_star
 188 {
 189   SCM *argv;
 190   size_t i;
 191   long n;
 192
 193   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
 194   argv = alloca (sizeof (SCM)*n);
 195   for (i = 0; i < n; i++, args = scm_cdr (args))
 196     argv[i] = scm_car (args);
 197
 198   scm_c_abort (scm_the_vm (), tag, n, argv, NULL);
 199
 200   /* Oh, what, you're still here? The abort must have been reinstated. Actually,
 201      that's quite impossible, given that we're already in C-land here, so...
 202      abort! */
 203
 204   abort ();
 205 }
 206 #undef FUNC_NAME
 207
 208 void
 209 scm_init_control (void)
 210 {
 211 #include "libguile/control.x"
 212 }
 213
 214 /*
 215   Local Variables:
 216   c-file-style: "gnu"
 217   End:
 218 */