fix stack corruption on vm-save-stack; more robust with nonlocal exits

* module/system/repl/command.scm: Coerce rationals to floats.

* module/system/vm/program.scm (program-documentation): Fix a typo, doh!

* src/vm.c (vm_reset_stack, struct vm_unwind_data): Add unwind handler to
  reset vp->sp, vp->fp, and vp->this_frame when performing a nonlocal
  exit from a vm_run.
  (vm_heapify_frames_1): Don't repack the stack, it causes stack
  corruption. I think we need spaghetti stacks to handle continuations,
  not separate heap frames. I don't think call/cc is working now.
  (vm-save-stack): Don't call heapify_frames, that modifies the stack
  that we're copying. Instead call its helper, heapify_1.

* src/vm_engine.c (vm_run): Set up the vm_reset_stack unwind handler.

* src/vm_engine.h (IP_REG, SP_REG, FP_REG): If we got through all of the
  checks without having these macros defined, define them as empty.
  Happens on x86-64.

* src/vm_system.c (halt): End the dynwind before we return from the VM.

* src/vm_scheme.c (REL): Sync the regs before calling scm_lt_p et al,
  cause they can do a nonlocal exit.

module/system/repl/command.scm

@@ -301,7 +301,7 @@ Time execution."
 	 (gc-end (gc-run-time))
 	 (vms-end (vm-stats (repl-vm repl))))
     (define (get proc start end)
-      (/ (- (proc end) (proc start)) internal-time-units-per-second))
+      (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
     (repl-print repl result)
     (display "clock utime stime cutime cstime gctime\n")
     (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"

module/system/vm/program.scm

@@ -59,5 +59,5 @@
   (assq-ref (program-properties proc) prop))
 
 (define (program-documentation prog)
-  (assq-ref (program-properties proc) 'documentation))
+  (assq-ref (program-properties prog) 'documentation))
 

src/vm.c

@@ -99,6 +99,24 @@ reinstate_vm_cont (struct scm_vm *vp, SCM cont)
   memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
 }
 
+struct vm_unwind_data 
+{
+  struct scm_vm *vp;
+  SCM *sp;
+  SCM *fp;
+  SCM this_frame;
+};
+
+static void
+vm_reset_stack (void *data)
+{
+  struct vm_unwind_data *w = data;
+  
+  w->vp->sp = w->sp;
+  w->vp->fp = w->fp;
+  w->vp->this_frame = w->this_frame;
+}
+
 static SCM
 vm_cont_mark (SCM obj)
 {
@@ -182,10 +200,18 @@ vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
       SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
     }
 
+  /* Apparently the intention here is to be able to have a frame on the heap,
+     but data on the stack, so that you can push as much as you want on the
+     stack; but I think that it's currently causing borkage with nonlocal exits
+     and the unwind handler, which reinstates the sp and fp, but it's no longer
+     pointing at a valid stack frame. So disable for now, we'll get back to
+     this later. */
+#if 0
   /* Move stack data */
   for (; src <= sp; src++, dest++)
     *dest = *src;
   *destp = dest;
+#endif
 
   return frame;
 }
@@ -519,9 +545,12 @@ SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_vm_save_stack
 {
+  struct scm_vm *vp;
+  SCM *dest;
   SCM_VALIDATE_VM (1, vm);
-  SCM_VM_DATA (vm)->last_frame = vm_heapify_frames (vm);
+  vp = SCM_VM_DATA (vm);
-  return SCM_VM_DATA (vm)->last_frame;
+  vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
+  return vp->last_frame;
 }
 #undef FUNC_NAME
   

src/vm_engine.c

@@ -72,6 +72,16 @@ vm_run (SCM vm, SCM program, SCM args)
 #if VM_USE_HOOKS
   SCM hook_args = SCM_LIST1 (vm);
 #endif
+  struct vm_unwind_data wind_data;
+
+  /* dynwind ended in the halt instruction */
+  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+  wind_data.vp = vp;
+  wind_data.sp = vp->sp;
+  wind_data.fp = vp->fp;
+  wind_data.this_frame = vp->this_frame;
+  scm_dynwind_unwind_handler (vm_reset_stack, &wind_data, 0);
+  
 
 #ifdef HAVE_LABELS_AS_VALUES
   /* Jump table */

src/vm_engine.h

@@ -112,6 +112,16 @@
 #endif
 #endif
 
+#ifndef IP_REG
+#define IP_REG
+#endif
+#ifndef SP_REG
+#define SP_REG
+#endif
+#ifndef FP_REG
+#define FP_REG
+#endif
+
 
 /*
  * Cache/Sync

src/vm_scheme.c

@@ -169,7 +169,8 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
   ARGS2 (x, y);							\
   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))			\
     RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y)));	\
-  RETURN (srel (x, y));						\
+  SYNC_REGISTER ();                                             \
+  RETURN (srel (x, y));                                         \
 }
 
 VM_DEFINE_FUNCTION (ee, "ee?", 2)

src/vm_system.c

@@ -60,6 +60,7 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
   POP (ret);
   FREE_FRAME ();
   SYNC_ALL ();
+  scm_dynwind_end ();
   return ret;
 }