add ,step ,stepi ,next and ,nexti

* module/system/vm/traps.scm (trap-matching-instructions): New trap,
  just installs a next hook and runs the handler when a predicate
  succeeds.

* module/system/vm/trap-state.scm (add-ephemeral-stepping-trap!): New
  procedure, uses trap-matching-instructions with an appropriate
  predicate to handle step, stepi, next, and nexti repl metacommands.

* module/system/repl/command.scm (step, step-instruction, next)
  (next-instruction): New repl debugger commands.

3 files changed, 119 insertions, 3 deletions

diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 3f47d9bc4..fce232448 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -50,7 +50,7 @@
 ;;;
 
 (define *command-table*
-  '((help     (help h) (show s) (apropos a) (describe d))
+  '((help     (help h) (show) (apropos a) (describe d))
     (module   (module m) (import use) (load l) (binding b))
     (language (language L))
     (compile  (compile c) (compile-file cc)
@@ -59,6 +59,8 @@
     (debug    (backtrace bt) (up) (down) (frame fr)
               (procedure proc) (locals) (error-message error)
               (break br bp) (break-at-source break-at bs)
+              (step s) (step-instruction si)
+              (next n) (next-instruction ni)
               (finish)
               (tracepoint tp)
               (traps) (delete del) (disable) (enable)
@@ -629,6 +631,60 @@ Resume execution, breaking when the current frame finishes."
     (add-ephemeral-trap-at-frame-finish! cur handler)
     (throw 'quit)))
 
+(define (repl-next-resumer msg)
+  ;; Capture the dynamic environment with this prompt thing. The
+  ;; result is a procedure that takes a frame.
+  (% (let ((stack (abort
+                   (lambda (k)
+                     ;; Call frame->stack-vector before reinstating the
+                     ;; continuation, so that we catch the %stacks fluid
+                     ;; at the time of capture.
+                     (lambda (frame)
+                       (k (frame->stack-vector frame)))))))
+       (format #t "~a~%" msg)
+       ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
+        #:debug (make-debug stack 0 msg)))))
+
+(define-stack-command (step repl)
+  "step
+Step until control reaches a different source location.
+
+Step until control reaches a different source location."
+  (let ((msg (format #f "Step into ~a" cur)))
+    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+                                  #:into? #t #:instruction? #f)
+    (throw 'quit)))
+
+(define-stack-command (step-instruction repl)
+  "step-instruction
+Step until control reaches a different instruction.
+
+Step until control reaches a different VM instruction."
+  (let ((msg (format #f "Step into ~a" cur)))
+    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+                                  #:into? #t #:instruction? #t)
+    (throw 'quit)))
+
+(define-stack-command (next repl)
+  "next
+Step until control reaches a different source location in the current frame.
+
+Step until control reaches a different source location in the current frame."
+  (let ((msg (format #f "Step into ~a" cur)))
+    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+                                  #:into? #f #:instruction? #f)
+    (throw 'quit)))
+
+(define-stack-command (step-instruction repl)
+  "next-instruction
+Step until control reaches a different instruction in the current frame.
+
+Step until control reaches a different VM instruction in the current frame."
+  (let ((msg (format #f "Step into ~a" cur)))
+    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+                                  #:into? #f #:instruction? #t)
+    (throw 'quit)))
+
 (define-meta-command (tracepoint repl (form))
   "tracepoint PROCEDURE
 Add a tracepoint to PROCEDURE.
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 1f21615ad..e9a2ad86c 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -26,6 +26,8 @@
   #:use-module (system vm vm)
   #:use-module (system vm traps)
   #:use-module (system vm trace)
+  #:use-module (system vm frame)
+  #:use-module (system vm program)
   #:export (list-traps
             trap-enabled?
             trap-name
@@ -39,7 +41,8 @@
             add-trap-at-procedure-call!
             add-trace-at-procedure-call!
             add-trap-at-source-location!
-            add-ephemeral-trap-at-frame-finish!))
+            add-ephemeral-trap-at-frame-finish!
+            add-ephemeral-stepping-trap!))
 
 (define %default-trap-handler (make-fluid))
 
@@ -253,6 +256,44 @@
       idx #t trap
       (format #f "Return from ~a" frame)))))
 
+(define (source-string source)
+  (if source
+      (format #f "~a:~a:~a" (or (source:file source) "unknown file")
+              (source:line-for-user source) (source:column source))
+      "unknown source location"))
+
+(define* (add-ephemeral-stepping-trap! frame handler
+                                       #:optional (trap-state
+                                                   (the-trap-state))
+                                       #:key (into? #t) (instruction? #f))
+  (define (wrap-predicate-according-to-into predicate)
+    (if into?
+        predicate
+        (let ((fp (frame-address frame)))
+          (lambda (f)
+            (and (<= (frame-address f) fp)
+                 (predicate f))))))
+  
+  (let* ((source (frame-source frame))
+         (idx (next-ephemeral-index! trap-state))
+         (trap (trap-matching-instructions
+                (wrap-predicate-according-to-into
+                 (if instruction?
+                     (lambda (f) #t)
+                     (lambda (f) (not (equal? (frame-source f) source)))))
+                (ephemeral-handler-for-index trap-state idx handler))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (if instruction?
+          (if into?
+              "Step to different instruction"
+              (format #f "Step to different instruction in ~a" frame))
+          (if into?
+              (format #f "Step into ~a" (source-string source)) 
+              (format #f "Step out of ~a" (source-string source))))))))
+
 (define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
   (let* ((idx (next-index! trap-state)))
     (add-trap-wrapper!
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 856492904..627e6c581 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -72,7 +72,8 @@
             trap-in-dynamic-extent
             trap-calls-in-dynamic-extent
             trap-instructions-in-dynamic-extent
-            trap-calls-to-procedure))
+            trap-calls-to-procedure
+            trap-matching-instructions))
 
 (define-syntax arg-check
   (syntax-rules ()
@@ -662,3 +663,21 @@
 
     (with-pending-finish-disablers
      (trap-at-procedure-call proc apply-hook #:vm vm))))
+
+;; Trap when the source location changes.
+;;
+(define* (trap-matching-instructions frame-pred handler
+                                     #:key (vm (the-vm)))
+  (arg-check frame-pred procedure?)
+  (arg-check handler procedure?)
+  (let ()
+    (define (next-hook frame)
+      (if (frame-pred frame)
+          (handler frame)))
+  
+    (new-enabled-trap
+     vm #f
+     (lambda (frame)
+       (add-hook! (vm-next-hook vm) next-hook))
+     (lambda (frame)
+       (remove-hook! (vm-next-hook vm) next-hook)))))