~ chicken-core (chicken-5) 3bb96457ec91a91895c5ecffbdea4c9c124c02f2
commit 3bb96457ec91a91895c5ecffbdea4c9c124c02f2
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Oct 27 10:34:28 2011 +0200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Sun Nov 6 12:00:55 2011 +0100
write debugging output for optimizations into generated source file
- changed debug-mode flag for scrutiny from 'x to 'o
- slightly extended compiler-debugging-output mechanism
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/batch-driver.scm b/batch-driver.scm
index 1b30fdff..42550996 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -483,11 +483,14 @@
'() )
'((##core#undefined))) ] )
- (when (and (pair? compiler-syntax-statistics)
- (debugging 'S "applied compiler syntax:"))
- (for-each
- (lambda (cs) (printf " ~a\t\t~a~%" (car cs) (cdr cs)))
- compiler-syntax-statistics))
+ (when (pair? compiler-syntax-statistics)
+ (with-debugging-output
+ 'S
+ (lambda ()
+ (print "applied compiler syntax:")
+ (for-each
+ (lambda (cs) (printf " ~a\t\t~a~%" (car cs) (cdr cs)))
+ compiler-syntax-statistics))))
(when (debugging '|N| "real name table:")
(display-real-name-table) )
(when (debugging 'n "line number database:")
@@ -657,7 +660,8 @@
(let ((out (if outfile (open-output-file outfile) (current-output-port))) )
(dribble "generating `~A' ..." outfile)
(generate-code literals lliterals lambdas out filename dynamic db)
- (when outfile (close-output-port out)))
+ (when outfile
+ (close-output-port out)))
(end-time "code generation")
(when (memq 't debugging-chicken)
(##sys#display-times (##sys#stop-timer)))
diff --git a/c-backend.scm b/c-backend.scm
index 5dbcadda..32dab846 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -70,9 +70,6 @@
(or (find (lambda (ll) (eq? id (lambda-literal-id ll))) lambdas)
(bomb "can't find lambda" id) ) )
- (define (slashify s) (string-translate (->string s) "\\" "/"))
- (define (uncommentify s) (string-translate* (->string s) '(("*/" . "* /"))))
-
;; Compile a single expression
(define (expression node temps ll)
@@ -493,7 +490,12 @@
(generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) ) )
(define (trailer)
- (gen #t "/* end of file */" #t) )
+ (gen #t #t "/*" #t
+ (uncommentify
+ (get-output-string
+ collected-debugging-output))
+ "*/"
+ #t "/* end of file */" #t))
(define (declarations)
(let ((n (length literals)))
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index b1929b17..a23d31d4 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -52,6 +52,7 @@
close-checked-input-file
collapsable-literal?
collect!
+ collected-debugging-output
compile-format-string
compiler-arguments
compiler-cleanup-hook
@@ -263,6 +264,7 @@
simplified-ops
simplify-named-call
simplify-type
+ slashify
sort-symbols
source-filename
source-info->string
@@ -285,6 +287,7 @@
toplevel-scope
transform-direct-lambdas!
tree-copy
+ uncommentify
undefine-shadowed-macros
unique-id
unit-name
@@ -301,6 +304,7 @@
variable-visible?
varnode
verbose-mode
+ with-debugging-output
words
words->bytes
words-per-flonum
diff --git a/optimizer.scm b/optimizer.scm
index e0f4214f..40974dda 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -490,14 +490,18 @@
(set! simplified-ops '())
(let ((node2 (walk node '() '())))
(when (pair? simplified-classes) (debugging 'o "simplifications" simplified-classes))
- (when (and (pair? simplified-ops) (debugging 'o " call simplifications:"))
- (for-each
- (lambda (p)
- (print* #\tab (car p))
- (if (> (cdr p) 1)
- (print #\tab (cdr p))
- (newline) ) )
- simplified-ops) )
+ (when (pair? simplified-ops)
+ (with-debugging-output
+ 'o
+ (lambda ()
+ (print " call simplifications:")
+ (for-each
+ (lambda (p)
+ (print* " " (car p))
+ (if (> (cdr p) 1)
+ (print #\tab (cdr p))
+ (newline) ) )
+ simplified-ops) ) ) )
(when (> replaced-vars 0) (debugging 'o "replaced variables" replaced-vars))
(when (> removed-lets 0) (debugging 'o "removed binding forms" removed-lets))
(when (> removed-ifs 0) (debugging 'o "removed conditional forms" removed-ifs))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index e2f4e438..18543035 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -794,16 +794,19 @@
results)))
(let ((rn (walk (first (node-subexpressions node)) '() '() #f #f (list (tag)) #f)))
- (when (and (pair? specialization-statistics)
- (debugging 'x "specializations:")) ;XXX use 'o
- (for-each
- (lambda (ss)
- (printf " ~a ~s~%" (cdr ss) (car ss)))
- specialization-statistics))
+ (when (pair? specialization-statistics)
+ (with-debugging-output
+ 'o
+ (lambda ()
+ (print "specializations:")
+ (for-each
+ (lambda (ss)
+ (printf " ~a ~s~%" (cdr ss) (car ss)))
+ specialization-statistics))))
(when (positive? safe-calls)
- (debugging 'x "safe calls" safe-calls)) ;XXX use 'o
+ (debugging 'o "safe calls" safe-calls))
(when (positive? dropped-branches)
- (debugging 'x "dropped branches" dropped-branches)) ;XXX use 'o
+ (debugging 'o "dropped branches" dropped-branches))
(when errors
(quit "some variable types do not satisfy strictness"))
rn)))
diff --git a/support.scm b/support.scm
index 921b97a6..28c950b9 100644
--- a/support.scm
+++ b/support.scm
@@ -49,17 +49,51 @@
(apply error (string-append "[internal compiler error] " (car msg-and-args)) (cdr msg-and-args))
(error "[internal compiler error]") ) )
+(define collected-debugging-output
+ (open-output-string))
+
+(define +logged-debugging-modes+ '(o x S i))
+
(define (debugging mode msg . args)
- (and (memq mode debugging-chicken)
- (begin
- (printf "~a" msg)
- (if (pair? args)
- (begin
- (display ": ")
- (for-each (lambda (x) (printf "~s " (force x))) args) ) )
- (newline)
- (flush-output)
- #t) ) )
+ (define (text)
+ (with-output-to-string
+ (lambda ()
+ (display msg)
+ (when (pair? args)
+ (display ": ")
+ (for-each
+ (lambda (x) (printf "~s " (force x)))
+ args) )
+ (newline))))
+ (define (dump txt)
+ (fprintf collected-debugging-output "~a|~a" mode txt))
+ (cond ((memq mode debugging-chicken)
+ (let ((txt (text)))
+ (display txt)
+ (flush-output)
+ (when (memq mode +logged-debugging-modes+)
+ (dump txt))
+ #t))
+ (else
+ (when (memq mode +logged-debugging-modes+)
+ (dump (text)))
+ #f)))
+
+(define (with-debugging-output mode thunk)
+ (define (collect text)
+ (for-each
+ (lambda (ln)
+ (fprintf collected-debugging-output "~a|~a~%"
+ mode ln))
+ (string-split text "\n")))
+ (cond ((memq mode debugging-chicken)
+ (let ((txt (with-output-to-string thunk)))
+ (display txt)
+ (flush-output)
+ (when (memq mode +logged-debugging-modes+)
+ (collect txt))))
+ ((memq mode +logged-debugging-modes+)
+ (collect (with-output-to-string thunk)))))
(define (quit msg . args)
(let ([out (current-error-port)])
@@ -123,6 +157,10 @@
((string? x) (string->symbol x))
(else (string->symbol (sprintf "~a" x))) ) )
+(define (slashify s) (string-translate (->string s) "\\" "/"))
+
+(define (uncommentify s) (string-translate* (->string s) '(("*/" . "*_/"))))
+
(define (build-lambda-list vars argc rest)
(let loop ((vars vars) (n argc))
(cond ((or (zero? n) (null? vars)) (or rest '()))
Trap