Debugger, begin runtime stuff

asm/fib.scm

@@ -0,0 +1,36 @@
+  (variable result 0)
+  (push result)
+  (@)
+  (push fib)
+  (call)
+  (push cleanup)
+  (jmp)
+fib
+  (dup)
+  (push 0)
+  (=)
+  (over)
+  (push 1)
+  (=)
+  (or)
+  (push recur)
+  (branch)
+  (return)
+recur
+  (dup)
+  (push 1)
+  (-)
+  (push fib)
+  (call)
+  (over)
+  (push 2)
+  (-)
+  (push fib)
+  (call)
+  (+)
+  (nip)
+  (return)
+cleanup
+  (push result)
+  (!)
+  (bye)

asm/runtime.scm

@@ -0,0 +1,76 @@
+;; Note that this is scheme syntax wrapping asm for a stack machine
+(variable scan 0)
+(variable free 0)
+(variable eom 1024)
+;; These need to be initialized later
+(variable root 0)
+(variable the-cars 0) 
+(variable the-cdrs 0)
+(variable new-cars 0)
+(variable new-cdrs 0)
+
+
+(push main)
+(jmp)
+
+alloc
+;; Test if free will go beyond eom
+(push free)
+(@)
+(dup) ; ( -- free free)
+(push 8)
+(+)
+(dup) ; ( -- free free+8 free+8)
+(push eom)
+(@)
+(<) ; ( -- free free+8 (free+8 < eom))
+(branch alloc-do-gc)
+;; write free+8 to free
+(push free)
+(!)
+;; return the old free, it is memory the program can use
+(return)
+alloc-do-gc
+;; Empty the stack
+(drop)
+(drop)
+;; Run garbage collection
+(push gc-start)
+(call)
+;; Tail-call allocation
+(push alloc)
+(jmp)
+
+gc-start
+; Move scan & free back to 0
+(push 0)
+(push free)
+(!)
+(push 0)
+(push scan)
+(!)
+; Push the first cons to relocate (root)
+(push root)
+(@)
+; Call the relocation routine
+(push gc-loop)
+(call)
+; Swap new and old cars and cdrs
+(push new-cars)
+(@)
+(push the-cars)
+(@)
+(push new-cars)
+(!)
+(push the-cars)
+(!)
+(push new-cdrs)
+(@)
+(push the-cdrs)
+(@)
+(push new-cdrs)
+(!)
+(push the-cdrs)
+(!)
+; return to allocation
+(return)

scmvm.scm

@@ -1,26 +1,27 @@
-#! /bin/sh
-exec guile -L . -e main -s "$0" "$@"
-!#
+(define-module (scmvm)
+  #:use-module (scmvm vm)
+  #:use-module (scmvm assembler)
+  #:use-module (scmvm debugger)
+  #:use-module (ice-9 ports)
+  #:re-export ( ;; vm
+               make-vm run-vm vm-load-program!
+               vm-memory-ref vm-memory-set!
+               vm-pc vm-pc-set!
+               ;; assembler
+               assemble
+               ;; debugger
+               make-debugger debugger-continue
+               debugger-vm
+               debugger-breakpoints debugger-breakpoints-set!
+               debugger-breakpoint-add! debugger-breakpoint-ref
+               debugger-breakpoint-enable! debugger-breakpoint-disable!)
+  #:export (read-all-instructions instructions-from-file))
 
-(use-modules (scmvm vm)
-             (scmvm assembler)
-             (srfi srfi-11)
-             (srfi srfi-26)
-             (ice-9 control))
+(define (read-all-instructions)
+  (let ([inst (read)])
+    (if (eof-object? inst)
+        '()
+        (cons inst (read-all-instructions)))))
 
-(define (make-debugger source asm)
-  ())
-
-(define (debug file)
-  (let*-values ([(source) (open-file file)]
-                [(asm) (call-with-output-bytevector (cut assemble-file file <>))]
-                [(begin-debugger resume-debugger) (make-debugger source asm)])
-    (% (begin-debugger)
-       (resume-debugger))))
-
-(define (main . args)
-  (when (null? args)
-    (usage))
-  (case (car args)
-    [(help) (usage)]
-    [(debug) (apply debug (cdr args))]))
+(define (instructions-from-file file)
+  (with-input-from-file file read-all-instructions))

scmvm/assembler.scm

@@ -5,7 +5,7 @@
   #:use-module (rnrs io ports)
   #:use-module ((scheme base)
                 #:select (write-u8 write-bytevector))
