[Chicken-hackers] [PATCH] also add debugging-output to generated C file

[Felix]

The attached patch adds debugging-output for optimizations
done by the compiler to the generated C file, which may be
helpful when analyzing or debugging the compiler.


cheers,
felix

>From ad0c0fa4fcf2997aa1eda1eec54a2a14666c0fd6 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Thu, 27 Oct 2011 10:34:28 +0200
Subject: [PATCH] - 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

---
 batch-driver.scm       |   16 ++++++++-----
 c-backend.scm          |   10 +++++---
 compiler-namespace.scm |    4 +++
 optimizer.scm          |   20 ++++++++++------
 scrutinizer.scm        |   19 +++++++++------
 support.scm            |   58 +++++++++++++++++++++++++++++++++++++++--------
 6 files changed, 91 insertions(+), 36 deletions(-)

diff --git a/batch-driver.scm b/batch-driver.scm
index 1b30fdf..4255099 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 5dbcadd..32dab84 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 b1929b1..a23d31d 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 e0f4214..40974dd 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 674e54d..c9916f6 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -797,16 +797,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 921b97a..28c950b 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 '()))
-- 
1.7.6.msysgit.0