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..)
"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"
"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"
;;; 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
;;; 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*))
;;; 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
(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))
;;; 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))
(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
;;; 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))
\f
;;;; specials used during code generation
(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)))))
(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)
(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)))))
(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)))
;;; 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.
(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
(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
(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
(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
*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))
(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
(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)))))
;;; 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)))))
(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
;;; 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))
(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)
(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)))
: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))
+++ /dev/null
-;;;; 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))
-\f
-;;;; 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))
-\f
-;;;; 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))
(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)
(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
(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)
(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))
;;; 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))
\f
;;;; 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))
(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.
#!-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.
(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)))))
;;;; 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
;; 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
;;; 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)))
(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))))
(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))))
(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)))))
(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)))))
(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)))
(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)))))
;;; 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))
(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)))))
(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))
(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)
;;; 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))
(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.
(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)))
(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
(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)))
(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))
(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)
;;; 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))))
\f
;;;; multiple values
(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)
;;; 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)
;;; 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
(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)))
\f
;;;; 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)))
;;; 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))
(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))
\f
;;;; 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))
(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)
(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.
(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) ()))
(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)
;; 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)
(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")
(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)
(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)))))
;; 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.
;; 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
;; 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
;;; 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))
;;; 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,
(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
;; 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
;; (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
;;; 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:
#!-sb-fluid
(declaim (freeze-type node leaf lexenv continuation cblock component cleanup
- environment tail-set nlx-info))
+ physenv tail-set nlx-info))
--- /dev/null
+;;;; 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))
+\f
+;;;; 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))
+\f
+;;;; 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))
(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
(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)
(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
(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.
;;; 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.
;; 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.
;; 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
;; 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
(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))
(!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
;;; 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))
;; 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.
("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)
;; 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")
("src/compiler/dfo")
("src/compiler/checkgen")
("src/compiler/constraint")
- ("src/compiler/envanal")
+ ("src/compiler/physenvanal")
("src/compiler/tn")
("src/compiler/life")
("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"
("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*.
;;; 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"
projects / sbcl.git / commitdiff