-  #:export (assemble assemble-file))
+  #:export (assemble))
 
 (define (lookup-instruction inst)
   (define inst-obj (assq inst *instruction-set*))
@@ -36,9 +36,9 @@
   (write-bytevector bv))
 
 (define (assemble inst-seq port)
+  (define labels (find-labels inst-seq 1))
   (with-output-to-port port
     (lambda ()
-      (define labels (find-labels inst-seq 1))
       (let loop ([seq inst-seq])
         (cond
          [(null? seq) '()]
@@ -54,13 +54,5 @@
               (if (number? (cadr inst))
                   (write-word (cadr inst))
                   (write-word (assq-ref labels (cadr inst)))))
-            (loop (cdr seq)))])))))
-
-(define (assemble-file file out)
-  (call-with-input-file file
-    (lambda (in)
-      (define (read-all next)
-        (if (eof-object? next)
-            '()
-            (cons next (read-all (read in)))))
-      (assemble (read-all (read in)) out))))
+            (loop (cdr seq)))]))))
+  labels)

scmvm/debugger.scm

@@ -0,0 +1,68 @@
+(define-module (scmvm debugger)
+  #:use-module (scmvm assembler)
+  #:use-module (scmvm vm)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 exceptions)
+  #:export ((make-debugger* . make-debugger)
+            debugger-vm
+            debugger-source
+            debugger-breakpoints debugger-breakpoints-set!
+            debugger-breakpoint-add! debugger-breakpoint-ref
+            debugger-breakpoint-enable! debugger-breakpoint-disable!
+            debugger-continue))
+
+(define-record-type <debugger>
+  (make-debugger vm source breakpoints continuation)
+  debugger?
+  (vm debugger-vm)
+  (source debugger-source)
+  (breakpoints debugger-breakpoints debugger-breakpoints-set!)
+  (continuation debugger-continuation debugger-continuation-set!))
+
+(define (make-debugger* source)
+  (define-values (prgm symbols)
+    (call-with-values open-bytevector-output-port
+      (lambda (port get-bv)
+        (define symbols (assemble source port))
+        (values (get-bv) symbols))))
+  (define the-debugger #f)
+  (define (debug)
+    (shift k
+           (debugger-continuation-set! the-debugger k)
+           (when (not (assq-ref (debugger-breakpoints the-debugger)
+                                (vm-pc (debugger-vm the-debugger))))
+             (k))))
+  (define vm (make-vm #:debugger debug))
+  (vm-load-program! vm prgm)
+  (set! the-debugger (make-debugger vm source '((1 . #t)) #f))
+  (reset (run-vm vm))
+  the-debugger)
+
+(define (debugger-continue debugger)
+  ((debugger-continuation debugger)))
+
+(define* (debugger-breakpoint-add! debugger breakpoint #:key (enabled? #f))
+  (debugger-breakpoints-set!
+   debugger
+   (assq-set! (debugger-breakpoints debugger) breakpoint enabled?)))
+
+(define (debugger-breakpoint-ref debugger breakpoint)
+  (assq breakpoint (debugger-breakpoints debugger)))
+
+(define (debugger-breakpoint-enable! debugger breakpoint)
+  (define breakpoints (debugger-breakpoints debugger))
+  (if (pair? (assq breakpoints breakpoint))
+      (assq-set! breakpoints breakpoint #t)
+      (raise-exception (make-exception
+                        (make-error)
+                        (make-exception-with-message "Cannot enable nonexistant breakpoint")))))
+
+(define (debugger-breakpoint-disable! debugger breakpoint)
+  (define breakpoints (debugger-breakpoints debugger))
+  (if (pair? (assq breakpoints breakpoint))
+      (assq-set! breakpoints breakpoint #f)
+      (raise-exception (make-exception
+                        (make-error)
+                        (make-exception-with-message "Cannot disable nonexistant breakpoint")))))

scmvm/vm.scm

@@ -5,7 +5,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (make-vm run-vm vm-memory-ref vm-memory-set! vm-memory vm-load-program!
-            vm-pc-ref vm-pc-set!
+            vm-pc vm-pc-set!
             *instruction-set* instruction-type instruction-code))
 
 ;;; Data Structures
@@ -156,70 +156,70 @@
       word))
   (define (fetch-and-execute)
     (define exit? #f)
-    (let lp ([op (fetch-byte)])
-      (when debugger
-        (debugger))
-      (case (op-lookup op)
-        [(push)
-         (push data-stack (fetch-word))]
-        [(!)
-         (let ([addr (pop data-stack)]
-               [v (pop data-stack)])
-           (ram-word-set! addr v))]
-        [(@)
-         (let* ([addr (pop data-stack)]
-                [v (ram-word-ref addr)])
-           (push data-stack v))]
-        [(+ - and or nand nor xor)
-         (let ([v2 (pop data-stack)]
-               [v1 (pop data-stack)])
-           (push data-stack ((binop-lookup op) v1 v2)))]
-        [(= > <)
-         (let ([v2 (pop data-stack)]
-               [v1 (pop data-stack)])
-           (if ((relop-lookup op) v1 v2)
-               (push data-stack 1)
-               (push data-stack 0)))]
-        [(jmp)
-         (jump (pop data-stack))]
-        [(branch)
-         (let ([addr (pop data-stack)])
-           (when (zero? (pop data-stack))
-             (jump addr)))]
-        [(call)
-         (let ([addr (pop data-stack)])
-           (push ret-stack pc)
-           (jump addr))]
-        [(return)
-         (jump (pop ret-stack))]
-        [(>R)
-         (push ret-stack (pop data-stack))]
-        [(R>)
-         (push data-stack (pop ret-stack))]
-        [(drop)
-         (pop data-stack)]
-        [(nip)
-         (let ([v (pop data-stack)])
-           (pop data-stack)
-           (push data-stack v))]
-        [(dup)
-         (push data-stack (peek data-stack))]
-        [(swap)
-         (swap data-stack)]
-        [(rot)
-         (let* ([a (pop data-stack)]
-                [b (pop data-stack)]
-                [c (pop data-stack)])
-           (push data-stack a)
-           (push data-stack c)
-           (push data-stack b))]
-        [(over)
-         (let* ([a (pop data-stack)]
-                [b (pop data-stack)])
-           (push data-stack b)
-           (push data-stack a)
-           (push data-stack b))]
-        [(bye) (set! exit? #t)]))
+    (when debugger
+      (debugger))
+    (define op (fetch-byte))
+    (case (op-lookup op)
+      [(push)
+       (push data-stack (fetch-word))]
+      [(!)
+       (let ([addr (pop data-stack)]
+             [v (pop data-stack)])
+         (ram-word-set! addr v))]
+      [(@)
+       (let* ([addr (pop data-stack)]
+              [v (ram-word-ref addr)])
+         (push data-stack v))]
+      [(+ - and or nand nor xor)
+       (let ([v2 (pop data-stack)]
+             [v1 (pop data-stack)])
+         (push data-stack ((binop-lookup op) v1 v2)))]
+      [(= > <)
+       (let ([v2 (pop data-stack)]
+             [v1 (pop data-stack)])
+         (if ((relop-lookup op) v1 v2)
+             (push data-stack 1)
+             (push data-stack 0)))]
+      [(jmp)
+       (jump (pop data-stack))]
+      [(branch)
+       (let ([addr (pop data-stack)])
+         (when (zero? (pop data-stack))
+           (jump addr)))]
+      [(call)
+       (let ([addr (pop data-stack)])
+         (push ret-stack pc)
+         (jump addr))]
+      [(return)
+       (jump (pop ret-stack))]
+      [(>R)
+       (push ret-stack (pop data-stack))]
+      [(R>)
+       (push data-stack (pop ret-stack))]
+      [(drop)
+       (pop data-stack)]
+      [(nip)
+       (let ([v (pop data-stack)])
+         (pop data-stack)
+         (push data-stack v))]
+      [(dup)
+       (push data-stack (peek data-stack))]
+      [(swap)
+       (swap data-stack)]
+      [(rot)
+       (let* ([a (pop data-stack)]
+              [b (pop data-stack)]
+              [c (pop data-stack)])
+         (push data-stack a)
+         (push data-stack c)
+         (push data-stack b))]
+      [(over)
+       (let* ([a (pop data-stack)]
+              [b (pop data-stack)])
+         (push data-stack b)
+         (push data-stack a)
+         (push data-stack b))]
+      [(bye) (set! exit? #t)])
     (when (not exit?)
       (fetch-and-execute)))
   (lambda (x)
@@ -228,7 +228,7 @@
       [(vm-memory) (lambda () ram)]
       [(vm-memory-ref) ram-word-ref]
       [(vm-memory-set!) ram-word-set!]
-      [(vm-pc-ref) (lambda () pc)]
+      [(vm-pc) (lambda () pc)]
       [(vm-pc-set!) (lambda (v) (set! pc v))]
       [else (error "vm unknown dispatch")])))
 
@@ -251,9 +251,9 @@
                       ram 0
                       (bytevector-length prgm))))
 
-(define (vm-pc-ref vm)
+(define (vm-pc vm)
   "Return the value of the pc"
-  ((vm 'vm-pc-ref)))
+  ((vm 'vm-pc)))
 
 (define (vm-pc-set! vm pc)
   "Set the value of the pc"