From f410d1161a651a4d6eed203c4e72e03dbc615f5d Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Thu, 4 Apr 1991 14:13:36 +0000
Subject: [PATCH] Added support the the ANSI *COMPILE-VERBOSE*,
 *COMPILE-PRINT*, *COMPILE-FILE-PATHNAME* and *COMPILE-FILE-TRUENAME*
 variables. The old *COMPILE-VERBOSE* has been renamed to *COMPILE-PROGRESS*
 and exported from EXTENSIONS. Many fixes and improvements of block
 compilation.  It is now possible to block compile only part of a file using
 the START-BLOCK and END-BLOCK declarations.  Also, you can designate which
 functions are entry points to the component.  Non-entry-point functions can
 be optimized like lexical functions, since they can't get new references.
 Changed CLEAR-IR1-INFO to not muck with the *FREE-xxx*, since we always call
 CLEAR-STUFF right afterward. Made LOCALLY be recognized by PROCESS-FORM so
 that subforms can be compiled separately. Split up PROCESS-FORM a bit.
 Changed COMPILE-TOP-LEVEL to call CLEAR-STUFF, since it was being called in
 all the same places. Added :ENTRY-POINTS keywords.  Documented
 :BLOCK-COMPILE.

---
 compiler/main.lisp | 319 ++++++++++++++++++++++++++++++++-------------
 1 file changed, 226 insertions(+), 93 deletions(-)

diff --git a/compiler/main.lisp b/compiler/main.lisp
index 365737820..125dc7571 100644
--- a/compiler/main.lisp
+++ b/compiler/main.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.35 1991/03/20 03:01:09 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.36 1991/04/04 14:13:36 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -17,7 +17,11 @@
 ;;;
 (in-package "C")
 (in-package "EXTENSIONS")
-(export '(compile-from-stream))
+(export '(*compile-progress* compile-from-stream *block-compile-default*
+			     start-block end-block))
+(in-package "LISP")
+(export '(*compile-verbose* *compile-print* *compile-file-pathname*
+			    *compile-file-truename*))
 (in-package "C")
 
 (proclaim '(special *constants* *free-variables* *compile-component*
@@ -35,23 +39,45 @@
 		    *last-source-form* *last-format-string* *last-format-args*
 		    *last-message-count* *lexical-environment*))
 
+(defvar *block-compile-default* :specified
+  "The default value for the :Block-Compile argument to COMPILE-FILE.")
+
 (defvar compiler-version "1.0")
 
 (defvar *check-consistency* nil)
 (defvar *all-components*)
 
-;;; The value of the :Block-Compile argument that Compile-File was called with.
+;;; The current block compilation state.  These are initialized to the 
+;;; :Block-Compile and :Entry-Points arguments that COMPILE-FILE was called
+;;; with.  Subsequent START-BLOCK or END-BLOCK declarations alter the values.
 ;;;
 (defvar *block-compile*)
+(declaim (type (member nil t :specified) *block-compile*))
+(defvar *entry-points*)
+(declaim (list *entry-points*))
 
 ;;; When block compiling, used by PROCESS-FORM to accumulate top-level lambdas
 ;;; resulting from compiling subforms.  (In reverse order.)
 ;;;
 (defvar *top-level-lambdas*)
+(declaim (list *top-level-lambdas*))
 
