From: William Harold Newman Date: Sun, 11 Nov 2001 17:13:36 +0000 (+0000) Subject: 0.pre7.86.flaky7.3: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e2b33e0d99f0f93263defcd2e0dffe20c4e388f3;p=sbcl.git 0.pre7.86.flaky7.3: (This version cross-compiles all the way up to target-sxhash, where it dies with some sort of bug in &OPTIONAL arguments in FLET.) s/physenv-function/physenv-lambda/ PHYSENV-LAMBDA is read-only. PRE-PHYSENV-ANALYZE-TOPLEVEL does COMPUTE-CLOSURE on all the LETs of each CLAMBDA. PREALLOCATE-PHYSENVS-FOR-TOPLEVELISH-LAMBDAS, which is supposed to play the same role, does not. What bozo wrote that?:-( Ahem. So.. ..Since there's never a good reason to call COMPUTE-CLOSURE on CLAMBDA without calling it on its LETs as well, and since I've demonstrated that it's an attractive nuisance, I'll try to make it less attractive, by making COMPUTE-CLOSURE automatically run over all the the LETs, and moving the old COMPUTE-CLOSURE code into an FLET hidden by the new COMPUTE-CLOSURE interface. --- diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 73f3aed..2a107f6 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -175,14 +175,14 @@ ;;; Dump the successors of Block, being careful not to fly into space ;;; on weird successors. -(defun dump-block-successors (block env) - (declare (type cblock block) (type physenv env)) +(defun dump-block-successors (block physenv) + (declare (type cblock block) (type physenv physenv)) (let* ((tail (component-tail (block-component block))) (succ (block-succ block)) (valid-succ (if (and succ (or (eq (car succ) tail) - (not (eq (block-physenv (car succ)) env)))) + (not (eq (block-physenv (car succ)) physenv)))) () succ))) (vector-push-extend @@ -190,7 +190,7 @@ *byte-buffer*) (let ((base (block-number (node-block - (lambda-bind (physenv-function env)))))) + (lambda-bind (physenv-lambda physenv)))))) (dolist (b valid-succ) (write-var-integer (the index (- (block-number b) base)) @@ -209,17 +209,17 @@ (setf (fill-pointer *byte-buffer*) 0) (let ((*previous-location* 0) (tlf-num (find-tlf-number fun)) - (env (lambda-physenv fun)) + (physenv (lambda-physenv fun)) (prev-locs nil) (prev-block nil)) (collect ((elsewhere)) - (do-physenv-ir2-blocks (2block env) + (do-physenv-ir2-blocks (2block physenv) (let ((block (ir2-block-block 2block))) (when (eq (block-info block) 2block) (when prev-block (dump-block-locations prev-block prev-locs tlf-num var-locs)) (setq prev-block block prev-locs ()) - (dump-block-successors block env))) + (dump-block-successors block physenv))) (collect ((here prev-locs)) (dolist (loc (ir2-block-locations 2block)) @@ -304,13 +304,13 @@ (make-sc-offset (sc-number (tn-sc tn)) (tn-offset tn))) -;;; Dump info to represent Var's location being TN. ID is an integer -;;; that makes Var's name unique in the function. Buffer is the vector -;;; we stick the result in. If Minimal is true, we suppress name -;;; dumping, and set the minimal flag. +;;; Dump info to represent VAR's location being TN. ID is an integer +;;; that makes VAR's name unique in the function. BUFFER is the vector +;;; we stick the result in. If MINIMAL, we suppress name dumping, and +;;; set the minimal flag. ;;; -;;; The debug-var is only marked as always-live if the TN is -;;; environment live and is an argument. If a :debug-environment TN, +;;; The DEBUG-VAR is only marked as always-live if the TN is +;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN, ;;; then we also exclude set variables, since the variable is not ;;; guaranteed to be live everywhere in that case. (defun dump-1-variable (fun var tn id minimal buffer) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index c8759f9..defa9ab 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -830,10 +830,7 @@ (closure (ir2-physenv-environment 2env)) (pc (ir2-physenv-return-pc-pass 2env)) (fp (ir2-physenv-old-fp 2env)) - (2block (block-info - (node-block - (lambda-bind - (physenv-function env)))))) + (2block (block-info (lambda-block (physenv-lambda env))))) (do ((conf (ir2-block-global-tns 2block) (global-conflicts-next conf))) ((null conf)) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 044b564..1c24056 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -100,9 +100,8 @@ (values)) ;;; This function is called on each block by FIND-INITIAL-DFO-AUX -;;; before it walks the successors. It looks at the home lambda's bind -;;; block to see whether that block is in some other component: - +;;; before it walks the successors. It looks at the home CLAMBDA's +;;; BIND block to see whether that block is in some other component: ;;; -- If the block is in the initial component, then do ;;; DFO-WALK-CALL-GRAPH on the home function to move it ;;; into COMPONENT. @@ -221,23 +220,18 @@ ;;; already be one. (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))) (old-lambda-component (block-component bind-block)) (return (lambda-return fun))) (cond ((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 old-lambda-component) (delete fun (component-lambdas old-lambda-component))) @@ -248,19 +242,15 @@ (link-blocks return-block (component-tail component)) (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-funs fun) (lambda-calls fun)) (lambda-calls fun)))) (do ((res (find-initial-dfo-aux bind-block component) - (dfo-scavenge-call-graph (first funs) res)) - (funs calls (rest funs))) - ((null funs) res) + (dfo-scavenge-call-graph (first remaining-calls) res)) + (remaining-calls calls (rest remaining-calls))) + ((null remaining-calls) + res) (declare (type component res)))))))) ;;; Return true if FUN is either an XEP or has EXITS to some of its @@ -342,7 +332,6 @@ ;;; 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)) ;; We iterate over the lambdas in each initial component, trying ;; to put each function in its own component, but joining it to @@ -352,15 +341,12 @@ ;; 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 (lambda-block 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))) @@ -375,13 +361,11 @@ 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))) @@ -401,7 +385,7 @@ (separate-toplevelish-components (components)))) ;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA. -(defun merge-1-tl-lambda (result-lambda lambda) +(defun merge-1-toplevel-lambda (result-lambda lambda) (declare (type clambda result-lambda lambda)) ;; Delete the lambda, and combine the LETs and entries. @@ -498,7 +482,7 @@ (add-continuation-use use new)))) (dolist (lambda (rest lambdas)) - (merge-1-tl-lambda result-lambda lambda))) + (merge-1-toplevel-lambda result-lambda lambda))) (t (dolist (lambda (rest lambdas)) (setf (functional-entry-fun lambda) nil) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index e9910b5..22ce720 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -809,7 +809,7 @@ ;;; This is a special special form that makes an "escape function" ;;; which returns unknown values from named block. We convert the ;;; function, set its kind to :ESCAPE, and then reference it. The -;;; :Escape kind indicates that this function's purpose is to +;;; :ESCAPE kind indicates that this function's purpose is to ;;; represent a non-local control transfer, and that it might not ;;; actually have to be compiled. ;;; @@ -818,7 +818,8 @@ (def-ir1-translator %escape-function ((tag) start cont) (let ((fun (ir1-convert-lambda `(lambda () - (return-from ,tag (%unknown-values)))))) + (return-from ,tag (%unknown-values))) + :debug-name (debug-namify "escape function for ~S" tag)))) (setf (functional-kind fun) :escape) (reference-leaf start cont fun))) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 122810d..ff7fb3a 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1242,7 +1242,7 @@ ;;; changes. We look at each changed argument. If the corresponding ;;; variable is set, then we call PROPAGATE-FROM-SETS. Otherwise, we ;;; consider substituting for the variable, and also propagate -;;; derived-type information for the arg to all the Var's refs. +;;; derived-type information for the arg to all the VAR's refs. ;;; ;;; Substitution is inhibited when the arg leaf's derived type isn't a ;;; subtype of the argument's asserted type. This prevents type @@ -1259,7 +1259,7 @@ ;;; are done, then we delete the LET. ;;; ;;; Note that we are responsible for clearing the -;;; Continuation-Reoptimize flags. +;;; CONTINUATION-REOPTIMIZE flags. (defun propagate-let-args (call fun) (declare (type combination call) (type clambda fun)) (loop for arg in (combination-args call) @@ -1283,8 +1283,7 @@ this-comp) t) (t - (aver (eq (functional-kind (lambda-home fun)) - :toplevel)) + (aver (lambda-toplevelish-p (lambda-home fun))) nil))) leaf var)) t))))) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index e40948d..eadcf86 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -429,7 +429,7 @@ ;;; The politically correct way to print out progress messages and ;;; such like. We clear the current error context so that we know that -;;; it needs to be reprinted, and we also Force-Output so that the +;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the ;;; message gets seen right away. (declaim (ftype (function (string &rest t) (values)) compiler-mumble)) (defun compiler-mumble (format-string &rest format-args) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index c8709fb..f577861 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -890,10 +890,10 @@ (let ((*compiler-error-context* (lambda-bind fun))) (unless (policy *compiler-error-context* (= inhibit-warnings 3)) ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" - ;; requires this to be a STYLE-WARNING. + ;; requires this to be no more than a STYLE-WARNING. (compiler-style-warning "The variable ~S is defined but never used." (leaf-debug-name var))) - (setf (leaf-ever-used var) t)))) + (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN (values)) (defvar *deletion-ignored-objects* '(t nil)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 8b170e9..95b97fd 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -54,9 +54,9 @@ ;;;; leaf reference ;;; Return the TN that holds the value of THING in the environment ENV. +(declaim (ftype (function ((or nlx-info lambda-var) physenv) tn) + find-in-physenv)) (defun find-in-physenv (thing physenv) - (declare (type (or nlx-info lambda-var) thing) (type physenv physenv) - (values tn)) (or (cdr (assoc thing (ir2-physenv-environment (physenv-info physenv)))) (etypecase thing (lambda-var diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 0233e3c..d16b38d 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -514,7 +514,10 @@ (ir1-convert-lambda `(lambda ,vars (declare (ignorable . ,ignores)) - (%funcall ,entry . ,args)))))) + (%funcall ,entry . ,args)) + :debug-name (debug-namify "hairy fun entry ~S" + (continuation-fun-name + (basic-combination-fun call))))))) (convert-call ref call new-fun) (dolist (ref (leaf-refs entry)) (convert-call-if-possible ref (continuation-dest (node-cont ref)))))) @@ -761,7 +764,7 @@ (setf (lambda-physenv clambda) home-env) (let ((lets (lambda-lets clambda))) - ;; All CLAMBDA's LETs belong to HOME now. + ;; All of CLAMBDA's LETs belong to HOME now. (dolist (let lets) (setf (lambda-home let) home) (setf (lambda-physenv let) home-env)) @@ -780,7 +783,7 @@ ;; which calls things. (setf (lambda-calls clambda) nil) - ;; All CLAMBDA's ENTRIES belong to HOME now. + ;; All of CLAMBDA's ENTRIES belong to HOME now. (setf (lambda-entries home) (nconc (lambda-entries clambda) (lambda-entries home))) ;; CLAMBDA no longer has an independent existence as an entity @@ -911,7 +914,7 @@ ;;; Actually do LET conversion. We call subfunctions to do most of the ;;; work. We change the CALL's CONT to be the continuation heading the -;;; bind block, and also do REOPTIMIZE-CONTINUATION on the args and +;;; BIND block, and also do REOPTIMIZE-CONTINUATION on the args and ;;; CONT so that LET-specific IR1 optimizations get a chance. We blow ;;; away any entry for the function in *FREE-FUNCTIONS* so that nobody ;;; will create new references to it. diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index ed1bff3..0da76e3 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -895,7 +895,7 @@ ;; to implement an out-of-line version in terms of inline ;; transforms or VOPs or whatever. (unless template - (when (let ((funleaf (physenv-function (node-physenv call)))) + (when (let ((funleaf (physenv-lambda (node-physenv call)))) (and (leaf-has-source-name-p funleaf) (eq (continuation-fun-name (combination-fun call)) (leaf-source-name funleaf)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index f3b81da..84e9f86 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -865,9 +865,6 @@ :source-name (or name '.anonymous.) :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-fun fun) locall-fun (functional-kind fun) :external (functional-has-external-references-p fun) t) @@ -893,15 +890,12 @@ ;; nice default for things where we don't have a ;; real source path (as in e.g. inside CL:COMPILE). '(original-source-start 0 0))) - (/show "entering %COMPILE" lambda-expression name) (unless (or (null name) (legal-fun-name-p name)) (error "not a legal function name: ~S" name)) (let* ((*lexenv* (make-lexenv :policy *policy*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) - (/show "back in %COMPILE from M-F-FROM-TL-LAMBDA" fun) - (/show (lambda-component fun) (component-lambdas (lambda-component fun))) ;; FIXME: The compile-it code from here on is sort of a ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be @@ -911,17 +905,10 @@ ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..) - #+nil (break "before LOCALL-ANALYZE-CLAMBDAS-UNTIL-DONE" 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))) ;; FIXME: This is more monkey see monkey do based on CMU CL @@ -932,7 +919,6 @@ (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) (replace-toplevel-xeps component-from-dfo))) @@ -947,8 +933,7 @@ (aver found-p) result)) (mapc #'clear-ir1-info components-from-dfo) - (clear-stuff) - (/show "returning from %COMPILE"))))) + (clear-stuff))))) (defun process-toplevel-cold-fset (name lambda-expression path) (unless (producing-fasl-file) diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index a948f99..90cfd02 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -1921,9 +1921,7 @@ (defmacro do-physenv-ir2-blocks ((block-var physenv &optional result) &body body) (once-only ((n-physenv physenv)) - (once-only ((n-first `(node-block - (lambda-bind - (physenv-function ,n-physenv))))) + (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv)))) (once-only ((n-tail `(block-info (component-tail (block-component ,n-first))))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index abda10b..c8e43e6 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -323,6 +323,14 @@ ;;; A COMPONENT structure provides a handle on a connected piece of ;;; the flow graph. Most of the passes in the compiler operate on ;;; COMPONENTs rather than on the entire flow graph. +;;; +;;; According to the CMU CL internals/front.tex, the reason for +;;; separating compilation into COMPONENTs is +;;; to increase the efficiency of large block compilations. In +;;; addition to improving locality of reference and reducing the +;;; size of flow analysis problems, this allows back-end data +;;; structures to be reclaimed after the compilation of each +;;; component. (defstruct (component (:copier nil)) ;; the kind of component ;; @@ -488,7 +496,7 @@ ;;; TNs, or eventually stack slots and registers). -- WHN 2001-09-29 (defstruct (physenv (:copier nil)) ;; the function that allocates this physical environment - (function (missing-arg) :type clambda) + (lambda (missing-arg) :type clambda :read-only t) #| ; seems not to be used as of sbcl-0.pre7.51 ;; a list of all the lambdas that allocate variables in this ;; physical environment @@ -508,7 +516,7 @@ ;; some kind of info used by the back end (info nil)) (defprinter (physenv :identity t) - function + lambda (closure :test closure) (nlx-info :test nlx-info)) @@ -1046,8 +1054,8 @@ ;;; LAMBDA-VARs with no REFs are considered to be deleted; physical ;;; environment analysis isn't done on these variables, so the back ;;; end must check for and ignore unreferenced variables. Note that a -;;; deleted lambda-var may have sets; in this case the back end is -;;; still responsible for propagating the Set-Value to the set's Cont. +;;; deleted LAMBDA-VAR may have sets; in this case the back end is +;;; still responsible for propagating the SET-VALUE to the set's CONT. (def!struct (lambda-var (:include basic-var)) ;; true if this variable has been declared IGNORE (ignorep nil :type boolean) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 8860c6a..4afe914 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -34,10 +34,7 @@ (setf (component-new-funs component) ()) (dolist (fun (component-lambdas component)) (reinit-lambda-physenv fun)) - (dolist (fun (component-lambdas component)) - (compute-closure fun) - (dolist (let (lambda-lets fun)) - (compute-closure let))) + (mapc #'compute-closure (component-lambdas component)) (find-non-local-exits component) (find-cleanup-points component) @@ -66,10 +63,7 @@ (let ((found-it nil)) (dolist (lambda (component-lambdas component)) (when (compute-closure lambda) - (setq found-it t)) - (dolist (let (lambda-lets lambda)) - (when (compute-closure let) - (setq found-it t)))) + (setq found-it t))) found-it)) ;;; This is like old CMU CL PRE-ENVIRONMENT-ANALYZE-TOPLEVEL, except @@ -90,37 +84,38 @@ ;;; post-pass will use the existing structure, rather than ;;; allocating a new one. We return true if we discover any ;;; possible closure vars. -;;; But that doesn't seem to explain why it's important. I do observe -;;; that when it's not done, compiler assertions occasionally fail. My -;;; tentative hypothesis is that other environment analysis expects to +;;; But that doesn't seem to explain either why it's important to do +;;; this for top level lambdas, or why it's important to do it only +;;; for top level lambdas instead of just doing it indiscriminately +;;; for all lambdas. I do observe that when it's not done, compiler +;;; assertions occasionally fail. My tentative hypothesis for why it's +;;; important to do it is that other environment analysis expects to ;;; bottom out on the outermost enclosing thing, and (insert ;;; mysterious reason here) it's important to set up bottomed-out-here -;;; environments before anything else. -- WHN 2001-09-30 +;;; environments before anything else. I haven't been able to guess +;;; why it's important to do it selectively instead of +;;; indiscriminately. -- WHN 2001-11-10 (defun preallocate-physenvs-for-toplevelish-lambdas (component) - (/show "entering PREALLOCATE-PHYSENVS-FOR-TOPLEVELISH-LAMDBAS" component) (dolist (clambda (component-lambdas component)) - (/show clambda (lambda-vars clambda) (lambda-toplevelish-p clambda)) (when (lambda-toplevelish-p clambda) (compute-closure clambda))) - (/show "leaving PREALLOCATE-PHYSENVS-FOR-TOPLEVELISH-LAMDBAS" component) (values)) -;;; If CLAMBDA has a PHYSENV , return it, otherwise assign an empty one. +;;; If CLAMBDA has a PHYSENV, return it, otherwise assign an empty one +;;; and return that. (defun get-lambda-physenv (clambda) (declare (type clambda clambda)) (let ((homefun (lambda-home clambda))) (or (lambda-physenv homefun) - (let ((res (make-physenv :function homefun))) + (let ((res (make-physenv :lambda homefun))) (setf (lambda-physenv homefun) res) + ;; All the LETLAMBDAs belong to HOMEFUN, and share the same + ;; PHYSENV. Thus, (1) since HOMEFUN's PHYSENV was NIL, + ;; theirs should be NIL too, and (2) since we're modifying + ;; HOMEFUN's PHYSENV, we should modify theirs, too. (dolist (letlambda (lambda-lets homefun)) - ;; This assertion is to make explicit an - ;; apparently-otherwise-undocumented property of existing - ;; code: We never overwrite an old LAMBDA-PHYSENV. - ;; -- WHN 2001-09-30 - (aver (null (lambda-physenv letlambda))) - ;; I *think* this is true regardless of LAMBDA-KIND. - ;; -- WHN 2001-09-30 (aver (eql (lambda-home letlambda) homefun)) + (aver (null (lambda-physenv letlambda))) (setf (lambda-physenv letlambda) res)) res)))) @@ -153,45 +148,72 @@ (declare (type node node)) (get-lambda-physenv (node-home-lambda node))) -;;; Find any variables in FUN with references outside of the home -;;; environment and close over them. If a closed over variable is set, -;;; then we set the INDIRECT flag so that we will know the closed over -;;; value is really a pointer to the value cell. We also warn about -;;; unreferenced variables here, just because it's a convenient place -;;; to do it. We return true if we close over anything. -(defun compute-closure (fun) - (declare (type clambda fun)) - (let ((env (get-lambda-physenv fun)) - (did-something nil)) - (note-unreferenced-vars fun) - (dolist (var (lambda-vars fun)) - (dolist (ref (leaf-refs var)) - (let ((ref-env (get-node-physenv ref))) - (unless (eq ref-env env) - (when (lambda-var-sets var) - (setf (lambda-var-indirect var) t)) - (setq did-something t) - (close-over var ref-env env)))) - (dolist (set (basic-var-sets var)) - (let ((set-env (get-node-physenv set))) - (unless (eq set-env env) - (setq did-something t) - (setf (lambda-var-indirect var) t) - (close-over var set-env env))))) - did-something)) +;;; Find any variables in CLAMBDA -- either directly in LAMBDA-VARS or +;;; in the LAMBDA-VARS of elements of LAMBDA-LETS -- with references +;;; outside of the home environment and close over them. If a +;;; closed-over variable is set, then we set the INDIRECT flag so that +;;; we will know the closed over value is really a pointer to the +;;; value cell. We also warn about unreferenced variables here, just +;;; because it's a convenient place to do it. We return true if we +;;; close over anything. +(defun compute-closure (clambda) + (declare (type clambda clambda)) + (flet (;; This is the old CMU CL COMPUTE-CLOSURE, which only works + ;; on LAMBDA-VARS directly, not on the LAMBDA-VARS of + ;; LAMBDA-LETS. It seems never to be valid to use this + ;; operation alone, so in SBCL, it's private, and the public + ;; interface always runs over all the variables, both the + ;; LAMBDA-VARS of CLAMBDA itself and the LAMBDA-VARS of + ;; CLAMBDA's LAMBDA-LETS. + ;; + ;; Note that we don't need to make a distinction between the + ;; outer CLAMBDA argument and the inner one, or refer to the + ;; outer CLAMBDA argument at all, because the LET-conversion + ;; process carefully modifies all the necessary CLAMBDA slots + ;; (e.g. LAMBDA-PHYSENV) of a LET-converted CLAMBDA to refer + ;; to the new home. + (%compute-closure (clambda) + (let ((physenv (get-lambda-physenv clambda)) + (did-something nil)) + (note-unreferenced-vars clambda) + (dolist (var (lambda-vars clambda)) + (dolist (ref (leaf-refs var)) + (let ((ref-physenv (get-node-physenv ref))) + (unless (eq ref-physenv physenv) + (when (lambda-var-sets var) + (setf (lambda-var-indirect var) t)) + (setq did-something t) + (close-over var ref-physenv physenv)))) + (dolist (set (basic-var-sets var)) + (let ((set-physenv (get-node-physenv set))) + (unless (eq set-physenv physenv) + (setq did-something t) + (setf (lambda-var-indirect var) t) + (close-over var set-physenv physenv))))) + did-something))) + (let ((did-something nil)) + (when (%compute-closure clambda) + (setf did-something t)) + (dolist (lambda-let (lambda-lets clambda)) + ;; There's no need to recurse through full COMPUTE-CLOSURE + ;; here, since LETS only go one layer deep. + (aver (null (lambda-lets lambda-let))) + (when (%compute-closure lambda-let) + (setf did-something t))) + did-something))) -;;; Make sure that THING is closed over in REF-ENV and in all -;;; environments for the functions that reference REF-ENV's function -;;; (not just calls.) HOME-ENV is THING's home environment. When we +;;; Make sure that THING is closed over in REF-PHYSENV and in all +;;; PHYSENVs for the functions that reference REF-PHYSENV's function +;;; (not just calls). HOME-PHYSENV is THING's home environment. When we ;;; reach the home environment, we stop propagating the closure. -(defun close-over (thing ref-env home-env) - (declare (type physenv ref-env home-env)) - (cond ((eq ref-env home-env)) - ((member thing (physenv-closure ref-env))) +(defun close-over (thing ref-physenv home-physenv) + (declare (type physenv ref-physenv home-physenv)) + (cond ((eq ref-physenv home-physenv)) + ((member thing (physenv-closure ref-physenv))) (t - (push thing (physenv-closure ref-env)) - (dolist (call (leaf-refs (physenv-function ref-env))) - (close-over thing (get-node-physenv call) home-env)))) + (push thing (physenv-closure ref-physenv)) + (dolist (call (leaf-refs (physenv-lambda ref-physenv))) + (close-over thing (get-node-physenv call) home-physenv)))) (values)) ;;;; non-local exit diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 0a23261..0353031 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -312,7 +312,7 @@ ;;; IR2 conversion may need to compile a forward reference. In this ;;; case the slots aren't actually initialized until entry analysis runs. (defstruct (entry-info (:copier nil)) - ;; true if this function has a non-null closure environment + ;; Does this function have a non-null closure environment? (closure-p nil :type boolean) ;; a label pointing to the entry vector for this function, or NIL ;; before ENTRY-ANALYZE runs @@ -331,13 +331,13 @@ ;;; An IR2-PHYSENV is used to annotate non-LET LAMBDAs with their ;;; passing locations. It is stored in the PHYSENV-INFO. (defstruct (ir2-physenv (:copier nil)) - ;; the TNs that hold the passed environment within the function. - ;; This is an alist translating from the NLX-INFO or LAMBDA-VAR to - ;; the TN that holds the corresponding value within this function. + ;; TN info for closed-over things within the function: an alist + ;; mapping from NLX-INFOs and LAMBDA-VARs to TNs holding the + ;; corresponding thing within this function ;; - ;; The elements of this list correspond to the elements of the list - ;; in the CLOSURE slot of the ENVIRONMENT object that links to us: - ;; essentially this list is related to the CLOSURE list by MAPCAR. + ;; Elements of this list have a one-to-one correspondence with + ;; elements of the PHYSENV-CLOSURE list of the PHYSENV object that + ;; links to us. (environment (missing-arg) :type list :read-only t) ;; the TNs that hold the OLD-FP and RETURN-PC within the function. ;; We always save these so that the debugger can do a backtrace, diff --git a/version.lisp-expr b/version.lisp-expr index 7362e6d..69065b2 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.1" +"0.pre7.86.flaky7.3"