- trace-lambda and debug-call now interact properly and do not lose
tail calls.
This commit is contained in:
parent
8ef5eaeca2
commit
b35f5a9e1d
|
@ -18,7 +18,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \
|
||||||
ikarus.promises.ss ikarus.reader.ss \
|
ikarus.promises.ss ikarus.reader.ss \
|
||||||
ikarus.records.procedural.ss ikarus.conditions.ss \
|
ikarus.records.procedural.ss ikarus.conditions.ss \
|
||||||
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
||||||
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \
|
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss \
|
||||||
ikarus.unicode-conversion.ss ikarus.unicode.ss \
|
ikarus.unicode-conversion.ss ikarus.unicode.ss \
|
||||||
ikarus.vectors.ss ikarus.writer.ss makefile.ss \
|
ikarus.vectors.ss ikarus.writer.ss makefile.ss \
|
||||||
pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss \
|
pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss \
|
||||||
|
|
|
@ -173,7 +173,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \
|
||||||
ikarus.promises.ss ikarus.reader.ss \
|
ikarus.promises.ss ikarus.reader.ss \
|
||||||
ikarus.records.procedural.ss ikarus.conditions.ss \
|
ikarus.records.procedural.ss ikarus.conditions.ss \
|
||||||
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
||||||
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \
|
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss \
|
||||||
ikarus.unicode-conversion.ss ikarus.unicode.ss \
|
ikarus.unicode-conversion.ss ikarus.unicode.ss \
|
||||||
ikarus.vectors.ss ikarus.writer.ss makefile.ss \
|
ikarus.vectors.ss ikarus.writer.ss makefile.ss \
|
||||||
pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss \
|
pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss \
|
||||||
|
|
|
@ -1,7 +1,9 @@
|
||||||
|
|
||||||
(library (ikarus.debugger)
|
(library (ikarus.debugger)
|
||||||
(export debug-call guarded-start)
|
(export debug-call guarded-start
|
||||||
(import (ikarus))
|
make-traced-procedure make-traced-macro)
|
||||||
|
(import (except (ikarus) make-traced-procedure make-traced-macro))
|
||||||
|
|
||||||
|
|
||||||
(define (with-output-to-string/limit x len)
|
(define (with-output-to-string/limit x len)
|
||||||
(define n 0)
|
(define n 0)
|
||||||
|
@ -27,13 +29,14 @@
|
||||||
(flush-output-port p))
|
(flush-output-port p))
|
||||||
(substring str 0 n))))
|
(substring str 0 n))))
|
||||||
|
|
||||||
(define-struct scell (cf ocell prev))
|
(define-struct scell (cf ocell trace filter prev))
|
||||||
|
|
||||||
(define (mkcell prev)
|
(define (mkcell prev)
|
||||||
(make-scell #f #f prev))
|
(make-scell #f #f #f #f prev))
|
||||||
|
|
||||||
(define *scell* (mkcell #f))
|
(define *scell* (mkcell #f))
|
||||||
|
|
||||||
|
|
||||||
(define (stacked-call pre thunk post)
|
(define (stacked-call pre thunk post)
|
||||||
(call/cf
|
(call/cf
|
||||||
(lambda (cf)
|
(lambda (cf)
|
||||||
|
@ -59,9 +62,67 @@
|
||||||
(define return-handler
|
(define return-handler
|
||||||
(lambda v*
|
(lambda v*
|
||||||
(set-scell-ocell! *scell* #f)
|
(set-scell-ocell! *scell* #f)
|
||||||
|
(cond
|
||||||
|
[(scell-trace *scell*) =>
|
||||||
|
(lambda (n)
|
||||||
|
(display-return-trace n ((scell-filter *scell*) v*)))])
|
||||||
(apply values v*)))
|
(apply values v*)))
|
||||||
|
|
||||||
|
|
||||||
|
(module (display-return-trace make-traced-procedure make-traced-macro)
|
||||||
|
(define *trace-depth* 0)
|
||||||
|
|
||||||
|
(define display-prefix
|
||||||
|
(lambda (n)
|
||||||
|
(let f ([i 0])
|
||||||
|
(unless (= i n)
|
||||||
|
(display (if (even? i) "|" " "))
|
||||||
|
(f (+ i 1))))))
|
||||||
|
|
||||||
|
(define (display-call-trace n ls)
|
||||||
|
(display-prefix n)
|
||||||
|
(write ls)
|
||||||
|
(newline))
|
||||||
|
|
||||||
|
(define (display-return-trace n ls)
|
||||||
|
(display-prefix n)
|
||||||
|
(unless (null? ls)
|
||||||
|
(write (car ls))
|
||||||
|
(let f ([ls (cdr ls)])
|
||||||
|
(unless (null? ls)
|
||||||
|
(write-char #\space)
|
||||||
|
(write (car ls))
|
||||||
|
(f (cdr ls)))))
|
||||||
|
(newline))
|
||||||
|
|
||||||
|
(define make-traced-procedure
|
||||||
|
(case-lambda
|
||||||
|
[(name proc) (make-traced-procedure name proc (lambda (x) x))]
|
||||||
|
[(name proc filter)
|
||||||
|
(lambda args
|
||||||
|
(stacked-call
|
||||||
|
(lambda ()
|
||||||
|
(set! *trace-depth* (add1 *trace-depth*)))
|
||||||
|
(lambda ()
|
||||||
|
(set-scell-trace! *scell* *trace-depth*)
|
||||||
|
(set-scell-filter! *scell* filter)
|
||||||
|
(display-call-trace *trace-depth* (filter (cons name args)))
|
||||||
|
(apply proc args))
|
||||||
|
(lambda ()
|
||||||
|
(set! *trace-depth* (sub1 *trace-depth*)))))]))
|
||||||
|
|
||||||
|
(define make-traced-macro
|
||||||
|
(lambda (name x)
|
||||||
|
(cond
|
||||||
|
[(procedure? x)
|
||||||
|
(make-traced-procedure name x syntax->datum)]
|
||||||
|
[(variable-transformer? x)
|
||||||
|
(make-variable-transformer
|
||||||
|
(make-traced-procedure name
|
||||||
|
(variable-transformer-procedure x)
|
||||||
|
syntax->datum))]
|
||||||
|
[else x]))))
|
||||||
|
|
||||||
(define-struct trace (src/expr rator rands))
|
(define-struct trace (src/expr rator rands))
|
||||||
|
|
||||||
(define (trace-src x)
|
(define (trace-src x)
|
||||||
|
|
|
@ -77,7 +77,7 @@
|
||||||
(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)
|
(only (ikarus.compiler) generate-debug-calls)
|
||||||
(ikarus.debugger)
|
(only (ikarus.debugger) guarded-start)
|
||||||
(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!)
|
||||||
|
|
|
@ -262,8 +262,8 @@
|
||||||
(die who "failed to initialize" rtype argtypes)
|
(die who "failed to initialize" rtype argtypes)
|
||||||
(die who "FFI support is not enabled. \
|
(die who "FFI support is not enabled. \
|
||||||
You need to recompile ikarus with \
|
You need to recompile ikarus with \
|
||||||
--enable-ffi option set in order to \
|
--enable-libffi option set in order \
|
||||||
make use of the (ikarus foreign) \
|
to make use of the (ikarus foreign) \
|
||||||
library.")))
|
library.")))
|
||||||
argtypes-n
|
argtypes-n
|
||||||
rtype-n)))
|
rtype-n)))
|
||||||
|
|
|
@ -1,213 +0,0 @@
|
||||||
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
|
||||||
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
|
|
||||||
;;;
|
|
||||||
;;; This program is free software: you can redistribute it and/or modify
|
|
||||||
;;; it under the terms of the GNU General Public License version 3 as
|
|
||||||
;;; published by the Free Software Foundation.
|
|
||||||
;;;
|
|
||||||
;;; This program is distributed in the hope that it will be useful, but
|
|
||||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
||||||
;;; General Public License for more details.
|
|
||||||
;;;
|
|
||||||
;;; You should have received a copy of the GNU General Public License
|
|
||||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
|
|
||||||
(library (ikarus trace)
|
|
||||||
(export make-traced-procedure make-traced-macro)
|
|
||||||
(import (except (ikarus) make-traced-procedure make-traced-macro))
|
|
||||||
|
|
||||||
|
|
||||||
(define-struct scell (cf trace filter prev))
|
|
||||||
|
|
||||||
(define (mkcell prev)
|
|
||||||
(make-scell #f #f #f prev))
|
|
||||||
|
|
||||||
(define *scell* (mkcell #f))
|
|
||||||
|
|
||||||
(define *trace-depth* 0)
|
|
||||||
|
|
||||||
(define display-prefix
|
|
||||||
(lambda (n)
|
|
||||||
(let f ([i 0])
|
|
||||||
(unless (= i n)
|
|
||||||
(display (if (even? i) "|" " "))
|
|
||||||
(f (+ i 1))))))
|
|
||||||
|
|
||||||
(define display-trace
|
|
||||||
(lambda (k* v)
|
|
||||||
(display-prefix k* #t)
|
|
||||||
(write v)
|
|
||||||
(newline)))
|
|
||||||
|
|
||||||
(define (display-return-trace n ls)
|
|
||||||
(display-prefix n)
|
|
||||||
(unless (null? ls)
|
|
||||||
(write (car ls))
|
|
||||||
(let f ([ls (cdr ls)])
|
|
||||||
(unless (null? ls)
|
|
||||||
(write-char #\space)
|
|
||||||
(write (car ls))
|
|
||||||
(f (cdr ls)))))
|
|
||||||
(newline))
|
|
||||||
|
|
||||||
(define (display-call-trace n ls)
|
|
||||||
(display-prefix n)
|
|
||||||
(write ls)
|
|
||||||
(newline))
|
|
||||||
|
|
||||||
(define (stacked-call pre thunk post)
|
|
||||||
(call/cf
|
|
||||||
(lambda (cf)
|
|
||||||
(if (eq? cf (scell-cf *scell*))
|
|
||||||
(thunk)
|
|
||||||
(dynamic-wind
|
|
||||||
(let ([scell (mkcell *scell*)])
|
|
||||||
(lambda ()
|
|
||||||
(set! *scell* scell)
|
|
||||||
(pre)))
|
|
||||||
(lambda ()
|
|
||||||
(call-with-values
|
|
||||||
(lambda ()
|
|
||||||
(call/cf
|
|
||||||
(lambda (cf)
|
|
||||||
(set-scell-cf! *scell* cf)
|
|
||||||
(thunk))))
|
|
||||||
return-handler))
|
|
||||||
(lambda ()
|
|
||||||
(post)
|
|
||||||
(set! *scell* (scell-prev *scell*))))))))
|
|
||||||
|
|
||||||
(define return-handler
|
|
||||||
(lambda v*
|
|
||||||
(cond
|
|
||||||
[(scell-trace *scell*) =>
|
|
||||||
(lambda (n)
|
|
||||||
(display-return-trace n ((scell-filter *scell*) v*)))])
|
|
||||||
(apply values v*)))
|
|
||||||
|
|
||||||
(define make-traced-procedure
|
|
||||||
(case-lambda
|
|
||||||
[(name proc) (make-traced-procedure name proc (lambda (x) x))]
|
|
||||||
[(name proc filter)
|
|
||||||
(lambda args
|
|
||||||
(stacked-call
|
|
||||||
(lambda ()
|
|
||||||
(set! *trace-depth* (add1 *trace-depth*)))
|
|
||||||
(lambda ()
|
|
||||||
(set-scell-trace! *scell* *trace-depth*)
|
|
||||||
(set-scell-filter! *scell* filter)
|
|
||||||
(display-call-trace *trace-depth* (filter (cons name args)))
|
|
||||||
(apply proc args))
|
|
||||||
(lambda ()
|
|
||||||
(set! *trace-depth* (sub1 *trace-depth*)))))]))
|
|
||||||
|
|
||||||
|
|
||||||
(define make-traced-macro
|
|
||||||
(lambda (name x)
|
|
||||||
(cond
|
|
||||||
[(procedure? x)
|
|
||||||
(make-traced-procedure name x syntax->datum)]
|
|
||||||
[(variable-transformer? x)
|
|
||||||
(make-variable-transformer
|
|
||||||
(make-traced-procedure name
|
|
||||||
(variable-transformer-procedure x)
|
|
||||||
syntax->datum))]
|
|
||||||
[else x]))))
|
|
||||||
|
|
||||||
|
|
||||||
#!eof
|
|
||||||
|
|
||||||
(define traced-symbols '())
|
|
||||||
|
|
||||||
(define untrace-symbol!
|
|
||||||
(lambda (s)
|
|
||||||
(define loop
|
|
||||||
(lambda (ls)
|
|
||||||
(cond
|
|
||||||
[(null? ls) '()]
|
|
||||||
[(eq? s (caar ls))
|
|
||||||
(let ([a (cdar ls)])
|
|
||||||
(when (eq? (cdr a) (symbol-value s))
|
|
||||||
(set-symbol-value! s (car a)))
|
|
||||||
(cdr ls))]
|
|
||||||
[else (cons (car ls) (loop (cdr ls)))])))
|
|
||||||
(set! traced-symbols (loop traced-symbols))))
|
|
||||||
|
|
||||||
(define trace-symbol!
|
|
||||||
(lambda (s)
|
|
||||||
(cond
|
|
||||||
[(assq s traced-symbols) =>
|
|
||||||
(lambda (pr)
|
|
||||||
(let ([a (cdr pr)] [v (symbol-value s)])
|
|
||||||
(unless (eq? (cdr a) v)
|
|
||||||
(unless (procedure? v)
|
|
||||||
(die 'trace
|
|
||||||
"the top-level value is not a procedure"
|
|
||||||
s v))
|
|
||||||
(let ([p (make-traced-procedure s v)])
|
|
||||||
(set-car! a v)
|
|
||||||
(set-cdr! a p)
|
|
||||||
(set-symbol-value! s p)))))]
|
|
||||||
[else
|
|
||||||
(unless (symbol-bound? s)
|
|
||||||
(die 'trace "unbound" s))
|
|
||||||
(let ([v (symbol-value s)])
|
|
||||||
(unless (procedure? v)
|
|
||||||
(die 'trace "the top-level value is not a procedure" s v))
|
|
||||||
(let ([p (make-traced-procedure s v)])
|
|
||||||
(set! traced-symbols
|
|
||||||
(cons (cons s (cons v p)) traced-symbols))
|
|
||||||
(set-symbol-value! s p)))])))
|
|
||||||
Try:
|
|
||||||
|
|
||||||
(trace-define fact
|
|
||||||
(lambda (n)
|
|
||||||
(if (zero? n)
|
|
||||||
1
|
|
||||||
(* n (fact (sub1 n))))))
|
|
||||||
(fact 5)
|
|
||||||
|
|
||||||
(trace-define (fact n m)
|
|
||||||
(cond
|
|
||||||
[(zero? n) m]
|
|
||||||
[else (fact (sub1 n) (* n m))]))
|
|
||||||
(fact 5 1)
|
|
||||||
|
|
||||||
|
|
||||||
(trace-define (fact n m k)
|
|
||||||
(cond
|
|
||||||
[(zero? n) (k m)]
|
|
||||||
[else (begin (fact (sub1 n) (* n m) k) 0)]))
|
|
||||||
|
|
||||||
|
|
||||||
(call/cc
|
|
||||||
(lambda (k)
|
|
||||||
(fact 6 1
|
|
||||||
(trace-lambda escape (v) (k v)))))
|
|
||||||
|
|
||||||
|
|
||||||
(call/cc
|
|
||||||
(lambda k*
|
|
||||||
(trace-define (fact n)
|
|
||||||
(cond
|
|
||||||
[(zero? n)
|
|
||||||
(call/cc
|
|
||||||
(lambda (k)
|
|
||||||
(set! k* (cons k k*))
|
|
||||||
1))]
|
|
||||||
[else (* n (fact (sub1 n)))]))
|
|
||||||
(fact 9)
|
|
||||||
(let ([k (car k*)])
|
|
||||||
(set! k* (cdr k*))
|
|
||||||
(k 100000))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(trace-define (infinite-loop n)
|
|
||||||
(infinite-loop (add1 n)))
|
|
||||||
(infinite-loop 0)
|
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
1784
|
1785
|
||||||
|
|
|
@ -110,7 +110,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.trace.ss"
|
;"ikarus.trace.ss"
|
||||||
"ikarus.debugger.ss"
|
"ikarus.debugger.ss"
|
||||||
"ikarus.main.ss"
|
"ikarus.main.ss"
|
||||||
))
|
))
|
||||||
|
|
Loading…
Reference in New Issue