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
  90   flags = SCM_F_VM_CONT_PARTIAL;
  91   /* If we are aborting to a prompt that has the same registers as those
  92      of the abort, it means there are no intervening C frames on the
  93      stack, and so the continuation can be relocated elsewhere on the
  94      stack: it is rewindable.  */
  95   if (saved_registers && saved_registers == current_registers)
  96     flags |= SCM_F_VM_CONT_REWINDABLE;
  97
  98   /* Since non-escape continuations should begin with a thunk application, the
  99      first bit of the stack should be a frame, with the saved fp equal to the fp
 100      that was current when the prompt was made. */
 101   if ((SCM*)SCM_UNPACK (saved_sp[1]) != saved_fp)
 102     abort ();
 103
 104   /* Capture from the top of the thunk application frame up to the end. Set an
 105      MVRA only, as the post-abort code is in an MV context. */
 106   vm_cont = scm_i_vm_capture_stack (saved_sp + 4,
 107                                     SCM_VM_DATA (vm)->fp,
 108                                     SCM_VM_DATA (vm)->sp,
 109                                     NULL,
 110                                     SCM_VM_DATA (vm)->ip,
 111                                     dynstack,
 112                                     flags);
 113
 114   return make_partial_continuation (vm_cont);
 115 }
 116
 117 void
 118 scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
 119              scm_i_jmp_buf *current_registers)
 120 {
 121   SCM cont;
 122   scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
 123   scm_t_bits *prompt;
 124   scm_t_dynstack_prompt_flags flags;
 125   SCM *fp, *sp;
 126   scm_t_uint8 *ip;
 127   scm_i_jmp_buf *registers;
 128   size_t i;
 129
 130   prompt = scm_dynstack_find_prompt (dynstack, tag,
 131                                      &flags, &fp, &sp, &ip, &registers);
 132
 133   if (!prompt)
 134     scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
 135
 136   /* Only reify if the continuation referenced in the handler. */
 137   if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
 138     cont = SCM_BOOL_F;
 139   else
 140     {
 141       scm_t_dynstack *captured;
 142
 143       captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
 144       cont = reify_partial_continuation (vm, fp, sp, ip, registers, captured,
 145                                          current_registers);
 146     }
 147
 148   /* Unwind.  */
 149   scm_dynstack_unwind (dynstack, prompt);
 150
 151   /* Unwinding may have changed the current thread's VM, so use the
 152      new one.  */
 153   vm = scm_the_vm ();
 154
 155   /* Restore VM regs */
 156   SCM_VM_DATA (vm)->fp = fp;
 157   SCM_VM_DATA (vm)->sp = sp;
 158   SCM_VM_DATA (vm)->ip = ip;
 159
 160   /* Since we're jumping down, we should always have enough space.  */
 161   if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
 162     abort ();
 163
 164   /* Push vals */
 165   *(++(SCM_VM_DATA (vm)->sp)) = cont;
 166   for (i = 0; i < n; i++)
 167     *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
 168   if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
 169     *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
 170
 171   /* Jump! */
 172   SCM_I_LONGJMP (*registers, 1);
 173
 174   /* Shouldn't get here */
 175   abort ();
 176 }
 177
 178 SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
 179             (SCM tag, SCM args),
 180             "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
 181             "values in the list, @var{args}.")
 182 #define FUNC_NAME s_scm_abort_to_prompt_star
 183 {
 184   SCM *argv;
 185   size_t i;
 186   long n;
 187
 188   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
 189   argv = alloca (sizeof (SCM)*n);
 190   for (i = 0; i < n; i++, args = scm_cdr (args))
 191     argv[i] = scm_car (args);
 192
 193   scm_c_abort (scm_the_vm (), tag, n, argv, NULL);
 194
 195   /* Oh, what, you're still here? The abort must have been reinstated. Actually,
 196      that's quite impossible, given that we're already in C-land here, so...
 197      abort! */
 198
 199   abort ();
 200 }
 201 #undef FUNC_NAME
 202
 203 void
 204 scm_init_control (void)
 205 {
 206 #include "libguile/control.x"
 207 }
 208
 209 /*
 210   Local Variables:
 211   c-file-style: "gnu"
 212   End:
 213 */