From 262ce9115743c3590ddaa6966bd3f2569f60003a Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 3 Oct 2010 11:12:36 +0200
Subject: [PATCH] bugfixen in source breakpoints and in-procedure traps

* module/system/vm/traps.scm (trap-in-procedure): If we are
  (re-)entering the procedure from a return, call the enter-proc with
  the returnee, not the returner.
  (in-range?): Tighten up a bit.
  (program-sources-before-retire): New helper, like program-sources but
  indexed before instructions are retired instead of after.
  (program-sources-by-line): Use program-sources-before-retire so that
  we can break on instructions by source line *before* those
  instructions are executed.
---
 module/system/vm/traps.scm | 62 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 59 insertions(+), 3 deletions(-)

diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 0e7a540ec..7abe45396 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -60,6 +60,7 @@
   #:use-module (system vm frame)
   #:use-module (system vm program)
   #:use-module (system vm objcode)
+  #:use-module (system vm instruction)
   #:use-module (system xref)
   #:use-module (rnrs bytevectors)
   #:export (trap-at-procedure-call
@@ -186,7 +187,7 @@
       (if in-proc?
           (exit-proc frame))
       (if (our-frame? (frame-previous frame))
-          (enter-proc frame)))
+          (enter-proc (frame-previous frame))))
 
     (define (abort-hook frame)
       (if in-proc?
@@ -262,7 +263,8 @@
 
 (define (in-range? range i)
   (or-map (lambda (bounds)
-            (<= (car bounds) i (cdr bounds)))
+            (and (<= (car bounds) i)
+                 (< i (cdr bounds))))
           range))
 
 ;; Building on trap-instructions-in-procedure, we have
@@ -290,14 +292,68 @@
                                     #:current-frame current-frame #:vm vm
                                     #:our-frame? our-frame?)))
 
+;; FIXME: pull this definition from elsewhere.
+(define *bytecode-header-len* 8)
+
 ;; FIXME: define this in objcode somehow. We are reffing the first
 ;; uint32 in the objcode, which is the length of the program (without
 ;; the meta).
 (define (program-last-ip prog)
   (bytevector-u32-native-ref (objcode->bytecode (program-objcode prog)) 0))
 
+;; We could decompile the program to get this, but that seems like a
+;; waste.
+(define (bytecode-instruction-length bytecode ip)
+  (let* ((idx (+ ip *bytecode-header-len*))
+         (inst (opcode->instruction (bytevector-u8-ref bytecode idx))))
+    ;; 1+ for the instruction itself.
+    (1+ (cond
+         ((eq? inst 'load-program)
+          (+ (bytevector-u32-native-ref bytecode (+ idx 1))
+             (bytevector-u32-native-ref bytecode (+ idx 5))))
+         ((< (instruction-length inst) 0)
+          ;; variable length instruction -- the length is encoded in the
+          ;; instruction stream.
+          (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16)
+             (ash (bytevector-u8-ref bytecode (+ idx 2)) 8)
+             (bytevector-u8-ref bytecode (+ idx 3))))
+         (else
+          ;; fixed length
+          (instruction-length inst))))))
+
+;; Source information could in theory be correlated with the ip of the
+;; instruction, or the ip just after the instruction is retired. Guile
+;; does the latter, to make backtraces easy -- an error produced while
+;; running an opcode always happens after it has retired its arguments.
+;;
+;; But for breakpoints and such, we need the ip before the instruction
+;; is retired -- before it has had a chance to do anything. So here we
+;; change from the post-retire addresses given by program-sources to
+;; pre-retire addresses.
+;;
+(define (program-sources-before-retire proc)
+  (let ((bv (objcode->bytecode (program-objcode proc))))
+    (let lp ((in (program-sources proc))
+             (out '())
+             (ip 0))
+      (cond
+       ((null? in)
+        (reverse out))
+       (else
+        (pmatch (car in)
+          ((,post-ip . ,source)
+           (let lp2 ((ip ip)
+                     (next ip))
+             (if (< next post-ip)
+                 (lp2 next (+ next (bytecode-instruction-length bv next)))
+                 (lp (cdr in)
+                     (acons ip source out)
+                     next))))
+          (else
+           (error "unexpected"))))))))
+
 (define (program-sources-by-line proc file)
-  (let lp ((sources (program-sources proc))
+  (let lp ((sources (program-sources-before-retire proc))
            (out '()))
     (if (pair? sources)
         (lp (cdr sources)