implement breakpoints in the repl

* module/system/vm/trap-state.scm: New file, tracks a VM-specific set of
  traps.
* module/Makefile.am: Add trap-state.scm.

* module/system/repl/error-handling.scm: While in a with-error-handling
  block, bind a default trap handler that invokes a recursive prompt.

* module/system/repl/command.scm: Add a `break' repl meta-command.

module/Makefile.am

@@ -314,6 +314,7 @@ SYSTEM_SOURCES =				\
   system/vm/program.scm				\
   system/vm/trace.scm				\
   system/vm/traps.scm				\
+  system/vm/trap-state.scm			\
   system/vm/vm.scm				\
   system/foreign.scm				\
   system/xref.scm				\

module/system/repl/command.scm

@@ -27,6 +27,7 @@
   #:use-module (system repl debug)
   #:use-module (system vm objcode)
   #:use-module (system vm program)
+  #:use-module (system vm trap-state)
   #:use-module (system vm vm)
   #:autoload (system base language) (lookup-language language-reader)
   #:autoload (system vm trace) (vm-trace)
@@ -55,7 +56,8 @@
 	      (disassemble x) (disassemble-file xx))
     (profile  (time t) (profile pr) (trace tr))
     (debug    (backtrace bt) (up) (down) (frame fr)
-              (procedure proc) (locals) (error-message error))
+              (procedure proc) (locals) (error-message error)
+              (break br))
     (inspect  (inspect i) (pretty-print pp))
     (system   (gc) (statistics stat) (option o)
               (quit q continue cont))))
@@ -476,14 +478,6 @@ Trace execution."
                    body body* ...)
                  (format #t "Nothing to debug.~%"))))))))
 
-(define-stack-command (error-message repl)
-  "error-message
-Show error message.
-
-Display the message associated with the error that started the current
-debugging REPL."
-  (format #t "~a~%" (if (string? message) message "No error message")))
-
 (define-stack-command (backtrace repl #:optional count
                                  #:key (width 72) full?)
   "backtrace [COUNT] [#:width W] [#:full? F]
@@ -566,6 +560,26 @@ Show local variables.
 Show locally-bound variables in the selected frame."
   (print-locals cur))
 
+(define-stack-command (error-message repl)
+  "error-message
+Show error message.
+
+Display the message associated with the error that started the current
+debugging REPL."
+  (format #t "~a~%" (if (string? message) message "No error message")))
+
+(define-meta-command (break repl (form))
+  "break PROCEDURE
+Break on calls to PROCEDURE.
+
+Starts a recursive prompt when PROCEDURE is called."
+  (let ((proc (repl-eval repl (repl-parse repl form))))
+    (if (not (procedure? proc))
+        (error "Not a procedure: ~a" proc)
+        (let ((idx (add-trap-at-procedure-call! proc)))
+          (format #t "Added breakpoint ~a at ~a.~%" idx proc)))))
+
+
 
 ;;;
 ;;; Inspection commands

module/system/repl/error-handling.scm

@@ -21,6 +21,7 @@
 
 (define-module (system repl error-handling)
   #:use-module (system base pmatch)
+  #:use-module (system vm trap-state)
   #:use-module (system repl debug)
   #:export (call-with-error-handling
             with-error-handling))
@@ -56,8 +57,34 @@
               (with-error-to-port err
                 thunk))))))
 
+    (define (debug-trap-handler frame trap-idx trap-name)
+      (let* ((tag (and (pair? (fluid-ref %stacks))
+                       (cdar (fluid-ref %stacks))))
+             (stack (narrow-stack->vector
+                     (make-stack frame)
+                     ;; Take the stack from the given frame, cutting 0
+                     ;; frames.
+                     0
+                     ;; Narrow the end of the stack to the most recent
+                     ;; start-stack.
+                     tag
+                     ;; And one more frame, because %start-stack
+                     ;; invoking the start-stack thunk has its own frame
+                     ;; too.
+                     0 (and tag 1)))
+             (error-msg (format #f "Trap ~d: ~a" trap-idx trap-name))
+             (debug (make-debug stack 0 error-msg)))
+        (with-saved-ports
+         (lambda ()
+           (format #t "~a~%" error-msg)
+           (format #t "Entering a new prompt.  ")
+           (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+           ((@ (system repl repl) start-repl) #:debug debug)))))
+
     (catch #t
-      (lambda () (%start-stack #t thunk))
+      (lambda () 
+        (with-default-trap-handler debug-trap-handler
+          (lambda () (%start-stack #t thunk))))
 
       (case post-error
         ((report)

module/system/vm/trap-state.scm

@@ -0,0 +1,174 @@
+;;; trap-state.scm: a set of traps
+
+;; Copyright (C)  2010 Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; Code:
+
+(define-module (system vm trap-state)
+  #:use-module (system base syntax)
+  #:use-module (system vm vm)
+  #:use-module (system vm traps)
+  #:export (list-traps
+            trap-enabled?
+            enable-trap!
+            disable-trap!
+            delete-trap!
+            
+            with-default-trap-handler
+            install-trap-handler!
+
+            add-trap-at-procedure-call!))
+
+(define %default-trap-handler (make-fluid))
+
+(define (with-default-trap-handler handler thunk)
+  (with-fluids ((%default-trap-handler handler))
+    (thunk)))
+
+(define (default-trap-handler frame idx trap-name)
+  (if %default-trap-handler
+      ((fluid-ref %default-trap-handler) frame idx trap-name)
+      (warn "Trap with no handler installed" frame idx trap-name)))
+
+(define-record <trap-wrapper>
+  index
+  enabled?
+  trap
+  name)
+
+(define-record <trap-state>
+  (handler default-trap-handler)
+  (next-idx 0)
+  (wrappers '()))
+
+(define (trap-wrapper<? t1 t2)
+  (< (trap-wrapper-index t1) (trap-wrapper-index t2)))
+
+;; The interface that a trap provides to the outside world is that of a
+;; procedure, which when called disables the trap, and returns a
+;; procedure to enable the trap. Perhaps this is a bit too odd and we
+;; should fix this.
+(define (enable-trap-wrapper! wrapper)
+  (if (trap-wrapper-enabled? wrapper)
+      (error "Trap already enabled" (trap-wrapper-index wrapper))
+      (let ((trap (trap-wrapper-trap wrapper)))
+        (set! (trap-wrapper-trap wrapper) (trap))
+        (set! (trap-wrapper-enabled? wrapper) #t))))
+
+(define (disable-trap-wrapper! wrapper)
+  (if (not (trap-wrapper-enabled? wrapper))
+      (error "Trap already disabled" (trap-wrapper-index wrapper))
+      (let ((trap (trap-wrapper-trap wrapper)))
+        (set! (trap-wrapper-trap wrapper) (trap))
+        (set! (trap-wrapper-enabled? wrapper) #f))))
+
+(define (add-trap-wrapper! trap-state wrapper)
+  (set! (trap-state-wrappers trap-state)
+        (append (trap-state-wrappers trap-state) (list wrapper)))
+  (trap-wrapper-index wrapper))
+
+(define (remove-trap-wrapper! trap-state wrapper)
+  (delq wrapper (trap-state-wrappers trap-state)))
+
+(define (wrapper-at-index trap-state idx)
+  (let lp ((wrappers (trap-state-wrappers trap-state)))
+    (cond
+     ((null? wrappers)
+      (warn "no wrapper found with index in trap-state" idx)
+      #f)
+     ((= (trap-wrapper-index (car wrappers)) idx)
+      (car wrappers))
+     (else
+      (lp (cdr wrappers))))))
+
+(define (next-index! trap-state)
+  (let ((idx (trap-state-next-idx trap-state)))
+    (set! (trap-state-next-idx trap-state) (1+ idx))
+    idx))
+
+(define (handler-for-index trap-state idx)
+  (lambda (frame)
+    (let ((wrapper (wrapper-at-index trap-state idx))
+          (handler (trap-state-handler trap-state)))
+      (if wrapper
+          (handler frame
+                   (trap-wrapper-index wrapper)
+                   (trap-wrapper-name wrapper))))))
+
+
+
+;;;
+;;; VM-local trap states
+;;;
+
+(define *trap-states* (make-weak-key-hash-table))
+
+(define (trap-state-for-vm vm)
+  (or (hashq-ref *trap-states* vm)
+      (let ((ts (make-trap-state)))
+        (hashq-set! *trap-states* vm ts)
+        (trap-state-for-vm vm))))
+
+(define (the-trap-state)
+  (trap-state-for-vm (the-vm)))
+
+
+
+;;;
+;;; API
+;;;
+
+(define* (list-traps #:optional (trap-state (the-trap-state)))
+  (map (lambda (wrapper)
+         (cons (trap-wrapper-index wrapper)
+               (trap-wrapper-name wrapper)))
+       (trap-state-wrappers trap-state)))
+
+(define* (trap-enabled? idx #:optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         trap-wrapper-enabled?))
+
+(define* (enable-trap! idx #:optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         enable-trap-wrapper!))
+
+(define* (disable-trap! idx #:optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         disable-trap-wrapper!))
+
+(define* (delete-trap! idx #:optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         (lambda (wrapper)
+           (if (trap-wrapper-enabled? wrapper)
+               (disable-trap-wrapper! wrapper))
+           (remove-trap-wrapper! trap-state wrapper))))
+
+(define* (install-trap-handler! handler #:optional (trap-state (the-trap-state)))
+  (set! (trap-state-handler trap-state) handler))
+
+(define* (add-trap-at-procedure-call! proc #:optional (trap-state (the-trap-state)))
+  (let* ((idx (next-index! trap-state))
+         (trap (trap-at-procedure-call
+                proc
+                (handler-for-index trap-state idx))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "breakpoint at ~a" proc)))))