From 51d783ecf8ecfb007f32c125976ce44d6793ad7c Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 25 Oct 2006 05:42:48 +0000
Subject: [PATCH] Use new WITH-NOTIFICATION and WRITE-NOTIFICATION-LINE to
 generate status output.

---
 v7/src/compiler/base/asstop.scm     |  84 +++++------
 v7/src/compiler/base/toplev.scm     | 213 ++++++++++++++--------------
 v7/src/compiler/machines/C/ctop.scm |  31 ++--
 v7/src/sf/toplev.scm                | 157 +++++++++-----------
 4 files changed, 221 insertions(+), 264 deletions(-)

diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm
index 6c63208f0..dcc2df717 100644
--- a/v7/src/compiler/base/asstop.scm
+++ b/v7/src/compiler/base/asstop.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: asstop.scm,v 1.14 2003/02/14 18:28:01 cph Exp $
+$Id: asstop.scm,v 1.15 2006/10/25 05:42:13 cph Exp $
 
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright 1992,1993,1994,2001,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -140,19 +140,19 @@ USA.
   (compiler-phase
    "Assembly"
    (lambda ()
-     (with-values (lambda () (assemble *block-label* (last-reference *lap*)))
-       (lambda (count code-vector labels bindings)
-	 (set! *code-vector* code-vector)
-	 (set! *entry-points* labels)
-	 (set! *label-bindings* bindings)
-	 (if compiler:show-phases?
-	     (begin
-	       (newline)
-	       (write-string *output-prefix*)
-	       (write-string "  Branch tensioning done in ")
-	       (write (1+ count))
-	       (write-string
-		(if (zero? count) " iteration." " iterations.")))))))))
+     (receive (count code-vector labels bindings)
+	 (assemble *block-label* (last-reference *lap*))
+       (set! *code-vector* code-vector)
+       (set! *entry-points* labels)
+       (set! *label-bindings* bindings)
+       (if compiler:show-phases?
+	   (write-notification-line
+	    (lambda (port)
+	      (write-string "Branch tensioning done in " port)
+	      (write (+ count 1) port)
+	      (write-string " iteration" port)
+	      (if (> count 0) (write-string "s" port))
+	      (write-string "." port))))))))
 
 (define (phase/link)
   (compiler-phase
@@ -276,55 +276,43 @@ USA.
 ;;; Various ways of dumping an info file
 
 (define (compiler:dump-inf-file binf pathname)
-  (fasdump binf pathname #t)
-  (announce-info-files pathname))
+  (fasdump binf pathname))
 
 (define (compiler:dump-bif/bsm-files binf pathname)
   (let ((bif-path (pathname-new-type pathname "bif"))
 	(bsm-path (pathname-new-type pathname "bsm")))
     (let ((bsm (split-inf-structure! binf bsm-path)))
-      (fasdump binf bif-path #t)
-      (fasdump bsm bsm-path #t))
-    (announce-info-files bif-path bsm-path)))
+      (fasdump binf bif-path)
+      (fasdump bsm bsm-path))))
   
 (define (compiler:dump-bci/bcs-files binf pathname)
   (let ((bci-path (pathname-new-type pathname "bci"))
 	(bcs-path (pathname-new-type pathname "bcs")))
     (let ((bsm (split-inf-structure! binf bcs-path)))
-      (call-with-temporary-filename
-	(lambda (bif-name)
-	  (fasdump binf bif-name #t)
-	  (compress bif-name bci-path)))
-      (call-with-temporary-filename
-	(lambda (bsm-name)
-	  (fasdump bsm bsm-name #t)
-	  (compress bsm-name bcs-path))))
-    (announce-info-files bci-path bcs-path)))
-  
+      (dump-compressed binf bci-path)
+      (dump-compressed bsm bcs-path))))
+
 (define (compiler:dump-bci-file binf pathname)
   (let ((bci-path (pathname-new-type pathname "bci")))
     (split-inf-structure! binf #f)
-    (call-with-temporary-filename
-      (lambda (bif-name)
-	(fasdump binf bif-name #t)
-	(compress bif-name bci-path)))
-    (announce-info-files bci-path)))
-
-(define (announce-info-files . files)
-  (if compiler:noisy?
-      (let ((port (nearest-cmdl/port)))
-	(let loop ((files files))
-	  (if (null? files)
-	      unspecific
-	      (begin
-		(fresh-line port)
-		(write-string ";")
-		(write (->namestring (car files)))
-		(write-string " dumped ")
-		(loop (cdr files))))))))
+    (dump-compressed binf bci-path)))
+
+(define (dump-compressed object path)
+  (with-notification (lambda (port)
+		       (write-string "Dumping " port)
+		       (write (enough-namestring path) port))
+    (lambda ()
+      (call-with-temporary-filename
+	(lambda (temp)
+	  (fasdump object temp #t)
+	  (compress temp path))))))
 
 (define compiler:dump-info-file
   compiler:dump-bci-file)
+
+(define (compile-data-from-file scode output-pathname)
+  scode output-pathname
+  (error "Illegal operation:" 'COMPILE-DATA-FROM-FILE))
 
 ;;;; LAP->CODE
 ;;; Example of `lap->code' usage (MC68020):
diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index d78f959f1..37a90b62c 100644
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 4.65 2006/09/16 11:19:09 gjr Exp $
+$Id: toplev.scm,v 4.66 2006/10/25 05:42:21 cph Exp $
 
-Copyright (c) 1988-2001, 2006 Massachusetts Institute of Technology
+Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
+Copyright 1993,1994,1997,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -58,17 +60,17 @@ USA.
 				 (warn "Missing dependency:"
 				       (->namestring dependency))
 				 #f)))))))))
-	  (if (not (null? reasons))
+	  (if (pair? reasons)
 	      (begin
-		(fresh-line)
-		(write-string ";Generating ")
-		(write (->namestring output-file))
-		(write-string " because of:")
-		(for-each (lambda (reason)
-			    (write-char #\space)
-			    (write (->namestring reason)))
-			  reasons)
-		(newline)
+		(write-notification-line
+		 (lambda (port)
+		   (write-string ";Generating " port)
+		   (write (->namestring output-file) port)
+		   (write-string " because of:" port)
+		   (for-each (lambda (reason)
+			       (write-char #\space port)
+			       (write (->namestring reason) port))
+			     reasons)))
 		(doit)))))))
 
   (set! compile-file
@@ -177,17 +179,20 @@ USA.
 		       (if output-string
 			   (merge-pathnames output-string output-pathname)
 			   output-pathname))))
-		(if compiler:noisy?
-		    (begin
-		      (fresh-line)
-		      (write-string "Compile File: ")
-		      (write (enough-namestring input-pathname))
-		      (write-string " => ")
-		      (write (enough-namestring output-pathname))
-		      (newline)))
-		(compiler-file-output
-		 (transform input-pathname output-pathname)
-		 output-pathname)))))
+		(let ((do-it
+		       (lambda ()
+			 (compiler-file-output
+			  (transform input-pathname output-pathname)
+			  output-pathname))))
+		  (if compiler:noisy?
+		      (with-notification
+			  (lambda (port)
+			    (write-string ";Compile File: " port)
+			    (write (enough-namestring input-pathname) port)
+			    (write-string " => " port)
+			    (write (enough-namestring output-pathname) port))
+			do-it)
+		      (do-it)))))))
 	 (kernel
 	  (if compiler:batch-mode?
 	      (batch-kernel core)
@@ -265,7 +270,7 @@ USA.
   (if (not compiler:abort-handled?)
       (error "Not set up to abort" value))
   (fresh-line)
-  (write-string "*** Aborting...")
+  (write-string ";*** Aborting...")
   (newline)
   (compiler:abort-continuation value))
 
@@ -285,63 +290,55 @@ USA.
   ;; Used by the compiler when it wants to compile subexpressions as
   ;; separate code-blocks.
   ;; The rtl output should be fixed.
-  (let ((my-number *recursive-compilation-count*)
-	(output?
-	 (and compiler:show-phases?
-	      (not compiler:show-procedures?))))
-    (set! *recursive-compilation-count* (1+ my-number))
-    (if output?
-	(begin
-	  (fresh-line)
-	  (newline)
-	  (write-string *output-prefix*)
-	  (write-string "*** Recursive compilation ")
-	  (write my-number)
-	  (write-string " ***")
-	  (newline)))
-    (let ((value
-	   ((let ((do-it
-		   (lambda ()
-		     (fluid-let ((*recursive-compilation-number* my-number)
-				 (compiler:package-optimization-level 'NONE)
-				 (*procedure-result?* procedure-result?))
-		       (compile-scode/internal
-			scode
-			(and *info-output-filename*
-			     (if (eq? *info-output-filename* 'KEEP)
-				 'KEEP
-				 'RECURSIVE))
-			*rtl-output-port*
-			*lap-output-port*
-			bind-compiler-variables)))))
-	      (if procedure-result?
-		  (let ((do-it
-			 (lambda ()
-			   (let ((result (do-it)))
-			     (set! *remote-links*
-				   (cons (cdr result) *remote-links*))
-			     (car result)))))
-		    (if compiler:show-procedures?
-			(lambda ()
-			  (compiler-phase/visible
-			   (string-append
-			    "Compiling procedure: "
-			    (write-to-string procedure-name))
-			   do-it))
-			do-it))
-		  (lambda ()
-		    (fluid-let ((*remote-links* '()))
-		      (do-it))))))))
-      (if output?
-	  (begin
-	    (fresh-line)
-	    (write-string *output-prefix*)
-	    (write-string "*** Done with recursive compilation ")
-	    (write my-number)
-	    (write-string " ***")
-	    (newline)
-	    (newline)))
-      value)))
+  (let ((my-number *recursive-compilation-count*))
+    (set! *recursive-compilation-count* (+ my-number 1))
+    (let ((do-it
+	   (lambda ()
+	     (compile-recursively-1 scode
+				    procedure-result?
+				    procedure-name
+				    my-number))))
+      (if (and compiler:show-phases?
+	       (not compiler:show-procedures?))
+	  (with-notification (lambda (port)
+			       (write-string "*** Recursive compilation " port)
+			       (write my-number port))
+	    do-it)
+	  (do-it)))))
+
+(define (compile-recursively-1 scode procedure-result? procedure-name
+			       my-number)
+  (let ((do-it
+	 (lambda ()
+	   (fluid-let ((*recursive-compilation-number* my-number)
+		       (compiler:package-optimization-level 'NONE)
+		       (*procedure-result?* procedure-result?))
+	     (compile-scode/internal
+	      scode
+	      (and *info-output-filename*
+		   (if (eq? *info-output-filename* 'KEEP)
+		       'KEEP
+		       'RECURSIVE))
+	      *rtl-output-port*
+	      *lap-output-port*
+	      bind-compiler-variables)))))
+    (if procedure-result?
+	(let ((do-it
+	       (lambda ()
+		 (let ((result (do-it)))
+		   (set! *remote-links*
+			 (cons (cdr result) *remote-links*))
+		   (car result)))))
+	  (if compiler:show-procedures?
+	      (compiler-phase/visible
+	       (call-with-output-string
+		 (lambda (port)
+		   (write-string "Compiling procedure: " port)
+		   (write procedure-name port)))
+	       do-it)
+	      (do-it)))
+	(fluid-let ((*remote-links* '()))
+	  (do-it)))))
 
 ;;;; Global variables
 
@@ -587,23 +584,20 @@ USA.
       (compiler-phase/invisible thunk)))
 
 (define (compiler-phase/visible name thunk)
-  (fluid-let ((*output-prefix* (string-append "    " *output-prefix*)))
-    (fresh-line)
-    (write-string *output-prefix*)
-    (write-string name)
-    (write-string "...")
-    (newline)
+  (let ((thunk
+	 (lambda ()
+	   (with-notification (lambda (port) (write-string name port))
+	     thunk))))
     (if compiler:show-time-reports?
 	(let ((process-start *process-time*)
 	      (real-start *real-time*))
 	  (let ((value (thunk)))
-	    (compiler-time-report "  Time taken"
+	    (compiler-time-report "Time taken"
 				  (- *process-time* process-start)
 				  (- *real-time* real-start))
 	    value))
 	(thunk))))
 
-(define *output-prefix* "")
 (define *phase-level* 0)
 
 (define (compiler-phase/invisible thunk)
@@ -624,14 +618,14 @@ USA.
 	  (do-it)))))
 
 (define (compiler-time-report prefix process-time real-time)
-  (write-string *output-prefix*)
-  (write-string prefix)
-  (write-string ": ")
-  (write (/ (exact->inexact process-time) 1000))
-  (write-string " (process time); ")
-  (write (/ (exact->inexact real-time) 1000))
-  (write-string " (real time)")
-  (newline))
+  (write-notification-line
+   (lambda (port)
+     (write-string prefix port)
+     (write-string ": " port)
+     (write (/ (exact->inexact process-time) 1000) port)
+     (write-string " (process time); " port)
+     (write (/ (exact->inexact real-time) 1000) port)
+     (write-string " (real time)" port))))
 
 (define (phase/fg-generation)
   (compiler-superphase "Flow Graph Generation"
@@ -866,16 +860,17 @@ USA.
 			(- (rgraph-n-registers rgraph)
 			   number-of-machine-registers))
 		      *rtl-graphs*)))
-	    (write-string *output-prefix*)
-	    (write-string "  Registers used: ")
-	    (write (apply max n-registers))
-	    (write-string " max, ")
-	    (write (apply min n-registers))
-	    (write-string " min, ")
-	    (write
-	     (exact->inexact (/ (apply + n-registers) (length n-registers))))
-	    (write-string " mean")
-	    (newline))))))
+	    (write-notification-line
+	     (lambda (port)
+	       (write-string "Registers used: " port)
+	       (write (apply max n-registers) port)
+	       (write-string " max, " port)
+	       (write (apply min n-registers) port)
+	       (write-string " min, " port)
+	       (write (exact->inexact (/ (apply + n-registers)
+					 (length n-registers)))
+		      port)
+	       (write-string " mean" port))))))))
 
 (define (phase/rtl-optimization)
   (compiler-superphase "RTL Optimization"
@@ -958,7 +953,7 @@ USA.
       (write-string "RTL for object " port)
       (write *recursive-compilation-number* port)
       (newline port)
-      (pp scode port #T 4)
+      (pp scode port #t 4)
       (newline port)
       (newline port)
       (write-rtl-instructions (linearize-rtl *rtl-root*
@@ -1031,7 +1026,7 @@ USA.
 	    (write-string "LAP for object ")
 	    (write *recursive-compilation-number*)
 	    (newline)
-	    (pp scode (current-output-port) #T 4)
+	    (pp scode (current-output-port) #t 4)
 	    (newline)
 	    (newline)
 	    (newline)
diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm
index cde6b1042..a8c08e834 100644
--- a/v7/src/compiler/machines/C/ctop.scm
+++ b/v7/src/compiler/machines/C/ctop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ctop.scm,v 1.18 2006/10/01 05:37:56 cph Exp $
+$Id: ctop.scm,v 1.19 2006/10/25 05:42:48 cph Exp $
 
 Copyright 1993,2006 Massachusetts Institute of Technology
 
@@ -589,24 +589,17 @@ USA.
 (define (compiler:dump-bci-file binf pathname)
   (let ((bci-path (pathname-new-type pathname "bci")))
     (split-inf-structure! binf false)
-    (call-with-temporary-filename
-      (lambda (bif-name)
-	(fasdump binf bif-name true)
-	(compress bif-name bci-path)))
-    (announce-info-files bci-path)))
-
-(define (announce-info-files . files)
-  (if compiler:noisy?
-      (let ((port (nearest-cmdl/port)))
-	(let loop ((files files))
-	  (if (null? files)
-	      unspecific
-	      (begin
-		(fresh-line port)
-		(write-string ";")
-		(write (->namestring (car files)))
-		(write-string " dumped ")
-		(loop (cdr files))))))))
+    (dump-compressed binf bci-path)))
+
+(define (dump-compressed object path)
+  (with-notification (lambda (port)
+		       (write-string "Dumping " port)
+		       (write (enough-namestring path) port))
+    (lambda ()
+      (call-with-temporary-filename
+	(lambda (temp)
+	  (fasdump object temp #t)
+	  (compress temp path))))))
 
 (define compiler:dump-info-file compiler:dump-bci-file)
 
diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm
index 97eaec097..978301172 100644
--- a/v7/src/sf/toplev.scm
+++ b/v7/src/sf/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 4.27 2006/09/29 19:30:07 cph Exp $
+$Id: toplev.scm,v 4.28 2006/10/25 05:41:02 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1995,1997,2000,2001,2002 Massachusetts Institute of Technology
@@ -134,26 +134,31 @@ USA.
 (define (sf/internal input-pathname bin-pathname spec-pathname
 		     environment declarations)
   spec-pathname				;ignored
-  (let ((start-date (get-decoded-time)))
+  (let ((do-it
+	 (let ((start-date (get-decoded-time)))
+	   (lambda ()
+	     (fasdump (make-comment
+		       `((SOURCE-FILE . ,(->namestring input-pathname))
+			 (DATE ,(decoded-time/year start-date)
+			       ,(decoded-time/month start-date)
+			       ,(decoded-time/day start-date))
+			 (TIME ,(decoded-time/hour start-date)
+			       ,(decoded-time/minute start-date)
+			       ,(decoded-time/second start-date)))
+		       (sf/file->scode input-pathname bin-pathname
+				       environment declarations))
+		      bin-pathname)))))
     (if sf:noisy?
-	(let ((port (notification-output-port)))
-	  (fresh-line port)
-	  (write-string "Syntax file: " port)
-	  (write (enough-namestring input-pathname) port)
-	  (write-string " " port)
-	  (write (enough-namestring bin-pathname) port)
-	  (newline port)))
-    (fasdump (make-comment
-	      `((SOURCE-FILE . ,(->namestring input-pathname))
-		(DATE ,(decoded-time/year start-date)
-		      ,(decoded-time/month start-date)
-		      ,(decoded-time/day start-date))
-		(TIME ,(decoded-time/hour start-date)
-		      ,(decoded-time/minute start-date)
-		      ,(decoded-time/second start-date)))
-	      (sf/file->scode input-pathname bin-pathname
-			      environment declarations))
-	     bin-pathname)))
+	(let ((message
+	       (lambda (port)
+		 (write-string "Syntax file: " port)
+		 (write (enough-namestring input-pathname) port)
+		 (write-string " " port)
+		 (write (enough-namestring bin-pathname) port))))
+	  (if (eq? sf:noisy? 'old-style)
+	      (timed message do-it)
+	      (with-notification message do-it)))
+	(do-it))))
 
 (define (sf/file->scode input-pathname output-pathname
 			environment declarations)
@@ -247,82 +252,58 @@ USA.
 	  expression))))
 
 (define (integrate/kernel get-scode)
-  (fluid-let ((previous-name #f)
-	      (previous-process-time #f)
-	      (previous-real-time #f))
-    (receive (expression externs-block externs)
-	(call-with-values
-	    (lambda ()
-	      (call-with-values (lambda () (phase:transform (get-scode)))
-		phase:optimize))
-	  phase:generate-scode)
-      (end-phase)
-      (values expression externs-block externs))))
-
+  (receive (operations environment expression)
+      (receive (block expression) (phase:transform (get-scode))
+	(phase:optimize block expression))
+    (phase:generate-scode operations environment expression)))
+
 (define (phase:read filename)
-  (mark-phase "Read")
-  (read-file filename))
+  (in-phase "Read" (lambda () (read-file filename))))
 
 (define (phase:syntax s-expressions environment declarations)
-  (mark-phase "Syntax")
-  (syntax* (if (null? declarations)
-	       s-expressions
-	       (cons (cons (close-syntax 'DECLARE system-global-environment)
-			   declarations)
-		     s-expressions))
-	   environment))
+  (in-phase "Syntax"
+    (lambda ()
+      (syntax* (if (null? declarations)
+		   s-expressions
+		   (cons (cons (close-syntax 'DECLARE
+					     system-global-environment)
+			       declarations)
+			 s-expressions))
+	       environment))))
 
 (define (phase:transform scode)
-  (mark-phase "Transform")
-  (transform/top-level scode sf/top-level-definitions))
+  (in-phase "Transform"
+    (lambda ()
+      (transform/top-level scode sf/top-level-definitions))))
 
 (define (phase:optimize block expression)
-  (mark-phase "Optimize")
-  (integrate/top-level block expression))
+  (in-phase "Optimize" (lambda () (integrate/top-level block expression))))
 
 (define (phase:generate-scode operations environment expression)
-  (mark-phase "Generate SCode")
-  (receive (externs-block externs)
-      (operations->external operations environment)
-    (values (cgen/external expression) externs-block externs)))
-
-(define previous-name)
-(define previous-process-time)
-(define previous-real-time)
-
-(define (mark-phase this-name)
-  (end-phase)
-  (if (eq? sf:noisy? 'old-style)
-      (let ((port (notification-output-port)))
-	(fresh-line port)
-	(write-string "    " port)
-	(write-string this-name port)
-	(write-string "..." port)
-	(newline port)))
-  (set! previous-name this-name)
-  unspecific)
-
-(define (end-phase)
-  (let ((this-process-time (process-time-clock))
-	(this-real-time (real-time-clock)))
-    (if previous-process-time
-	(let ((delta-process-time (- this-process-time previous-process-time)))
-	  (time-report "      Time taken"
-		       delta-process-time
-		       (- this-real-time previous-real-time))))
-    (set! previous-process-time this-process-time)
-    (set! previous-real-time this-real-time))
-  unspecific)
+  (in-phase "Generate SCode"
+    (lambda ()
+      (receive (externs-block externs)
+	  (operations->external operations environment)
+	(values (cgen/external expression) externs-block externs)))))
 
-;; Should match the compiler.  We'll merge the two at some point.
-(define (time-report prefix process-time real-time)
+(define (in-phase name thunk)
   (if (eq? sf:noisy? 'old-style)
-      (let ((port (notification-output-port)))
-	(fresh-line port)
-	(write-string prefix port)
-	(write-string ": " port)
-	(write (/ (exact->inexact process-time) 1000) port)
-	(write-string " (process time); " port)
-	(write (/ (exact->inexact real-time) 1000) port)
-	(write-string " (real time)" port)
-	(newline port))))
\ No newline at end of file
+      (timed (lambda (port)
+	       (write-string name port))
+	     thunk)
+      (thunk)))
+
+(define (timed message thunk)
+  (let ((start-process-time (process-time-clock))
+	(start-real-time (real-time-clock)))
+    (let ((v (with-notification message thunk)))
+      (let ((process-time (- (process-time-clock) start-process-time))
+	    (real-time (- (real-time-clock) start-real-time)))
+	(write-notification-line
+	 (lambda (port)
+	   (write-string "Time taken: " port)
+	   (write (/ (exact->inexact process-time) 1000) port)
+	   (write-string " (process time); " port)
+	   (write (/ (exact->inexact real-time) 1000) port)
+	   (write-string " (real time)" port))))
+      v)))
\ No newline at end of file
-- 
2.25.1