add scm_c_abort, wire it up to the abort opcode

* libguile/control.h:
* libguile/control.c (scm_c_abort): Add an implementation of `abort',
  but it doesn't reify the continuation yet.

* libguile/vm-i-system.c (abort):
* libguile/vm.c (vm_abort): Wire up the call to `abort', avoiding
  consing the args into a list.

* module/language/tree-il/compile-glil.scm (flatten): Add some compily
  bits that can allow the abort to be resumed.

libguile/control.c

@@ -73,6 +73,64 @@ scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 escape_only_p)
   return ret;
 }
 
+SCM
+scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv)
+{
+  SCM winds, prompt = SCM_BOOL_F;
+  long delta;
+  size_t i;
+
+  /* Search the wind list for an appropriate prompt.
+     "Waiter, please bring us the wind list." */
+  for (winds = scm_i_dynwinds (), delta = 0;
+       scm_is_pair (winds);
+       winds = SCM_CDR (winds), delta++)
+    {
+      SCM elt = SCM_CAR (winds);
+      if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag))
+        {
+          prompt = elt;
+          break;
+        }
+    }
+  
+  /* If we didn't find anything, print a message and abort the process
+     right here.  If you don't want this, establish a catch-all around
+     any code that might throw up. */
+  if (scm_is_false (prompt))
+    {
+      /* FIXME: jump to default */
+      /* scm_handle_by_message (NULL, key, args); */
+      abort ();
+    }
+
+  /* Unwind once more, beyond the prompt. */
+  winds = SCM_CDR (winds), delta++;
+  
+  /* Unwind */
+  scm_dowinds (winds, delta);
+
+  /* Restore VM regs */
+  SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
+  SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;
+  SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip;
+
+  /* Since we're jumping down, we should always have enough space */
+  if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
+    abort ();
+
+  /* Push vals */
+  *(++(SCM_VM_DATA (vm)->sp)) = SCM_BOOL_F; /* the continuation */
+  for (i = 0; i < n; i++)
+    *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
+  *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
+
+  /* Jump! */
+  SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1);
+
+  /* Shouldn't get here */
+  abort ();
+}
 
 
 

libguile/control.h

@@ -43,6 +43,7 @@ struct scm_prompt_registers
 
 SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, SCM handler,
                                     scm_t_uint8 escape_only_p);
+SCM_INTERNAL SCM scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv) SCM_NORETURN;
 
 
 SCM_INTERNAL void scm_register_control (void);

libguile/vm-i-system.c

@@ -1509,13 +1509,10 @@ VM_DEFINE_INSTRUCTION (85, wind, "wind", 0, 2, 0)
 VM_DEFINE_INSTRUCTION (86, abort, "abort", 1, -1, -1)
 {
   unsigned n = FETCH ();
-  SCM k;
-  SCM args;
-  POP_LIST (n);
-  POP (args);
-  POP (k);
   SYNC_REGISTER ();
-  vm_abort (vm, k, args);
+  if (sp - n - 1 <= SCM_FRAME_UPPER_ADDRESS (fp))
+    goto vm_error_stack_underflow;
+  vm_abort (vm, n);
   /* vm_abort should not return */
   abort ();
 }

libguile/vm.c

@@ -201,17 +201,20 @@ vm_dispatch_hook (SCM vm, int hook_num)
   vp->trace_level++;
 }
 
-
+static void vm_abort (SCM vm, size_t n) SCM_NORETURN;
-/*
- * The dynamic stack
- */
-#define VM_SETJMP(jmpbuf) 0
-
-static void vm_abort (SCM vm, SCM tag, SCM args) SCM_NORETURN;
 static void
-vm_abort (SCM vm, SCM tag, SCM args)
+vm_abort (SCM vm, size_t n)
 {
-  abort ();
+  size_t i;
+  SCM tag, *argv;
+  
+  tag = SCM_VM_DATA (vm)->sp[-n];
+  argv = alloca (n * sizeof (SCM));
+  for (i = 0; i < n; i++)
+    argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
+  SCM_VM_DATA (vm)->sp -= n + 1;
+
+  scm_c_abort (vm, tag, n, argv);
 }
 
 

module/language/tree-il/compile-glil.scm

@@ -1114,4 +1114,21 @@
       ((<abort> src tag args)
        (comp-push tag)
        (for-each comp-push args)
-       (emit-code src (make-glil-call 'abort (length args)))))))
+       (emit-code src (make-glil-call 'abort (length args)))
+       ;; so, the abort can actually return. if it does, the values will be on
+       ;; the stack, then the MV marker, just as in an MV context.
+       (case context
+         ((tail)
+          ;; Return values.
+          (emit-code #f (make-glil-call 'return/nvalues 1)))
+         ((drop)
+          ;; Drop all values and goto RA, or otherwise fall through.
+          (emit-code #f (make-glil-mv-bind '() #f))
+          (emit-code #f (make-glil-unbind))
+          (if RA (emit-branch #f 'br RA)))
+         ((push)
+          ;; Truncate to one value.
+          (emit-code #f (make-glil-mv-bind '(val) #f)))
+         ((vals)
+          ;; Go to MVRA.
+          (emit-branch #f 'br MVRA)))))))