From 378fb74e34b2354b13054b0a73e7af0cbbcadcb9 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Mon, 25 Nov 1991 12:07:18 +0000 Subject: [PATCH] Added load-time-value and make-load-form support. Also removed #+new-compiler conditionals. --- compiler/main.lisp | 353 +++++++++++++++++++++++++++++++++------------ 1 file changed, 261 insertions(+), 92 deletions(-) diff --git a/compiler/main.lisp b/compiler/main.lisp index 883c0a741..9d49e34b3 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.46 1991/11/13 19:34:18 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.47 1991/11/25 12:07:18 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -100,8 +100,13 @@ (when *compile-progress* (apply #'compiler-mumble foo))) + (deftype object () '(or fasl-file core-object null)) +(defvar *compile-object* nil) +(declaim (type object *compile-object*)) + + ;;;; Component compilation: @@ -205,7 +210,7 @@ ;;; Compile-Component -- Internal ;;; -(defun compile-component (component object) +(defun compile-component (component) (when *compile-print* (compiler-mumble "~&Compiling ~A: " (component-name component))) @@ -295,15 +300,15 @@ (when *collect-dynamic-statistics* (setup-dynamic-count-info component)) - (etypecase object + (etypecase *compile-object* (fasl-file (maybe-mumble "FASL") (fasl-dump-component component *code-segment* - length trace-table object)) + length trace-table *compile-object*)) (core-object (maybe-mumble "Core") (make-core-component component *code-segment* - length trace-table object)) + length trace-table *compile-object*)) (null)) (nuke-segment *code-segment*))) @@ -810,8 +815,8 @@ ;;; The cookies at this time becomes the default policy for compiling the ;;; form. Any enclosed PROCLAIMs will affect only subsequent forms. ;;; -(defun convert-and-maybe-compile (form path object) - (declare (list path) (type object object)) +(defun convert-and-maybe-compile (form path) + (declare (list path)) ;; ;; This W/O GC is pretty much of a hack, and should be replaced with a less ;; drastic GC procrastination mechanism. The problem is that in addition to @@ -824,7 +829,7 @@ (tll (ir1-top-level form path nil))) (cond ((eq *block-compile* t) (push tll *top-level-lambdas*)) (t - (compile-top-level (list tll) object)))))) + (compile-top-level (list tll) nil)))))) ;;; PROCESS-PROGN -- Internal @@ -832,10 +837,10 @@ ;;; Process a PROGN-like portion of a top-level form. Forms is a list of ;;; the forms, and Path is source path of the form they came out of. ;;; -(defun process-progn (forms path object) - (declare (list forms) (list path) (type object object)) +(defun process-progn (forms path) + (declare (list forms) (list path)) (dolist (form forms) - (process-form form path object))) + (process-form form path))) ;;; PREPROCESSOR-MACROEXPAND -- Internal @@ -861,8 +866,8 @@ ;;; 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)) +(defun process-locally (form path) + (declare (list path)) (multiple-value-bind (body decls) (system:parse-body (cdr form) *lexical-environment* nil) @@ -871,7 +876,7 @@ (*default-cookie* (lexenv-cookie *lexical-environment*)) (*default-interface-cookie* (lexenv-interface-cookie *lexical-environment*))) - (process-progn body path object)))) + (process-progn body path)))) ;;; PROCESS-FILE-COMMENT -- Internal @@ -897,16 +902,17 @@ ;;; will be evaluated in the correct package environment. Eval the form if ;;; Eval is true, then dump the form to evaled at (cold) load time. ;;; -(defun process-cold-load-form (form path object eval) - (typecase object - (fasl-file - (compile-top-level-lambdas () t object))) - (when eval (eval form)) - (etypecase object - (fasl-file - (fasl-dump-cold-load-form form object)) - ((or null core-object) - (convert-and-maybe-compile form path object)))) +(defun process-cold-load-form (form path eval) + (let ((object *compile-object*)) + (typecase object + (fasl-file + (compile-top-level-lambdas () t))) + (when eval (eval form)) + (etypecase object + (fasl-file + (fasl-dump-cold-load-form form object)) + ((or null core-object) + (convert-and-maybe-compile form path))))) ;;; PROCESS-PROCLAIM -- Internal @@ -915,22 +921,22 @@ ;;; appropriate. Otherwise, just convert-and-maybe-compile the form. If ;;; *BLOCK-COMPILE* is NIL, then we ignore block declarations. ;;; -(defun process-proclaim (form path object) +(defun process-proclaim (form path) (if (and (eql (length form) 2) (constantp (cadr form))) (let ((spec (eval (cadr form)))) (if (consp spec) (case (first spec) (start-block (when *block-compile* - (finish-block-compilation object) + (finish-block-compilation) (setq *block-compile* t) (setq *entry-points* (rest spec)))) (end-block - (finish-block-compilation object)) + (finish-block-compilation)) (t - (convert-and-maybe-compile form path object))) - (convert-and-maybe-compile form path object))) - (convert-and-maybe-compile form path object))) + (convert-and-maybe-compile form path))) + (convert-and-maybe-compile form path))) + (convert-and-maybe-compile form path))) (proclaim '(special *compiler-error-bailout*)) @@ -943,8 +949,8 @@ ;;; -- If it is a macro expand it. ;;; -- Otherwise, just compile it. ;;; -(defun process-form (form path object) - (declare (list path) (type object object)) +(defun process-form (form path) + (declare (list path)) (catch 'process-form-error-abort (let* ((path (or (gethash form *source-paths*) (cons form path))) (*compiler-error-bailout* @@ -952,42 +958,209 @@ (convert-and-maybe-compile `(error "Execution of a form compiled with errors:~% ~S" ',form) - path object) + path) (throw 'process-form-error-abort nil)))) (if (atom form) - (convert-and-maybe-compile form path object) + (convert-and-maybe-compile form path) (case (car form) ((make-package in-package shadow shadowing-import export unexport use-package unuse-package import) - (process-cold-load-form form path object t)) + (process-cold-load-form form path t)) ((error cerror break signal) - (process-cold-load-form form path object nil)) + (process-cold-load-form form path nil)) ((eval-when) (unless (>= (length form) 2) (compiler-error "EVAL-WHEN form is too short: ~S." form)) (do-eval-when-stuff (cadr form) (cddr form) #'(lambda (forms) - (process-progn forms path object)))) + (process-progn forms path)))) ((macrolet) (unless (>= (length form) 2) (compiler-error "MACROLET form is too short: ~S." form)) (do-macrolet-stuff (cadr form) #'(lambda () - (process-progn (cddr form) path object)))) - (locally (process-locally form path object)) - (progn (process-progn (cdr form) path object)) + (process-progn (cddr form) path)))) + (locally (process-locally form path)) + (progn (process-progn (cdr form) path)) (file-comment (process-file-comment form)) - (proclaim (process-proclaim form path object)) + (proclaim (process-proclaim form path)) (t (let ((exp (preprocessor-macroexpand form))) (if (eq exp form) - (convert-and-maybe-compile form path object) - (process-form exp path object)))))))) + (convert-and-maybe-compile form path) + (process-form exp path)))))))) (undefined-value)) + +;;;; Load time value support. + +;;; PRODUCING-FASL-FILE -- interface. +;;; +;;; Returns T iff we are currently producing a fasl-file and hence constants +;;; need to be dumped carfully. +;;; +(defun producing-fasl-file () + (unless *converting-for-interpreter* + (fasl-file-p *compile-object*))) + +;;; COMPILE-LOAD-TIME-VALUE -- interface. +;;; +;;; Compile FORM and arrange for it to be called at load-time. Returns the +;;; dumper handle and our best guess at the type of the object. +;;; +(defun compile-load-time-value + (form &optional + (name (let ((*print-level* 2) (*print-length* 3)) + (format nil "Load Time Value of ~S" form)))) + (let ((lambda (compile-load-time-stuff form name t))) + (values + (fasl-dump-load-time-value-lambda lambda *compile-object*) + (let ((type (leaf-type lambda))) + (if (function-type-p type) + (single-value-type (function-type-returns type)) + *wild-type*))))) + +;;; COMPILE-MAKE-LOAD-FORM-INIT-FORMS -- internal. +;;; +;;; Compile the FORMS and arrange for them to be called (for effect, not value) +;;; at load-time. +;;; +(defun compile-make-load-form-init-forms (forms name) + (let ((lambda (compile-load-time-stuff `(progn ,@forms) name nil))) + (fasl-dump-top-level-lambda-call lambda *compile-object*))) + +;;; COMPILE-LOAD-TIME-STUFF -- internal. +;;; +;;; Does the actual work of COMPILE-LOAD-TIME-VALUE or COMPILE-MAKE-LOAD-FORM- +;;; INIT-FORMS. +;;; +(defun compile-load-time-stuff (form name for-value) + (compile-top-level-lambdas () t) + (with-ir1-namespace + (let* ((*lexical-environment* (make-null-environment)) + (lambda (ir1-top-level form *current-path* for-value))) + (setf (leaf-name lambda) name) + (compile-top-level (list lambda) t) + lambda))) + +;;; COMPILE-LOAD-TIME-VALUE-LAMBDA -- internal. +;;; +;;; Called by COMPILE-TOP-LEVEL when it was pased T for LOAD-TIME-VALUE-P +;;; (which happens in COMPILE-LOAD-TIME-STUFF). We don't try to combine +;;; this component with anything else and frob the name. +;;; +(defun compile-load-time-value-lambda (lambdas) + (assert (null (cdr lambdas))) + (let* ((lambda (car lambdas)) + (component (block-component (node-block (lambda-bind lambda))))) + (setf (component-name component) (leaf-name lambda)) + (compile-component component) + (clear-ir2-info component) + (clear-ir1-info component))) + + +;;; EMIT-MAKE-LOAD-FORM -- interface. +;;; +;;; The entry point for MAKE-LOAD-FORM support. When IR1 conversion finds a +;;; constant structure, it invokes this to arrange for proper dumping. If it +;;; turns out that the constant has already been dumped, then we don't need +;;; to do anything. +;;; +;;; If the constant hasn't been dumped, then we check to see if we are in the +;;; process of creating it. We detect this by maintaining the special +;;; *constants-being-created* as a list of all the constants we are in the +;;; process of creating. Actually, each entry is a list of the constant and +;;; any init forms that need to be processed on behalf of that constant. +;;; +;;; It's not necessarily an error for this to happen. If we are processing the +;;; init form for some object that showed up *after* the original reference +;;; to this constant, then we just need to defer the processing of that init +;;; form. To detect this, we maintain *constants-created-sense-last-init* as +;;; a list of the constants created sense the last time we started processing +;;; an init form. If the constant passed to emit-make-load-form shows up in +;;; this list, then there is a circular chain through creation forms, which is +;;; an error. +;;; +;;; If there is some intervening init form, then we blow out of processing it +;;; by throwing to the tag PENDING-INIT. The value we throw is the entry from +;;; *constants-being-created*. This is so the offending init form can be +;;; tacked onto the init forms for the circular object. +;;; +;;; If the constant doesn't show up in *constants-being-created*, then we have +;;; to create it. We call MAKE-LOAD-FORM and check to see if the creation +;;; form is the magic value :just-dump-it-normally. If it is, then we don't +;;; do anything. The dumper will eventually get it's hands on the object +;;; and use the normal structure dumping noise on it. +;;; +;;; Otherwise, we bind *constants-being-created* and *constants-created-sense- +;;; last-init* and compile the creation form a la load-time-value. When this +;;; finishes, we tell the dumper to use that result instead whenever it sees +;;; this constant. +;;; +;;; Now we try to compile the init form. We bind *constants-created-sense- +;;; last-init* to NIL and compile the init form (and any init forms that were +;;; added because of circularity detection). If this works, great. If not, +;;; we add the init forms to the init forms for the object that caused the +;;; problems and let it deal with it. +;;; +(defvar *constants-being-created* nil) +(defvar *constants-created-sense-last-init* nil) +;;; +(defun emit-make-load-form (constant) + (assert (fasl-file-p *compile-object*)) + (unless (or (not (fboundp 'make-load-form)) + (fasl-constant-already-dumped constant *compile-object*)) + (let ((circular-ref (assoc constant *constants-being-created* :test #'eq))) + (when circular-ref + (when (find constant *constants-created-sense-last-init* :test #'eq) + (throw constant t)) + (throw 'pending-init circular-ref))) + (multiple-value-bind + (creation-form init-form) + (make-load-form constant *lexical-environment*) + (unless (eq creation-form :just-dump-it-normally) + (let* ((name (let ((*print-level* 1) (*print-length* 2)) + (with-output-to-string (stream) + (write constant :stream stream)))) + (info (if init-form + (list constant name init-form) + (list constant)))) + (let ((*constants-being-created* + (cons info *constants-being-created*)) + (*constants-created-sense-last-init* + (cons constant *constants-created-sense-last-init*))) + (when + (catch constant + (fasl-note-handle-for-constant + constant + (compile-load-time-value + creation-form + (format nil "Creation Form for ~A" name)) + *compile-object*)) + (compiler-error "Circular references in creation form for ~S" + constant))) + (when (cdr info) + (let* ((*constants-created-sense-last-init* nil) + (circular-ref + (catch 'pending-init + (loop for (name form) on (cdr info) by #'cddr + collect name into names + collect form into forms + finally do + (compile-make-load-form-init-forms + forms + (format nil "Init Form~:[~;s~] for ~{~A~^, ~}" + (cdr forms) names))) + nil))) + (when circular-ref + (setf (cdr circular-ref) + (append (cdr circular-ref) (cdr info)))))))))) + (undefined-value)) + + ;;;; COMPILE-FILE and COMPILE-FROM-STREAM: @@ -1004,14 +1177,15 @@ ;;; OBJECT-CALL-TOP-LEVEL-LAMBDA -- Internal ;;; -(defun object-call-top-level-lambda (tll object) - (declare (type functional tll) (type object object)) - (etypecase object - (fasl-file - (fasl-dump-top-level-lambda-call tll object)) - (core-object - (core-call-top-level-lambda tll object)) - (null))) +(defun object-call-top-level-lambda (tll) + (declare (type functional tll)) + (let ((object *compile-object*)) + (etypecase object + (fasl-file + (fasl-dump-top-level-lambda-call tll object)) + (core-object + (core-call-top-level-lambda tll object)) + (null)))) ;;; SUB-COMPILE-TOP-LEVEL-LAMBDAS -- Internal @@ -1021,8 +1195,8 @@ ;;; the lambdas into a single component, compile it, and call the resulting ;;; function. ;;; -(defun sub-compile-top-level-lambdas (lambdas force-p object) - (declare (list lambdas) (type object object)) +(defun sub-compile-top-level-lambdas (lambdas force-p) + (declare (list lambdas)) (setq *pending-top-level-lambdas* (append *pending-top-level-lambdas* lambdas)) (let ((pending *pending-top-level-lambdas*)) @@ -1032,10 +1206,10 @@ (multiple-value-bind (component tll) (merge-top-level-lambdas pending) (setq *pending-top-level-lambdas* ()) - (compile-component component object) + (compile-component component) (clear-ir2-info component) (clear-ir1-info component) - (object-call-top-level-lambda tll object)))) + (object-call-top-level-lambda tll)))) (undefined-value)) @@ -1045,8 +1219,8 @@ ;;; top-level lambdas in non-top-level components here, calling SUB-c-t-l-l on ;;; each subsequence of normal top-level lambdas. ;;; -(defun compile-top-level-lambdas (lambdas force-p object) - (declare (list lambdas) (type object object)) +(defun compile-top-level-lambdas (lambdas force-p) + (declare (list lambdas)) (let ((len (length lambdas))) (flet ((loser (start) (or (position-if #'(lambda (x) @@ -1062,12 +1236,11 @@ (loser (loser start) (loser start))) ((>= start len) (when force-p - (sub-compile-top-level-lambdas nil t object))) + (sub-compile-top-level-lambdas nil t))) (sub-compile-top-level-lambdas (subseq lambdas start loser) - (or force-p (/= loser len)) - object) + (or force-p (/= loser len))) (unless (= loser len) - (object-call-top-level-lambda (elt lambdas loser) object))))) + (object-call-top-level-lambda (elt lambdas loser)))))) (undefined-value)) @@ -1078,8 +1251,8 @@ ;;; 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)) +(defun compile-top-level (lambdas load-time-value-p) + (declare (list lambdas)) (maybe-mumble "Locall ") (loop (let ((did-something nil)) @@ -1104,7 +1277,7 @@ (pre-environment-analyze-top-level component)) (dolist (component components) - (compile-component component object) + (compile-component component) (clear-ir2-info component) (when (replace-top-level-xeps component) (setq top-level-closure t))) @@ -1113,7 +1286,9 @@ (maybe-mumble "[Check]~%") (check-ir1-consistency *all-components*)) - (compile-top-level-lambdas lambdas top-level-closure object) + (if load-time-value-p + (compile-load-time-value-lambda lambdas) + (compile-top-level-lambdas lambdas top-level-closure)) (dolist (component components) (clear-ir1-info component)) @@ -1126,11 +1301,10 @@ ;;; Actually compile any stuff that has been queued up for block ;;; compilation. ;;; -(defun finish-block-compilation (object) - (declare (type object object)) +(defun finish-block-compilation () (when *block-compile* (when *top-level-lambdas* - (compile-top-level (nreverse *top-level-lambdas*) object) + (compile-top-level (nreverse *top-level-lambdas*) nil) (setq *top-level-lambdas* ())) (setq *block-compile* :specified) (setq *entry-points* nil))) @@ -1142,8 +1316,8 @@ ;;; 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)) +(defun sub-compile-file (info &optional d-s-info) + (declare (type source-info info)) (with-ir1-namespace (clear-stuff) (let* ((start-errors *compiler-error-count*) @@ -1185,14 +1359,15 @@ (when eof-p (return)) (clrhash *source-paths*) (find-source-paths form tlf) - (process-form form `(original-source-start 0 ,tlf) object))) - - (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)) - (null)) + (process-form form `(original-source-start 0 ,tlf)))) + + (finish-block-compilation) + (compile-top-level-lambdas () t) + (let ((object *compile-object*)) + (etypecase object + (fasl-file (fasl-dump-source-info info object)) + (core-object (fix-core-source-info info object d-s-info)) + (null))) (cond ((> *compiler-error-count* start-errors) :error) ((> *compiler-warning-count* start-warnings) :warning) @@ -1219,7 +1394,6 @@ (if (listp stuff) stuff (list stuff)))) -#+new-compiler ;;; COMPILE-FROM-STREAM -- Public ;;; ;;; Just call SUB-COMPILE-FILE on the on a stream source info for the @@ -1251,7 +1425,8 @@ (let ((info (make-stream-source-info stream)) (*backend* *native-backend*)) (unwind-protect - (let ((won (sub-compile-file info (make-core-object) source-info))) + (let* ((*compile-object* (make-core-object)) + (won (sub-compile-file info source-info))) (values (not (null won)) (if (member won '(:error :warning)) t nil))) (close-source-info info)))) @@ -1359,8 +1534,6 @@ (default (pathname (first source)))) (unwind-protect (progn - #-new-compiler - (pushnew :new-compiler *features*) (flet ((frob (file type) (if (eq file t) (make-pathname :type type :defaults default) @@ -1396,12 +1569,10 @@ (when *compile-verbose* (start-error-output source-info)) (setq error-severity - (sub-compile-file source-info fasl-file)) + (let ((*compile-object* fasl-file)) + (sub-compile-file source-info))) (setq compile-won t)) - #-new-compiler - (setq *features* (remove :new-compiler *features*)) - (close-source-info source-info) (when fasl-file @@ -1478,7 +1649,6 @@ ;;; COMPILE -- Public ;;; -#+new-compiler (defun compile (name &optional (definition (fdefinition name))) "Compiles the function whose name is Name. If Definition is supplied, it should be a lambda expression that is compiled and then placed in the @@ -1514,7 +1684,7 @@ (*last-format-string* nil) (*last-format-args* nil) (*last-message-count* 0) - (object (make-core-object))) + (*compile-object* (make-core-object))) (find-source-paths form 0) (let ((lambda (ir1-top-level form '(original-source-start 0 0) t))) @@ -1528,12 +1698,12 @@ (find-initial-dfo (list lambda)) (let ((*all-components* (append components top-components))) (dolist (component *all-components*) - (compile-component component object) + (compile-component component) (clear-ir2-info component)))) - (let* ((res (core-call-top-level-lambda lambda object)) + (let* ((res (core-call-top-level-lambda lambda *compile-object*)) (return (or name res))) - (fix-core-source-info *source-info* object res) + (fix-core-source-info *source-info* *compile-object* res) (when name (setf (fdefinition name) res)) @@ -1545,7 +1715,6 @@ (t (values return nil nil))))))))) -#+new-compiler ;;; UNCOMPILE -- Public ;;; (defun uncompile (name) -- GitLab