add program-sources-pre-retire to core and define frame-next-source

* libguile/programs.h:
* libguile/programs.c (scm_program_source): Add an optional arg, the
  sources table to traverse. Defaults to the result of
  scm_program_sources.

* module/system/vm/program.scm (program-sources-pre-retire): Move
  definition here from (system vm traps), and export.

* module/system/vm/traps.scm: Adapt.

* module/system/vm/frame.scm (frame-next-source): New exported binding,
  returns the source line corresponding to the next instruction instead
  of the previous instruction.

diff --git a/libguile/programs.c b/libguile/programs.c
index 3a14f65..4404f83 100644 (file)
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -267,28 +267,37 @@ scm_i_program_properties (SCM program)
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
-           (SCM program, SCM ip),
+static SCM
+program_source (SCM program, size_t ip, SCM sources)
+{
+  SCM source = SCM_BOOL_F;
+
+  while (!scm_is_null (sources)
+         && scm_to_size_t (scm_caar (sources)) <= ip)
+    {
+      source = scm_car (sources);
+      sources = scm_cdr (sources);
+    }
+  
+  return source; /* (addr . (filename . (line . column))) */
+}
+
+SCM_DEFINE (scm_program_source, "program-source", 2, 1, 0,
+           (SCM program, SCM ip, SCM sources),
            "")
 #define FUNC_NAME s_scm_program_source
 {
   SCM_VALIDATE_PROGRAM (1, program);
-  return scm_c_program_source (program, scm_to_size_t (ip));
+  if (SCM_UNBNDP (sources))
+    sources = scm_program_sources (program);
+  return program_source (program, scm_to_size_t (ip), sources);
 }
 #undef FUNC_NAME
     
 extern SCM
 scm_c_program_source (SCM program, size_t ip)
 {
-  SCM sources, source = SCM_BOOL_F;
-
-  for (sources = scm_program_sources (program);
-       !scm_is_null (sources)
-         && scm_to_size_t (scm_caar (sources)) <= ip;
-       sources = scm_cdr (sources))
-    source = scm_car (sources);
-  
-  return source; /* (addr . (filename . (line . column))) */
+  return program_source (program, ip, scm_program_sources (program));
 }
 
 SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,

diff --git a/libguile/programs.h b/libguile/programs.h
index 7f9b6f7..d0e788e 100644 (file)
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -54,7 +54,7 @@ SCM_API SCM scm_program_base (SCM program);
 SCM_API SCM scm_program_meta (SCM program);
 SCM_API SCM scm_program_bindings (SCM program);
 SCM_API SCM scm_program_sources (SCM program);
-SCM_API SCM scm_program_source (SCM program, SCM ip);
+SCM_API SCM scm_program_source (SCM program, SCM ip, SCM sources);
 SCM_API SCM scm_program_arities (SCM program);
 SCM_API SCM scm_program_objects (SCM program);
 SCM_API SCM scm_program_module (SCM program);

diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 57ae877..94619ba 100644 (file)
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -26,7 +26,7 @@
   #:export (frame-bindings
             frame-lookup-binding
             frame-binding-ref frame-binding-set!
-            frame-source frame-call-representation
+            frame-source frame-next-source frame-call-representation
             frame-environment
             frame-object-binding frame-object-name
             frame-return-values))
@@ -71,8 +71,17 @@
 ;;;
 
 (define (frame-source frame)
-  (program-source (frame-procedure frame)
-                  (frame-instruction-pointer frame)))
+  (let ((proc (frame-procedure frame)))
+    (program-source proc
+                    (frame-instruction-pointer frame)
+                    (program-sources proc))))
+
+(define (frame-next-source frame)
+  (let ((proc (frame-procedure frame)))
+    (program-source proc
+                    (frame-instruction-pointer frame)
+                    (program-sources-pre-retire proc))))
+
 
 ;; Basically there are two cases to deal with here:
 ;;

diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index a1e3ea4..02d5ec4 100644 (file)
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -20,6 +20,9 @@
 
 (define-module (system vm program)
   #:use-module (system base pmatch)
+  #:use-module (system vm instruction)
+  #:use-module (system vm objcode)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (make-program
@@ -29,7 +32,7 @@
 
             source:addr source:line source:column source:file
             source:line-for-user
-            program-sources program-source
+            program-sources program-sources-pre-retire program-source
 
             program-bindings program-bindings-by-index program-bindings-for-ip
             program-arities program-arity arity:start arity:end
@@ -71,6 +74,60 @@
 (define (source:line-for-user source)
   (1+ (source:line source)))
 
+;; FIXME: pull this definition from elsewhere.
+(define *bytecode-header-len* 8)
+
+;; 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-pre-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 (collapse-locals locs)
   (let lp ((ret '()) (locs locs))
     (if (null? locs)

diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 627e6c5..cccd6ea 100644 (file)
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -309,68 +309,14 @@
                                     #: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-before-retire proc))
+  (let lp ((sources (program-sources-pre-retire proc))
            (out '()))
     (if (pair? sources)
         (lp (cdr sources)