improve source loc info in nonlocal exits and backtraces

* module/system/il/compile.scm (codegen): The currently-executing
  instruction is actually the one right before the instruction pointer;
  so for purposes of assv to find a source location for an ip, put the
  source after the code, as it was before.

* module/system/vm/debug.scm (vm-backtrace): Move more code to frame.scm.

* module/system/vm/frame.scm (make-frame-chain): Include all frames, even
  the bootstrap one. For a reentrant backtrace we'll have boostrap
  programs anyway. Probably should check for objcode[2] == scm_op_halt,
  to not show those frames in the trace.
  (frame-line-number, frame-file): New helpers.
  (print-frame): Print out the line number too.
  (frame-call-representation): Code from print-frame-call moved here.
  (print-frame-chain-as-backtrace): A backtrace printer, yays.
  (program-name): Check link validity before calling frame-address on it.

* module/system/vm/program.scm (source:addr, source:line, source:column)
  (source:file): New accessors for the elements of program-sources.

* module/system/vm/vm.scm (vm:last-ip): New export.
  (vm-last-frame-chain): Use vm:last-ip in making the frame chain.

* src/vm.h (struct scm_vm):
* src/vm.c (make_vm, scm_vm_last_ip, scm_vm_save_stack): Save the last
  instruction pointer when saving the stack. Really though, we should be
  saving all of the stack data on a spaghetti stack.

* src/vm_system.c (late-variable-ref): Pointless s/REGISTER/BEFORE_GC/.

module/system/il/compile.scm

