From: William Harold Newman Date: Sat, 6 Oct 2001 22:31:20 +0000 (+0000) Subject: 0.pre7.51: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7fd2eb4b1bc68e8aaec233c4a39bdfc40225bda2;p=sbcl.git 0.pre7.51: The LAMBDAS slot of ENVIRONMENT isn't used? Delete it. renamed ENVIRONMENT structure to PHYSENV to reflect my understanding from reverse engineering while working on flaky5_branch renamed IR2-ENVIRONMENT structure to IR2-PHYSENV rename envanal.lisp to physenvanal.lisp bumped fasl file version number (should have done that last version too, since new low-level type codes are not good for binary compatibility, oops..) --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 6c6343c..d3b717c 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -207,7 +207,7 @@ "DEFKNOWN" "DEFOPTIMIZER" "DEFTRANSFORM" "DERIVE-TYPE" "ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP" - "ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN" + "PHYSENV-DEBUG-LIVE-TN" "PHYSENV-LIVE-TN" "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" "FOLDABLE" "FORCE-TN-TO-STACK" "GET-VECTOR-SUBTYPE" @@ -215,7 +215,7 @@ "IF-EQ" "INLINE-SYNTACTIC-CLOSURE-LAMBDA" "INSTANCE-REF" "INSTANCE-SET" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" - "IR2-ENVIRONMENT-NUMBER-STACK-P" + "IR2-PHYSENV-NUMBER-STACK-P" "KNOWN-CALL-LOCAL" "KNOWN-RETURN" "LAMBDA-INDEPENDENT-OF-LEXENV-P" "LAMBDA-WITH-LEXENV" "LOCATION=" "LTN-ANNOTATE" diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 706c94c..12492c1 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -38,7 +38,7 @@ ;;; This value should be incremented when the system changes in such ;;; a way that it will no longer work reliably with old fasl files. -(defconstant +fasl-file-version+ 18) +(defconstant +fasl-file-version+ 20) ;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC. ;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot. ;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET @@ -75,6 +75,12 @@ ;;; 18 = sbcl-0.pre7.39 swapped FUNCTION-POINTER-TYPE and ;;; INSTANCE-POINTER-TYPE low-level type codes to help with ;;; the PPC port +;;; (In 0.pre7.48, the low-level object layout of SYMBOL on the +;;; non-X86 ports changed. I forgot to bump the fasl version number: +;;; I only have an X86..) +;;; 19 = sbcl-0.pre7.50 deleted byte-compiler-related low-level type codes +;;; 20 = sbcl-0.pre7.51 modified names and layouts of +;;; physical-environment-related structures in the compiler ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index cedb2df..4e42c95 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -49,14 +49,14 @@ ;;; debugger can find them at a known location. (!def-vm-support-routine make-old-fp-save-location (env) (specify-save-tn - (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) (make-wired-tn *fixnum-primitive-type* control-stack-arg-scn ocfp-save-offset))) (!def-vm-support-routine make-return-pc-save-location (env) (let ((ptype *backend-t-primitive-type*)) (specify-save-tn - (environment-debug-live-tn (make-normal-tn ptype) env) + (physenv-debug-live-tn (make-normal-tn ptype) env) (make-wired-tn ptype control-stack-arg-scn lra-save-offset)))) ;;; Make a TN for the standard argument count passing location. We @@ -163,7 +163,7 @@ (trace-table-entry trace-table-function-prologue) (move csp-tn res) (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) csp-tn) - (when (ir2-environment-number-stack-p callee) + (when (ir2-physenv-number-stack-p callee) (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) nsp-tn) (move nsp-tn nfp)) diff --git a/src/compiler/alpha/nlx.lisp b/src/compiler/alpha/nlx.lisp index 3fd46b2..4892eb7 100644 --- a/src/compiler/alpha/nlx.lisp +++ b/src/compiler/alpha/nlx.lisp @@ -14,7 +14,7 @@ ;;; Make an environment-live stack TN for saving the SP for NLX entry. (!def-vm-support-routine make-nlx-sp-tn (env) - (environment-live-tn + (physenv-live-tn (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) env)) diff --git a/src/compiler/codegen.lisp b/src/compiler/codegen.lisp index 8ca6eeb..3b51f49 100644 --- a/src/compiler/codegen.lisp +++ b/src/compiler/codegen.lisp @@ -35,9 +35,9 @@ (defun current-nfp-tn (vop) (unless (zerop (sb-allocated-size 'non-descriptor-stack)) (let ((block (ir2-block-block (vop-block vop)))) - (when (ir2-environment-number-stack-p - (environment-info - (block-environment block))) + (when (ir2-physenv-number-stack-p + (physenv-info + (block-physenv block))) (ir2-component-nfp (component-info (block-component block))))))) ;;; the TN that is used to hold the number stack frame-pointer in the @@ -45,13 +45,13 @@ ;;; allocated (defun callee-nfp-tn (2env) (unless (zerop (sb-allocated-size 'non-descriptor-stack)) - (when (ir2-environment-number-stack-p 2env) + (when (ir2-physenv-number-stack-p 2env) (ir2-component-nfp (component-info *component-being-compiled*))))) ;;; the TN used for passing the return PC in a local call to the function ;;; designated by 2ENV (defun callee-return-pc-tn (2env) - (ir2-environment-return-pc-pass 2env)) + (ir2-physenv-return-pc-pass 2env)) ;;;; specials used during code generation @@ -134,10 +134,10 @@ (block-start 1block)) (sb!assem:assemble (*code-segment*) (sb!assem:emit-label (block-label 1block))) - (let ((env (block-environment 1block))) + (let ((env (block-physenv 1block))) (unless (eq env prev-env) (let ((lab (gen-label))) - (setf (ir2-environment-elsewhere-start (environment-info env)) + (setf (ir2-physenv-elsewhere-start (physenv-info env)) lab) (emit-label-elsewhere lab)) (setq prev-env env))))) diff --git a/src/compiler/control.lisp b/src/compiler/control.lisp index 3a1d235..3d96ee6 100644 --- a/src/compiler/control.lisp +++ b/src/compiler/control.lisp @@ -50,15 +50,15 @@ (defun find-rotated-loop-head (block) (declare (type cblock block)) (let* ((num (block-number block)) - (env (block-environment block)) + (env (block-physenv block)) (pred (dolist (pred (block-pred block) nil) (when (and (not (block-flag pred)) - (eq (block-environment pred) env) + (eq (block-physenv pred) env) (< (block-number pred) num)) (return pred))))) (cond ((and pred - (not (environment-nlx-info env)) + (not (physenv-nlx-info env)) (not (eq (node-block (lambda-bind (block-home-lambda block))) block))) (let ((current pred) @@ -69,7 +69,7 @@ (when (eq pred block) (return-from DONE)) (when (and (not (block-flag pred)) - (eq (block-environment pred) env) + (eq (block-physenv pred) env) (> (block-number pred) current-num)) (setq current pred current-num (block-number pred)) (return))))) @@ -110,8 +110,8 @@ (let ((last (block-last block))) (cond ((and (combination-p last) (node-tail-p last) (eq (basic-combination-kind last) :local) - (not (eq (node-environment last) - (lambda-environment (combination-lambda last))))) + (not (eq (node-physenv last) + (lambda-physenv (combination-lambda last))))) (combination-lambda last)) (t (let ((component-tail (component-tail (block-component block))) @@ -128,12 +128,12 @@ ;;; Analyze all of the NLX EPs first to ensure that code reachable ;;; only from a NLX is emitted contiguously with the code reachable -;;; from the Bind. Code reachable from the Bind is inserted *before* -;;; the NLX code so that the Bind marks the beginning of the code for -;;; the function. If the walks from NLX EPs reach the bind block, then +;;; from the BIND. Code reachable from the BIND is inserted *before* +;;; the NLX code so that the BIND marks the beginning of the code for +;;; the function. If the walks from NLX EPs reach the BIND block, then ;;; we just move it to the beginning. ;;; -;;; If the walk from the bind node encountered a tail local call, then +;;; If the walk from the BIND node encountered a tail local call, then ;;; we start over again there to help the call drop through. Of ;;; course, it will never get a drop-through if either function has ;;; NLX code. @@ -143,7 +143,7 @@ (prev-block (block-annotation-prev tail-block)) (bind-block (node-block (lambda-bind fun)))) (unless (block-flag bind-block) - (dolist (nlx (environment-nlx-info (lambda-environment fun))) + (dolist (nlx (physenv-nlx-info (lambda-physenv fun))) (control-analyze-block (nlx-info-target nlx) tail-block block-info-constructor)) (cond diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 3848eb2..be17be3 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -46,10 +46,10 @@ (list location))) location)) -#!-sb-fluid (declaim (inline ir2-block-environment)) -(defun ir2-block-environment (2block) +#!-sb-fluid (declaim (inline ir2-block-physenv)) +(defun ir2-block-physenv (2block) (declare (type ir2-block 2block)) - (block-environment (ir2-block-block 2block))) + (block-physenv (ir2-block-block 2block))) ;;; Given a local conflicts vector and an IR2 block to represent the ;;; set of live TNs, and the VAR-LOCS hash-table representing the @@ -136,7 +136,7 @@ (declare (type clambda fun)) (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))) (declare (type (or index null) res)) - (do-environment-ir2-blocks (2block (lambda-environment fun)) + (do-physenv-ir2-blocks (2block (lambda-physenv fun)) (let ((block (ir2-block-block 2block))) (when (eq (block-info block) 2block) (unless (eql (source-path-tlf-number @@ -173,16 +173,16 @@ (dump-location-from-info loc tlf-num var-locs)) (values)) -;;; Dump the successors of Block, being careful not to fly into space on -;;; weird successors. +;;; 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 environment env)) + (declare (type cblock block) (type physenv env)) (let* ((tail (component-tail (block-component block))) (succ (block-succ block)) (valid-succ (if (and succ (or (eq (car succ) tail) - (not (eq (block-environment (car succ)) env)))) + (not (eq (block-physenv (car succ)) env)))) () succ))) (vector-push-extend @@ -190,7 +190,7 @@ *byte-buffer*) (let ((base (block-number (node-block - (lambda-bind (environment-function env)))))) + (lambda-bind (physenv-function env)))))) (dolist (b valid-succ) (write-var-integer (the index (- (block-number b) base)) @@ -209,11 +209,11 @@ (setf (fill-pointer *byte-buffer*) 0) (let ((*previous-location* 0) (tlf-num (find-tlf-number fun)) - (env (lambda-environment fun)) + (env (lambda-physenv fun)) (prev-locs nil) (prev-block nil)) (collect ((elsewhere)) - (do-environment-ir2-blocks (2block env) + (do-physenv-ir2-blocks (2block env) (let ((block (ir2-block-block 2block))) (when (eq (block-info block) 2block) (when prev-block @@ -366,8 +366,8 @@ (frob-leaf leaf (leaf-info leaf) gensym-p)))) (frob-lambda fun t) (when (>= level 2) - (dolist (x (ir2-environment-environment - (environment-info (lambda-environment fun)))) + (dolist (x (ir2-physenv-environment + (physenv-info (lambda-physenv fun)))) (let ((thing (car x))) (when (lambda-var-p thing) (frob-leaf thing (cdr x) (= level 3))))) @@ -471,7 +471,7 @@ ;;; Return a C-D-F structure with all the mandatory slots filled in. (defun dfun-from-fun (fun) (declare (type clambda fun)) - (let* ((2env (environment-info (lambda-environment fun))) + (let* ((2env (physenv-info (lambda-physenv fun))) (dispatch (lambda-optional-dispatch fun)) (main-p (and dispatch (eq fun (optional-dispatch-main-entry dispatch))))) @@ -484,10 +484,10 @@ (component-name (block-component (node-block (lambda-bind fun)))))) :kind (if main-p nil (functional-kind fun)) - :return-pc (tn-sc-offset (ir2-environment-return-pc 2env)) - :old-fp (tn-sc-offset (ir2-environment-old-fp 2env)) - :start-pc (label-position (ir2-environment-environment-start 2env)) - :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env))))) + :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env)) + :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env)) + :start-pc (label-position (ir2-physenv-environment-start 2env)) + :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env))))) ;;; Return a complete C-D-F structure for Fun. This involves ;;; determining the DEBUG-INFO level and filling in optional slots as diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index c565cae..fe81a45 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -825,16 +825,16 @@ ;;; full call passing locations. (defun check-environment-lifetimes (component) (dolist (fun (component-lambdas component)) - (let* ((env (lambda-environment fun)) - (2env (environment-info env)) + (let* ((env (lambda-physenv fun)) + (2env (physenv-info env)) (vars (lambda-vars fun)) - (closure (ir2-environment-environment 2env)) - (pc (ir2-environment-return-pc-pass 2env)) - (fp (ir2-environment-old-fp 2env)) + (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 - (environment-function env)))))) + (physenv-function 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 f312dff..cb0960f 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -366,7 +366,7 @@ (setf (functional-kind lambda) :deleted) (dolist (let (lambda-lets lambda)) (setf (lambda-home let) result-lambda) - (setf (lambda-environment let) (lambda-environment result-lambda)) + (setf (lambda-physenv let) (lambda-physenv result-lambda)) (push let (lambda-lets result-lambda))) (setf (lambda-entries result-lambda) (nconc (lambda-entries result-lambda) diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 7025db2..1b1e56d 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -56,7 +56,7 @@ (let ((bind (lambda-bind fun)) (internal-fun (functional-entry-function fun))) (setf (entry-info-closure-p info) - (not (null (environment-closure (lambda-environment fun))))) + (not (null (physenv-closure (lambda-physenv fun))))) (setf (entry-info-offset info) (gen-label)) (setf (entry-info-name info) (let ((name (leaf-name internal-fun))) @@ -94,8 +94,8 @@ :info (leaf-info lambda) :name (leaf-name ef) :lexenv (make-null-lexenv))) - (closure (environment-closure - (lambda-environment (main-entry ef))))) + (closure (physenv-closure + (lambda-physenv (main-entry ef))))) (dolist (ref (leaf-refs lambda)) (let ((ref-component (block-component (node-block ref)))) (cond ((eq ref-component component)) diff --git a/src/compiler/envanal.lisp b/src/compiler/envanal.lisp deleted file mode 100644 index 0208d03..0000000 --- a/src/compiler/envanal.lisp +++ /dev/null @@ -1,388 +0,0 @@ -;;;; This file implements the environment analysis phase for the -;;;; compiler. This phase annotates IR1 with a hierarchy environment -;;;; structures, determining the environment that each LAMBDA -;;;; allocates its variables and finding what values are closed over -;;;; by each environment. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!C") - -;;; Do environment analysis on the code in COMPONENT. This involves -;;; various things: -;;; 1. Make an ENVIRONMENT structure for each non-LET LAMBDA, assigning -;;; the LAMBDA-ENVIRONMENT for all LAMBDAs. -;;; 2. Find all values that need to be closed over by each environment. -;;; 3. Scan the blocks in the component closing over non-local-exit -;;; continuations. -;;; 4. Delete all non-top-level functions with no references. This -;;; should only get functions with non-NULL kinds, since normal -;;; functions are deleted when their references go to zero. -(defun environment-analyze (component) - (declare (type component component)) - (aver (every (lambda (x) - (eq (functional-kind x) :deleted)) - (component-new-functions component))) - (setf (component-new-functions component) ()) - (dolist (fun (component-lambdas component)) - (reinit-lambda-environment fun)) - (dolist (fun (component-lambdas component)) - (compute-closure fun) - (dolist (let (lambda-lets fun)) - (compute-closure let))) - - (find-non-local-exits component) - (find-cleanup-points component) - (tail-annotate component) - - (dolist (fun (component-lambdas component)) - (when (null (leaf-refs fun)) - (let ((kind (functional-kind fun))) - (unless (or (eq kind :top-level) - (functional-has-external-references-p fun)) - (aver (member kind '(:optional :cleanup :escape))) - (setf (functional-kind fun) nil) - (delete-functional fun))))) - - (values)) - -;;; This is to be called on a COMPONENT with top-level LAMBDAs before -;;; the compilation of the associated non-top-level code to detect -;;; closed over top-level variables. We just do COMPUTE-CLOSURE on all -;;; the lambdas. This will pre-allocate environments for all the -;;; functions with closed-over top-level variables. The post-pass will -;;; use the existing structure, rather than allocating a new one. We -;;; return true if we discover any possible closure vars. -(defun pre-environment-analyze-top-level (component) - (declare (type component component)) - (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)))) - found-it)) - -;;; This is like old CMU CL PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL, except -;;; (1) It's been brought into the post-0.7.0 world where the property -;;; HAS-EXTERNAL-REFERENCES-P is orthogonal to the property of -;;; being specialized/optimized for locall at top level. -;;; (2) There's no return value, since we don't care whether we -;;; find any possible closure variables. -;;; -;;; I wish I could find an explanation of why -;;; PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL is important. The old CMU CL -;;; comments said -;;; Called on component with top-level lambdas before the -;;; compilation of the associated non-top-level code to detect -;;; closed over top-level variables. We just do COMPUTE-CLOSURE on -;;; all the lambdas. This will pre-allocate environments for all -;;; the functions with closed-over top-level variables. The -;;; 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 -;;; 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 -(defun preallocate-environments-for-top-levelish-lambdas (component) - (dolist (clambda (component-lambdas component)) - (when (lambda-top-levelish-p clambda) - (compute-closure clambda))) - (values)) - -;;; If FUN has an environment, return it, otherwise assign an empty one. -(defun get-lambda-environment (fun) - (declare (type clambda fun)) - (let* ((fun (lambda-home fun)) - (env (lambda-environment fun))) - (or env - (let ((res (make-environment :function fun))) - (setf (lambda-environment fun) res) - (dolist (letlambda (lambda-lets fun)) - ;; This assertion is to make explicit an - ;; apparently-otherwise-undocumented property of existing - ;; code: We never overwrite an old LAMBDA-ENVIRONMENT. - ;; -- WHN 2001-09-30 - (aver (null (lambda-environment letlambda))) - ;; I *think* this is true regardless of LAMBDA-KIND. - ;; -- WHN 2001-09-30 - (aver (eql (lambda-home letlambda) fun)) - (setf (lambda-environment letlambda) res)) - res)))) - -;;; If FUN has no physical environment, assign one, otherwise clean up -;;; the old physical environment, removing/flagging variables that -;;; have no sets or refs. If a var has no references, we remove it -;;; from the closure. If it has no sets, we clear the INDIRECT flag. -;;; This is necessary because pre-analysis is done before -;;; optimization. -(defun reinit-lambda-environment (fun) - (let ((old (lambda-environment (lambda-home fun)))) - (cond (old - (setf (environment-closure old) - (delete-if #'(lambda (x) - (and (lambda-var-p x) - (null (leaf-refs x)))) - (environment-closure old))) - (flet ((clear (fun) - (dolist (var (lambda-vars fun)) - (unless (lambda-var-sets var) - (setf (lambda-var-indirect var) nil))))) - (clear fun) - (dolist (let (lambda-lets fun)) - (clear let)))) - (t - (get-lambda-environment fun)))) - (values)) - -;;; Get NODE's environment, assigning one if necessary. -(defun get-node-environment (node) - (declare (type node node)) - (get-lambda-environment (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-environment fun)) - (did-something nil)) - (note-unreferenced-vars fun) - (dolist (var (lambda-vars fun)) - (dolist (ref (leaf-refs var)) - (let ((ref-env (get-node-environment 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-environment set))) - (unless (eq set-env env) - (setq did-something t) - (setf (lambda-var-indirect var) t) - (close-over var set-env env))))) - 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 -;;; reach the home environment, we stop propagating the closure. -(defun close-over (thing ref-env home-env) - (declare (type environment ref-env home-env)) - (cond ((eq ref-env home-env)) - ((member thing (environment-closure ref-env))) - (t - (push thing (environment-closure ref-env)) - (dolist (call (leaf-refs (environment-function ref-env))) - (close-over thing (get-node-environment call) home-env)))) - (values)) - -;;;; non-local exit - -;;; Insert the entry stub before the original exit target, and add a -;;; new entry to the ENVIRONMENT-NLX-INFO. The %NLX-ENTRY call in the -;;; stub is passed the NLX-INFO as an argument so that the back end -;;; knows what entry is being done. -;;; -;;; The link from the EXIT block to the entry stub is changed to be a -;;; link to the component head. Similarly, the EXIT block is linked to -;;; the component tail. This leaves the entry stub reachable, but -;;; makes the flow graph less confusing to flow analysis. -;;; -;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the -;;; last node in the cleanup code to be the enclosing environment, to -;;; represent the fact that the binding was undone as a side-effect of -;;; the exit. This will cause a lexical exit to be broken up if we are -;;; actually exiting the scope (i.e. a BLOCK), and will also do any -;;; other cleanups that may have to be done on the way. -(defun insert-nlx-entry-stub (exit env) - (declare (type environment env) (type exit exit)) - (let* ((exit-block (node-block exit)) - (next-block (first (block-succ exit-block))) - (cleanup (entry-cleanup (exit-entry exit))) - (info (make-nlx-info :cleanup cleanup - :continuation (node-cont exit))) - (entry (exit-entry exit)) - (new-block (insert-cleanup-code exit-block next-block - entry - `(%nlx-entry ',info) - (entry-cleanup entry))) - (component (block-component new-block))) - (unlink-blocks exit-block new-block) - (link-blocks exit-block (component-tail component)) - (link-blocks (component-head component) new-block) - - (setf (nlx-info-target info) new-block) - (push info (environment-nlx-info env)) - (push info (cleanup-nlx-info cleanup)) - (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) - (setf (node-lexenv (block-last new-block)) - (node-lexenv entry)))) - - (values)) - -;;; Do stuff necessary to represent a non-local exit from the node -;;; EXIT into ENV. This is called for each non-local exit node, of -;;; which there may be several per exit continuation. This is what we -;;; do: -;;; -- If there isn't any NLX-Info entry in the environment, make -;;; an entry stub, otherwise just move the exit block link to -;;; the component tail. -;;; -- Close over the NLX-Info in the exit environment. -;;; -- If the exit is from an :Escape function, then substitute a -;;; constant reference to NLX-Info structure for the escape -;;; function reference. This will cause the escape function to -;;; be deleted (although not removed from the DFO.) The escape -;;; function is no longer needed, and we don't want to emit code -;;; for it. We then also change the %NLX-ENTRY call to use the -;;; NLX continuation so that there will be a use to represent -;;; the NLX use. -(defun note-non-local-exit (env exit) - (declare (type environment env) (type exit exit)) - (let ((entry (exit-entry exit)) - (cont (node-cont exit)) - (exit-fun (node-home-lambda exit))) - - (if (find-nlx-info entry cont) - (let ((block (node-block exit))) - (aver (= (length (block-succ block)) 1)) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block)))) - (insert-nlx-entry-stub exit env)) - - (let ((info (find-nlx-info entry cont))) - (aver info) - (close-over info (node-environment exit) env) - (when (eq (functional-kind exit-fun) :escape) - (mapc #'(lambda (x) - (setf (node-derived-type x) *wild-type*)) - (leaf-refs exit-fun)) - (substitute-leaf (find-constant info) exit-fun) - (let ((node (block-last (nlx-info-target info)))) - (delete-continuation-use node) - (add-continuation-use node (nlx-info-continuation info)))))) - - (values)) - -;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT -;;; when we find a block that ends in a non-local EXIT node. We also -;;; ensure that all EXIT nodes are either non-local or degenerate by -;;; calling IR1-OPTIMIZE-EXIT on local exits. This makes life simpler -;;; for later phases. -(defun find-non-local-exits (component) - (declare (type component component)) - (dolist (lambda (component-lambdas component)) - (dolist (entry (lambda-entries lambda)) - (dolist (exit (entry-exits entry)) - (let ((target-env (node-environment entry))) - (if (eq (node-environment exit) target-env) - (maybe-delete-exit exit) - (note-non-local-exit target-env exit)))))) - - (values)) - -;;;; cleanup emission - -;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating -;;; cleanup code as we go. When we are done, convert the cleanup code -;;; in an implicit MV-PROG1. We have to force local call analysis of -;;; new references to UNWIND-PROTECT cleanup functions. If we don't -;;; actually have to do anything, then we don't insert any cleanup -;;; code. -;;; -;;; If we do insert cleanup code, we check that BLOCK1 doesn't end in -;;; a "tail" local call. -;;; -;;; We don't need to adjust the ending cleanup of the cleanup block, -;;; since the cleanup blocks are inserted at the start of the DFO, and -;;; are thus never scanned. -(defun emit-cleanups (block1 block2) - (declare (type cblock block1 block2)) - (collect ((code) - (reanalyze-funs)) - (let ((cleanup2 (block-start-cleanup block2))) - (do ((cleanup (block-end-cleanup block1) - (node-enclosing-cleanup (cleanup-mess-up cleanup)))) - ((eq cleanup cleanup2)) - (let* ((node (cleanup-mess-up cleanup)) - (args (when (basic-combination-p node) - (basic-combination-args node)))) - (ecase (cleanup-kind cleanup) - (:special-bind - (code `(%special-unbind ',(continuation-value (first args))))) - (:catch - (code `(%catch-breakup))) - (:unwind-protect - (code `(%unwind-protect-breakup)) - (let ((fun (ref-leaf (continuation-use (second args))))) - (reanalyze-funs fun) - (code `(%funcall ,fun)))) - ((:block :tagbody) - (dolist (nlx (cleanup-nlx-info cleanup)) - (code `(%lexical-exit-breakup ',nlx))))))) - - (when (code) - (aver (not (node-tail-p (block-last block1)))) - (insert-cleanup-code block1 block2 - (block-last block1) - `(progn ,@(code))) - (dolist (fun (reanalyze-funs)) - (local-call-analyze-1 fun))))) - - (values)) - -;;; Loop over the blocks in COMPONENT, calling EMIT-CLEANUPS when we -;;; see a successor in the same environment with a different cleanup. -;;; We ignore the cleanup transition if it is to a cleanup enclosed by -;;; the current cleanup, since in that case we are just messing up the -;;; environment, hence this is not the place to clean it. -(defun find-cleanup-points (component) - (declare (type component component)) - (do-blocks (block1 component) - (let ((env1 (block-environment block1)) - (cleanup1 (block-end-cleanup block1))) - (dolist (block2 (block-succ block1)) - (when (block-start block2) - (let ((env2 (block-environment block2)) - (cleanup2 (block-start-cleanup block2))) - (unless (or (not (eq env2 env1)) - (eq cleanup1 cleanup2) - (and cleanup2 - (eq (node-enclosing-cleanup - (cleanup-mess-up cleanup2)) - cleanup1))) - (emit-cleanups block1 block2))))))) - (values)) - -;;; Mark all tail-recursive uses of function result continuations with -;;; the corresponding TAIL-SET. Nodes whose type is NIL (i.e. don't -;;; return) such as calls to ERROR are never annotated as tail in -;;; order to preserve debugging information. -(defun tail-annotate (component) - (declare (type component component)) - (dolist (fun (component-lambdas component)) - (let ((ret (lambda-return fun))) - (when ret - (let ((result (return-result ret))) - (do-uses (use result) - (when (and (immediately-used-p result use) - (or (not (eq (node-derived-type use) *empty-type*)) - (not (basic-combination-p use)) - (eq (basic-combination-kind use) :local))) - (setf (node-tail-p use) t))))))) - (values)) diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index e508d22..b954bb7 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -20,7 +20,7 @@ (setf (component-info component) (make-ir2-component)) (let ((funs (component-lambdas component))) (dolist (fun funs) - (assign-ir2-environment fun) + (assign-ir2-physenv fun) (assign-return-locations fun) (assign-ir2-nlx-info fun) (assign-lambda-var-tns fun nil) @@ -30,7 +30,7 @@ (values)) ;;; We have to allocate the home TNs for variables before we can call -;;; ASSIGN-IR2-ENVIRONMENT so that we can close over TNs that haven't +;;; ASSIGN-IR2-PHYSENV so that we can close over TNs that haven't ;;; had their home environment assigned yet. Here we evaluate the ;;; DEBUG-INFO/SPEED tradeoff to determine how variables are ;;; allocated. If SPEED is 3, then all variables are subject to @@ -49,21 +49,20 @@ (policy node (zerop debug)) (policy node (= speed 3))) temp - (environment-debug-live-tn temp - (lambda-environment fun))))) + (physenv-debug-live-tn temp (lambda-physenv fun))))) (setf (tn-leaf res) var) (setf (leaf-info var) res)))) (values)) -;;; Give CLAMBDA an IR2-ENVIRONMENT structure. (And in order to +;;; Give CLAMBDA an IR2-PHYSENV structure. (And in order to ;;; properly initialize the new structure, we make the TNs which hold ;;; environment values and the old-FP/return-PC.) -(defun assign-ir2-environment (clambda) +(defun assign-ir2-physenv (clambda) (declare (type clambda clambda)) - (let ((lambda-environment (lambda-environment clambda)) - (reversed-ir2-environment-alist nil)) + (let ((lambda-physenv (lambda-physenv clambda)) + (reversed-ir2-physenv-alist nil)) ;; FIXME: should be MAPCAR, not DOLIST - (dolist (thing (environment-closure lambda-environment)) + (dolist (thing (physenv-closure lambda-physenv)) (let ((ptype (etypecase thing (lambda-var (if (lambda-var-indirect thing) @@ -71,17 +70,17 @@ (primitive-type (leaf-type thing)))) (nlx-info *backend-t-primitive-type*)))) (push (cons thing (make-normal-tn ptype)) - reversed-ir2-environment-alist))) + reversed-ir2-physenv-alist))) - (let ((res (make-ir2-environment - :environment (nreverse reversed-ir2-environment-alist) + (let ((res (make-ir2-physenv + :environment (nreverse reversed-ir2-physenv-alist) :return-pc-pass (make-return-pc-passing-location (external-entry-point-p clambda))))) - (setf (environment-info lambda-environment) res) - (setf (ir2-environment-old-fp res) - (make-old-fp-save-location lambda-environment)) - (setf (ir2-environment-return-pc res) - (make-return-pc-save-location lambda-environment)))) + (setf (physenv-info lambda-physenv) res) + (setf (ir2-physenv-old-fp res) + (make-old-fp-save-location lambda-physenv)) + (setf (ir2-physenv-return-pc res) + (make-return-pc-save-location lambda-physenv)))) (values)) @@ -204,12 +203,12 @@ ;;; isn't live afterwards. (defun assign-ir2-nlx-info (fun) (declare (type clambda fun)) - (let ((env (lambda-environment fun))) - (dolist (nlx (environment-nlx-info env)) + (let ((physenv (lambda-physenv fun))) + (dolist (nlx (physenv-nlx-info physenv)) (setf (nlx-info-info nlx) (make-ir2-nlx-info :home (when (member (cleanup-kind (nlx-info-cleanup nlx)) '(:block :tagbody)) (make-normal-tn *backend-t-primitive-type*)) - :save-sp (make-nlx-sp-tn env))))) + :save-sp (make-nlx-sp-tn physenv))))) (values)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 31f8748..c892d64 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -230,9 +230,10 @@ ;;;; miscellaneous shorthand functions -;;; Return the home (i.e. enclosing non-let) lambda for Node. Since the -;;; LEXENV-LAMBDA may be deleted, we must chain up the LAMBDA-CALL-LEXENV -;;; thread until we find a lambda that isn't deleted, and then return its home. +;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since +;;; the LEXENV-LAMBDA may be deleted, we must chain up the +;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't +;;; deleted, and then return its home. (declaim (maybe-inline node-home-lambda)) (defun node-home-lambda (node) (declare (type node node)) @@ -244,14 +245,14 @@ (return fun)))) #!-sb-fluid (declaim (inline node-block node-tlf-number)) -(declaim (maybe-inline node-environment)) +(declaim (maybe-inline node-physenv)) (defun node-block (node) (declare (type node node)) (the cblock (continuation-block (node-prev node)))) -(defun node-environment (node) +(defun node-physenv (node) (declare (type node node)) #!-sb-fluid (declare (inline node-home-lambda)) - (the environment (lambda-environment (node-home-lambda node)))) + (the physenv (lambda-physenv (node-home-lambda node)))) ;;; Return the enclosing cleanup for environment of the first or last node ;;; in BLOCK. @@ -268,11 +269,11 @@ #!-sb-fluid (declare (inline node-home-lambda)) (node-home-lambda (block-last block))) -;;; Return the IR1 environment for BLOCK. -(defun block-environment (block) +;;; Return the IR1 physical environment for BLOCK. +(defun block-physenv (block) (declare (type cblock block)) #!-sb-fluid (declare (inline node-home-lambda)) - (lambda-environment (node-home-lambda (block-last block)))) + (lambda-physenv (node-home-lambda (block-last block)))) ;;; Return the Top Level Form number of PATH, i.e. the ordinal number ;;; of its original source's top-level form in its compilation unit. @@ -1162,7 +1163,7 @@ (defun find-nlx-info (entry cont) (declare (type entry entry) (type continuation cont)) (let ((entry-cleanup (entry-cleanup entry))) - (dolist (nlx (environment-nlx-info (node-environment entry)) nil) + (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) (when (and (eq (nlx-info-continuation nlx) cont) (eq (nlx-info-cleanup nlx) entry-cleanup)) (return nlx))))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index ff4ef10..38e54fd 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -54,17 +54,17 @@ ;;;; leaf reference ;;; Return the TN that holds the value of THING in the environment ENV. -(defun find-in-environment (thing env) - (declare (type (or nlx-info lambda-var) thing) (type environment env) +(defun find-in-physenv (thing physenv) + (declare (type (or nlx-info lambda-var) thing) (type physenv physenv) (values tn)) - (or (cdr (assoc thing (ir2-environment-environment (environment-info env)))) + (or (cdr (assoc thing (ir2-physenv-environment (physenv-info physenv)))) (etypecase thing (lambda-var ;; I think that a failure of this assertion means that we're ;; trying to access a variable which was improperly closed - ;; over. An ENVIRONMENT structure is a physical environment. - ;; Every variable that a form refers to should either be in - ;; its physical environment directly, or grabbed from a + ;; over. The PHYSENV describes a physical environment. Every + ;; variable that a form refers to should either be in its + ;; physical environment directly, or grabbed from a ;; surrounding physical environment when it was closed over. ;; The ASSOC expression above finds closed-over variables, so ;; if we fell through the ASSOC expression, it wasn't closed @@ -72,10 +72,10 @@ ;; directly. If instead it is in some other physical ;; environment, then it's bogus for us to reference it here ;; without it being closed over. -- WHN 2001-09-29 - (aver (eq env (lambda-environment (lambda-var-home thing)))) + (aver (eq physenv (lambda-physenv (lambda-var-home thing)))) (leaf-info thing)) (nlx-info - (aver (eq env (block-environment (nlx-info-target thing)))) + (aver (eq physenv (block-physenv (nlx-info-target thing)))) (ir2-nlx-info-home (nlx-info-info thing)))))) ;;; If LEAF already has a constant TN, return that, otherwise make a @@ -90,11 +90,11 @@ ;;; isn't directly represented by a TN. ENV is the environment that ;;; the reference is done in. (defun leaf-tn (leaf env) - (declare (type leaf leaf) (type environment env)) + (declare (type leaf leaf) (type physenv env)) (typecase leaf (lambda-var (unless (lambda-var-indirect leaf) - (find-in-environment leaf env))) + (find-in-physenv leaf env))) (constant (constant-tn leaf)) (t nil))) @@ -115,7 +115,7 @@ (res (first locs))) (etypecase leaf (lambda-var - (let ((tn (find-in-environment leaf (node-environment node)))) + (let ((tn (find-in-physenv leaf (node-physenv node)))) (if (lambda-var-indirect leaf) (vop value-cell-ref node block tn res) (emit-move node block tn res)))) @@ -166,19 +166,19 @@ (let ((entry (make-load-time-constant-tn :entry leaf)) (closure (etypecase leaf (clambda - (environment-closure (get-lambda-environment leaf))) + (physenv-closure (get-lambda-physenv leaf))) (functional (aver (eq (functional-kind leaf) :top-level-xep)) nil)))) (cond (closure - (let ((this-env (node-environment node))) + (let ((this-env (node-physenv node))) (vop make-closure node block entry (length closure) res) (loop for what in closure and n from 0 do (unless (and (lambda-var-p what) (null (leaf-refs what))) (vop closure-init node block res - (find-in-environment what this-env) + (find-in-physenv what this-env) n))))) (t (emit-move node block entry res)))) @@ -200,7 +200,7 @@ (etypecase leaf (lambda-var (when (leaf-refs leaf) - (let ((tn (find-in-environment leaf (node-environment node)))) + (let ((tn (find-in-physenv leaf (node-physenv node)))) (if (lambda-var-indirect leaf) (vop value-cell-set node block tn val) (emit-move node block val tn))))) @@ -234,7 +234,7 @@ (ecase (ir2-continuation-kind 2cont) (:delayed (let ((ref (continuation-use cont))) - (leaf-tn (ref-leaf ref) (node-environment ref)))) + (leaf-tn (ref-leaf ref) (node-physenv ref)))) (:fixed (aver (= (length (ir2-continuation-locs 2cont)) 1)) (first (ir2-continuation-locs 2cont))))) @@ -621,8 +621,8 @@ (defun emit-psetq-moves (node block fun old-fp) (declare (type combination node) (type ir2-block block) (type clambda fun) (type (or tn null) old-fp)) - (let* ((called-env (environment-info (lambda-environment fun))) - (this-1env (node-environment node)) + (let* ((called-env (physenv-info (lambda-physenv fun))) + (this-1env (node-physenv node)) (actuals (mapcar #'(lambda (x) (when x (continuation-tn node block x))) @@ -648,12 +648,12 @@ (locs loc)))) (when old-fp - (dolist (thing (ir2-environment-environment called-env)) - (temps (find-in-environment (car thing) this-1env)) + (dolist (thing (ir2-physenv-environment called-env)) + (temps (find-in-physenv (car thing) this-1env)) (locs (cdr thing))) (temps old-fp) - (locs (ir2-environment-old-fp called-env))) + (locs (ir2-physenv-old-fp called-env))) (values (temps) (locs))))) @@ -663,19 +663,19 @@ ;;; function's passing location. (defun ir2-convert-tail-local-call (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) - (let ((this-env (environment-info (node-environment node)))) + (let ((this-env (physenv-info (node-physenv node)))) (multiple-value-bind (temps locs) - (emit-psetq-moves node block fun (ir2-environment-old-fp this-env)) + (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env)) (mapc #'(lambda (temp loc) (emit-move node block temp loc)) temps locs)) (emit-move node block - (ir2-environment-return-pc this-env) - (ir2-environment-return-pc-pass - (environment-info - (lambda-environment fun))))) + (ir2-physenv-return-pc this-env) + (ir2-physenv-return-pc-pass + (physenv-info + (lambda-physenv fun))))) (values)) @@ -704,7 +704,7 @@ (emit-psetq-moves node block fun old-fp) (vop current-fp node block old-fp) (vop allocate-frame node block - (environment-info (lambda-environment fun)) + (physenv-info (lambda-physenv fun)) fp nfp) (values fp nfp temps (mapcar #'make-alias-tn locs))))) @@ -720,7 +720,7 @@ (vop* known-call-local node block (fp nfp (reference-tn-list temps nil)) ((reference-tn-list locs t)) - arg-locs (environment-info (lambda-environment fun)) start) + arg-locs (physenv-info (lambda-physenv fun)) start) (move-continuation-result node block locs cont))) (values)) @@ -740,7 +740,7 @@ (multiple-value-bind (fp nfp temps arg-locs) (ir2-convert-local-call-args node block fun) (let ((2cont (continuation-info cont)) - (env (environment-info (lambda-environment fun))) + (env (physenv-info (lambda-physenv fun))) (temp-refs (reference-tn-list temps nil))) (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) (vop* multiple-call-local node block (fp nfp temp-refs) @@ -835,12 +835,12 @@ ;;; named) tail call. (defun ir2-convert-tail-full-call (node block) (declare (type combination node) (type ir2-block block)) - (let* ((env (environment-info (node-environment node))) + (let* ((env (physenv-info (node-physenv node))) (args (basic-combination-args node)) (nargs (length args)) (pass-refs (move-tail-full-call-args node block)) - (old-fp (ir2-environment-old-fp env)) - (return-pc (ir2-environment-return-pc env))) + (old-fp (ir2-physenv-old-fp env)) + (return-pc (ir2-physenv-return-pc env))) (multiple-value-bind (fun-tn named) (function-continuation-tn node block (basic-combination-fun node)) @@ -1012,7 +1012,7 @@ (defun init-xep-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) (let ((start-label (entry-info-offset (leaf-info fun))) - (env (environment-info (node-environment node)))) + (env (physenv-info (node-physenv node)))) (let ((ef (functional-entry-function fun))) (cond ((and (optional-dispatch-p ef) (optional-dispatch-more-entry ef)) ;; Special case the xep-allocate-frame + copy-more-arg case. @@ -1021,13 +1021,13 @@ (t ;; No more args, so normal entry. (vop xep-allocate-frame node block start-label nil))) - (if (ir2-environment-environment env) + (if (ir2-physenv-environment env) (let ((closure (make-normal-tn *backend-t-primitive-type*))) (vop setup-closure-environment node block start-label closure) (when (getf (functional-plist ef) :fin-function) (vop funcallable-instance-lexenv node block closure closure)) (let ((n -1)) - (dolist (loc (ir2-environment-environment env)) + (dolist (loc (ir2-physenv-environment env)) (vop closure-ref node block closure (incf n) (cdr loc))))) (vop setup-environment node block start-label))) @@ -1047,13 +1047,13 @@ (incf n)))) (emit-move node block (make-old-fp-passing-location t) - (ir2-environment-old-fp env))) + (ir2-physenv-old-fp env))) (values)) ;;; Emit function prolog code. This is only called on bind nodes for ;;; functions that allocate environments. All semantics of let calls -;;; are handled by IR2-Convert-Let. +;;; are handled by IR2-CONVERT-LET. ;;; ;;; If not an XEP, all we do is move the return PC from its passing ;;; location, since in a local call, the caller allocates the frame @@ -1061,7 +1061,7 @@ (defun ir2-convert-bind (node block) (declare (type bind node) (type ir2-block block)) (let* ((fun (bind-lambda node)) - (env (environment-info (lambda-environment fun)))) + (env (physenv-info (lambda-physenv fun)))) (aver (member (functional-kind fun) '(nil :external :optional :top-level :cleanup))) @@ -1074,11 +1074,11 @@ (emit-move node block - (ir2-environment-return-pc-pass env) - (ir2-environment-return-pc env)) + (ir2-physenv-return-pc-pass env) + (ir2-physenv-return-pc env)) (let ((lab (gen-label))) - (setf (ir2-environment-environment-start env) lab) + (setf (ir2-physenv-environment-start env) lab) (vop note-environment-start node block lab))) (values)) @@ -1098,9 +1098,9 @@ (2cont (continuation-info cont)) (cont-kind (ir2-continuation-kind 2cont)) (fun (return-lambda node)) - (env (environment-info (lambda-environment fun))) - (old-fp (ir2-environment-old-fp env)) - (return-pc (ir2-environment-return-pc env)) + (env (physenv-info (lambda-physenv fun))) + (old-fp (ir2-physenv-old-fp env)) + (return-pc (ir2-physenv-return-pc env)) (returns (tail-set-info (lambda-tail-set fun)))) (cond ((and (eq (return-info-kind returns) :fixed) @@ -1141,10 +1141,10 @@ ;;; stack. It returns the OLD-FP and RETURN-PC for the current ;;; function as multiple values. (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block) - (let ((env (environment-info (node-environment node)))) + (let ((env (physenv-info (node-physenv node)))) (move-continuation-result node block - (list (ir2-environment-old-fp env) - (ir2-environment-return-pc env)) + (list (ir2-physenv-old-fp env) + (ir2-physenv-return-pc env)) (node-cont node)))) ;;;; multiple values @@ -1192,10 +1192,10 @@ (eq (ir2-continuation-kind start-cont) :unknown))) (cond (tails - (let ((env (environment-info (node-environment node)))) + (let ((env (physenv-info (node-physenv node)))) (vop tail-call-variable node block start fun - (ir2-environment-old-fp env) - (ir2-environment-return-pc env)))) + (ir2-physenv-old-fp env) + (ir2-physenv-return-pc env)))) ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) (vop* multiple-call-variable node block (start fun nil) @@ -1291,9 +1291,9 @@ ;;; IR2 converted. (defun ir2-convert-exit (node block) (declare (type exit node) (type ir2-block block)) - (let ((loc (find-in-environment (find-nlx-info (exit-entry node) - (node-cont node)) - (node-environment node))) + (let ((loc (find-in-physenv (find-nlx-info (exit-entry node) + (node-cont node)) + (node-physenv node))) (temp (make-stack-pointer-tn)) (value (exit-value node))) (vop value-cell-ref node block loc temp) @@ -1314,7 +1314,7 @@ ;;; cell that holds the closed unwind block. (defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block) (vop value-cell-set node block - (find-in-environment (continuation-value info) (node-environment node)) + (find-in-physenv (continuation-value info) (node-physenv node)) (emit-constant 0))) ;;; We have to do a spurious move of no values to the result @@ -1341,9 +1341,9 @@ (type (or continuation null) tag)) (let* ((2info (nlx-info-info info)) (kind (cleanup-kind (nlx-info-cleanup info))) - (block-tn (environment-live-tn + (block-tn (physenv-live-tn (make-normal-tn (primitive-type-or-lose 'catch-block)) - (node-environment node))) + (node-physenv node))) (res (make-stack-pointer-tn)) (target-label (ir2-nlx-info-target 2info))) diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp index 05cdbdf..154fdb6 100644 --- a/src/compiler/life.lisp +++ b/src/compiler/life.lisp @@ -370,9 +370,9 @@ ;;;; environment TN stuff -;;; Add a :LIVE global conflict for TN in 2block if there is none present. -;;; If Debug-P is false (a :ENVIRONMENT TN), then modify any existing conflict -;;; to be :LIVE. +;;; Add a :LIVE global conflict for TN in 2block if there is none +;;; present. If DEBUG-P is false (a :ENVIRONMENT TN), then modify any +;;; existing conflict to be :LIVE. (defun setup-environment-tn-conflict (tn 2block debug-p) (declare (type tn tn) (type ir2-block 2block)) (let ((block-num (ir2-block-number 2block))) @@ -398,14 +398,14 @@ ;;; TN. We make the TN global if it isn't already. The TN must have at ;;; least one reference. (defun setup-environment-tn-conflicts (component tn env debug-p) - (declare (type component component) (type tn tn) (type environment env)) + (declare (type component component) (type tn tn) (type physenv env)) (when (and debug-p (not (tn-global-conflicts tn)) (tn-local tn)) (convert-to-global tn)) (setf (tn-current-conflict tn) (tn-global-conflicts tn)) (do-blocks-backwards (block component) - (when (eq (block-environment block) env) + (when (eq (block-physenv block) env) (let* ((2block (block-info block)) (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) (prev 2block b)) @@ -421,56 +421,58 @@ (defun setup-environment-live-conflicts (component) (declare (type component component)) (dolist (fun (component-lambdas component)) - (let* ((env (lambda-environment fun)) - (2env (environment-info env))) - (dolist (tn (ir2-environment-live-tns 2env)) + (let* ((env (lambda-physenv fun)) + (2env (physenv-info env))) + (dolist (tn (ir2-physenv-live-tns 2env)) (setup-environment-tn-conflicts component tn env nil)) - (dolist (tn (ir2-environment-debug-live-tns 2env)) + (dolist (tn (ir2-physenv-debug-live-tns 2env)) (setup-environment-tn-conflicts component tn env t)))) (values)) ;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN. This ;;; requires adding :LIVE conflicts to all blocks in TN-ENV. (defun convert-to-environment-tn (tn tn-env) - (declare (type tn tn) (type environment tn-env)) + (declare (type tn tn) (type physenv tn-env)) (aver (member (tn-kind tn) '(:normal :debug-environment))) (when (eq (tn-kind tn) :debug-environment) - (aver (eq (tn-environment tn) tn-env)) - (let ((2env (environment-info tn-env))) - (setf (ir2-environment-debug-live-tns 2env) - (delete tn (ir2-environment-debug-live-tns 2env))))) + (aver (eq (tn-physenv tn) tn-env)) + (let ((2env (physenv-info tn-env))) + (setf (ir2-physenv-debug-live-tns 2env) + (delete tn (ir2-physenv-debug-live-tns 2env))))) (setup-environment-tn-conflicts *component-being-compiled* tn tn-env nil) (setf (tn-local tn) nil) (setf (tn-local-number tn) nil) (setf (tn-kind tn) :environment) - (setf (tn-environment tn) tn-env) - (push tn (ir2-environment-live-tns (environment-info tn-env))) + (setf (tn-physenv tn) tn-env) + (push tn (ir2-physenv-live-tns (physenv-info tn-env))) (values)) ;;;; flow analysis -;;; For each Global-TN in Block2 that is :Live, :Read or :Read-Only, ensure -;;; that there is a corresponding Global-Conflict in Block1. If there is none, -;;; make a :Live Global-Conflict. If there is a :Read-Only conflict, promote -;;; it to :Live. +;;; For each GLOBAL-TN in Block2 that is :LIVE, :READ or :READ-ONLY, +;;; ensure that there is a corresponding GLOBAL-CONFLICT in BLOCK1. If +;;; there is none, make a :LIVE GLOBAL-CONFLICT. If there is a +;;; :READ-ONLY conflict, promote it to :LIVE. ;;; -;;; If we did added a new conflict, return true, otherwise false. We don't -;;; need to return true when we promote a :Read-Only conflict, since it doesn't -;;; reveal any new information to predecessors of Block1. +;;; If we did added a new conflict, return true, otherwise false. We +;;; don't need to return true when we promote a :READ-ONLY conflict, +;;; since it doesn't reveal any new information to predecessors of +;;; BLOCK1. ;;; -;;; We use the Tn-Current-Conflict to walk through the global -;;; conflicts. Since the global conflicts for a TN are ordered by block, we -;;; can be sure that the Current-Conflict always points at or before the block -;;; that we are looking at. This allows us to quickly determine if there is a -;;; global conflict for a given TN in Block1. +;;; We use the TN-CURRENT-CONFLICT to walk through the global +;;; conflicts. Since the global conflicts for a TN are ordered by +;;; block, we can be sure that the CURRENT-CONFLICT always points at +;;; or before the block that we are looking at. This allows us to +;;; quickly determine if there is a global conflict for a given TN in +;;; BLOCK1. ;;; -;;; When we scan down the conflicts, we know that there must be at least one -;;; conflict for TN, since we got our hands on TN by picking it out of a -;;; conflict in Block2. +;;; When we scan down the conflicts, we know that there must be at +;;; least one conflict for TN, since we got our hands on TN by picking +;;; it out of a conflict in BLOCK2. ;;; -;;; We leave the Current-Conflict pointing to the conflict for Block1. The -;;; Current-Conflict must be initialized to the head of the Global-Conflicts -;;; for the TN between each flow analysis iteration. +;;; We leave the CURRENT-Conflict pointing to the conflict for BLOCK1. +;;; The CURRENT-CONFLICT must be initialized to the head of the +;;; GLOBAL-CONFLICTS for the TN between each flow analysis iteration. (defun propagate-live-tns (block1 block2) (declare (type ir2-block block1 block2)) (let ((live-in (ir2-block-live-in block1)) @@ -598,7 +600,7 @@ (num (global-conflicts-number conf))) (when (and num (zerop (sbit live-bits num)) (eq (tn-kind tn) :debug-environment) - (eq (tn-environment tn) (block-environment 1block)) + (eq (tn-physenv tn) (block-physenv 1block)) (saved-after-read tn block)) (note-conflicts live-bits live-list tn num) (setf (sbit live-bits num) 1) @@ -668,7 +670,7 @@ (unless (eq (tn-kind tn) :environment) (convert-to-environment-tn tn - (block-environment (ir2-block-block block)))))))) + (block-physenv (ir2-block-block block)))))))) (values)) ;;; FIXME: The next 3 macros aren't needed in the target runtime. diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 410fdfd..b8f4697 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -742,15 +742,15 @@ (depart-from-tail-set fun) (let* ((home (node-home-lambda call)) - (home-env (lambda-environment home))) + (home-env (lambda-physenv home))) (push fun (lambda-lets home)) (setf (lambda-home fun) home) - (setf (lambda-environment fun) home-env) + (setf (lambda-physenv fun) home-env) (let ((lets (lambda-lets fun))) (dolist (let lets) (setf (lambda-home let) home) - (setf (lambda-environment let) home-env)) + (setf (lambda-physenv let) home-env)) (setf (lambda-lets home) (nconc lets (lambda-lets home))) (setf (lambda-lets fun) ())) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index ea9c1dd..d09dacc 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -897,8 +897,8 @@ (unless template (when (and (eq (continuation-function-name (combination-fun call)) (leaf-name - (environment-function - (node-environment call)))) + (physenv-function + (node-physenv call)))) (let ((info (basic-combination-kind call))) (not (or (function-info-ir2-convert info) (ir1-attributep (function-info-attributes info) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 254b64b..cf88b99 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -472,7 +472,7 @@ ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more? (maybe-mumble "env ") - (environment-analyze component) + (physenv-analyze component) (dfo-as-needed component) (delete-if-no-entries component) @@ -911,7 +911,7 @@ (let ((*all-components* (append components-from-dfo top-components))) (/noshow components-from-dfo top-components *all-components*) - (mapc #'preallocate-environments-for-top-levelish-lambdas + (mapc #'preallocate-physenvs-for-top-levelish-lambdas (append hairy-top top-components)) (dolist (component-from-dfo components-from-dfo) (/show "compiling a COMPONENT-FROM-DFO") @@ -1256,7 +1256,7 @@ (check-ir1-consistency *all-components*)) (dolist (component (append hairy-top top-components)) - (when (pre-environment-analyze-top-level component) + (when (pre-physenv-analyze-top-level component) (setq top-level-closure t))) (dolist (component components) diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 2d73241..d814394 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -1917,19 +1917,19 @@ (when (and ,tn-var (not (eq ,tn-var :more))) (,n-bod ,tn-var))))))))))) -;;; Iterate over all the IR2 blocks in the environment Env, in emit order. -(defmacro do-environment-ir2-blocks ((block-var env &optional result) - &body body) - (once-only ((n-env env)) +;;; Iterate over all the IR2 blocks in PHYSENV, in emit order. +(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 - (environment-function ,n-env))))) + (physenv-function ,n-physenv))))) (once-only ((n-tail `(block-info (component-tail (block-component ,n-first))))) `(do ((,block-var (block-info ,n-first) (ir2-block-next ,block-var))) ((or (eq ,block-var ,n-tail) - (not (eq (ir2-block-environment ,block-var) ,n-env))) + (not (eq (ir2-block-physenv ,block-var) ,n-physenv))) ,result) ,@body))))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 41d2953..1eb7ec0 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -186,10 +186,10 @@ ;; top-level form containing the original source. (source-path *current-path* :type list) ;; If this node is in a tail-recursive position, then this is set to - ;; T. At the end of IR1 (in environment analysis) this is computed - ;; for all nodes (after cleanup code has been emitted). Before then, - ;; a non-null value indicates that IR1 optimization has converted a - ;; tail local call to a direct transfer. + ;; T. At the end of IR1 (in physical environment analysis) this is + ;; computed for all nodes (after cleanup code has been emitted). + ;; Before then, a non-null value indicates that IR1 optimization has + ;; converted a tail local call to a direct transfer. ;; ;; If the back-end breaks tail-recursion for some reason, then it ;; can null out this slot. @@ -357,9 +357,9 @@ ;; Entry/exit points have these blocks as their ;; predecessors/successors. Null temporarily. The start and return ;; from each non-deleted function is linked to the component head - ;; and tail. Until environment analysis links NLX entry stubs to the - ;; component head, every successor of the head is a function start - ;; (i.e. begins with a BIND node.) + ;; and tail. Until physical environment analysis links NLX entry + ;; stubs to the component head, every successor of the head is a + ;; function start (i.e. begins with a BIND node.) (head nil :type (or null cblock)) (tail nil :type (or null cblock)) ;; This becomes a list of the CLAMBDA structures for all functions @@ -457,16 +457,14 @@ ;; deleted due to unreachability. (mess-up nil :type (or node null)) ;; a list of all the NLX-INFO structures whose NLX-INFO-CLEANUP is - ;; this cleanup. This is filled in by environment analysis. + ;; this cleanup. This is filled in by physical environment analysis. (nlx-info nil :type list)) (defprinter (cleanup :identity t) kind mess-up (nlx-info :test nlx-info)) -;;; original CMU CL comment: -;;; An ENVIRONMENT structure represents the result of environment -;;; analysis. +;;; A PHYSENV represents the result of physical environment analysis. ;;; ;;; As far as I can tell from reverse engineering, this IR1 structure ;;; represents the physical environment (which is probably not the @@ -484,29 +482,32 @@ ;;; FROB-THINGS and FROBBING-ONE-THING are all in the inner LAMBDA's ;;; lexical environment, but of those only THING, PATTERN, and ;;; FROB-THINGS are in its physical environment. In IR1, we largely -;;; just collect the names of these things; in IR2 an IR2-ENVIRONMENT +;;; just collect the names of these things; in IR2 an IR2-PHYSENV ;;; structure is attached to INFO and used to keep track of ;;; associations between these names and less-abstract things (like ;;; TNs, or eventually stack slots and registers). -- WHN 2001-09-29 -(defstruct (environment (:copier nil)) - ;; the function that allocates this environment +(defstruct (physenv (:copier nil)) + ;; the function that allocates this physical environment (function (required-argument) :type clambda) - ;; a list of all the lambdas that allocate variables in this environment + #| ; seems not to be used as of sbcl-0.pre7.51 + ;; a list of all the lambdas that allocate variables in this + ;; physical environment (lambdas nil :type list) + |# ;; This ultimately converges to a list of all the LAMBDA-VARs and ;; NLX-INFOs needed from enclosing environments by code in this - ;; environment. In the meantime, it may be + ;; physical environment. In the meantime, it may be ;; * NIL at object creation time ;; * a superset of the correct result, generated somewhat later ;; * smaller and smaller sets converging to the correct result as ;; we notice and delete unused elements in the superset (closure nil :type list) ;; a list of NLX-INFO structures describing all the non-local exits - ;; into this environment + ;; into this physical environment (nlx-info nil :type list) ;; some kind of info used by the back end (info nil)) -(defprinter (environment :identity t) +(defprinter (physenv :identity t) function (closure :test closure) (nlx-info :test nlx-info)) @@ -541,7 +542,7 @@ ;;; The NLX-Info structure is used to collect various information ;;; about non-local exits. This is effectively an annotation on the ;;; CONTINUATION, although it is accessed by searching in the -;;; ENVIRONMENT-NLX-INFO. +;;; PHYSENV-NLX-INFO. (def!struct (nlx-info (:make-load-form-fun ignore-it)) ;; the cleanup associated with this exit. In a catch or ;; unwind-protect, this is the :CATCH or :UNWIND-PROTECT cleanup, @@ -551,8 +552,8 @@ (cleanup (required-argument) :type cleanup) ;; the continuation exited to (the CONT of the EXIT nodes). If this ;; exit is from an escape function (CATCH or UNWIND-PROTECT), then - ;; environment analysis deletes the escape function and instead has - ;; the %NLX-ENTRY use this continuation. + ;; physical environment analysis deletes the escape function and + ;; instead has the %NLX-ENTRY use this continuation. ;; ;; This slot is primarily an indication of where this exit delivers ;; its values to (if any), but it is also used as a sort of name to @@ -561,9 +562,9 @@ ;; since exits to different places may deliver their result to the ;; same continuation. (continuation (required-argument) :type continuation) - ;; the entry stub inserted by environment analysis. This is a block - ;; containing a call to the %NLX-Entry funny function that has the - ;; original exit destination as its successor. Null only + ;; the entry stub inserted by physical environment analysis. This is + ;; a block containing a call to the %NLX-Entry funny function that + ;; has the original exit destination as its successor. Null only ;; temporarily. (target nil :type (or cblock null)) ;; some kind of info used by the back end @@ -829,11 +830,11 @@ ;; (so that any further optimizations on the rest of the tail ;; set won't modify the value) if necessary. (tail-set nil :type (or tail-set null)) - ;; the structure which represents the environment that this + ;; the structure which represents the phsical environment that this ;; function's variables are allocated in. This is filled in by - ;; environment analysis. In a LET, this is EQ to our home's - ;; environment. - (environment nil :type (or environment null)) + ;; physical environment analysis. In a LET, this is EQ to our home's + ;; physical environment. + (physenv nil :type (or physenv null)) ;; In a LET, this is the NODE-LEXENV of the combination node. We ;; retain it so that if the LET is deleted (due to a lack of vars), ;; we will still have caller's lexenv to figure out which cleanup is @@ -945,20 +946,20 @@ ;;; lambda arguments which may ultimately turn out not to be simple ;;; and lexical. ;;; -;;; LAMBDA-VARs with no REFs are considered to be deleted; 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. +;;; 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. (def!struct (lambda-var (:include basic-var)) ;; true if this variable has been declared IGNORE (ignorep nil :type boolean) ;; the CLAMBDA that this var belongs to. This may be null when we are ;; building a lambda during IR1 conversion. (home nil :type (or null clambda)) - ;; This is set by environment analysis if it chooses an indirect - ;; (value cell) representation for this variable because it is both - ;; set and closed over. + ;; This is set by physical environment analysis if it chooses an + ;; indirect (value cell) representation for this variable because it + ;; is both set and closed over. (indirect nil :type boolean) ;; The following two slots are only meaningful during IR1 conversion ;; of hairy lambda vars: @@ -1187,4 +1188,4 @@ #!-sb-fluid (declaim (freeze-type node leaf lexenv continuation cblock component cleanup - environment tail-set nlx-info)) + physenv tail-set nlx-info)) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp new file mode 100644 index 0000000..61cd2da --- /dev/null +++ b/src/compiler/physenvanal.lisp @@ -0,0 +1,388 @@ +;;;; This file implements the environment analysis phase for the +;;;; compiler. This phase annotates IR1 with a hierarchy environment +;;;; structures, determining the physical environment that each LAMBDA +;;;; allocates its variables and finding what values are closed over +;;;; by each physical environment. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!C") + +;;; Do environment analysis on the code in COMPONENT. This involves +;;; various things: +;;; 1. Make a PHYSENV structure for each non-LET LAMBDA, assigning +;;; the LAMBDA-PHYSENV for all LAMBDAs. +;;; 2. Find all values that need to be closed over by each +;;; physical environment. +;;; 3. Scan the blocks in the component closing over non-local-exit +;;; continuations. +;;; 4. Delete all non-top-level functions with no references. This +;;; should only get functions with non-NULL kinds, since normal +;;; functions are deleted when their references go to zero. +(defun physenv-analyze (component) + (declare (type component component)) + (aver (every (lambda (x) + (eq (functional-kind x) :deleted)) + (component-new-functions component))) + (setf (component-new-functions 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))) + + (find-non-local-exits component) + (find-cleanup-points component) + (tail-annotate component) + + (dolist (fun (component-lambdas component)) + (when (null (leaf-refs fun)) + (let ((kind (functional-kind fun))) + (unless (or (eq kind :top-level) + (functional-has-external-references-p fun)) + (aver (member kind '(:optional :cleanup :escape))) + (setf (functional-kind fun) nil) + (delete-functional fun))))) + + (values)) + +;;; This is to be called on a COMPONENT with top-level LAMBDAs before +;;; the compilation of the associated non-top-level code to detect +;;; closed over top-level variables. We just do COMPUTE-CLOSURE on all +;;; the lambdas. This will pre-allocate environments for all the +;;; functions with closed-over top-level variables. The post-pass will +;;; use the existing structure, rather than allocating a new one. We +;;; return true if we discover any possible closure vars. +(defun pre-physenv-analyze-top-level (component) + (declare (type component component)) + (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)))) + found-it)) + +;;; This is like old CMU CL PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL, except +;;; (1) It's been brought into the post-0.7.0 world where the property +;;; HAS-EXTERNAL-REFERENCES-P is orthogonal to the property of +;;; being specialized/optimized for locall at top level. +;;; (2) There's no return value, since we don't care whether we +;;; find any possible closure variables. +;;; +;;; I wish I could find an explanation of why +;;; PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL is important. The old CMU CL +;;; comments said +;;; Called on component with top-level lambdas before the +;;; compilation of the associated non-top-level code to detect +;;; closed over top-level variables. We just do COMPUTE-CLOSURE on +;;; all the lambdas. This will pre-allocate environments for all +;;; the functions with closed-over top-level variables. The +;;; 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 +;;; 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 +(defun preallocate-physenvs-for-top-levelish-lambdas (component) + (dolist (clambda (component-lambdas component)) + (when (lambda-top-levelish-p clambda) + (compute-closure clambda))) + (values)) + +;;; If CLAMBDA has a PHYSENV , return it, otherwise assign an empty one. +(defun get-lambda-physenv (clambda) + (declare (type clambda clambda)) + (let ((homefun (lambda-home clambda))) + (or (lambda-physenv homefun) + (let ((res (make-physenv :function homefun))) + (setf (lambda-physenv homefun) res) + (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)) + (setf (lambda-physenv letlambda) res)) + res)))) + +;;; If FUN has no physical environment, assign one, otherwise clean up +;;; the old physical environment, removing/flagging variables that +;;; have no sets or refs. If a var has no references, we remove it +;;; from the closure. If it has no sets, we clear the INDIRECT flag. +;;; This is necessary because pre-analysis is done before +;;; optimization. +(defun reinit-lambda-physenv (fun) + (let ((old (lambda-physenv (lambda-home fun)))) + (cond (old + (setf (physenv-closure old) + (delete-if #'(lambda (x) + (and (lambda-var-p x) + (null (leaf-refs x)))) + (physenv-closure old))) + (flet ((clear (fun) + (dolist (var (lambda-vars fun)) + (unless (lambda-var-sets var) + (setf (lambda-var-indirect var) nil))))) + (clear fun) + (dolist (let (lambda-lets fun)) + (clear let)))) + (t + (get-lambda-physenv fun)))) + (values)) + +;;; Get NODE's environment, assigning one if necessary. +(defun get-node-physenv (node) + (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)) + +;;; 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 +;;; 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))) + (t + (push thing (physenv-closure ref-env)) + (dolist (call (leaf-refs (physenv-function ref-env))) + (close-over thing (get-node-physenv call) home-env)))) + (values)) + +;;;; non-local exit + +;;; Insert the entry stub before the original exit target, and add a +;;; new entry to the PHYSENV-NLX-INFO. The %NLX-ENTRY call in the +;;; stub is passed the NLX-INFO as an argument so that the back end +;;; knows what entry is being done. +;;; +;;; The link from the EXIT block to the entry stub is changed to be a +;;; link to the component head. Similarly, the EXIT block is linked to +;;; the component tail. This leaves the entry stub reachable, but +;;; makes the flow graph less confusing to flow analysis. +;;; +;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the +;;; last node in the cleanup code to be the enclosing environment, to +;;; represent the fact that the binding was undone as a side-effect of +;;; the exit. This will cause a lexical exit to be broken up if we are +;;; actually exiting the scope (i.e. a BLOCK), and will also do any +;;; other cleanups that may have to be done on the way. +(defun insert-nlx-entry-stub (exit env) + (declare (type physenv env) (type exit exit)) + (let* ((exit-block (node-block exit)) + (next-block (first (block-succ exit-block))) + (cleanup (entry-cleanup (exit-entry exit))) + (info (make-nlx-info :cleanup cleanup + :continuation (node-cont exit))) + (entry (exit-entry exit)) + (new-block (insert-cleanup-code exit-block next-block + entry + `(%nlx-entry ',info) + (entry-cleanup entry))) + (component (block-component new-block))) + (unlink-blocks exit-block new-block) + (link-blocks exit-block (component-tail component)) + (link-blocks (component-head component) new-block) + + (setf (nlx-info-target info) new-block) + (push info (physenv-nlx-info env)) + (push info (cleanup-nlx-info cleanup)) + (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) + (setf (node-lexenv (block-last new-block)) + (node-lexenv entry)))) + + (values)) + +;;; Do stuff necessary to represent a non-local exit from the node +;;; EXIT into ENV. This is called for each non-local exit node, of +;;; which there may be several per exit continuation. This is what we +;;; do: +;;; -- If there isn't any NLX-Info entry in the environment, make +;;; an entry stub, otherwise just move the exit block link to +;;; the component tail. +;;; -- Close over the NLX-Info in the exit environment. +;;; -- If the exit is from an :Escape function, then substitute a +;;; constant reference to NLX-Info structure for the escape +;;; function reference. This will cause the escape function to +;;; be deleted (although not removed from the DFO.) The escape +;;; function is no longer needed, and we don't want to emit code +;;; for it. We then also change the %NLX-ENTRY call to use the +;;; NLX continuation so that there will be a use to represent +;;; the NLX use. +(defun note-non-local-exit (env exit) + (declare (type physenv env) (type exit exit)) + (let ((entry (exit-entry exit)) + (cont (node-cont exit)) + (exit-fun (node-home-lambda exit))) + + (if (find-nlx-info entry cont) + (let ((block (node-block exit))) + (aver (= (length (block-succ block)) 1)) + (unlink-blocks block (first (block-succ block))) + (link-blocks block (component-tail (block-component block)))) + (insert-nlx-entry-stub exit env)) + + (let ((info (find-nlx-info entry cont))) + (aver info) + (close-over info (node-physenv exit) env) + (when (eq (functional-kind exit-fun) :escape) + (mapc #'(lambda (x) + (setf (node-derived-type x) *wild-type*)) + (leaf-refs exit-fun)) + (substitute-leaf (find-constant info) exit-fun) + (let ((node (block-last (nlx-info-target info)))) + (delete-continuation-use node) + (add-continuation-use node (nlx-info-continuation info)))))) + + (values)) + +;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT +;;; when we find a block that ends in a non-local EXIT node. We also +;;; ensure that all EXIT nodes are either non-local or degenerate by +;;; calling IR1-OPTIMIZE-EXIT on local exits. This makes life simpler +;;; for later phases. +(defun find-non-local-exits (component) + (declare (type component component)) + (dolist (lambda (component-lambdas component)) + (dolist (entry (lambda-entries lambda)) + (dolist (exit (entry-exits entry)) + (let ((target-env (node-physenv entry))) + (if (eq (node-physenv exit) target-env) + (maybe-delete-exit exit) + (note-non-local-exit target-env exit)))))) + + (values)) + +;;;; cleanup emission + +;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating +;;; cleanup code as we go. When we are done, convert the cleanup code +;;; in an implicit MV-PROG1. We have to force local call analysis of +;;; new references to UNWIND-PROTECT cleanup functions. If we don't +;;; actually have to do anything, then we don't insert any cleanup +;;; code. +;;; +;;; If we do insert cleanup code, we check that BLOCK1 doesn't end in +;;; a "tail" local call. +;;; +;;; We don't need to adjust the ending cleanup of the cleanup block, +;;; since the cleanup blocks are inserted at the start of the DFO, and +;;; are thus never scanned. +(defun emit-cleanups (block1 block2) + (declare (type cblock block1 block2)) + (collect ((code) + (reanalyze-funs)) + (let ((cleanup2 (block-start-cleanup block2))) + (do ((cleanup (block-end-cleanup block1) + (node-enclosing-cleanup (cleanup-mess-up cleanup)))) + ((eq cleanup cleanup2)) + (let* ((node (cleanup-mess-up cleanup)) + (args (when (basic-combination-p node) + (basic-combination-args node)))) + (ecase (cleanup-kind cleanup) + (:special-bind + (code `(%special-unbind ',(continuation-value (first args))))) + (:catch + (code `(%catch-breakup))) + (:unwind-protect + (code `(%unwind-protect-breakup)) + (let ((fun (ref-leaf (continuation-use (second args))))) + (reanalyze-funs fun) + (code `(%funcall ,fun)))) + ((:block :tagbody) + (dolist (nlx (cleanup-nlx-info cleanup)) + (code `(%lexical-exit-breakup ',nlx))))))) + + (when (code) + (aver (not (node-tail-p (block-last block1)))) + (insert-cleanup-code block1 block2 + (block-last block1) + `(progn ,@(code))) + (dolist (fun (reanalyze-funs)) + (local-call-analyze-1 fun))))) + + (values)) + +;;; Loop over the blocks in COMPONENT, calling EMIT-CLEANUPS when we +;;; see a successor in the same environment with a different cleanup. +;;; We ignore the cleanup transition if it is to a cleanup enclosed by +;;; the current cleanup, since in that case we are just messing up the +;;; environment, hence this is not the place to clean it. +(defun find-cleanup-points (component) + (declare (type component component)) + (do-blocks (block1 component) + (let ((env1 (block-physenv block1)) + (cleanup1 (block-end-cleanup block1))) + (dolist (block2 (block-succ block1)) + (when (block-start block2) + (let ((env2 (block-physenv block2)) + (cleanup2 (block-start-cleanup block2))) + (unless (or (not (eq env2 env1)) + (eq cleanup1 cleanup2) + (and cleanup2 + (eq (node-enclosing-cleanup + (cleanup-mess-up cleanup2)) + cleanup1))) + (emit-cleanups block1 block2))))))) + (values)) + +;;; Mark all tail-recursive uses of function result continuations with +;;; the corresponding TAIL-SET. Nodes whose type is NIL (i.e. don't +;;; return) such as calls to ERROR are never annotated as tail in +;;; order to preserve debugging information. +(defun tail-annotate (component) + (declare (type component component)) + (dolist (fun (component-lambdas component)) + (let ((ret (lambda-return fun))) + (when ret + (let ((result (return-result ret))) + (do-uses (use result) + (when (and (immediately-used-p result use) + (or (not (eq (node-derived-type use) *empty-type*)) + (not (basic-combination-p use)) + (eq (basic-combination-kind use) :local))) + (setf (node-tail-p use) t))))))) + (values)) diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index 3f049b3..66fd31b 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -317,9 +317,9 @@ (vop-block (tn-ref-vop ref))))) (tails (lambda-tail-set lambda))) (flet ((frob (fun) - (setf (ir2-environment-number-stack-p - (environment-info - (lambda-environment fun))) + (setf (ir2-physenv-number-stack-p + (physenv-info + (lambda-physenv fun))) t))) (frob lambda) (when tails diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index 508b6ef..00dd5a6 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -100,7 +100,7 @@ (dolist (pred (block-pred block)) (if (eq pred (component-head (block-component block))) (aver (find block - (environment-nlx-info (block-environment block)) + (physenv-nlx-info (block-physenv block)) :key #'nlx-info-target)) (let ((pred-stack (ir2-block-end-stack (block-info pred)))) (unless (tailp new-stack pred-stack) diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index b5d39cc..3409a63 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -64,14 +64,14 @@ (case (tn-kind tn) (:environment (clear-live tn - #'ir2-environment-live-tns - #'(setf ir2-environment-live-tns))) + #'ir2-physenv-live-tns + #'(setf ir2-physenv-live-tns))) (:debug-environment (clear-live tn - #'ir2-environment-debug-live-tns - #'(setf ir2-environment-debug-live-tns))))) + #'ir2-physenv-debug-live-tns + #'(setf ir2-physenv-debug-live-tns))))) (clear-live (tn getter setter) - (let ((env (environment-info (tn-environment tn)))) + (let ((env (physenv-info (tn-physenv tn)))) (funcall setter (delete tn (funcall getter env)) env)))) (declare (inline used-p delete-some delete-1 clear-live)) (delete-some #'ir2-component-alias-tns @@ -136,23 +136,24 @@ (push-in tn-next res (ir2-component-restricted-tns component)) res)) -;;; Make TN be live throughout environment. Return TN. In the DEBUG case, -;;; the TN is treated normally in blocks in the environment which reference the -;;; TN, allowing targeting to/from the TN. This results in move efficient -;;; code, but may result in the TN sometimes not being live when you want it. -(defun environment-live-tn (tn env) - (declare (type tn tn) (type environment env)) +;;; Make TN be live throughout environment. Return TN. In the DEBUG +;;; case, the TN is treated normally in blocks in the environment +;;; which reference the TN, allowing targeting to/from the TN. This +;;; results in move efficient code, but may result in the TN sometimes +;;; not being live when you want it. +(defun physenv-live-tn (tn env) + (declare (type tn tn) (type physenv env)) (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :environment) - (setf (tn-environment tn) env) - (push tn (ir2-environment-live-tns (environment-info env))) + (setf (tn-physenv tn) env) + (push tn (ir2-physenv-live-tns (physenv-info env))) tn) -(defun environment-debug-live-tn (tn env) - (declare (type tn tn) (type environment env)) +(defun physenv-debug-live-tn (tn env) + (declare (type tn tn) (type physenv env)) (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :debug-environment) - (setf (tn-environment tn) env) - (push tn (ir2-environment-debug-live-tns (environment-info env))) + (setf (tn-physenv tn) env) + (push tn (ir2-physenv-debug-live-tns (physenv-info env))) tn) ;;; Make TN be live throughout the current component. Return TN. diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 39c688a..e78a376 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -77,8 +77,8 @@ ;;; environment pointer should be saved after the binding is ;;; instantiated. ;;; -;;; Environment-Info -;;; Holds the IR2-Environment structure. +;;; Physenv-Info +;;; Holds the Ir2-Physenv structure. ;;; ;;; Tail-Set-Info ;;; Holds the Return-Info structure. @@ -328,9 +328,9 @@ ;; of this function (type 'function :type (or list (member function)))) -;;; An IR2-ENVIRONMENT is used to annotate non-LET LAMBDAs with their -;;; passing locations. It is stored in the ENVIRONMENT-INFO. -(defstruct (ir2-environment (:copier nil)) +;;; 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. @@ -367,7 +367,7 @@ ;; from their passing locations, etc. This is the start of the ;; function as far as the debugger is concerned. (environment-start nil :type (or label null))) -(defprinter (ir2-environment) +(defprinter (ir2-physenv) environment old-fp return-pc @@ -924,8 +924,8 @@ ;; some kind of info about how important this TN is (cost 0 :type fixnum) ;; If a :ENVIRONMENT or :DEBUG-ENVIRONMENT TN, this is the - ;; environment that the TN is live throughout. - (environment nil :type (or environment null))) + ;; physical environment that the TN is live throughout. + (physenv nil :type (or physenv null))) (def!method print-object ((tn tn) stream) (print-unreadable-object (tn stream :type t) ;; KLUDGE: The distinction between PRINT-TN and PRINT-OBJECT on TN is diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 67f5215..4fda851 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -70,28 +70,28 @@ (make-normal-tn *fixnum-primitive-type*))) ;;; Make the TNs used to hold Old-FP and Return-PC within the current -;;; function. We treat these specially so that the debugger can find them at a -;;; known location. +;;; function. We treat these specially so that the debugger can find +;;; them at a known location. ;;; ;;; Without using a save-tn - which does not make much sense if it is ;;; wire to the stack? No problems. (!def-vm-support-routine make-old-fp-save-location (env) - (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type* - control-stack-sc-number - ocfp-save-offset) - env)) + (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type* + control-stack-sc-number + ocfp-save-offset) + env)) ;;; Using a save-tn. No problems. #+nil (!def-vm-support-routine make-old-fp-save-location (env) (specify-save-tn - (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset))) ;;; Without using a save-tn - which does not make much sense if it is ;;; wire to the stack? No problems. (!def-vm-support-routine make-return-pc-save-location (env) - (environment-debug-live-tn + (physenv-debug-live-tn (make-wired-tn (primitive-type-or-lose 'system-area-pointer) sap-stack-sc-number return-pc-save-offset) env)) @@ -100,7 +100,7 @@ (!def-vm-support-routine make-return-pc-save-location (env) (let ((ptype (primitive-type-or-lose 'system-area-pointer))) (specify-save-tn - (environment-debug-live-tn (make-normal-tn ptype) env) + (physenv-debug-live-tn (make-normal-tn ptype) env) (make-wired-tn ptype sap-stack-sc-number return-pc-save-offset)))) ;;; Make a TN for the standard argument count passing location. We only diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index a0030d4..5b2ea6e 100644 --- a/src/compiler/x86/nlx.lisp +++ b/src/compiler/x86/nlx.lisp @@ -13,7 +13,7 @@ ;;; Make an environment-live stack TN for saving the SP for NLX entry. (!def-vm-support-routine make-nlx-sp-tn (env) - (environment-live-tn + (physenv-live-tn (make-representation-tn *fixnum-primitive-type* any-reg-sc-number) env)) diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 99c6e28..5bc126d 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -140,11 +140,7 @@ ;; inherited from CMU CL comcom.lisp. We shouldn't need two versions, ;; so I've deleted the one here. -- WHN 19990620 - ;; FIXME: There are lots of "maybe" notes in this file, e.g. - ;; "maybe should be :BYTE-COMPILE T". Once the system is stable, - ;; look into them. - - ("src/code/target-error" :not-host) ; maybe should be :BYTE-COMPILE T + ("src/code/target-error" :not-host) ;; a comment from classic CMU CL: ;; "These guys can supposedly come in any order, but not really. @@ -231,22 +227,22 @@ ("src/code/stream" :not-host) ("src/code/print" :not-host) - ("src/code/pprint" :not-host) ; maybe should be :BYTE-COMPILE T + ("src/code/pprint" :not-host) ("src/code/early-format") - ("src/code/target-format" :not-host) ; maybe should be :BYTE-COMPILE T + ("src/code/target-format" :not-host) ("src/code/defpackage" :not-host) - ("src/code/pp-backq" :not-host) ; maybe should be :BYTE-COMPILE T + ("src/code/pp-backq" :not-host) ("src/code/error-error" :not-host) ; needs WITH-STANDARD-IO-SYNTAX macro ("src/code/serve-event" :not-host) ("src/code/fd-stream" :not-host) - ("src/code/module" :not-host) ; maybe should be :BYTE-COMPILE T + ("src/code/module" :not-host) ("src/code/interr" :not-host) - ("src/code/query" :not-host) ; maybe should be :BYTE-COMPILE T + ("src/code/query" :not-host) ("src/code/sort" :not-host) ("src/code/time" :not-host) @@ -315,7 +311,7 @@ ;; The definitions for CONDITION and CONDITION-CLASS depend on ;; SLOT-CLASS, defined in classes.lisp. - ("src/code/condition" :not-host) ; FIXME: maybe should be :BYTE-COMPILE T + ("src/code/condition" :not-host) ("src/compiler/generic/primtype") @@ -468,7 +464,7 @@ ("src/compiler/dfo") ("src/compiler/checkgen") ("src/compiler/constraint") - ("src/compiler/envanal") + ("src/compiler/physenvanal") ("src/compiler/tn") ("src/compiler/life") @@ -573,10 +569,8 @@ ("src/code/target-random" :not-host) ; needs "code/random" ("src/code/target-hash-table" :not-host) ; needs "code/hash-table" ("src/code/reader" :not-host) ; needs "code/readtable" - ("src/code/target-pathname" :not-host) ; needs "code/pathname", maybe - ; should be :BYTE-COMPILE T - ("src/code/filesys" :not-host) ; needs HOST from "code/pathname", - ; maybe should be :BYTE-COMPILE T + ("src/code/target-pathname" :not-host) ; needs "code/pathname" + ("src/code/filesys" :not-host) ; needs HOST from "code/pathname" ("src/code/save" :not-host) ; uses the definition of PATHNAME ; from "code/pathname" ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" @@ -588,7 +582,7 @@ ("src/compiler/target-disassem" :not-host) ("src/compiler/target/target-insts" :not-host) - ("src/code/debug" :not-host) ; maybe should be :BYTE-COMPILE T + ("src/code/debug" :not-host) ;; These can't be compiled until CONDITION and DEFINE-CONDITION ;; are defined, and they also use SB-DEBUG:*STACK-TOP-HINT*. diff --git a/version.lisp-expr b/version.lisp-expr index 247a876..cbd7b36 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.50" +"0.pre7.51"