- 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.
This commit is contained in:
Abdulaziz Ghuloum
parent
391e2fa87b
commit
2929379460
|
|
@ -5,80 +5,95 @@
|
|||
(import (ikarus system $codes))
|
||||
($make-annotated-procedure ann proc))
|
||||
|
||||
(define id
|
||||
(let ([id -1])
|
||||
(lambda ()
|
||||
(set! id (+ id 1))
|
||||
id)))
|
||||
(define-struct trace (src expr rator rands))
|
||||
|
||||
(module (with-click get-traces mark-reduction!
|
||||
reset-ring)
|
||||
(module (get-traces debug-call)
|
||||
|
||||
(define outer-ring-size 20)
|
||||
(define inner-ring-size 20)
|
||||
(define outer-ring-size 30)
|
||||
(define inner-ring-size 10)
|
||||
|
||||
(define-struct cell (prev next num content))
|
||||
|
||||
(define (make-ring n f)
|
||||
(cond
|
||||
[(= n 1)
|
||||
(let ([cell (make-cell #f #f -1 (f))])
|
||||
(set-cell-prev! cell cell)
|
||||
(set-cell-next! cell cell)
|
||||
cell)]
|
||||
[else
|
||||
(let ([ring (make-ring (- n 1) f)])
|
||||
(let ([next (cell-next ring)])
|
||||
(let ([cell (make-cell ring next -1 (f))])
|
||||
(set-cell-prev! next cell)
|
||||
(set-cell-next! ring cell)
|
||||
cell)))]))
|
||||
(define end-marker -1)
|
||||
|
||||
(define-struct icell (prev next num content))
|
||||
(define-struct ocell (prev next num cf icell))
|
||||
|
||||
(define (make-ring n cell-prev cell-next cell-prev-set! cell-next-set! make-cell)
|
||||
(let ([ring (make-cell)])
|
||||
(cell-prev-set! ring ring)
|
||||
(cell-next-set! ring ring)
|
||||
(do ((n n (- n 1)))
|
||||
((<= n 1))
|
||||
(let ([cell (make-cell)]
|
||||
[next (cell-next ring)])
|
||||
(cell-prev-set! cell ring)
|
||||
(cell-next-set! cell next)
|
||||
(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)
|
||||
(cons (car x) (ring->list (cdr x))))
|
||||
(ring->list step-ring)))
|
||||
(ring->list step-ring ocell-num ocell-prev
|
||||
(lambda (x)
|
||||
(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)
|
||||
(printf "RESET!\n")
|
||||
(set! step-ring (make-double-ring outer-ring-size inner-ring-size))
|
||||
(set-cell-num! step-ring 0))
|
||||
(define (debug-call src expr rator rands)
|
||||
(call/cf
|
||||
(lambda (cf)
|
||||
(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)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(let ([prev step-ring])
|
||||
(let ([next (cell-next prev)])
|
||||
(set-cell-num! next (+ (cell-num prev) 1))
|
||||
(set-cell-num! (cell-content next) -1)
|
||||
(set! step-ring next))))
|
||||
p
|
||||
(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))))
|
||||
(define (reduce src expr rator rands)
|
||||
(define (mark-reduction! x)
|
||||
(let ([prev (ocell-icell step-ring)])
|
||||
(let ([next (icell-next prev)])
|
||||
(set-icell-content! next x)
|
||||
(set-icell-num! next (+ (icell-num prev) 1))
|
||||
(set-ocell-icell! step-ring next))))
|
||||
(mark-reduction! (make-trace src expr rator rands))
|
||||
(apply rator rands))
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -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)
|
||||
#t)])
|
||||
(if (pair? ctxt) (car ctxt) #f))])
|
||||
(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?)
|
||||
(let ([e0 (compile-expr e0 env #f #f)]
|
||||
[e1 (compile-expr e1 env ctxt tail?)]
|
||||
[e2 (compile-expr e2 env ctxt tail?)])
|
||||
(define (compile-if e0 e1 e2 env ctxt)
|
||||
(let ([e0 (compile-expr e0 env #f)]
|
||||
[e1 (compile-expr e1 env ctxt)]
|
||||
[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)]
|
||||
[e* (compile-begin (car e*) (cdr e*) env ctxt tail?)])
|
||||
(let ([e0 (compile-expr e env #f)]
|
||||
[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)
|
||||
(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 (compile-let e e* env ctxt)
|
||||
(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?)
|
||||
(or (compile-let e e* env ctxt tail?)
|
||||
(if tail?
|
||||
(compile-tail-call ae e e* env ctxt)
|
||||
(compile-nontail-call ae e e* env ctxt))))
|
||||
(define (compile-expr expr env ctxt tail?)
|
||||
(define (compile-call ae e e* env ctxt)
|
||||
(or (compile-let e e* env ctxt)
|
||||
(let ([e (compile-expr e env (list ctxt))]
|
||||
[e* (map (lambda (x) (compile-expr x env #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*)])
|
||||
(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)
|
||||
(let f ()
|
||||
(printf "continue? (y/n) ")
|
||||
(case (read)
|
||||
[(y) (void)]
|
||||
[(n) (raise-continuable con)]
|
||||
[else (f)])))
|
||||
(lambda ()
|
||||
(reset-ring)
|
||||
(proc))))
|
||||
; (print-all-traces)
|
||||
((call/cc
|
||||
(lambda (k)
|
||||
(printf "Condition trapped by debugger.\n")
|
||||
(print-condition con)
|
||||
(printf "[t] Trace. [r] Reraise condition. [e] Exit. [^D] Return.\n")
|
||||
(new-cafe
|
||||
(lambda (x)
|
||||
(case x
|
||||
[(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")
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1777
|
||||
1778
|
||||
|
|
|
|||
Loading…
Reference in New Issue