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 (struct scm_vm *vp)
  43 {
  44   size_t i, n;
  45   SCM vals = SCM_EOL;
  46
  47   n = scm_to_size_t (vp->sp[0]);
  48   for (i = 0; i < n; i++)
  49     vals = scm_cons (vp->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   vp->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 (struct scm_vm *vp,
  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 = vp->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                                     vp->fp,
 116                                     vp->sp,
 117                                     vp->ip,
 118                                     dynstack,
 119                                     flags);
 120
 121   return make_partial_continuation (vm_cont);
 122 }
 123
 124 void
 125 scm_c_abort (struct scm_vm *vp, 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 = vp->stack_base + fp_offset;
 146   sp = vp->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 (vp, fp, sp, ip, registers, captured,
 157                                          current_registers);
 158     }
 159
 160   /* Unwind.  */
 161   scm_dynstack_unwind (dynstack, prompt);
 162
 163   /* Restore VM regs */
 164   vp->fp = fp;
 165   vp->sp = sp;
 166   vp->ip = ip;
 167
 168   /* Since we're jumping down, we should always have enough space.  */
 169   if (vp->sp + n + 1 >= vp->stack_limit)
 170     abort ();
 171
 172   /* Push vals */
 173   *(++(vp->sp)) = cont;
 174   for (i = 0; i < n; i++)
 175     *(++(vp->sp)) = argv[i];
 176   if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
 177     *(++(vp->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
 178
 179   /* Jump! */
 180   SCM_I_LONGJMP (*registers, 1);
 181
 182   /* Shouldn't get here */
 183   abort ();
 184 }
 185
 186 SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
 187             (SCM tag, SCM args),
 188             "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
 189             "values in the list, @var{args}.")
 190 #define FUNC_NAME s_scm_abort_to_prompt_star
 191 {
 192   SCM *argv;
 193   size_t i;
 194   long n;
 195
 196   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
 197   argv = alloca (sizeof (SCM)*n);
 198   for (i = 0; i < n; i++, args = scm_cdr (args))
 199     argv[i] = scm_car (args);
 200
 201   scm_c_abort (scm_the_vm (), tag, n, argv, NULL);
 202
 203   /* Oh, what, you're still here? The abort must have been reinstated. Actually,
 204      that's quite impossible, given that we're already in C-land here, so...
 205      abort! */
 206
 207   abort ();
 208 }
 209 #undef FUNC_NAME
 210
 211 void
 212 scm_init_control (void)
 213 {
 214 #include "libguile/control.x"
 215 }
 216
 217 /*
 218   Local Variables:
 219   c-file-style: "gnu"
 220   End:
 221 */