diff --git a/lab/ikarus.interpreter.ss b/lab/ikarus.interpreter.ss index c25fd8c..948d748 100644 --- a/lab/ikarus.interpreter.ss +++ b/lab/ikarus.interpreter.ss @@ -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") diff --git a/scheme/last-revision b/scheme/last-revision index 5a3aaf0..3bc34dd 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1777 +1778