@@ -107,8 +107,8 @@
 (define (codegen ghil)
   (let ((stack '()))
     (define (push-code! loc code)
-      (if loc (set! stack (cons (make-glil-source loc) stack)))
+      (set! stack (cons code stack))
-      (set! stack (cons code stack)))
+      (if loc (set! stack (cons (make-glil-source loc) stack))))
     (define (push-bindings! loc vars)
       (if (not (null? vars))
           (push-code!

module/system/vm/debug.scm

@@ -58,7 +58,5 @@
 ;;;
 
 (define (vm-backtrace vm)
-  (let ((chain (vm-last-frame-chain vm)))
+  (print-frame-chain-as-backtrace
-    (if (null? chain)
+   (reverse! (vm-last-frame-chain vm))))
-      (display "No backtrace available\n")
-      (for-each print-frame (reverse! chain)))))

module/system/vm/frame.scm

@@ -21,9 +21,10 @@
 
 (define-module (system vm frame)
   :use-module (system vm program)
+  :use-module ((srfi srfi-1) :select (fold))
   :export (frame-number frame-address
            make-frame-chain
-           print-frame print-frame-call
+           print-frame print-frame-chain-as-backtrace
            frame-arguments frame-local-variables frame-external-variables
            frame-environment
            frame-variable-exists? frame-variable-ref frame-variable-set!
@@ -43,11 +44,12 @@
 
 (define (make-frame-chain frame addr)
   (let* ((link (frame-dynamic-link frame))
-	 (chain (if (eq? link #t)
+	 (chain (cons frame
-		  '()
+                      (if (eq? link #t)
-		  (cons frame (make-frame-chain
+                          '()
-			       link (frame-return-address frame))))))
+                          (make-frame-chain
-    (set! (frame-number frame) (length chain))
+                           link (frame-return-address frame))))))
+    (set! (frame-number frame) (1- (length chain)))
     (set! (frame-address frame)
 	  (- addr (program-base (frame-program frame))))
     chain))
@@ -57,30 +59,63 @@
 ;;; Pretty printing
 ;;;
 
-(define (print-frame frame)
+(define (frame-line-number frame)
-  (format #t "#~A " (frame-number frame))
+  (let ((addr (frame-address frame)))
-  (print-frame-call frame)
+    (cond ((assv-ref (program-sources (frame-program frame)) addr)
-  (newline))
+           => source:line)
+          (else (format #f "@~a" addr)))))
 
-(define (print-frame-call frame)
+(define (frame-file frame prev)
+  (let ((sources (program-sources (frame-program frame))))
+    (if (null? sources)
+        prev
+        (or (source:file (car sources))
+            "current input"))))
+
+(define (print-frame frame)
+  (format #t "~4@a: ~a ~a\n" (frame-line-number frame) (frame-number frame)
+          (frame-call-representation frame)))
+
+
+(define (frame-call-representation frame)
   (define (abbrev x)
-    (cond ((list? x)   (if (> (length x) 3)
+    (cond ((list? x)
-			 (list (abbrev (car x)) (abbrev (cadr x)) '...)
+           (if (> (length x) 3)
-			 (map abbrev x)))
+               (list (abbrev (car x)) (abbrev (cadr x)) '...)
-	  ((pair? x)   (cons (abbrev (car x)) (abbrev (cdr x))))
+               (map abbrev x)))
-	  ((vector? x) (case (vector-length x)
+	  ((pair? x)
-			 ((0) x)
+           (cons (abbrev (car x)) (abbrev (cdr x))))
-			 ((1) (vector (abbrev (vector-ref x 0))))
+	  ((vector? x)
-			 (else (vector (abbrev (vector-ref x 0)) '...))))
+           (case (vector-length x)
+             ((0) x)
+             ((1) (vector (abbrev (vector-ref x 0))))
+             (else (vector (abbrev (vector-ref x 0)) '...))))
 	  (else x)))
-  (write (abbrev (cons (program-name frame)
+  (abbrev (cons (program-name frame) (frame-arguments frame))))
-                       (frame-arguments frame)))))
+
+(define (print-frame-chain-as-backtrace frames)
+  (if (null? frames)
+      (format #t "No backtrace available.\n")
+      (begin
+        (format #t "Backtrace:\n")
+        (pk frames (map frame-program frames)
+             (map frame-address frames)
+             )
+        (fold (lambda (frame file)
+                (let ((new-file (frame-file frame file)))
+                  (if (not (eqv? new-file file))
+                      (format #t "In ~a:\n" new-file))
+                  (print-frame frame)
+                  new-file))
+              'no-file
+              frames))))
 
 (define (program-name frame)
   (let ((prog (frame-program frame))
 	(link (frame-dynamic-link frame)))
     (or (object-property prog 'name)
-        (frame-object-name link (1- (frame-address link)) prog)
+        (and (frame? link)
+             (frame-object-name link (1- (frame-address link)) prog))
 	(hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
 		   prog (module-obarray (current-module))))))
 

module/system/vm/program.scm

@@ -22,6 +22,7 @@
 (define-module (system vm program)
   :export (arity:nargs arity:nrest arity:nlocs arity:nexts
            make-binding binding:name binding:extp binding:index
+           source:addr source:line source:column source:file
            program-bindings program-sources
            program-properties program-property program-documentation
            
@@ -47,6 +48,15 @@
   (cond ((program-meta prog) => car)
 	(else '())))
 
+(define (source:addr source)
+  (car source))
+(define (source:line source)
+  (vector-ref (cdr source) 0))
+(define (source:column source)
+  (vector-ref (cdr source) 1))
+(define (source:file source)
+  (vector-ref (cdr source) 2))
+
 (define (program-sources prog)
   (cond ((program-meta prog) => cadr)
 	(else '())))

module/system/vm/vm.scm

@@ -23,7 +23,7 @@
   :use-module (system vm frame)
   :use-module (system vm objcode)
   :export (vm? the-vm make-vm vm-version
-           vm:ip vm:sp vm:fp
+           vm:ip vm:sp vm:fp vm:last-ip
 
            vm-load vm-return-value
 
@@ -44,7 +44,7 @@
   (make-frame-chain (vm-this-frame vm) (vm:ip vm)))
 
 (define (vm-last-frame-chain vm)
-  (make-frame-chain (vm-last-frame vm) (vm:ip vm)))
+  (make-frame-chain (vm-last-frame vm) (vm:last-ip vm)))
 
 (define (vm-fetch-locals vm)
   (frame-local-variables (vm-this-frame vm)))

src/vm.c

@@ -277,6 +277,7 @@ make_vm (void)
   vp->options     = SCM_EOL;
   vp->this_frame  = SCM_BOOL_F;
   vp->last_frame  = SCM_BOOL_F;
+  vp->last_ip     = NULL;
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
     vp->hooks[i] = SCM_BOOL_F;
   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
@@ -540,6 +541,16 @@ SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_last_ip
+{
+  SCM_VALIDATE_VM (1, vm);
+  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip);
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
 	    (SCM vm),
 	    "")
@@ -550,6 +561,7 @@ SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
   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;
   return vp->last_frame;
 }
 #undef FUNC_NAME

src/vm.h

@@ -63,6 +63,7 @@ struct scm_vm {
   SCM *stack_limit;		/* stack limit address */
   SCM this_frame;		/* currrent frame */
   SCM last_frame;		/* last frame */
+  scm_byte_t *last_ip;		/* ip when exception occured */
   SCM hooks[SCM_VM_NUM_HOOKS];	/* hooks */
   SCM options;			/* options */
   unsigned long time;		/* time spent */

src/vm_system.c

@@ -267,9 +267,9 @@ VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
 
   if (!SCM_VARIABLEP (pair_or_var)) 
     {
-      SYNC_BEFORE_GC ();
+      SYNC_REGISTER ();
+      /* either one of these calls might longjmp */
       SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
-      /* module_lookup might longjmp */
       pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
       OBJECT_SET (objnum, pair_or_var);
       if (!VARIABLE_BOUNDP (pair_or_var))