-;;; Used to control compiler verbosity.
-;;;
-(defvar *compile-verbose* nil)
+(defvar *compile-verbose* t
+  "The default for the :VERBOSE argument to COMPILE-FILE.")
+(defvar *compile-print* t
+  "The default for the :PRINT argument to COMPILE-FILE.")
+(defvar *compile-progress* nil
+  "The default for the :PROGRESS argument to COMPILE-FILE.")
+
+(defvar *compile-file-pathname* nil
+  "The defaulted pathname of the file currently being compiler, or NIL if not
+  compiling.")
+(defvar *compile-file-truename* nil
+  "The TRUENAME of the file currently being compiler, or NIL if not
+  compiling.")
+
+(declaim (type (or pathname null) *compile-file-pathname*
+	       *compile-file-truename*))
 
 ;;; The values of *Package* and *Default-Cookie* when compilation started.
 ;;;
@@ -67,10 +93,10 @@
 
 ;;; Maybe-Mumble  --  Internal
 ;;;
-;;;    Mumble conditional on *Compile-Verbose*.
+;;;    Mumble conditional on *compile-progress*.
 ;;;
 (defun maybe-mumble (&rest foo)
-  (when *compile-verbose*
+  (when *compile-progress*
     (apply #'compiler-mumble foo)))
 
 (deftype object () '(or fasl-file core-object null))
@@ -163,7 +189,8 @@
 ;;; Compile-Component  --  Internal
 ;;;
 (defun compile-component (component object)
-  (compiler-mumble "Compiling ~A: " (component-name component))
+  (when *compile-print*
+    (compiler-mumble "Compiling ~A: " (component-name component)))
   
   (ir1-phases component)
   
@@ -214,7 +241,7 @@
     (maybe-mumble "Life ")
     (lifetime-analyze component)
 
-    (when *compile-verbose*
+    (when *compile-progress*
       (compiler-mumble "") ; Sync before doing random output.
       (pre-pack-tn-stats component *compiler-error-output*))
 
@@ -260,7 +287,8 @@
 
       (nuke-segment *code-segment*)))
 
-  (compiler-mumble "~&")
+  (when *compile-print*
+    (compiler-mumble "~&"))
   (undefined-value))
 
 
@@ -302,13 +330,17 @@
 ;;;
 (defun clear-ir1-info (component)
   (declare (type component component))
-  (flet ((blast (x)
-	   (maphash #'(lambda (k v)
-			(declare (ignore k))
-			(setf (leaf-refs v) nil)
-			(when (basic-var-p v)
-			  (setf (basic-var-sets v) nil)))
-		    x)))
+  (labels ((blast (x)
+	     (maphash #'(lambda (k v)
+			  (declare (ignore k))
+			  (setf (leaf-refs v)
+				(delete-if #'here-p (leaf-refs v)))
+			  (when (basic-var-p v)
+			    (setf (basic-var-sets v)
+				  (delete-if #'here-p (basic-var-sets v)))))
+		      x))
+	   (here-p (x)
+	     (eq (block-component (node-block x)) component)))
     (blast *free-variables*)
     (blast *free-functions*)
     (blast *constants*))
@@ -399,6 +431,7 @@
 	     (cdr summary) kind summary))))))
   
   (unless (or *converting-for-interpreter*
+	      (not *compile-verbose*)
 	      (and (not abort-p) (zerop abort-count)
 		   (zerop *compiler-error-count*)
 		   (zerop *compiler-warning-count*)
@@ -463,6 +496,11 @@
   ;; form, :LISP, if from a stream, :STREAM.
   (name (required-argument) :type (or pathname (member :lisp :stream)))
   ;;
+  ;; The defaulted, but not necessarily absolute file name (i.e. prior to
+  ;; TRUENAME call.)  Null if not a file.  This is only used to set
+  ;; *COMPILE-FILE-PATHNAME* 
+  (untruename nil :type (or pathname null))
+  ;;
   ;; The file's write date (if relevant.)
   (write-date nil :type (or unsigned-byte null))
   ;;
@@ -511,7 +549,8 @@
   (declare (list files))
   (let ((file-info
 	 (mapcar #'(lambda (x)
-		     (make-file-info :name x
+		     (make-file-info :name (truename x)
+				     :untruename x
 				     :write-date (file-write-date x)))
 		 files)))
 
@@ -645,10 +684,11 @@
 	(t
 	 (setq *package* *initial-package*)
 	 (setq *default-cookie* (copy-cookie *initial-cookie*))
-	 (setf (source-info-stream info)
-	       (open (file-info-name (first (source-info-current-file info)))
-		     :direction :input)))))
-
+	 (let* ((finfo (first (source-info-current-file info)))
+		(name (file-info-name finfo)))
+	   (setq *compile-file-truename* name)
+	   (setq *compile-file-pathname* (file-info-untruename finfo))
+	   (setf (source-info-stream info) (open name :direction :input))))))
 
 ;;; CLOSE-SOURCE-INFO  --  Internal
 ;;;
@@ -739,7 +779,7 @@
 ;;; CONVERT-AND-MAYBE-COMPILE  --  Internal
 ;;;
 ;;;    Called by top-level form processing when we are ready to actually
-;;; compile something.  If *BLOCK-COMPILE* is true, then we still convert the
+;;; compile something.  If *BLOCK-COMPILE* is T, then we still convert the
 ;;; form, but delay compilation, pushing the result on *TOP-LEVEL-LAMBDAS*
 ;;; instead.
 ;;;
@@ -752,10 +792,9 @@
   (let* ((*lexical-environment*
 	  (make-lexenv :cookie *default-cookie*))
 	 (tll (ir1-top-level form path nil)))
-    (cond (*block-compile* (push tll *top-level-lambdas*))
+    (cond ((eq *block-compile* t) (push tll *top-level-lambdas*))
 	  (t
-	   (compile-top-level (list tll) object)
-	   (clear-stuff))))
+	   (compile-top-level (list tll) object))))
   #+new-compiler
   (lisp::maybe-gc))
 
@@ -783,6 +822,85 @@
        (compiler-error "(during macroexpansion)~%~A" condition))))
 
 
