diff options
| -rw-r--r-- | make-host-2.sh | 12 | ||||
| -rw-r--r-- | src/compiler/checkgen.lisp | 2 | ||||
| -rw-r--r-- | src/compiler/debug.lisp | 8 | ||||
| -rw-r--r-- | src/compiler/dfo.lisp | 195 | ||||
| -rw-r--r-- | src/compiler/ir1opt.lisp | 6 | ||||
| -rw-r--r-- | src/compiler/ir1tran.lisp | 18 | ||||
| -rw-r--r-- | src/compiler/ir1util.lisp | 2 | ||||
| -rw-r--r-- | src/compiler/locall.lisp | 81 | ||||
| -rw-r--r-- | src/compiler/main.lisp | 47 | ||||
| -rw-r--r-- | src/compiler/node.lisp | 30 | ||||
| -rw-r--r-- | src/compiler/physenvanal.lisp | 6 | ||||
| -rw-r--r-- | src/pcl/fngen.lisp | 10 | ||||
| -rw-r--r-- | version.lisp-expr | 2 |
13 files changed, 245 insertions, 174 deletions
diff --git a/make-host-2.sh b/make-host-2.sh index 080f0485d..5e5c8e28e 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -41,6 +41,10 @@ rm -f output/after-xc.core # an enormously important disadvantage, either.) echo //running cross-compiler to create target object files $SBCL_XC_HOST <<-'EOF' || exit 1 + + ;;; + ;;; Set up the cross-compiler. + ;;; (setf *print-level* 5 *print-length* 5) (load "src/cold/shared.lisp") (in-package "SB-COLD") @@ -89,7 +93,15 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (setf *target-assemble-file* 'sb!c:assemble-file) (setf *in-target-compilation-mode-fn* #'in-target-cross-compilation-mode) + + ;;; + ;;; Run the cross-compiler to produce cold fasl files. + ;;; (load "src/cold/compile-cold-sbcl.lisp") + + ;;; + ;;; miscellaneous tidying up and saving results + ;;; (let ((filename "output/object-filenames-for-genesis.lisp-expr")) (ensure-directories-exist filename :verbose t) (with-open-file (s filename :direction :output) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 0b6b12888..2d983771f 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -394,7 +394,7 @@ (substitute-continuation new-start victim))) ;; Invoking local call analysis converts this call to a LET. - (local-call-analyze *current-component*)) + (locall-analyze-component *current-component*)) (values)) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index a1075e38e..fa8bbf330 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -245,8 +245,8 @@ (defun check-function-consistency (components) (dolist (c components) - (dolist (fun (component-new-functions c)) - (observe-functional fun)) + (dolist (new-fun (component-new-funs c)) + (observe-functional new-fun)) (dolist (fun (component-lambdas c)) (when (eq (functional-kind fun) :external) (let ((ef (functional-entry-function fun))) @@ -257,8 +257,8 @@ (observe-functional let)))) (dolist (c components) - (dolist (fun (component-new-functions c)) - (check-function-stuff fun)) + (dolist (new-fun (component-new-funs c)) + (check-function-stuff new-fun)) (dolist (fun (component-lambdas c)) (when (eq (functional-kind fun) :deleted) (barf "deleted lambda ~S in Lambdas for ~S" fun c)) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 0343d1d8c..41075214a 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -69,10 +69,10 @@ (setf (component-lambdas new) (nconc (component-lambdas old) (component-lambdas new))) - (setf (component-lambdas old) ()) - (setf (component-new-functions new) - (nconc (component-new-functions old) (component-new-functions new))) - (setf (component-new-functions old) ()) + (setf (component-lambdas old) nil) + (setf (component-new-funs new) (nconc (component-new-funs old) + (component-new-funs new)) + (component-new-funs old) nil) (dolist (xp (block-pred old-tail)) (unlink-blocks xp old-tail) @@ -125,7 +125,7 @@ (let* ((bind-block (node-block (lambda-bind home))) (home-component (block-component bind-block))) (cond ((eq (component-kind home-component) :initial) - (dfo-walk-call-graph home component)) + (dfo-scavenge-call-graph home component)) ((eq home-component component) component) (t @@ -178,7 +178,7 @@ ;;; ;;; References in deleted functions are also ignored, since this code ;;; will be deleted eventually. -(defun find-reference-functions (fun) +(defun find-reference-funs (fun) (collect ((res)) (dolist (ref (leaf-refs fun)) (let* ((home (node-home-lambda ref)) @@ -220,34 +220,46 @@ ;;; ensures that conversion of a full call to a local call won't ;;; result in a need to join components, since the components will ;;; already be one. -(defun dfo-walk-call-graph (fun component) +(defun dfo-scavenge-call-graph (fun component) (declare (type clambda fun) (type component component)) + (/show "entering DFO-SCAVENGE-CALL-GRAPH" fun component) (let* ((bind-block (node-block (lambda-bind fun))) - (this (block-component bind-block)) + (old-lambda-component (block-component bind-block)) (return (lambda-return fun))) (cond - ((eq this component) component) - ((not (eq (component-kind this) :initial)) - (join-components this component) - this) + ((eq old-lambda-component component) + (/show "LAMBDA is already in COMPONENT") + component) + ((not (eq (component-kind old-lambda-component) :initial)) + (/show "joining COMPONENTs") + (join-components old-lambda-component component) + old-lambda-component) ((block-flag bind-block) + (/show "do-nothing (BLOCK-FLAG BIND-BLOCK) case") component) (t + (/show "full scavenge case") (push fun (component-lambdas component)) - (setf (component-lambdas this) - (delete fun (component-lambdas this))) + (setf (component-lambdas old-lambda-component) + (delete fun (component-lambdas old-lambda-component))) (link-blocks (component-head component) bind-block) - (unlink-blocks (component-head this) bind-block) + (unlink-blocks (component-head old-lambda-component) bind-block) (when return (let ((return-block (node-block return))) (link-blocks return-block (component-tail component)) - (unlink-blocks return-block (component-tail this)))) + (unlink-blocks return-block (component-tail old-lambda-component)))) + + (/show (functional-kind fun)) + (/show (lambda-calls fun)) + (when (eq (functional-kind fun) :external) + (/show (find-reference-funs fun))) + (let ((calls (if (eq (functional-kind fun) :external) - (append (find-reference-functions fun) + (append (find-reference-funs fun) (lambda-calls fun)) (lambda-calls fun)))) (do ((res (find-initial-dfo-aux bind-block component) - (dfo-walk-call-graph (first funs) res)) + (dfo-scavenge-call-graph (first funs) res)) (funs calls (rest funs))) ((null funs) res) (declare (type component res)))))))) @@ -268,14 +280,15 @@ ;;; treat the component as normal, but also return such components in ;;; a list as the third value. Components with no entry of any sort ;;; are deleted. -(defun find-toplevel-components (components) +(defun separate-toplevelish-components (components) (declare (list components)) (collect ((real) (top) (real-top)) - (dolist (com components) - (unless (eq (block-next (component-head com)) (component-tail com)) - (let* ((funs (component-lambdas com)) + (dolist (component components) + (unless (eq (block-next (component-head component)) + (component-tail component)) + (let* ((funs (component-lambdas component)) (has-top (find :toplevel funs :key #'functional-kind)) (has-external-references (some #'functional-has-external-references-p funs))) @@ -288,75 +301,105 @@ ;; delete them just because they don't have any ;; references from pure :TOPLEVEL components. -- WHN has-external-references - (setf (component-kind com) :complex-toplevel) - (real com) - (real-top com)) + (setf (component-kind component) :complex-toplevel) + (real component) + (real-top component)) ((or (some #'has-xep-or-nlx funs) (and has-top (rest funs))) - (setf (component-name com) (find-component-name com)) - (real com) + (setf (component-name component) + (find-component-name component)) + (real component) (when has-top - (setf (component-kind com) :complex-toplevel) - (real-top com))) + (setf (component-kind component) :complex-toplevel) + (real-top component))) (has-top - (setf (component-kind com) :toplevel) - (setf (component-name com) "top level form") - (top com)) + (setf (component-kind component) :toplevel) + (setf (component-name component) "top level form") + (top component)) (t - (delete-component com)))))) + (delete-component component)))))) (values (real) (top) (real-top)))) -;;; Given a list of top level lambdas, return three lists of -;;; components representing the actual component division: -;;; 1. the non-top-level components, -;;; 2. and the second is the top level components, and -;;; 3. Components in [1] that also have a top level lambda. +;; COMPONENTs want strings for names, LEAF-DEBUG-NAMEs mightn't be +;; strings.. +(defun component-name-from-functional-debug-name (functional) + (declare (type functional functional)) + (let ((leaf-debug-name (leaf-debug-name functional))) + (the simple-string + (if (stringp leaf-debug-name) + leaf-debug-name + (debug-namify "function ~S" leaf-debug-name))))) + +;;; Given a list of top level lambdas, return +;;; (VALUES NONTOP-COMPONENTS TOP-COMPONENTS HAIRY-TOP-COMPONENTS). +;;; Each of the three values returned is a list of COMPONENTs: +;;; NONTOP-COMPONENTS = non-top-level-ish COMPONENTs; +;;; TOP-COMPONENTS = top-level-ish COMPONENTs; +;;; HAIRY-TOP-COMPONENTS = a subset of NONTOP-COMPONENTS, those +;;; elements which include a top-level-ish lambda. ;;; ;;; We assign the DFO for each component, and delete any unreachable -;;; blocks. We assume that the Flags have already been cleared. -;;; -;;; We iterate over the lambdas in each initial component, trying to -;;; put each function in its own component, but joining it to an -;;; existing component if we find that there are references between -;;; them. Any code that is left in an initial component must be -;;; unreachable, so we can delete it. Stray links to the initial -;;; component tail (due NIL function terminated blocks) are moved to -;;; the appropriate newc component tail. -;;; -;;; When we are done, we assign DFNs and call -;;; FIND-TOPLEVEL-COMPONENTS to pull out top level code. -(defun find-initial-dfo (lambdas) - (declare (list lambdas)) +;;; blocks. We assume that the FLAGS have already been cleared. +(defun find-initial-dfo (toplevel-lambdas) + (declare (list toplevel-lambdas)) + (/show "entering FIND-INITIAL-DFO" toplevel-lambdas) (collect ((components)) - (let ((new (make-empty-component))) - (dolist (tll lambdas) - (let ((component (block-component (node-block (lambda-bind tll))))) - (dolist (fun (component-lambdas component)) - (aver (member (functional-kind fun) - '(:optional :external :toplevel nil :escape - :cleanup))) - (let ((res (dfo-walk-call-graph fun new))) - (when (eq res new) - (components new) - (setq new (make-empty-component))))) - (when (eq (component-kind component) :initial) - (aver (null (component-lambdas component))) - (let ((tail (component-tail component))) - (dolist (pred (block-pred tail)) - (let ((pred-component (block-component pred))) - (unless (eq pred-component component) - (unlink-blocks pred tail) - (link-blocks pred (component-tail pred-component)))))) - (delete-component component))))) - - (dolist (com (components)) + ;; We iterate over the lambdas in each initial component, trying + ;; to put each function in its own component, but joining it to + ;; an existing component if we find that there are references + ;; between them. Any code that is left in an initial component + ;; must be unreachable, so we can delete it. Stray links to the + ;; initial component tail (due NIL function terminated blocks) + ;; are moved to the appropriate newc component tail. + (dolist (toplevel-lambda toplevel-lambdas) + (/show toplevel-lambda) + (let* ((block (node-block (lambda-bind toplevel-lambda))) + (old-component (block-component block)) + (old-component-lambdas (component-lambdas old-component)) + (new-component nil)) + (/show old-component old-component-lambdas) + (aver (member toplevel-lambda old-component-lambdas)) + (dolist (component-lambda old-component-lambdas) + (/show component-lambda) + (aver (member (functional-kind component-lambda) + '(:optional :external :toplevel nil :escape + :cleanup))) + (unless new-component + (setf new-component (make-empty-component)) + (setf (component-name new-component) + ;; This isn't necessarily an ideal name for the + ;; component, since it might end up with multiple + ;; lambdas in it, not just this one, but it does + ;; seem a better name than just "<unknown>". + (component-name-from-functional-debug-name + component-lambda))) + (let ((res (dfo-scavenge-call-graph component-lambda new-component))) + (when (eq res new-component) + (/show "saving" new-component (component-lambdas new-component)) + (aver (not (position new-component (components)))) + (components new-component) + (setq new-component nil)))) + (when (eq (component-kind old-component) :initial) + (aver (null (component-lambdas old-component))) + (/show "clearing/deleting OLD-COMPONENT because KIND=:INITIAL") + (let ((tail (component-tail old-component))) + (dolist (pred (block-pred tail)) + (let ((pred-component (block-component pred))) + (unless (eq pred-component old-component) + (unlink-blocks pred tail) + (link-blocks pred (component-tail pred-component)))))) + (delete-component old-component)))) + + ;; When we are done, we assign DFNs. + (dolist (component (components)) (let ((num 0)) (declare (fixnum num)) - (do-blocks-backwards (block com :both) + (do-blocks-backwards (block component :both) (setf (block-number block) (incf num))))) - (find-toplevel-components (components)))) + ;; Pull out top-level-ish code. + (separate-toplevelish-components (components)))) ;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA. (defun merge-1-tl-lambda (result-lambda lambda) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index c7b26e30d..616c98446 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -820,7 +820,7 @@ (frob) (with-ir1-environment call (frob) - (local-call-analyze *current-component*)))) + (locall-analyze-component *current-component*)))) (values (ref-leaf (continuation-use (basic-combination-fun call))) nil)) @@ -1090,7 +1090,7 @@ (ref (continuation-use (combination-fun node)))) (change-ref-leaf ref new-fun) (setf (combination-kind node) :full) - (local-call-analyze *current-component*))) + (locall-analyze-component *current-component*))) (values)) ;;; Replace a call to a foldable function of constant arguments with @@ -1491,7 +1491,7 @@ (funcall ,(ref-leaf ref) ,@dums))))) (change-ref-leaf ref fun) (aver (eq (basic-combination-kind node) :full)) - (local-call-analyze *current-component*) + (locall-analyze-component *current-component*) (aver (eq (basic-combination-kind node) :local))))))))) (values)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 5b025c66c..7a10dc174 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -487,11 +487,11 @@ (use-continuation res cont))) (values))) -;;; Add FUN to the COMPONENT-REANALYZE-FUNCTIONS. FUN is returned. - (defun maybe-reanalyze-function (fun) +;;; Add FUN to the COMPONENT-REANALYZE-FUNS. FUN is returned. +(defun maybe-reanalyze-fun (fun) (declare (type functional fun)) (when (typep fun '(or optional-dispatch clambda)) - (pushnew fun (component-reanalyze-functions *current-component*))) + (pushnew fun (component-reanalyze-funs *current-component*))) fun) ;;; Generate a REF node for LEAF, frobbing the LEAF structure as @@ -505,7 +505,7 @@ :notinline)) (let ((fun (defined-fun-functional leaf))) (when (and fun (not (functional-kind fun))) - (maybe-reanalyze-function fun)))) + (maybe-reanalyze-fun fun)))) leaf)) (res (make-ref (or (lexenv-find leaf type-restrictions) (leaf-type leaf)) @@ -780,7 +780,7 @@ (if (functional-kind fun) (throw 'local-call-lossage fun) (ir1-convert-combination start cont form - (maybe-reanalyze-function fun)))) + (maybe-reanalyze-fun fun)))) ;;;; PROCESS-DECLS @@ -1323,8 +1323,8 @@ ;;; Create a lambda node out of some code, returning the result. The ;;; bindings are specified by the list of VAR structures VARS. We deal ;;; with adding the names to the LEXENV-VARIABLES for the conversion. -;;; The result is added to the NEW-FUNCTIONS in the -;;; *CURRENT-COMPONENT* and linked to the component head and tail. +;;; The result is added to the NEW-FUNS in the *CURRENT-COMPONENT* and +;;; linked to the component head and tail. ;;; ;;; We detect special bindings here, replacing the original VAR in the ;;; lambda list with a temporary variable. We then pass a list of the @@ -1407,7 +1407,7 @@ (link-blocks block (component-tail *current-component*)))))) (link-blocks (component-head *current-component*) (node-block bind)) - (push lambda (component-new-functions *current-component*)) + (push lambda (component-new-funs *current-component*)) lambda)) ;;; Create the actual entry-point function for an optional entry @@ -1806,7 +1806,7 @@ :%source-name source-name :%debug-name debug-name)) (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) - (push res (component-new-functions *current-component*)) + (push res (component-new-funs *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals cont) (setf (optional-dispatch-min-args res) min) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 4c5d3a3d0..1e3369e24 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1050,7 +1050,7 @@ ;;; triggered by deletion. (defun delete-component (component) (declare (type component component)) - (aver (null (component-new-functions component))) + (aver (null (component-new-funs component))) (setf (component-kind component) :deleted) (do-blocks (block component) (setf (block-delete-p block) t)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 54d944d78..dc7c1ed26 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -124,7 +124,7 @@ ;;; FUN will be verified. Since nothing is known about the type of the ;;; XEP arg vars, type checks will be emitted when the XEP's arg vars ;;; are passed to the actual function. -(defun make-xep-lambda (fun) +(defun make-xep-lambda-expression (fun) (declare (type functional fun)) (etypecase fun (clambda @@ -179,7 +179,7 @@ (declare (type functional fun)) (aver (not (functional-entry-function fun))) (with-ir1-environment (lambda-bind (main-entry fun)) - (let ((res (ir1-convert-lambda (make-xep-lambda fun) + (let ((res (ir1-convert-lambda (make-xep-lambda-expression fun) :debug-name (debug-namify "XEP for ~A" (leaf-debug-name fun))))) @@ -190,12 +190,12 @@ (component-reanalyze *current-component*) t (component-reoptimize *current-component*) t) (etypecase fun - (clambda (local-call-analyze-1 fun)) + (clambda (locall-analyze-fun-1 fun)) (optional-dispatch (dolist (ep (optional-dispatch-entry-points fun)) - (local-call-analyze-1 ep)) + (locall-analyze-fun-1 ep)) (when (optional-dispatch-more-entry fun) - (local-call-analyze-1 (optional-dispatch-more-entry fun))))) + (locall-analyze-fun-1 (optional-dispatch-more-entry fun))))) res))) ;;; Notice a REF that is not in a local-call context. If the REF is @@ -223,10 +223,10 @@ ;;; function as an entry-point, creating a new XEP if necessary. We ;;; don't try to convert calls that are in error (:ERROR kind.) ;;; -;;; This is broken off from LOCAL-CALL-ANALYZE so that people can -;;; force analysis of newly introduced calls. Note that we don't do -;;; LET conversion here. -(defun local-call-analyze-1 (fun) +;;; This is broken off from LOCALL-ANALYZE-COMPONENT so that people +;;; can force analysis of newly introduced calls. Note that we don't +;;; do LET conversion here. +(defun locall-analyze-fun-1 (fun) (declare (type functional fun)) (let ((refs (leaf-refs fun)) (first-time t)) @@ -247,28 +247,27 @@ (values)) -;;; We examine all NEW-FUNCTIONS in component, attempting to convert -;;; calls into local calls when it is legal. We also attempt to -;;; convert each LAMBDA to a LET. LET conversion is also triggered by -;;; deletion of a function reference, but functions that start out -;;; eligible for conversion must be noticed sometime. +;;; We examine all NEW-FUNS in COMPONENT, attempting to convert calls +;;; into local calls when it is legal. We also attempt to convert each +;;; LAMBDA to a LET. LET conversion is also triggered by deletion of a +;;; function reference, but functions that start out eligible for +;;; conversion must be noticed sometime. ;;; ;;; Note that there is a lot of action going on behind the scenes ;;; here, triggered by reference deletion. In particular, the ;;; COMPONENT-LAMBDAS are being hacked to remove newly deleted and let ;;; converted LAMBDAs, so it is important that the LAMBDA is added to -;;; the COMPONENT-LAMBDAS when it is. Also, the -;;; COMPONENT-NEW-FUNCTIONS may contain all sorts of drivel, since it -;;; is not updated when we delete functions, etc. Only -;;; COMPONENT-LAMBDAS is updated. +;;; the COMPONENT-LAMBDAS when it is. Also, the COMPONENT-NEW-FUNS may +;;; contain all sorts of drivel, since it is not updated when we +;;; delete functions, etc. Only COMPONENT-LAMBDAS is updated. ;;; -;;; COMPONENT-REANALYZE-FUNCTIONS is treated similarly to -;;; NEW-FUNCTIONS, but we don't add lambdas to the LAMBDAS. -(defun local-call-analyze (component) +;;; COMPONENT-REANALYZE-FUNS is treated similarly to +;;; NEW-FUNS, but we don't add lambdas to the LAMBDAS. +(defun locall-analyze-component (component) (declare (type component component)) (loop - (let* ((new (pop (component-new-functions component))) - (fun (or new (pop (component-reanalyze-functions component))))) + (let* ((new-fun (pop (component-new-funs component))) + (fun (or new-fun (pop (component-reanalyze-funs component))))) (unless fun (return)) (let ((kind (functional-kind fun))) (cond ((member kind '(:deleted :let :mv-let :assignment))) @@ -276,15 +275,15 @@ (not (functional-entry-function fun))) (delete-functional fun)) (t - (when (and new (lambda-p fun)) + (when (and new-fun (lambda-p fun)) (push fun (component-lambdas component))) - (local-call-analyze-1 fun) + (locall-analyze-fun-1 fun) (when (lambda-p fun) (maybe-let-convert fun))))))) (values)) -(defun local-call-analyze-until-done (clambdas) +(defun locall-analyze-clambdas-until-done (clambdas) (loop (let ((did-something nil)) (dolist (clambda clambdas) @@ -294,9 +293,9 @@ ;; COMPONENT is the only one here. Let's make that explicit. (aver (= 1 (length (functional-components clambda)))) (aver (eql component (first (functional-components clambda)))) - (when (component-new-functions component) + (when (component-new-funs component) (setf did-something t) - (local-call-analyze component)))) + (locall-analyze-component component)))) (unless did-something (return)))) (values)) @@ -315,8 +314,10 @@ (won nil) (res (catch 'local-call-lossage (prog1 - (ir1-convert-lambda (functional-inline-expansion - :source-name fun)) + (ir1-convert-lambda + (functional-inline-expansion fun) + :debug-name (debug-namify "local inline ~A" + (leaf-debug-name fun))) (setq won t))))) (cond (won (change-ref-leaf ref res) @@ -486,17 +487,17 @@ (setf (basic-combination-kind call) :error)))) (values)) -;;; This function is used to convert a call to an entry point when complex -;;; transformations need to be done on the original arguments. Entry is the -;;; entry point function that we are calling. Vars is a list of variable names -;;; which are bound to the original call arguments. Ignores is the subset of -;;; Vars which are ignored. Args is the list of arguments to the entry point -;;; function. +;;; This function is used to convert a call to an entry point when +;;; complex transformations need to be done on the original arguments. +;;; ENTRY is the entry point function that we are calling. VARS is a +;;; list of variable names which are bound to the original call +;;; arguments. IGNORES is the subset of VARS which are ignored. ARGS +;;; is the list of arguments to the entry point function. ;;; -;;; In order to avoid gruesome graph grovelling, we introduce a new function -;;; that rearranges the arguments and calls the entry point. We analyze the -;;; new function and the entry point immediately so that everything gets -;;; converted during the single pass. +;;; In order to avoid gruesome graph grovelling, we introduce a new +;;; function that rearranges the arguments and calls the entry point. +;;; We analyze the new function and the entry point immediately so +;;; that everything gets converted during the single pass. (defun convert-hairy-fun-entry (ref call entry vars ignores args) (declare (list vars ignores args) (type ref ref) (type combination call) (type clambda entry)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index d17c7dcce..9d8e5826a 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -316,10 +316,10 @@ (declare (special *constraint-number* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) - (when (or (component-new-functions component) - (component-reanalyze-functions component)) + (when (or (component-new-funs component) + (component-reanalyze-funs component)) (maybe-mumble "locall ") - (local-call-analyze component)) + (locall-analyze-component component)) (dfo-as-needed component) (when *constraint-propagate* (maybe-mumble "constraint ") @@ -331,15 +331,15 @@ ;; confuse itself. (unless (and (or (component-reoptimize component) (component-reanalyze component) - (component-new-functions component) - (component-reanalyze-functions component)) + (component-new-funs component) + (component-reanalyze-funs component)) (< loop-count (- *reoptimize-after-type-check-max* 4))) (maybe-mumble "type ") (generate-type-checks component) (unless (or (component-reoptimize component) (component-reanalyze component) - (component-new-functions component) - (component-reanalyze-functions component)) + (component-new-funs component) + (component-reanalyze-funs component)) (return))) (when (>= loop-count *reoptimize-after-type-check-max*) (maybe-mumble "[reoptimize limit]") @@ -857,16 +857,19 @@ (component (make-empty-component)) (*current-component* component)) (setf (component-name component) - (format nil "~S initial component" name)) + (debug-namify "~S initial component" name)) (setf (component-kind component) :initial) (let* ((locall-fun (ir1-convert-lambda definition :debug-name (debug-namify "top level locall ~S" name))) - (fun (ir1-convert-lambda (make-xep-lambda locall-fun) + (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name (or name '.anonymous.) - :debug-name (or name "top level form")))) + :debug-name (unless name + "top level form")))) (/show "in MAKE-FUNCTIONAL-FROM-TOP-LEVEL-LAMBDA" locall-fun fun component) + (/show (component-lambdas component)) + (/show (lambda-calls fun)) (setf (functional-entry-function fun) locall-fun (functional-kind fun) :external (functional-has-external-references-p fun) t) @@ -899,7 +902,9 @@ (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) - (/show fun) + (/show "back in %COMPILE from M-F-FROM-TL-LAMBDA" fun) + (/show (block-component (node-block (lambda-bind fun)))) + (/show (component-lambdas (block-component (node-block (lambda-bind fun))))) ;; FIXME: The compile-it code from here on is sort of a ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be @@ -909,15 +914,25 @@ ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..) - (local-call-analyze-until-done (list fun)) - + (locall-analyze-clambdas-until-done (list fun)) + (/show (lambda-calls fun)) + #+nil (break "back from LOCALL-ANALYZE-CLAMBDAS-UNTIL-DONE" fun) + (multiple-value-bind (components-from-dfo top-components hairy-top) (find-initial-dfo (list fun)) (/show components-from-dfo top-components hairy-top) + (/show (mapcar #'component-lambdas components-from-dfo)) + (/show (mapcar #'component-lambdas top-components)) + (/show (mapcar #'component-lambdas hairy-top)) (let ((*all-components* (append components-from-dfo top-components))) - (mapc #'preallocate-physenvs-for-toplevelish-lambdas - (append hairy-top top-components)) + ;; FIXME: This is more monkey see monkey do based on CMU CL + ;; code. If anyone figures out why to only prescan HAIRY-TOP + ;; and TOP-COMPONENTS here, instead of *ALL-COMPONENTS* or + ;; some other combination of results from FIND-INITIAL-VALUES, + ;; it'd be good to explain it. + (mapc #'preallocate-physenvs-for-toplevelish-lambdas hairy-top) + (mapc #'preallocate-physenvs-for-toplevelish-lambdas top-components) (dolist (component-from-dfo components-from-dfo) (/show component-from-dfo (component-lambdas component-from-dfo)) (compile-component component-from-dfo) @@ -1245,7 +1260,7 @@ (declare (list lambdas)) (maybe-mumble "locall ") - (local-call-analyze-until-done lambdas) + (locall-analyze-clambdas-until-done lambdas) (maybe-mumble "IDFO ") (multiple-value-bind (components top-components hairy-top) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index ddde59eea..7b499a656 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -368,22 +368,22 @@ ;; deleted or LET lambdas. ;; ;; Note that logical associations between CLAMBDAs and COMPONENTs - ;; seem to exist for a while before this is initialized. In - ;; particular, I got burned by writing some code to use this value - ;; to decide which components need LOCAL-CALL-ANALYZE, when it turns - ;; out that LOCAL-CALL-ANALYZE had a role in initializing this value + ;; seem to exist for a while before this is initialized. See e.g. + ;; the NEW-FUNS slot. In particular, I got burned by writing some + ;; code to use this value to decide which components need + ;; LOCALL-ANALYZE-COMPONENT, when it turns out that + ;; LOCALL-ANALYZE-COMPONENT had a role in initializing this value ;; (and DFO stuff does too, maybe). Also, even after it's ;; initialized, it might change as CLAMBDAs are deleted or merged. ;; -- WHN 2001-09-30 (lambdas () :type list) - ;; a list of FUNCTIONAL structures for functions that are newly - ;; converted, and haven't been local-call analyzed yet. Initially - ;; functions are not in the LAMBDAS list. LOCAL-CALL-ANALYZE moves - ;; them there (possibly as LETs, or implicitly as XEPs if an - ;; OPTIONAL-DISPATCH.) Between runs of LOCAL-CALL-ANALYZE there may - ;; be some debris of converted or even deleted functions in this - ;; list. - (new-functions () :type list) + ;; a list of FUNCTIONALs for functions that are newly converted, and + ;; haven't been local-call analyzed yet. Initially functions are not + ;; in the LAMBDAS list. Local call analysis moves them there + ;; (possibly as LETs, or implicitly as XEPs if an OPTIONAL-DISPATCH.) + ;; Between runs of local call analysis there may be some debris of + ;; converted or even deleted functions in this list. + (new-funs () :type list) ;; If this is true, then there is stuff in this component that could ;; benefit from further IR1 optimization. (reoptimize t :type boolean) @@ -408,11 +408,11 @@ ;; arguments for the note, or the FUN-TYPE that would have ;; enabled the transformation but failed to match. (failed-optimizations (make-hash-table :test 'eq) :type hash-table) - ;; This is similar to NEW-FUNCTIONS, but is used when a function has + ;; This is similar to NEW-FUNS, but is used when a function has ;; already been analyzed, but new references have been added by - ;; inline expansion. Unlike NEW-FUNCTIONS, this is not disjoint from + ;; inline expansion. Unlike NEW-FUNS, this is not disjoint from ;; COMPONENT-LAMBDAS. - (reanalyze-functions nil :type list)) + (reanalyze-funs nil :type list)) (defprinter (component :identity t) name (reanalyze :test reanalyze)) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 0d16dbfb6..8860c6a87 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -30,8 +30,8 @@ (declare (type component component)) (aver (every (lambda (x) (eq (functional-kind x) :deleted)) - (component-new-functions component))) - (setf (component-new-functions component) ()) + (component-new-funs component))) + (setf (component-new-funs component) ()) (dolist (fun (component-lambdas component)) (reinit-lambda-physenv fun)) (dolist (fun (component-lambdas component)) @@ -344,7 +344,7 @@ (block-last block1) `(progn ,@(code))) (dolist (fun (reanalyze-funs)) - (local-call-analyze-1 fun))))) + (locall-analyze-fun-1 fun))))) (values)) diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index 08d8bdd8b..bdcb74687 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -39,7 +39,7 @@ ;;; There are three internal functions which operate on the lambda argument ;;; to GET-FUNCTION: ;;; compute-test converts the lambda into a key to be used for lookup, -;;; compute-code is used by get-new-function-generator-internal to +;;; compute-code is used by get-new-fun-generator-internal to ;;; generate the actual lambda to be compiled, and ;;; compute-constants is used to generate the argument list that is ;;; to be passed to the compiled function. @@ -113,17 +113,17 @@ (fgen (lookup-fgen test))) (if fgen (fgen-generator fgen) - (get-new-function-generator lambda test code-converter)))) + (get-new-fun-generator lambda test code-converter)))) -(defun get-new-function-generator (lambda test code-converter) +(defun get-new-fun-generator (lambda test code-converter) (multiple-value-bind (gensyms generator-lambda) - (get-new-function-generator-internal lambda code-converter) + (get-new-fun-generator-internal lambda code-converter) (let* ((generator (compile nil generator-lambda)) (fgen (make-fgen test gensyms generator generator-lambda nil))) (store-fgen fgen) generator))) -(defun get-new-function-generator-internal (lambda code-converter) +(defun get-new-fun-generator-internal (lambda code-converter) (multiple-value-bind (code gensyms) (compute-code lambda code-converter) (values gensyms `(lambda ,gensyms (function ,code))))) diff --git a/version.lisp-expr b/version.lisp-expr index 4d47b96e4..7362e6db4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.86.flaky7" +"0.pre7.86.flaky7.1" |