- debugging in interpreter is changed to use continuation frames

dynamically instead of performing context-sensitive transformation
  to determine tail/nontail calls.
- interpreter now has options to reraise, continue, or quit.

lab/ikarus.interpreter.ss

@@ -5,80 +5,95 @@
   (import (ikarus system $codes))
   ($make-annotated-procedure ann proc))
 
-(define id
+(define-struct trace (src expr rator rands))
-  (let ([id -1])
-    (lambda () 
-      (set! id (+ id 1))
-      id)))
 
-(module (with-click get-traces mark-reduction!
+(module (get-traces debug-call)
-                    reset-ring) 
 
-  (define outer-ring-size 20)
+  (define outer-ring-size 30)
-  (define inner-ring-size 20)
+  (define inner-ring-size 10)
 
-  (define-struct cell (prev next num content))
+  (define end-marker -1)
-  
+
-  (define (make-ring n f)
+  (define-struct icell (prev next num content))
-    (cond
+  (define-struct ocell (prev next num cf icell))
-      [(= n 1) 
+
-       (let ([cell (make-cell #f #f -1 (f))])
+  (define (make-ring n cell-prev cell-next cell-prev-set! cell-next-set! make-cell)
-         (set-cell-prev! cell cell)
+    (let ([ring (make-cell)])
-         (set-cell-next! cell cell)
+      (cell-prev-set! ring ring)
-         cell)]
+      (cell-next-set! ring ring)
-      [else 
+      (do ((n n (- n 1)))
-       (let ([ring (make-ring (- n 1) f)])
+        ((<= n 1))
-         (let ([next (cell-next ring)])
+        (let ([cell (make-cell)]
-           (let ([cell (make-cell ring next -1 (f))])
+              [next (cell-next ring)])
-             (set-cell-prev! next cell)
+          (cell-prev-set! cell ring)
-             (set-cell-next! ring cell)
+          (cell-next-set! cell next)
-             cell)))]))
+          (cell-prev-set! next cell)
+          (cell-next-set! ring cell)))
+      ring))
   
   (define (make-double-ring n m)
-    (make-ring n (lambda () (make-ring m (lambda () #f)))))
+    (make-ring n
+      ocell-prev ocell-next set-ocell-prev! set-ocell-next!
+      (lambda ()
+        (make-ocell #f #f end-marker #f 
+          (make-ring m 
+            icell-prev icell-next set-icell-prev! set-icell-next!
+            (lambda () (make-icell #f #f end-marker (lambda () #f))))))))
 
-  (define (ring->list x)
+  (define (ring->list x cell-num cell-prev cell-content)
     (let f ([x x] [orig #f])
-      (if (or (eq? x orig) (eqv? (cell-num x) -1))
+      (if (or (eq? x orig) (eqv? (cell-num x) end-marker))
           '()
            (cons (cons (cell-num x) (cell-content x))
              (f (cell-prev x) (or orig x))))))
    
   (define (get-traces)
-    (map (lambda (x) 
+    (ring->list step-ring ocell-num ocell-prev
-           (cons (car x) (ring->list (cdr x))))
+      (lambda (x)
-         (ring->list step-ring)))
+        (ring->list (ocell-icell x) icell-num icell-prev icell-content))))
 
-  (define step-ring #f)
+  (define step-ring 
+    (make-double-ring outer-ring-size inner-ring-size))
 
-  (define (reset-ring)
+  (define (debug-call src expr rator rands)
-    (printf "RESET!\n")
+    (call/cf
-    (set! step-ring (make-double-ring outer-ring-size inner-ring-size))
+      (lambda (cf)
-    (set-cell-num! step-ring 0))
+        (if (eq? cf (ocell-cf step-ring))
+            (reduce src expr rator rands)
+            (let ([cf #f] [pcf #f])
+              (dynamic-wind
+                (lambda () 
+                  (let ([prev step-ring])
+                    (let ([next (ocell-next prev)])
+                      (set! pcf (ocell-cf prev))
+                      (set-ocell-num! next (+ (ocell-num prev) 1))
+                      (set-icell-num! (ocell-icell next) end-marker)
+                      (set! step-ring next)
+                      (set-ocell-cf! step-ring cf))))
+                (lambda ()
+                  (call/cf
+                    (lambda (cf2)
+                      (set! cf cf2)
+                      (set-ocell-cf! step-ring cf)
+                      (reduce src expr rator rands))))
+                (lambda ()
+                  (let ([next step-ring])
+                    (let ([prev (ocell-prev next)])
+                      (set-ocell-num! prev (- (ocell-num next) 1))
+                      (set-ocell-num! next end-marker)
+                      (set-icell-num! (ocell-icell next) end-marker)
+                      (set-ocell-cf! prev pcf)
+                      (set! step-ring prev))))))))))
 
-  (define (with-click p)
+  (define (reduce src expr rator rands)
-    (dynamic-wind
+    (define (mark-reduction! x)
-      (lambda () 
+      (let ([prev (ocell-icell step-ring)])
-        (let ([prev step-ring])
+        (let ([next (icell-next prev)])
-          (let ([next (cell-next prev)])
+          (set-icell-content! next x)
-            (set-cell-num! next (+ (cell-num prev) 1))
+          (set-icell-num! next (+ (icell-num prev) 1))
-            (set-cell-num! (cell-content next) -1)
+          (set-ocell-icell! step-ring next))))
-            (set! step-ring next))))
+    (mark-reduction! (make-trace src expr rator rands))
-      p
+    (apply rator rands))
-      (lambda ()
-        (let ([next step-ring])
-          (let ([prev (cell-prev next)])
-            (set-cell-num! prev (- (cell-num next) 1))
-            (set-cell-num! next -1)
-            (set-cell-num! (cell-content next) -1)
-            (set! step-ring prev))))))
-
-  (define (mark-reduction! x)
-    (let ([prev (cell-content step-ring)])
-      (let ([next (cell-next prev)])
-        (set-cell-content! next x)
-        (set-cell-num! next (+ (cell-num prev) 1))
-        (set-cell-content! step-ring next))))
 
 )
 
@@ -196,14 +211,14 @@
           [(matching? (caar cls*) args)
            (caar cls*)]
           [else (f (cdr cls*))])))
-    (define (compile-letrec* binding* body env ctxt tail?)
+    (define (compile-letrec* binding* body env ctxt)
       (let ([lhs* (map car binding*)]
             [rhs* (map cadr binding*)])
         (let-values ([(env n) (extend-env lhs* env)])
           (let ([rhs* (map (lambda (lhs rhs) 
-                             (compile-expr rhs env lhs #f))
+                             (compile-expr rhs env lhs))
                            lhs* rhs*)]
-                [body (compile-expr body env ctxt tail?)])
+                [body (compile-expr body env ctxt)])
             (lambda (env)
               (let ([vec (make-vector n)])
                 (let ([env (cons vec env)])
@@ -213,15 +228,15 @@
                         (begin 
                           (vector-set! vec i ((car rhs*) env))
                           (f (+ i 1) (cdr rhs*))))))))))))
-    (define (compile-library-letrec* binding* body env ctxt tail?)
+    (define (compile-library-letrec* binding* body env ctxt)
       (let ([lhs* (map car binding*)]
             [loc* (map cadr binding*)]
             [rhs* (map caddr binding*)])
         (let-values ([(env n) (extend-env lhs* env)])
           (let ([rhs* (map (lambda (lhs rhs)
-                             (compile-expr rhs env lhs #f))
+                             (compile-expr rhs env lhs))
                            lhs* rhs*)]
-                [body (compile-expr body env ctxt tail?)])
+                [body (compile-expr body env ctxt)])
             (lambda (env)
               (let ([vec (make-vector n)])
                 (let ([env (cons vec env)])
@@ -236,8 +251,7 @@
       (define (compile-clause fmls expr k)
         (let-values ([(env n) (extend-env fmls env)])
           (let ([expr (compile-expr expr env
-                        (if (pair? ctxt) (car ctxt) #f)
+                        (if (pair? ctxt) (car ctxt) #f))])
-                        #t)])
             (cond
               [(list? fmls) 
                (lambda (env args argcount)
@@ -290,7 +304,7 @@
                (global-ref loc)))]
           [else (die who "invalid value" x)])))
     (define (compile-set! lhs rhs env)
-      (let ([rhs (compile-expr rhs env lhs #f)]
+      (let ([rhs (compile-expr rhs env lhs)]
             [x (lookup lhs env)])
         (case (car x)
           [(lexical)
@@ -302,48 +316,31 @@
              (lambda (env)
                (global-set! loc (rhs env))))]
           [else (die who "invalid set! target" lhs)])))
-    (define (compile-if e0 e1 e2 env ctxt tail?)
+    (define (compile-if e0 e1 e2 env ctxt)
-      (let ([e0 (compile-expr e0 env #f #f)]
+      (let ([e0 (compile-expr e0 env #f)]
-            [e1 (compile-expr e1 env ctxt tail?)]
+            [e1 (compile-expr e1 env ctxt)]
-            [e2 (compile-expr e2 env ctxt tail?)])
+            [e2 (compile-expr e2 env ctxt)])
         (lambda (env)
           (if (e0 env) (e1 env) (e2 env)))))
-    (define (compile-begin e e* env ctxt tail?)
+    (define (compile-begin e e* env ctxt)
       (cond
-        [(null? e*) (compile-expr e env ctxt tail?)]
+        [(null? e*) (compile-expr e env ctxt)]
         [else
-         (let ([e0 (compile-expr e env #f #f)]
+         (let ([e0 (compile-expr e env #f)]
-               [e* (compile-begin (car e*) (cdr e*) env ctxt tail?)])
+               [e* (compile-begin (car e*) (cdr e*) env ctxt)])
            (lambda (env) (e0 env) (e* env)))]))
     (define (get-src/expr ae)
       (if (annotation? ae)
           (values (annotation-source ae) (annotation-stripped ae))
           (values #f (syntax->datum ae))))
-    (define (compile-tail-call ae e e* env ctxt)
+    (define (compile-let e e* env ctxt)
-      (let ([e (compile-expr e env (list ctxt) #f)]
-            [e* (map (lambda (x) (compile-expr x env #f #f)) e*)])
-        (if ae
-            (let-values ([(src expr) (get-src/expr ae)])
-              (lambda (env)
-                (let ([e (e env)] [e* (map (lambda (e) (e env)) e*)])
-                  (mark-reduction! (make-trace src expr env e e* (id)))
-                  (apply e e*))))
-            (lambda (env)
-              (let ([e (e env)] [e* (map (lambda (e) (e env)) e*)])
-                (mark-reduction! (make-trace #f #f env e e* (id)))
-                (apply e e*))))))
-    (define (compile-nontail-call ae e e* env ctxt)
-      (let ([proc (compile-tail-call ae e e* env ctxt)])
-        (lambda (env)
-          (with-click (lambda () (proc env))))))
-    (define (compile-let e e* env ctxt tail?)
       (define (build-let fmls e* body)
         (let ([e*
                (list->vector
-                 (map (lambda (x e) (compile-expr e env x #f))
+                 (map (lambda (x e) (compile-expr e env x))
                       fmls e*))])
           (let-values ([(env _) (extend-env fmls env)])
-            (let ([body (compile-expr body env ctxt tail?)])
+            (let ([body (compile-expr body env ctxt)])
               (lambda (env)
                 (body (cons (vector-map (lambda (x) (x env)) e*) env)))))))
       (define (dispatch cls*)
@@ -359,12 +356,19 @@
              [(case-lambda) (dispatch (cdr e))]
              [(annotated-case-lambda) (dispatch (cddr e))]
              [else #f])))
-    (define (compile-call ae e e* env ctxt tail?)
+    (define (compile-call ae e e* env ctxt)
-      (or (compile-let e e* env ctxt tail?)
+      (or (compile-let e e* env ctxt)
-          (if tail?
+          (let ([e (compile-expr e env (list ctxt))]
-              (compile-tail-call ae e e* env ctxt)
+                [e* (map (lambda (x) (compile-expr x env #f)) e*)])
-              (compile-nontail-call ae e e* env ctxt))))
+            (if ae
-    (define (compile-expr expr env ctxt tail?)
+                (let-values ([(src expr) (get-src/expr ae)])
+                  (lambda (env)
+                    (let ([e (e env)] [e* (map (lambda (e) (e env)) e*)])
+                      (debug-call src expr e e*))))
+                (lambda (env)
+                  (let ([e (e env)] [e* (map (lambda (e) (e env)) e*)])
+                    (debug-call #f #f e e*)))))))
+    (define (compile-expr expr env ctxt)
       (cond
         [(symbol? expr) (compile-var expr env)]
         [(and (pair? expr) (list? expr))
@@ -373,9 +377,9 @@
              [(quote) (let ([v (car d)]) (lambda (env) v))]
              [(set!) (compile-set! (car d) (cadr d) env)]
              [(if)
-              (compile-if (car d) (cadr d) (caddr d) env ctxt tail?)]
+              (compile-if (car d) (cadr d) (caddr d) env ctxt)]
              [(begin) 
-              (compile-begin (car d) (cdr d) env ctxt tail?)]
+              (compile-begin (car d) (cdr d) env ctxt)]
              [(lambda)
               (compile-case-lambda #f (list d) env ctxt)]
              [(case-lambda)
@@ -383,29 +387,28 @@
              [(annotated-case-lambda)
               (compile-case-lambda (car d) (cdr d) env ctxt)]
              [(letrec letrec*)
-              (compile-letrec* (car d) (cadr d) env ctxt tail?)]
+              (compile-letrec* (car d) (cadr d) env ctxt)]
              [(library-letrec*)
-              (compile-library-letrec* (car d) (cadr d) env ctxt tail?)]
+              (compile-library-letrec* (car d) (cadr d) env ctxt)]
              [(primitive)
               (let ([v (primitive-value (car d))])
                 (lambda (env) v))]
              [(annotated-call) 
-              (compile-call (car d) (cadr d) (cddr d) env ctxt tail?)]
+              (compile-call (car d) (cadr d) (cddr d) env ctxt)]
              [(foreign-call) 
               (let ([name (car d)] [args (cdr d)])
                 (let ([ls (map (lambda (x) (gensym)) args)])
                   (let ([code 
                          (real-eval
                             `(lambda ,ls (foreign-call ,name . ,ls)))])
-                    (compile-expr `(',code . ,args) env ctxt tail?))))]
+                    (compile-expr `(',code . ,args) env ctxt))))]
              [else
-              (compile-call #f a d env ctxt tail?)]))]
+              (compile-call #f a d env ctxt)]))]
         [else
          (die who "invalid expression" expr)]))
     (lambda (expr)
-      ((compile-expr expr '() #f #t) '()))))
+      ((compile-expr expr '() #f) '()))))
 
-(define-struct trace (src expr env v v* id))
 
 (define (print-trace x)
   (define (chop x)
@@ -417,11 +420,11 @@
     (let ([src (trace-src x)])
       (when (pair? src)
         (printf "     source: char ~a of ~a\n" (cdr src) (car src))))
-    (printf "     operator: ~s\n" (trace-v x))
+    (printf "     operator: ~s\n" (trace-rator x))
     (printf "     operands: ")
-    (let ([ls (map (lambda (x) (format "~s" x)) (trace-v* x))])
+    (let ([ls (map (lambda (x) (format "~s" x)) (trace-rands x))])
       (if (< (apply + 1 (length ls) (map string-length ls)) 60)
-          (write (trace-v* x))
+          (write (trace-rands x))
           (begin
             (display "(")
             (let f ([a (car ls)] [ls (cdr ls)])
@@ -446,16 +449,21 @@
 (define (guarded-start proc)
   (with-exception-handler
     (lambda (con)
-      (print-all-traces)
+;      (print-all-traces)
-      (let f ()
+      ((call/cc
-        (printf "continue? (y/n) ")
+         (lambda (k)
-        (case (read)
+           (printf "Condition trapped by debugger.\n")
-          [(y) (void)]
+           (print-condition con)
-          [(n) (raise-continuable con)]
+           (printf "[t] Trace.  [r] Reraise condition.  [e] Exit.  [^D] Return.\n")
-          [else (f)])))
+           (new-cafe
-    (lambda () 
+             (lambda (x)
-      (reset-ring)
+               (case x
-      (proc))))
+                [(R r) (k (lambda () (raise-continuable con)))]
+                [(E e) (exit 0)]
+                [(T t) (print-all-traces)]
+                [else (printf "invalid option\n")])))
+           void))))
+    proc))
 
 (define (start-repl)
   (display "Ikarus Interpreter\n\n")

scheme/last-revision

@@ -1 +1 @@
-1777
+1778