fix bug in compilation of and' and or'; more robust underflow detection.

* module/system/il/compile.scm (codegen): Rewrite handling of `and' and
  `or' ghil compilation, because it was broken if drop was #t. Tricky
  bug, this one! Took me days to track down!

* module/system/repl/repl.scm: Export call-with-backtrace, which probably
  should go in some other file.

* src/vm.c (scm_vm_save_stack): Handle the fp==0 case for errors before
  we have a frame.

* src/vm_engine.h (NEW_FRAME, FREE_FRAME): Stricter underflow checking,
  raising the stack base to the return address, in an attempt to prevent
  inadvertant stack smashing (the symptom of the and/or miscompilation
  bug).
  (CHECK_IP): A check that the current IP is within the bounds of the
  current program. Not normally compiled in. Perhaps it should be?

* src/vm_system.c (halt): Set vp->ip to NULL. Paranoia, I know.
  (return): Call CHECK_IP(), if such a thing is compiled in.

* testsuite/Makefile.am (vm_test_files):
* testsuite/t-catch.scm:
* testsuite/t-map.scm:
* testsuite/t-or.scm: New tests.

module/system/il/compile.scm

@@ -217,20 +217,22 @@
 	 ;;     (br L2)
 	 ;; L1: (const #f)
 	 ;; L2:
-	 (let ((L1 (make-label)) (L2 (make-label)))
+         (cond ((null? exps) (return-object! loc #t))
-	   (if (null? exps)
+               ((null? (cdr exps)) (comp-tail (car exps)))
-	       (return-object! loc #t)
+               (else
-	       (do ((exps exps (cdr exps)))
+                (let ((L1 (make-label)) (L2 (make-label)))
-		   ((null? (cdr exps))
+                  (let lp ((exps exps))
-		    (comp-tail (car exps))
+                    (cond ((null? (cdr exps))
-		    (if (not tail) (push-branch! #f 'br L2))
+                           (comp-tail (car exps))
-		    (push-label! L1)
+                           (push-branch! #f 'br L2)
-		    (return-object! #f #f)
+                           (push-label! L1)
-		    (if (not tail) (push-label! L2))
+                           (return-object! #f #f)
-		    (maybe-drop)
+                           (push-label! L2)
-		    (maybe-return))
+                           (maybe-return))
-		 (comp-push (car exps))
+                          (else
-		 (push-branch! #f 'br-if-not L1)))))
+                           (comp-push (car exps))
+                           (push-branch! #f 'br-if-not L1)
+                           (lp (cdr exps)))))))))
 
 	((<ghil-or> env loc exps)
 	 ;;     EXP
@@ -240,19 +242,21 @@
 	 ;;     ...
 	 ;;     TAIL
 	 ;; L1:
-	 (let ((L1 (make-label)))
+         (cond ((null? exps) (return-object! loc #f))
-	   (if (null? exps)
+               ((null? (cdr exps)) (comp-tail (car exps)))
-	       (return-object! loc #f)
+               (else
-	       (do ((exps exps (cdr exps)))
+                (let ((L1 (make-label)))
-		   ((null? (cdr exps))
+                  (let lp ((exps exps))
-		    (comp-tail (car exps))
+                    (cond ((null? (cdr exps))
-		    (push-label! L1)
+                           (comp-tail (car exps))
-		    (maybe-drop)
+                           (push-label! L1)
-		    (maybe-return))
+                           (maybe-return))
-		 (comp-push (car exps))
+                          (else
-		 (push-call! #f 'dup '())
+                           (comp-push (car exps))
-		 (push-branch! #f 'br-if L1)
+                           (push-call! #f 'dup '())
-		 (push-call! #f 'drop '())))))
+                           (push-branch! #f 'br-if L1)
+                           (push-call! #f 'drop '())
+                           (lp (cdr exps)))))))))
 
 	((<ghil-begin> env loc exps)
 	 ;; EXPS...

module/system/repl/repl.scm

@@ -29,7 +29,7 @@
   :use-module (system vm vm)
   :use-module (system vm debug)
   :use-module (ice-9 rdelim)
-  :export (start-repl))
+  :export (start-repl call-with-backtrace))
 
 (define meta-command-token (cons 'meta 'command))
 

src/vm.c

@@ -560,8 +560,18 @@ SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
   SCM *dest;
   SCM_VALIDATE_VM (1, vm);
   vp = SCM_VM_DATA (vm);
-  vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
+
-  vp->last_ip = vp->ip;
+  if (vp->fp) 
+    {
+      vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
+      vp->last_ip = vp->ip;
+    }
+  else
+    {
+      vp->last_frame = SCM_BOOL_F;
+    }
+  
+  
   return vp->last_frame;
 }
 #undef FUNC_NAME

src/vm_engine.h

@@ -141,6 +141,13 @@
   vp->fp = fp;					\
 }
 
+#ifdef IP_PARANOIA
+#define CHECK_IP() \
+  do { if (ip < bp->base || ip - bp->base > bp->size) abort (); } while (0)
+#else
+#define CHECK_IP()
+#endif
+
 /* Get a local copy of the program's "object table" (i.e. the vector of
    external bindings that are referenced by the program), initialized by
    `load-program'.  */
@@ -232,9 +239,9 @@
   if (sp > stack_limit)				\
     goto vm_error_stack_overflow
 
-#define CHECK_UNDERFLOW()                                               \
+#define CHECK_UNDERFLOW()                       \
-  if (sp < stack_base)                                                  \
+  if (sp < stack_base)                          \
-    goto vm_error_stack_underflow
+    goto vm_error_stack_underflow;
 
 #define PUSH(x)	do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
 #define DROP()	do { sp--; CHECK_UNDERFLOW (); } while (0)
@@ -428,6 +435,7 @@ do {						\
   p[2] = dl;					\
   p[1] = SCM_BOOL_F;				\
   p[0] = external;				\
+  stack_base = p + 3;				\
 }
 
 #define FREE_FRAME()				\
@@ -454,6 +462,9 @@ do {						\
 	*sp++ = *p++;				\
       sp--;					\
     }						\
+  stack_base = fp ?				\
+    SCM_FRAME_UPPER_ADDRESS (fp) - 1		\
+    : vp->stack_base;				\
 }
 
 #define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]

src/vm_system.c

@@ -60,6 +60,7 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
   POP (ret);
   FREE_FRAME ();
   SYNC_ALL ();
+  vp->ip = NULL;
   scm_dynwind_end ();
   return ret;
 }
@@ -657,6 +658,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
   program = SCM_FRAME_PROGRAM (fp);
   CACHE_PROGRAM ();
   CACHE_EXTERNAL ();
+  CHECK_IP ();
   NEXT;
 }
 

testsuite/Makefile.am

@@ -6,12 +6,15 @@ GUILE_VM = $(top_builddir)/src/guile-vm
 vm_test_files =					\
       t-basic-contructs.scm			\
       t-global-bindings.scm			\
+      t-catch.scm				\
       t-closure.scm				\
       t-closure2.scm				\
       t-closure3.scm				\
       t-do-loop.scm				\
       t-macros.scm				\
       t-macros2.scm				\
+      t-map.scm					\
+      t-or.scm					\
       t-proc-with-setter.scm			\
       t-values.scm				\
       t-records.scm				\

testsuite/t-catch.scm

@@ -0,0 +1,10 @@
+;; Test that nonlocal exits of the VM work.
+
+(begin
+  (define (foo thunk)
+    (catch #t thunk (lambda args args)))
+  (foo
+   (lambda ()
+     (let ((a 'one))
+       (1+ a)))))
+       

testsuite/t-map.scm

@@ -0,0 +1,10 @@
+; Currently, map is a C function, so this is a way of testing that the
+; VM is reentrant.
+
+(begin
+
+  (define (square x)
+    (* x x))
+
+  (map (lambda (x) (square x))
+       '(1 2 3)))

testsuite/t-or.scm

@@ -0,0 +1,27 @@
+;; all the different permutations of or
+(list
+ ;; not in tail position, no args
+ (or)
+ ;; not in tail position, one arg
+ (or 'what)
+ (or #f)
+ ;; not in tail position, two arg
+ (or 'what 'where)
+ (or #f 'where)
+ (or #f #f)
+ (or 'what #f)
+ ;; in tail position (within the lambdas)
+ ((lambda ()
+    (or)))
+ ((lambda ()
+    (or 'what)))
+ ((lambda ()
+    (or #f)))
+ ((lambda ()
+    (or 'what 'where)))
+ ((lambda ()
+    (or #f 'where)))
+ ((lambda ()
+    (or #f #f)))
+ ((lambda ()
+    (or 'what #f))))