+;;; PROCESS-LOCALLY  --  Internal
+;;;
+;;;    Process a top-level use of LOCALLY.  We parse declarations and then
+;;; recursively process the body.
+;;;
+;;;    Binding *DEFAULT-COOKIE* is pretty much of a hack, since it causes
+;;; LOCALLY to "capture" enclosed proclamations.  It is necessary because
+;;; CONVERT-AND-MAYBE-COMPILE uses the value of *DEFAULT-COOKIE* as the policy.
+;;; The need for this hack is due to the quirk that there is no way to
+;;; represent in a cookie that an optimize quality came from the default.
+;;;
+(defun process-locally (form path object)
+  (declare (list path) (type object object))
+  (multiple-value-bind
+      (body decls)
+      (system:parse-body (cdr form) *lexical-environment* nil)
+    (let* ((*lexical-environment*
+	    (process-declarations decls nil nil (make-continuation)))
+	   (*default-cookie* (lexenv-cookie *lexical-environment*)))
+      (process-progn body path object))))
+
+
+;;; PROCESS-FILE-COMMENT  --  Internal
+;;;
+;;;    Stash file comment in the file-info structure.
+;;;
+(defun process-file-comment (form)
+  (unless (and (= (length form) 2) (stringp (second form)))
+    (compiler-error "Bad FILE-COMMENT form: ~S." form))
+  (let ((file (first (source-info-current-file *source-info*))))
+    (cond ((file-info-comment file)
+	   (compiler-warning "Ignoring extra file comment:~%  ~S." form))
+	  (t
+	   (let ((comment (coerce (second form) 'simple-string)))
+	     (setf (file-info-comment file) comment)
+	     (when *compile-verbose*
+	       (compiler-mumble "~&Comment: ~A~2&" comment)))))))
+
+
+;;; PROCESS-PACKAGE-FROBBER  --  Internal
+;;;
+;;;    Force any pending top-level forms to be compiled and dumped so that they
+;;; will be evaluated in the correct package environment.  Then eval the
+;;; package form and dump it.  At least for now, always dump package frobbing
+;;; as interpreted cold load forms.  This might want to be on a switch someday.
+;;;
+(defun process-package-frobber (form path object)
+  (typecase object
+    (fasl-file
+     (compile-top-level-lambdas () t object)))
+  (eval form)
+  (etypecase object
+    (fasl-file
+     (fasl-dump-cold-load-form form object))
+    ((or null core-object)
+     (convert-and-maybe-compile form path object))))
+
+
+;;; PROCESS-PROCLAIM  --  Internal
+;;;
+;;;    If a special block compilation delimiter, then start or end the block as
+;;; appropriate.  Otherwise, just convert-and-maybe-compile the form.
+;;;
+(defun process-proclaim (form path object)
+  (if (and (eql (length form) 2) (constantp (cadr form)))
+      (let ((spec (eval (cadr form))))
+	(if (consp spec)
+	    (case (first spec)
+	      (start-block
+	       (finish-block-compilation object)
+	       (setq *block-compile* t)
+	       (setq *entry-points* (rest spec)))
+	      (end-block (finish-block-compilation object))
+	      (t
+	       (convert-and-maybe-compile form path object)))
+	    (convert-and-maybe-compile form path object)))
+      (convert-and-maybe-compile form path object)))
+
+
 (proclaim '(special *compiler-error-bailout*))
 
 ;;; PROCESS-FORM  --  Internal
@@ -793,9 +911,6 @@
 ;;; -- If it is a macro expand it.
 ;;; -- Otherwise, just compile it.
 ;;;
-;;; ### At least for now, always dump package frobbing as interpreted cold load
-;;; forms.  This might want to be on a switch someday.
-;;;
 (defun process-form (form path object)
   (declare (list path) (type object object))
   (catch 'process-form-error-abort
@@ -812,15 +927,7 @@
 	  (case (car form)
 	    ((make-package in-package shadow shadowing-import export
 			   unexport use-package unuse-package import)
-	     (typecase object
-	       (fasl-file
-		(compile-top-level-lambdas () t object)))
-	     (eval form)
-	     (etypecase object
-	       (fasl-file
-		(fasl-dump-cold-load-form form object))
-	       ((or null core-object)
-		(convert-and-maybe-compile form path object))))
+	     (process-package-frobber form path object))
 	    ((eval-when)
 	     (unless (>= (length form) 2)
 	       (compiler-error "EVAL-WHEN form is too short: ~S." form))
@@ -835,18 +942,10 @@
 	      (cadr form)
 	      #'(lambda ()
 		  (process-progn (cddr form) path object))))
+	    (locally (process-locally form path object))
 	    (progn (process-progn (cdr form) path object))
-	    (file-comment
-	     (unless (and (= (length form) 2) (stringp (second form)))
-	       (compiler-error "Bad FILE-COMMENT form: ~S." form))
-	     (let ((file (first (source-info-current-file *source-info*))))
-	       (cond ((file-info-comment file)
-		      (compiler-warning "Ignoring extra file comment:~%  ~S."
-					form))
-		     (t
-		      (let ((comment (coerce (second form) 'simple-string)))
-			(setf (file-info-comment file) comment)
-			(compiler-mumble "~&Comment: ~A~2&" comment))))))
+	    (file-comment (process-file-comment form))
+	    (proclaim (process-proclaim form path object))
 	    (t
 	     (let ((exp (preprocessor-macroexpand form)))
 	       (if (eq exp form)
@@ -941,15 +1040,22 @@
 ;;; Compile-Top-Level  --  Internal
 ;;;
 ;;;    Compile Lambdas (a list of the lambdas for top-level forms) into the
-;;; Object file.
+;;; Object file.  We loop doing local call analysis until it converges, since a
+;;; single pass might miss something due to components being joined by let
+;;; conversion.
 ;;;
 (defun compile-top-level (lambdas object)
   (declare (list lambdas) (type object object))
   (maybe-mumble "Local call analyze")
-  (dolist (lambda lambdas)
-    (let* ((component (block-component (node-block (lambda-bind lambda))))
-	   (*all-components* (list component)))
-      (local-call-analyze component)))
+  (loop
+    (let ((did-something nil))
+      (dolist (lambda lambdas)
+	(let* ((component (block-component (node-block (lambda-bind lambda))))
+	       (*all-components* (list component)))
+	  (when (component-new-functions component)
+	    (setq did-something t)
+	    (local-call-analyze component))))
+      (unless did-something (return))))
   (maybe-mumble ".~%")
   
   (maybe-mumble "Find components")
@@ -967,10 +1073,8 @@
       (dolist (component components)
 	(compile-component component object)
 	(clear-ir2-info component)
-	(if (replace-top-level-xeps component)
-	    (setq top-level-closure t)
-	    (unless *check-consistency*
-	      (clear-ir1-info component))))
+	(when (replace-top-level-xeps component)
+	    (setq top-level-closure t)))
       
       (when *check-consistency*
 	(maybe-mumble "[Check]~%")
@@ -978,20 +1082,31 @@
       
       (compile-top-level-lambdas lambdas top-level-closure object)
 
-      (when *check-consistency*
-	(dolist (component components)
-	  (clear-ir1-info component)))))
-
+      (dolist (component components)
+	(clear-ir1-info component))
+      (clear-stuff)))
   (undefined-value))
 
 
+;;; FINISH-BLOCK-COMPILATION  --  Internal
+;;;
+;;;    Actually compile any stuff that has been queued up for block
+;;; compilation.
+;;;
+(defun finish-block-compilation (object)
+  (declare (type object object))
+  (when *top-level-lambdas*
+    (compile-top-level (nreverse *top-level-lambdas*) object)
+    (setq *top-level-lambdas* ()))
+  (setq *block-compile* :specified)
+  (setq *entry-points* nil))
+
+
 ;;; Sub-Compile-File  --  Internal
 ;;;
-;;;    Read all forms from Info and compile them, with output to Object.  If
-;;; *Block-Compile* is true, we combine all the forms and compile as a unit,
-;;; otherwise we compile each one separately.  We return :ERROR, :WARNING,
-;;; :NOTE or NIL to indicate the most severe kind of compiler diagnostic
-;;; emitted.
+;;;    Read all forms from Info and compile them, with output to Object.  We
+;;; return :ERROR, :WARNING, :NOTE or NIL to indicate the most severe kind of
+;;; compiler diagnostic emitted.
 ;;;
 (defun sub-compile-file (info object &optional d-s-info)
   (declare (type source-info info) (type object object))
@@ -1007,6 +1122,8 @@
 	   (*lexical-environment* (make-null-environment))
 	   (*converting-for-interpreter* nil)
 	   (*source-info* info)
+	   (*compile-file-pathname* nil)
+	   (*compile-file-truename* nil)
 	   (*top-level-lambdas* ())
 	   (*pending-top-level-lambdas* ())
 	   (*compiler-error-bailout*
@@ -1032,13 +1149,9 @@
 	    (clrhash *source-paths*)
 	    (find-source-paths form tlf)
 	    (process-form form `(original-source-start 0 ,tlf) object)))
-	
-	(when *block-compile*
-	  (compile-top-level (nreverse *top-level-lambdas*) object)
-	  (clear-stuff))
 
+	(finish-block-compilation object)
 	(compile-top-level-lambdas () t object)
-	
 	(etypecase object
 	  (fasl-file (fasl-dump-source-info info object))
 	  (core-object (fix-core-source-info info object d-s-info))
@@ -1052,16 +1165,20 @@
 
 ;;; Verify-Source-Files  --  Internal
 ;;;
-;;;    Return a list of pathnames that are the truenames of all the named
-;;; files.
+;;;    Return a list of pathnames for the named files.  All the files must
+;;; exist.
 ;;;
 (defun verify-source-files (stuff)
   (unless stuff
     (error "Can't compile with no source files."))
   (mapcar #'(lambda (x)
-	      (or (probe-file x)
-		  (truename
-		   (merge-pathnames x (make-pathname :type "lisp")))))
+	      (let ((x (pathname x)))
+		(if (probe-file x)
+		    x
+		    (let ((x (merge-pathnames x (make-pathname :type "lisp"))))
+		      (if (probe-file x)
+			  x
+			  (truename x))))))
 	  (if (listp stuff) stuff (list stuff))))
 
 
@@ -1071,13 +1188,13 @@
 ;;;    Just call SUB-COMPILE-FILE on the on a stream source info for the
 ;;; stream, sending output to core.
 ;;;
-(defun compile-from-stream (stream
-			    &key
-			    ((:error-stream *compiler-error-output*)
-			     *error-output*)
-			    ((:trace-stream *compiler-trace-output*) nil)
-			    ((:block-compile *block-compile*) nil)
-			    source-info)
+(defun compile-from-stream
+       (stream &key
+	       ((:error-stream *compiler-error-output*) *error-output*)
+	       ((:trace-stream *compiler-trace-output*) nil)
+	       ((:block-compile *block-compile*) *block-compile-default*)
+	       ((:entry-points *entry-points*) nil)
+	       source-info)
   "Similar to COMPILE-FILE, but compiles text from Stream into the current lisp
   environment.  Stream is closed when compilation is complete.  These keywords
   are supported:
@@ -1153,7 +1270,8 @@
 	  (trace-file nil) 
 	  (error-output t)
 	  (load nil)
-	  ((:block-compile *block-compile*) nil))
+	  ((:block-compile *block-compile*) *block-compile-default*)
+	  ((:entry-points *entry-points*) nil))
   "Compiles Source, producing a corresponding .FASL file.  Source may be a list
   of files, in which case the files are compiled as a unit, producing a single
   .FASL file.  The output file names are defaulted from the first (or only)
@@ -1170,9 +1288,22 @@
         If a stream, then error output is sent there as well as to the listing
         file.  NIL suppresses this additional error output.  The default is T,
         which means use *ERROR-OUTPUT*.
-  :Block-Compile
-        If true, then function names will be resolved at compile time."
-  
+  :Block-Compile {NIL | :SPECIFIED | T}
+        Determines whether multiple functions are compiled together as
+	a unit, resolving function references at compile time.  NIL means that
+	global function names are never resolved at compilation time.
+	:SPECIFIED means that names are resolved at compile-time when
+	convenient (as in a self-recursive call), but the compiler doesn't
+        combine top-level DEFUNs.  With :SPECIFIED, an explicit START-BLOCK
+        declaration will enable block compilation.  A value of T indicates that
+        all forms in the file(s) should be compiled as a unit.  The default is
+        the value of *BLOCK-COMPILE-DEFAULT*, which is initially :SPECIFIED.
+  :Entry-Points
+        This specifies a list of function names for functions in the file(s)
+        that must be given global definitions.  This only applies to block
+        compilation, and is useful mainly when :BLOCK-COMPILE T is specified on
+        a file that lacks START-BLOCK declarations.  If the value is NIL (the
+        default) then all functions will be globally defined."
   (let* ((fasl-file nil)
 	 (error-file-stream nil)
 	 (output-file-name nil)
@@ -1219,7 +1350,8 @@
 					 error-output)
 				     error-file-stream))))
 
-	  (start-error-output source-info)
+	  (when *compile-verbose*
+	    (start-error-output source-info))
 	  (setq error-severity
 		(sub-compile-file source-info fasl-file))
 	  (setq compile-won t))
@@ -1231,11 +1363,12 @@
 
       (when fasl-file
 	(close-fasl-file fasl-file (not compile-won))
-	(when compile-won
+	(when (and compile-won *compile-verbose*)
 	  (compiler-mumble "~2&~A written.~%"
 			   (namestring (truename output-file-name)))))
 
-      (finish-error-output source-info compile-won)
+      (when *compile-verbose*
+	(finish-error-output source-info compile-won))
 
       (when error-file-stream
 	(let ((name (pathname error-file-stream)))
@@ -1253,7 +1386,7 @@
     (when load
       (unless output-file
 	(error "Can't :LOAD with no output file."))
-      (load output-file-name :verbose t))
+      (load output-file-name :verbose *compile-verbose*))
 
     (values (if output-file (truename output-file-name) nil)
 	    (not (null error-severity))
-- 
GitLab