- Added -d (--debug) flag that enables debugging at the repl, r6rs
scripts, and compiling dependencies. This is the first stab at the debugger. It's SLOW!
This commit is contained in:
Abdulaziz Ghuloum
parent
dbf0b07f13
commit
ff25a484fb
|
|
@ -0,0 +1,102 @@
|
||||||
|
|
||||||
|
(import (ikarus) (ikarus.debugger))
|
||||||
|
|
||||||
|
(define (operator? x)
|
||||||
|
(and (pair? x)
|
||||||
|
(eq? (car x) 'primitive)
|
||||||
|
(guard (con [(assertion-violation? con) #t])
|
||||||
|
(system-value (cadr x))
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define (get-src/expr ae)
|
||||||
|
(if (annotation? ae)
|
||||||
|
(cons (annotation-source ae) (annotation-stripped ae))
|
||||||
|
(cons #f (syntax->datum ae))))
|
||||||
|
|
||||||
|
(define (add-debug-calls expr)
|
||||||
|
(define who 'add-debug-calls)
|
||||||
|
(define (direct-call? op rands)
|
||||||
|
(define n (length rands))
|
||||||
|
(define (test cls*)
|
||||||
|
(and (pair? cls*)
|
||||||
|
(or
|
||||||
|
(let ([fmls (caar cls*)])
|
||||||
|
(and (list? fmls) (= (length fmls) n)))
|
||||||
|
(test (cdr cls*)))))
|
||||||
|
(and (pair? op)
|
||||||
|
(case (car op)
|
||||||
|
[(lambda) (test (list (cdr op)))]
|
||||||
|
[(case-lambda) (test (cdr op))]
|
||||||
|
[(annotated-case-lambda) (test (cddr op))]
|
||||||
|
[else #f])))
|
||||||
|
(define (E-call src/expr op rands)
|
||||||
|
(cond
|
||||||
|
[(or (operator? op) (direct-call? op rands))
|
||||||
|
`(,(E op) ,@(map E rands))]
|
||||||
|
[else
|
||||||
|
`(',debug-call ',src/expr ,(E op) ,@(map E rands))]))
|
||||||
|
(define (E expr)
|
||||||
|
(cond
|
||||||
|
[(symbol? expr) expr]
|
||||||
|
[(and (pair? expr) (list? expr))
|
||||||
|
(let ([a (car expr)] [d (cdr expr)])
|
||||||
|
(case a
|
||||||
|
[(quote) expr]
|
||||||
|
[(primitive) expr]
|
||||||
|
[(set!) `(set! ,(car d) ,(E (cadr d)))]
|
||||||
|
[(if) `(if ,(E (car d)) ,(E (cadr d)) ,(E (caddr d)))]
|
||||||
|
[(begin) (cons 'begin (map E d))]
|
||||||
|
[(lambda) (list 'lambda (car d) (E (cadr d)))]
|
||||||
|
[(case-lambda)
|
||||||
|
(cons 'case-lambda
|
||||||
|
(map (lambda (x) (list (car x) (E (cadr x)))) d))]
|
||||||
|
[(annotated-case-lambda)
|
||||||
|
(cons* 'annotated-case-lambda (car d)
|
||||||
|
(map (lambda (x) (list (car x) (E (cadr x)))) (cdr d)))]
|
||||||
|
[(letrec letrec*)
|
||||||
|
(list a
|
||||||
|
(map (lambda (x) (list (car x) (E (cadr x)))) (car d))
|
||||||
|
(E (cadr d)))]
|
||||||
|
[(foreign-call)
|
||||||
|
(cons* 'foreign-call (car d) (map E (cdr d)))]
|
||||||
|
[(library-letrec*)
|
||||||
|
(list a
|
||||||
|
(map (lambda (x) (list (car x) (cadr x) (E (caddr x)))) (car d))
|
||||||
|
(E (cadr d)))]
|
||||||
|
[(annotated-call)
|
||||||
|
(E-call (get-src/expr (car d)) (cadr d) (cddr d))]
|
||||||
|
[else (E-call #f a d)]))]
|
||||||
|
[else
|
||||||
|
(die who "invalid expression" expr)]))
|
||||||
|
(E expr))
|
||||||
|
|
||||||
|
(define (start-repl)
|
||||||
|
(display "Ikarus Interpreter\n\n")
|
||||||
|
(new-cafe
|
||||||
|
(lambda (x)
|
||||||
|
(guarded-start
|
||||||
|
(lambda ()
|
||||||
|
(eval x (interaction-environment)))))))
|
||||||
|
|
||||||
|
(define (start-script script-name args)
|
||||||
|
(command-line-arguments (cons script-name args))
|
||||||
|
(guarded-start
|
||||||
|
(lambda ()
|
||||||
|
(load-r6rs-script script-name #f #t))))
|
||||||
|
|
||||||
|
(current-core-eval
|
||||||
|
(let ([ev (current-core-eval)])
|
||||||
|
(lambda (x)
|
||||||
|
(let ([x (add-debug-calls x)])
|
||||||
|
(ev x)))))
|
||||||
|
|
||||||
|
(apply
|
||||||
|
(case-lambda
|
||||||
|
[(interpreter flag script-name . rest)
|
||||||
|
(if (string=? flag "--r6rs-script")
|
||||||
|
(start-script script-name rest)
|
||||||
|
(error interpreter "invalid args" (cons* flag script-name rest)))]
|
||||||
|
[(interpreter) (start-repl)]
|
||||||
|
[(interpreter . rest)
|
||||||
|
(error interpreter "invalid args" rest)])
|
||||||
|
(command-line-arguments))
|
||||||
|
|
@ -1,307 +0,0 @@
|
||||||
|
|
||||||
(import (ikarus))
|
|
||||||
|
|
||||||
(define (with-output-to-string/limit x len)
|
|
||||||
(define n 0)
|
|
||||||
(define str (make-string len))
|
|
||||||
(call/cc
|
|
||||||
(lambda (k)
|
|
||||||
(define p
|
|
||||||
(make-custom-textual-output-port
|
|
||||||
"*limited-port*"
|
|
||||||
(lambda (buf i count)
|
|
||||||
(let f ([i i] [count count])
|
|
||||||
(unless (zero? count)
|
|
||||||
(if (= n len)
|
|
||||||
(k str)
|
|
||||||
(begin
|
|
||||||
(string-set! str n (string-ref buf i))
|
|
||||||
(set! n (+ n 1))
|
|
||||||
(f (+ i 1) (- count 1))))))
|
|
||||||
count)
|
|
||||||
#f #f #f))
|
|
||||||
(parameterize ([print-graph #f])
|
|
||||||
(write x p)
|
|
||||||
(flush-output-port p))
|
|
||||||
(substring str 0 n))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define (make-annotated-procedure ann proc)
|
|
||||||
(import (ikarus system $codes))
|
|
||||||
($make-annotated-procedure ann proc))
|
|
||||||
|
|
||||||
(define-struct trace (src expr rator rands))
|
|
||||||
|
|
||||||
(module (get-traces debug-call)
|
|
||||||
|
|
||||||
(define outer-ring-size 30)
|
|
||||||
(define inner-ring-size 10)
|
|
||||||
|
|
||||||
(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
|
|
||||||
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 cell-num cell-prev cell-content)
|
|
||||||
(let f ([x x] [orig #f])
|
|
||||||
(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)
|
|
||||||
(ring->list step-ring ocell-num ocell-prev
|
|
||||||
(lambda (x)
|
|
||||||
(ring->list (ocell-icell x) icell-num icell-prev icell-content))))
|
|
||||||
|
|
||||||
(define step-ring
|
|
||||||
(make-double-ring outer-ring-size inner-ring-size))
|
|
||||||
|
|
||||||
(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 (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))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
(define (operator? x)
|
|
||||||
(and (pair? x)
|
|
||||||
(eq? (car x) 'primitive)
|
|
||||||
(guard (con [(assertion-violation? con) #t])
|
|
||||||
(system-value (cadr x))
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
|
|
||||||
(define (get-src/expr ae)
|
|
||||||
(if (annotation? ae)
|
|
||||||
(values (annotation-source ae) (annotation-stripped ae))
|
|
||||||
(values #f (syntax->datum ae))))
|
|
||||||
|
|
||||||
|
|
||||||
(define (add-debug-calls expr)
|
|
||||||
(define who 'add-debug-calls)
|
|
||||||
(define (direct-call? op rands)
|
|
||||||
(define n (length rands))
|
|
||||||
(define (test cls*)
|
|
||||||
(and (pair? cls*)
|
|
||||||
(or
|
|
||||||
(let ([fmls (caar cls*)])
|
|
||||||
(and (list? fmls) (= (length fmls) n)))
|
|
||||||
(test (cdr cls*)))))
|
|
||||||
(and (pair? op)
|
|
||||||
(case (car op)
|
|
||||||
[(lambda) (test (list (cdr op)))]
|
|
||||||
[(case-lambda) (test (cdr op))]
|
|
||||||
[(annotated-case-lambda) (test (cddr op))]
|
|
||||||
[else #f])))
|
|
||||||
(define (E-call src expr op rands)
|
|
||||||
(cond
|
|
||||||
[(or (operator? op) (direct-call? op rands))
|
|
||||||
`(,op ,@(map E rands))]
|
|
||||||
[else
|
|
||||||
`(',debug-call ',src ',expr ,(E op) ,@(map E rands))]))
|
|
||||||
(define (E expr)
|
|
||||||
(cond
|
|
||||||
[(symbol? expr) expr]
|
|
||||||
[(and (pair? expr) (list? expr))
|
|
||||||
(let ([a (car expr)] [d (cdr expr)])
|
|
||||||
(case a
|
|
||||||
[(quote) expr]
|
|
||||||
[(primitive) expr]
|
|
||||||
[(set!) `(set! ,(car d) ,(E (cadr d)))]
|
|
||||||
[(if) `(if ,(E (car d)) ,(E (cadr d)) ,(E (caddr d)))]
|
|
||||||
[(begin) (cons 'begin (map E d))]
|
|
||||||
[(lambda) (list 'lambda (car d) (E (cadr d)))]
|
|
||||||
[(case-lambda)
|
|
||||||
(cons 'case-lambda
|
|
||||||
(map (lambda (x) (list (car x) (E (cadr x)))) d))]
|
|
||||||
[(annotated-case-lambda)
|
|
||||||
(cons* 'annotated-case-lambda (car d)
|
|
||||||
(map (lambda (x) (list (car x) (E (cadr x)))) (cdr d)))]
|
|
||||||
[(letrec letrec*)
|
|
||||||
(list a
|
|
||||||
(map (lambda (x) (list (car x) (E (cadr x)))) (car d))
|
|
||||||
(E (cadr d)))]
|
|
||||||
[(foreign-call)
|
|
||||||
(cons* 'foreign-call (car d) (map E (cdr d)))]
|
|
||||||
[(library-letrec*)
|
|
||||||
(list a
|
|
||||||
(map (lambda (x) (list (car x) (cadr x) (E (caddr x)))) (car d))
|
|
||||||
(E (cadr d)))]
|
|
||||||
[(annotated-call)
|
|
||||||
(let-values ([(src expr) (get-src/expr (car d))])
|
|
||||||
(E-call src expr (cadr d) (cddr d)))]
|
|
||||||
[else (E-call #f #f a d)]))]
|
|
||||||
[else
|
|
||||||
(die who "invalid expression" expr)]))
|
|
||||||
(E expr))
|
|
||||||
|
|
||||||
|
|
||||||
(define (print-trace x)
|
|
||||||
(define (chop x)
|
|
||||||
(if (> (string-length x) 60)
|
|
||||||
(format "~a#..." (substring x 0 56))
|
|
||||||
x))
|
|
||||||
(let ([n (car x)] [x (cdr x)])
|
|
||||||
(printf " [~a] ~s\n" n (trace-expr x))
|
|
||||||
(let ([src (trace-src x)])
|
|
||||||
(when (pair? src)
|
|
||||||
(printf " source: char ~a of ~a\n" (cdr src) (car src))))
|
|
||||||
(printf " operator: ~s\n" (trace-rator x))
|
|
||||||
(printf " operands: ")
|
|
||||||
(let ([ls (map (lambda (x)
|
|
||||||
(with-output-to-string/limit x 80))
|
|
||||||
(trace-rands x))])
|
|
||||||
(if (< (apply + 1 (length ls) (map string-length ls)) 60)
|
|
||||||
(write (trace-rands x))
|
|
||||||
(begin
|
|
||||||
(display "(")
|
|
||||||
(let f ([a (car ls)] [ls (cdr ls)])
|
|
||||||
(display (chop a))
|
|
||||||
(if (null? ls)
|
|
||||||
(display ")")
|
|
||||||
(begin
|
|
||||||
(display "\n ")
|
|
||||||
(f (car ls) (cdr ls))))))))
|
|
||||||
(newline)))
|
|
||||||
|
|
||||||
(define (print-step x)
|
|
||||||
(let ([n (car x)] [ls (cdr x)])
|
|
||||||
(unless (null? ls)
|
|
||||||
(printf "FRAME ~s:\n" n)
|
|
||||||
(for-each print-trace (reverse ls)))))
|
|
||||||
|
|
||||||
(define (print-all-traces)
|
|
||||||
(let ([ls (reverse (get-traces))])
|
|
||||||
(printf "CALL FRAMES:\n")
|
|
||||||
(for-each print-step ls)))
|
|
||||||
|
|
||||||
(define (guarded-start proc)
|
|
||||||
(with-exception-handler
|
|
||||||
(lambda (con)
|
|
||||||
(define (help)
|
|
||||||
(printf "Condition trapped by debugger.\n")
|
|
||||||
(print-condition con)
|
|
||||||
(printf "~a\n"
|
|
||||||
(string-append
|
|
||||||
"[t] Trace. "
|
|
||||||
"[r] Reraise condition. "
|
|
||||||
"[c] Continue "
|
|
||||||
"[q] Quit "
|
|
||||||
"[?] Help. ")))
|
|
||||||
(help)
|
|
||||||
((call/cc
|
|
||||||
(lambda (k)
|
|
||||||
(new-cafe
|
|
||||||
(lambda (x)
|
|
||||||
(case x
|
|
||||||
[(R r) (k (lambda () (raise-continuable con)))]
|
|
||||||
[(Q q) (exit 0)]
|
|
||||||
[(T t) (print-all-traces)]
|
|
||||||
[(C c) (k void)]
|
|
||||||
[(?) (help)]
|
|
||||||
[else (printf "invalid option\n")])))
|
|
||||||
void))))
|
|
||||||
proc))
|
|
||||||
|
|
||||||
(define (start-repl)
|
|
||||||
(display "Ikarus Interpreter\n\n")
|
|
||||||
(new-cafe
|
|
||||||
(lambda (x)
|
|
||||||
(guarded-start
|
|
||||||
(lambda ()
|
|
||||||
(eval x (interaction-environment)))))))
|
|
||||||
|
|
||||||
(define (start-script script-name args)
|
|
||||||
(command-line-arguments (cons script-name args))
|
|
||||||
(guarded-start
|
|
||||||
(lambda ()
|
|
||||||
(load-r6rs-script script-name #f #t))))
|
|
||||||
|
|
||||||
(current-core-eval
|
|
||||||
(let ([ev (current-core-eval)])
|
|
||||||
(lambda (x)
|
|
||||||
(ev (add-debug-calls x)))))
|
|
||||||
|
|
||||||
(apply
|
|
||||||
(case-lambda
|
|
||||||
[(interpreter flag script-name . rest)
|
|
||||||
(if (string=? flag "--r6rs-script")
|
|
||||||
(start-script script-name rest)
|
|
||||||
(error interpreter "invalid args" (cons* flag script-name rest)))]
|
|
||||||
[(interpreter) (start-repl)]
|
|
||||||
[(interpreter . rest)
|
|
||||||
(error interpreter "invalid args" rest)])
|
|
||||||
(command-line-arguments))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#!eof
|
|
||||||
|
|
||||||
(print-graph #t)
|
|
||||||
|
|
||||||
;(write (make-double-rib 5 5))
|
|
||||||
(write (make-ring 10 (lambda () #f)))
|
|
||||||
(newline)
|
|
||||||
|
|
@ -38,6 +38,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \
|
||||||
ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
|
ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
|
||||||
ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss \
|
ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss \
|
||||||
ikarus.symbol-table.ss ikarus.apropos.ss ikarus.include-src.ss \
|
ikarus.symbol-table.ss ikarus.apropos.ss ikarus.include-src.ss \
|
||||||
|
ikarus.debugger.ss \
|
||||||
tests/SRFI-1.ss \
|
tests/SRFI-1.ss \
|
||||||
tests/bignum-to-flonum.ss \
|
tests/bignum-to-flonum.ss \
|
||||||
tests/bignums.ss \
|
tests/bignums.ss \
|
||||||
|
|
|
||||||
|
|
@ -193,6 +193,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \
|
||||||
ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
|
ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
|
||||||
ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss \
|
ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss \
|
||||||
ikarus.symbol-table.ss ikarus.apropos.ss ikarus.include-src.ss \
|
ikarus.symbol-table.ss ikarus.apropos.ss ikarus.include-src.ss \
|
||||||
|
ikarus.debugger.ss \
|
||||||
tests/SRFI-1.ss \
|
tests/SRFI-1.ss \
|
||||||
tests/bignum-to-flonum.ss \
|
tests/bignum-to-flonum.ss \
|
||||||
tests/bignums.ss \
|
tests/bignums.ss \
|
||||||
|
|
|
||||||
|
|
@ -22,7 +22,7 @@
|
||||||
compile-core-expr expand/optimize optimizer-output
|
compile-core-expr expand/optimize optimizer-output
|
||||||
cp0-effort-limit cp0-size-limit optimize-level
|
cp0-effort-limit cp0-size-limit optimize-level
|
||||||
perform-tag-analysis tag-analysis-output
|
perform-tag-analysis tag-analysis-output
|
||||||
strip-source-info)
|
strip-source-info generate-debug-calls)
|
||||||
(import
|
(import
|
||||||
(rnrs hashtables)
|
(rnrs hashtables)
|
||||||
(ikarus system $fx)
|
(ikarus system $fx)
|
||||||
|
|
@ -44,6 +44,7 @@
|
||||||
|
|
||||||
|
|
||||||
(define strip-source-info (make-parameter #f))
|
(define strip-source-info (make-parameter #f))
|
||||||
|
(define generate-debug-calls (make-parameter #f))
|
||||||
|
|
||||||
(define-syntax struct-case
|
(define-syntax struct-case
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
|
@ -309,7 +310,7 @@
|
||||||
(list? fml*))
|
(list? fml*))
|
||||||
body))))))
|
body))))))
|
||||||
cls*))
|
cls*))
|
||||||
(define (E-make-parameter args ctxt)
|
(define (E-make-parameter mk-call args ctxt)
|
||||||
(case (length args)
|
(case (length args)
|
||||||
[(1)
|
[(1)
|
||||||
(let ([val-expr (car args)]
|
(let ([val-expr (car args)]
|
||||||
|
|
@ -345,15 +346,15 @@
|
||||||
,guard-expr)
|
,guard-expr)
|
||||||
ctxt))]
|
ctxt))]
|
||||||
[else
|
[else
|
||||||
(make-funcall
|
(mk-call
|
||||||
(make-primref 'make-parameter)
|
(make-primref 'make-parameter)
|
||||||
(map (lambda (x) (E x #f)) args))]))
|
(map (lambda (x) (E x #f)) args))]))
|
||||||
(define (E-app rator args ctxt)
|
(define (E-app mk-call rator args ctxt)
|
||||||
(equal-case rator
|
(equal-case rator
|
||||||
[((primitive make-parameter)) (E-make-parameter args ctxt)]
|
[((primitive make-parameter)) (E-make-parameter mk-call args ctxt)]
|
||||||
[else
|
[else
|
||||||
(let ([names (get-fmls rator args)])
|
(let ([names (get-fmls rator args)])
|
||||||
(make-funcall
|
(mk-call
|
||||||
(E rator (list ctxt))
|
(E rator (list ctxt))
|
||||||
(let f ([args args] [names names])
|
(let f ([args args] [names names])
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -443,8 +444,29 @@
|
||||||
(let ([var (cadr x)])
|
(let ([var (cadr x)])
|
||||||
(make-primref var))]
|
(make-primref var))]
|
||||||
[(annotated-call)
|
[(annotated-call)
|
||||||
(E-app (caddr x) (cdddr x) ctxt)]
|
(E-app
|
||||||
[else (E-app (car x) (cdr x) ctxt)])]
|
(if (generate-debug-calls)
|
||||||
|
(lambda (op rands)
|
||||||
|
(define (operator? x)
|
||||||
|
(struct-case x
|
||||||
|
[(primref x)
|
||||||
|
(guard (con [(assertion-violation? con) #t])
|
||||||
|
(system-value x)
|
||||||
|
#f)]
|
||||||
|
[else #f]))
|
||||||
|
(define (get-src/expr ae)
|
||||||
|
(if (annotation? ae)
|
||||||
|
(cons (annotation-source ae) (annotation-stripped ae))
|
||||||
|
(cons #f (syntax->datum ae))))
|
||||||
|
(define src/expr
|
||||||
|
(make-constant (get-src/expr (cadr x))))
|
||||||
|
(if (operator? op)
|
||||||
|
(make-funcall op rands)
|
||||||
|
(make-funcall (make-primref 'debug-call)
|
||||||
|
(cons* src/expr op rands))))
|
||||||
|
make-funcall)
|
||||||
|
(caddr x) (cdddr x) ctxt)]
|
||||||
|
[else (E-app make-funcall (car x) (cdr x) ctxt)])]
|
||||||
[(symbol? x)
|
[(symbol? x)
|
||||||
(cond
|
(cond
|
||||||
[(lexical x) =>
|
[(lexical x) =>
|
||||||
|
|
@ -684,7 +706,7 @@
|
||||||
[(null? cls*) default]
|
[(null? cls*) default]
|
||||||
[(inline-case (car cls*) rand*)]
|
[(inline-case (car cls*) rand*)]
|
||||||
[else (try-inline (cdr cls*) rand* default)]))
|
[else (try-inline (cdr cls*) rand* default)]))
|
||||||
(define (inline rator rand*)
|
(define (inline mk rator rand*)
|
||||||
(define (valid-mv-consumer? x)
|
(define (valid-mv-consumer? x)
|
||||||
(struct-case x
|
(struct-case x
|
||||||
[(clambda L cases F)
|
[(clambda L cases F)
|
||||||
|
|
@ -714,7 +736,7 @@
|
||||||
(struct-case rator
|
(struct-case rator
|
||||||
[(clambda g cls*)
|
[(clambda g cls*)
|
||||||
(try-inline cls* rand*
|
(try-inline cls* rand*
|
||||||
(make-funcall rator rand*))]
|
(mk rator rand*))]
|
||||||
[(primref op)
|
[(primref op)
|
||||||
(case op
|
(case op
|
||||||
;;; FIXME HERE
|
;;; FIXME HERE
|
||||||
|
|
@ -732,36 +754,42 @@
|
||||||
[else
|
[else
|
||||||
(make-funcall rator rand*)]))]
|
(make-funcall rator rand*)]))]
|
||||||
[else
|
[else
|
||||||
(make-funcall rator rand*)])]
|
(mk rator rand*)])]
|
||||||
|
[(debug-call)
|
||||||
|
(inline
|
||||||
|
(lambda (op^ rand*^)
|
||||||
|
(mk rator (cons* (car rand*) op^ rand*^)))
|
||||||
|
(cadr rand*)
|
||||||
|
(cddr rand*))]
|
||||||
[else
|
[else
|
||||||
(make-funcall rator rand*)])]
|
(mk rator rand*)])]
|
||||||
[(bind lhs* rhs* body)
|
[(bind lhs* rhs* body)
|
||||||
(if (null? lhs*)
|
(if (null? lhs*)
|
||||||
(inline body rand*)
|
(inline mk body rand*)
|
||||||
(make-bind lhs* rhs*
|
(make-bind lhs* rhs*
|
||||||
(call-expr body rand*)))]
|
(call-expr mk body rand*)))]
|
||||||
[(recbind lhs* rhs* body)
|
[(recbind lhs* rhs* body)
|
||||||
(if (null? lhs*)
|
(if (null? lhs*)
|
||||||
(inline body rand*)
|
(inline mk body rand*)
|
||||||
(make-recbind lhs* rhs*
|
(make-recbind lhs* rhs*
|
||||||
(call-expr body rand*)))]
|
(call-expr mk body rand*)))]
|
||||||
[(rec*bind lhs* rhs* body)
|
[(rec*bind lhs* rhs* body)
|
||||||
(if (null? lhs*)
|
(if (null? lhs*)
|
||||||
(inline body rand*)
|
(inline mk body rand*)
|
||||||
(make-rec*bind lhs* rhs*
|
(make-rec*bind lhs* rhs*
|
||||||
(call-expr body rand*)))]
|
(call-expr mk body rand*)))]
|
||||||
[else (make-funcall rator rand*)]))
|
[else (mk rator rand*)]))
|
||||||
(define (call-expr x rand*)
|
(define (call-expr mk x rand*)
|
||||||
(cond
|
(cond
|
||||||
[(clambda? x) (inline x rand*)]
|
[(clambda? x) (inline mk x rand*)]
|
||||||
[(and (prelex? x) (not (prelex-source-assigned? x)))
|
[(and (prelex? x) (not (prelex-source-assigned? x)))
|
||||||
;;; FIXME: did we do the analysis yet?
|
;;; FIXME: did we do the analysis yet?
|
||||||
(make-funcall x rand*)]
|
(mk x rand*)]
|
||||||
[else
|
[else
|
||||||
(let ([t (make-prelex 'tmp #f)])
|
(let ([t (make-prelex 'tmp #f)])
|
||||||
(set-prelex-source-referenced?! t #t)
|
(set-prelex-source-referenced?! t #t)
|
||||||
(make-bind (list t) (list x)
|
(make-bind (list t) (list x)
|
||||||
(make-funcall t rand*)))]))
|
(mk t rand*)))]))
|
||||||
(define (Expr x)
|
(define (Expr x)
|
||||||
(struct-case x
|
(struct-case x
|
||||||
[(constant) x]
|
[(constant) x]
|
||||||
|
|
@ -789,7 +817,7 @@
|
||||||
cls*)
|
cls*)
|
||||||
cp free name)]
|
cp free name)]
|
||||||
[(funcall rator rand*)
|
[(funcall rator rand*)
|
||||||
(inline (Expr rator) (map Expr rand*))]
|
(inline make-funcall (Expr rator) (map Expr rand*))]
|
||||||
[(forcall rator rand*)
|
[(forcall rator rand*)
|
||||||
(make-forcall rator (map Expr rand*))]
|
(make-forcall rator (map Expr rand*))]
|
||||||
[(assign lhs rhs)
|
[(assign lhs rhs)
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,194 @@
|
||||||
|
|
||||||
|
(library (ikarus.debugger)
|
||||||
|
(export debug-call guarded-start)
|
||||||
|
(import (ikarus))
|
||||||
|
|
||||||
|
(define (with-output-to-string/limit x len)
|
||||||
|
(define n 0)
|
||||||
|
(define str (make-string len))
|
||||||
|
(call/cc
|
||||||
|
(lambda (k)
|
||||||
|
(define p
|
||||||
|
(make-custom-textual-output-port
|
||||||
|
"*limited-port*"
|
||||||
|
(lambda (buf i count)
|
||||||
|
(let f ([i i] [count count])
|
||||||
|
(unless (zero? count)
|
||||||
|
(if (= n len)
|
||||||
|
(k str)
|
||||||
|
(begin
|
||||||
|
(string-set! str n (string-ref buf i))
|
||||||
|
(set! n (+ n 1))
|
||||||
|
(f (+ i 1) (- count 1))))))
|
||||||
|
count)
|
||||||
|
#f #f #f))
|
||||||
|
(parameterize ([print-graph #f])
|
||||||
|
(write x p)
|
||||||
|
(flush-output-port p))
|
||||||
|
(substring str 0 n))))
|
||||||
|
|
||||||
|
(define-struct trace (src/expr rator rands))
|
||||||
|
|
||||||
|
(define (trace-src x)
|
||||||
|
(let ([x (trace-src/expr x)])
|
||||||
|
(if (pair? x) (car x) #f)))
|
||||||
|
(define (trace-expr x)
|
||||||
|
(let ([x (trace-src/expr x)])
|
||||||
|
(if (pair? x) (cdr x) #f)))
|
||||||
|
|
||||||
|
(module (get-traces debug-call)
|
||||||
|
|
||||||
|
(define outer-ring-size 16)
|
||||||
|
(define inner-ring-size 8)
|
||||||
|
|
||||||
|
(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
|
||||||
|
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 cell-num cell-prev cell-content)
|
||||||
|
(let f ([x x] [orig #f])
|
||||||
|
(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)
|
||||||
|
(ring->list step-ring ocell-num ocell-prev
|
||||||
|
(lambda (x)
|
||||||
|
(ring->list (ocell-icell x) icell-num icell-prev icell-content))))
|
||||||
|
|
||||||
|
(define step-ring
|
||||||
|
(make-double-ring outer-ring-size inner-ring-size))
|
||||||
|
|
||||||
|
(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 (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)))
|
||||||
|
|
||||||
|
(define (print-trace x)
|
||||||
|
(define (chop x)
|
||||||
|
(if (> (string-length x) 60)
|
||||||
|
(format "~a#..." (substring x 0 56))
|
||||||
|
x))
|
||||||
|
(let ([n (car x)] [x (cdr x)])
|
||||||
|
(printf " [~a] ~s\n" n (trace-expr x))
|
||||||
|
(let ([src (trace-src x)])
|
||||||
|
(when (pair? src)
|
||||||
|
(printf " source: char ~a of ~a\n" (cdr src) (car src))))
|
||||||
|
(printf " operator: ~s\n" (trace-rator x))
|
||||||
|
(printf " operands: ")
|
||||||
|
(let ([ls (map (lambda (x)
|
||||||
|
(with-output-to-string/limit x 80))
|
||||||
|
(trace-rands x))])
|
||||||
|
(if (< (apply + 1 (length ls) (map string-length ls)) 60)
|
||||||
|
(write (trace-rands x))
|
||||||
|
(begin
|
||||||
|
(display "(")
|
||||||
|
(let f ([a (car ls)] [ls (cdr ls)])
|
||||||
|
(display (chop a))
|
||||||
|
(if (null? ls)
|
||||||
|
(display ")")
|
||||||
|
(begin
|
||||||
|
(display "\n ")
|
||||||
|
(f (car ls) (cdr ls))))))))
|
||||||
|
(newline)))
|
||||||
|
|
||||||
|
(define (print-step x)
|
||||||
|
(let ([n (car x)] [ls (cdr x)])
|
||||||
|
(unless (null? ls)
|
||||||
|
(printf "FRAME ~s:\n" n)
|
||||||
|
(for-each print-trace (reverse ls)))))
|
||||||
|
|
||||||
|
(define (print-all-traces)
|
||||||
|
(let ([ls (reverse (get-traces))])
|
||||||
|
(printf "CALL FRAMES:\n")
|
||||||
|
(for-each print-step ls)))
|
||||||
|
|
||||||
|
(define (guarded-start proc)
|
||||||
|
(with-exception-handler
|
||||||
|
(lambda (con)
|
||||||
|
(define (help)
|
||||||
|
(printf "Condition trapped by debugger.\n")
|
||||||
|
(print-condition con)
|
||||||
|
(printf "~a\n"
|
||||||
|
(string-append
|
||||||
|
"[t] Trace. "
|
||||||
|
"[r] Reraise condition. "
|
||||||
|
"[c] Continue. "
|
||||||
|
"[q] Quit. "
|
||||||
|
"[?] Help. ")))
|
||||||
|
(help)
|
||||||
|
((call/cc
|
||||||
|
(lambda (k)
|
||||||
|
(new-cafe
|
||||||
|
(lambda (x)
|
||||||
|
(case x
|
||||||
|
[(R r) (k (lambda () (raise-continuable con)))]
|
||||||
|
[(Q q) (exit 0)]
|
||||||
|
[(T t) (print-all-traces)]
|
||||||
|
[(C c) (k void)]
|
||||||
|
[(?) (help)]
|
||||||
|
[else (printf "invalid option\n")])))
|
||||||
|
void))))
|
||||||
|
proc))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
@ -76,6 +76,8 @@
|
||||||
(export)
|
(export)
|
||||||
(import (except (ikarus) load-r6rs-script)
|
(import (except (ikarus) load-r6rs-script)
|
||||||
(except (ikarus startup) host-info)
|
(except (ikarus startup) host-info)
|
||||||
|
(only (ikarus.compiler) generate-debug-calls)
|
||||||
|
(ikarus.debugger)
|
||||||
(only (psyntax library-manager) current-library-expander)
|
(only (psyntax library-manager) current-library-expander)
|
||||||
(only (ikarus.reader.annotated) read-source-file)
|
(only (ikarus.reader.annotated) read-source-file)
|
||||||
(only (ikarus.symbol-table) initialize-symbol-table!)
|
(only (ikarus.symbol-table) initialize-symbol-table!)
|
||||||
|
|
@ -86,6 +88,12 @@
|
||||||
(let f ([args (command-line-arguments)])
|
(let f ([args (command-line-arguments)])
|
||||||
(cond
|
(cond
|
||||||
[(null? args) (values '() #f #f '())]
|
[(null? args) (values '() #f #f '())]
|
||||||
|
[(member (car args) '("-d" "--debug"))
|
||||||
|
(generate-debug-calls #t)
|
||||||
|
(f (cdr args))]
|
||||||
|
[(member (car args) '("-nd" "--no-debug"))
|
||||||
|
(generate-debug-calls #f)
|
||||||
|
(f (cdr args))]
|
||||||
[(string=? (car args) "-O2")
|
[(string=? (car args) "-O2")
|
||||||
(optimize-level 2)
|
(optimize-level 2)
|
||||||
(f (cdr args))]
|
(f (cdr args))]
|
||||||
|
|
@ -127,8 +135,19 @@
|
||||||
(apply die 'ikarus
|
(apply die 'ikarus
|
||||||
(format "load files not allowed for ~a" who)
|
(format "load files not allowed for ~a" who)
|
||||||
files)))
|
files)))
|
||||||
|
|
||||||
|
(define (start proc)
|
||||||
|
(if (generate-debug-calls)
|
||||||
|
(guarded-start proc)
|
||||||
|
(proc)))
|
||||||
|
(define-syntax doit
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ e e* ...)
|
||||||
|
(start (lambda () e e* ...))]))
|
||||||
|
|
||||||
(cond
|
(cond
|
||||||
[(eq? script-type 'r6rs-script)
|
[(eq? script-type 'r6rs-script)
|
||||||
|
(doit
|
||||||
(command-line-arguments (cons script args))
|
(command-line-arguments (cons script args))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (filename)
|
(lambda (filename)
|
||||||
|
|
@ -137,21 +156,23 @@
|
||||||
((current-library-expander) src))
|
((current-library-expander) src))
|
||||||
(read-source-file filename)))
|
(read-source-file filename)))
|
||||||
files)
|
files)
|
||||||
(load-r6rs-script script #f #t)
|
(load-r6rs-script script #f #t))]
|
||||||
(exit 0)]
|
|
||||||
[(eq? script-type 'compile)
|
[(eq? script-type 'compile)
|
||||||
(assert-null files "--compile-dependencies")
|
(assert-null files "--compile-dependencies")
|
||||||
|
(doit
|
||||||
(command-line-arguments (cons script args))
|
(command-line-arguments (cons script args))
|
||||||
(load-r6rs-script script #t #f)
|
(load-r6rs-script script #t #f))]
|
||||||
(exit 0)]
|
|
||||||
[(eq? script-type 'script) ; no greeting, no cafe
|
[(eq? script-type 'script) ; no greeting, no cafe
|
||||||
(command-line-arguments (cons script args))
|
(command-line-arguments (cons script args))
|
||||||
|
(doit
|
||||||
(for-each load files)
|
(for-each load files)
|
||||||
(load script)
|
(load script))]
|
||||||
(exit 0)]
|
|
||||||
[else
|
[else
|
||||||
(print-greeting)
|
(print-greeting)
|
||||||
(command-line-arguments (cons "*interactive*" args))
|
(command-line-arguments (cons "*interactive*" args))
|
||||||
(for-each load files)
|
(doit (for-each load files))
|
||||||
(new-cafe)
|
(new-cafe
|
||||||
(exit 0)])))
|
(lambda (x)
|
||||||
|
(doit (eval x (interaction-environment)))))])
|
||||||
|
|
||||||
|
(exit 0)))
|
||||||
|
|
|
||||||
|
|
@ -1 +1 @@
|
||||||
1779
|
1780
|
||||||
|
|
|
||||||
|
|
@ -111,6 +111,7 @@
|
||||||
"ikarus.command-line.ss"
|
"ikarus.command-line.ss"
|
||||||
"ikarus.pointers.ss"
|
"ikarus.pointers.ss"
|
||||||
"ikarus.not-yet-implemented.ss"
|
"ikarus.not-yet-implemented.ss"
|
||||||
|
"ikarus.debugger.ss"
|
||||||
"ikarus.main.ss"
|
"ikarus.main.ss"
|
||||||
))
|
))
|
||||||
|
|
||||||
|
|
@ -1531,6 +1532,7 @@
|
||||||
[make-c-callout $for]
|
[make-c-callout $for]
|
||||||
[make-c-callback $for]
|
[make-c-callback $for]
|
||||||
[host-info i]
|
[host-info i]
|
||||||
|
[debug-call ]
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue