[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-devel
Subject: Re: [Sbcl-devel] [Sbcl-commits] master: Do not retain load-time code when closing over top level bin
From: Stas Boukarev <stassats () gmail ! com>
Date: 2023-01-21 12:35:57
Message-ID: CAF63=11OE2HODNOcOjuV-ogJVyK-unBQFBN_=gTW74XiCnJxHA () mail ! gmail ! com
[Download RAW message or body]
It's just an example. Try
(let ((x (random 1d0)))
(defun test ()
(1+ x)))
then.
On Sat, Jan 21, 2023 at 2:37 PM Charles Zhang <charleszhang99@yahoo.com> wrote:
>
> More accurately: The code produced is the same (on x86-64 at least) (actually \
> better since the load time code isn't retained anymore), but the return value is \
> derived as T and not DOUBLE-FLOAT. Will look into it.
>
>
>
>
> On Saturday, January 21, 2023 at 05:46:50 AM GMT+1, Stas Boukarev \
> <stassats@gmail.com> wrote:
>
> This produces worse code:
> (let ((x (random 1d0)))
> (defun test ()
> x))
>
> It doesn't know that X is a double float.
>
> On Wed, Jan 4, 2023 at 1:50 AM apache--- via Sbcl-commits
> <sbcl-commits@lists.sourceforge.net> wrote:
> >
> > The branch "master" has been updated in SBCL:
> > via 9a5325b3cd7855b00fe9500401d5c2c41639575e (commit)
> > from d801db2da37e8c5db1854829acca6f88b5b8a3ec (commit)
> >
> > - Log -----------------------------------------------------------------
> > commit 9a5325b3cd7855b00fe9500401d5c2c41639575e
> > Author: Charles Zhang <charleszhang99@yahoo.com>
> > Date: Tue Jan 3 20:40:33 2023 +0100
> >
> > Do not retain load-time code when closing over top level bindings.
> >
> > Python was actually intentionally designed to separate out load-time
> > code even when run-time code would close over bindings created at load
> > time, as evidenced by various comments throughout the compiler
> > alluding to the compiler going "to special effort to allow
> > closing-over values in another component." However, since about 2001
> > SBCL has stopped doing that, and support has eroded through the
> > following changes:
> >
> > * The DFO walk was made to include closure dependencies to workaround
> > code deletion problems, meaning that load time code was being included
> > in runtime components by the DFO walk.
> > ** To fix this, we stop making closure dependencies combine
> > components. We delete code better now.
> >
> > After that was fixed, we had the following problems to solve.
> >
> > * The introduction of explicitly allocating closures in the right
> > place (IR2-CONVERT-ENCLOSE), which causes the convert method to
> > potentially allocate closures before the compiler realizes those
> > closures are dead code (As in the test :DEAD-CODE-DFO-PUKING).
> > ** To fix this, we move DELETE-IF-NO-ENTIRES into FIND-INITIAL-DFO
> > so that IR2-convert is no longer sensitive to the compilation order
> > of components.
> >
> > * The remvoal of the environment analysis prepass, even though the
> > comments alluding to such a prepass still exists.
> > ** To fix this, restore the environment prepass.
> >
> > * DERIVE-NODE-TYPE and PROPAGATE-LET-ARGS were substituting in
> > constant leafs into components that had already been compiled, causing
> > mismatches between code compiled in one component and code compiled in
> > another.
> > ** To fix this, inhibit constant substitution when the use and the
> > ref are in different components again, as was done before. Also,
> > don't have DERIVE-NODE-TYPE substitute in constant leafs based on
> > types. Constant folding and other type analyses now work directly
> > with the types and can figure out that there will be a constant
> > value without needing a constant leaf to be substituted in first.
> >
> > * THe make-closure vop for arm64 and x86-64 were always assuming that
> > we make closures off of simple funs which are always in the same
> > component.
> > ** Fix this assumption by creating two separate VOPs on these
> > platforms: one to create closures from entry points in the same
> > component and one outside the component using a descriptor argument.
> > ---
> > NEWS | 2 +
> > float-math.lisp-expr | 2 +
> > src/code/ntrace.lisp | 2 +-
> > src/cold/exports.lisp | 2 +-
> > src/compiler/arm/alloc.lisp | 3 +-
> > src/compiler/arm64/alloc.lisp | 44 +++++++----
> > src/compiler/dfo.lisp | 157 +++++++++++++++-----------------------
> > src/compiler/entry.lisp | 6 +-
> > src/compiler/envanal.lisp | 43 ++++++++++-
> > src/compiler/ir1-translators.lisp | 9 ---
> > src/compiler/ir1opt.lisp | 18 ++---
> > src/compiler/ir1tran.lisp | 3 -
> > src/compiler/ir1util.lisp | 7 +-
> > src/compiler/ir2tran.lisp | 33 +++++---
> > src/compiler/locall.lisp | 82 ++++++++++----------
> > src/compiler/main.lisp | 9 ++-
> > src/compiler/mips/alloc.lisp | 3 +-
> > src/compiler/node.lisp | 18 ++---
> > src/compiler/ppc/alloc.lisp | 3 +-
> > src/compiler/ppc64/alloc.lisp | 3 +-
> > src/compiler/riscv/alloc.lisp | 3 +-
> > src/compiler/sparc/alloc.lisp | 3 +-
> > src/compiler/vop.lisp | 2 +
> > src/compiler/x86-64/alloc.lisp | 78 ++++++++++---------
> > src/compiler/x86/alloc.lisp | 3 +-
> > tests/compiler-2.impure.lisp | 52 +++++++++++++
> > 26 files changed, 322 insertions(+), 268 deletions(-)
> >
> > diff --git a/NEWS b/NEWS
> > index fc294ec65..9c49a90b0 100644
> > --- a/NEWS
> > +++ b/NEWS
> > @@ -1,6 +1,8 @@
> > ;;;; -*- coding: utf-8; fill-column: 78 -*-
> >
> > changes relative to sbcl-2.3.0:
> > + * optimization: load-time only code is no longer retained at runtime when
> > + functions close over top level bindings.
> > * optimization: GO and RETURN-FROM now elide out-of-extent tag checks when
> > the compiler can prove it's safe even on high safety.
> > * sb-graph has been removed. To visualize IR1 in sbcl, it is recommended to
> > diff --git a/float-math.lisp-expr b/float-math.lisp-expr
> > index fe3334ffa..b06ac93f1 100644
> > --- a/float-math.lisp-expr
> > +++ b/float-math.lisp-expr
> > @@ -3051,6 +3051,7 @@
> > (>= (#x-467 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
> > (>= (#x-144 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
> > (>= (#x-135 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
> > +(>= (#x-1 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL)
> > (>= (#x0 #.(MAKE-SINGLE-FLOAT #x-40800000)) T)
> > (>= (#x0 #.(MAKE-SINGLE-FLOAT #x-32000000)) T)
> > (>= (#x0 #.(MAKE-SINGLE-FLOAT #x-22800000)) T)
> > @@ -3503,6 +3504,7 @@
> > (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x-20000001) T)
> > (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x0) T)
> > (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x1) NIL)
> > +(>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x34) NIL)
> > (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x133) NIL)
> > (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x142) NIL)
> > (>= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x3CB) NIL)
> > diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
> > index 0c9a8a05e..f1f6bf7c2 100644
> > --- a/src/code/ntrace.lisp
> > +++ b/src/code/ntrace.lisp
> > @@ -836,7 +836,7 @@ functions when called with no arguments."
> > #+(or x86-64 arm64)
> > (with-pinned-objects ((%closure-fun traced-fun))
> > (sb-vm::%alloc-closure 0 (sb-vm::%closure-callee traced-fun)))
> > - #-(or x86-64 arm64) (%primitive sb-vm::make-closure traced-fun nil \
> > 0 nil)) + #-(or x86-64 arm64) (%primitive sb-vm::make-closure \
> > traced-fun 0 nil)) (closure
> > ;; Same as above, but simpler - the original closure will redirect
> > ;; to the tracing wraper, which will invoke a new closure that is
> > diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
> > index 8d24d9ffb..d0ee293f9 100644
> > --- a/src/cold/exports.lisp
> > +++ b/src/cold/exports.lisp
> > @@ -1354,7 +1354,7 @@ like *STACK-TOP-HINT* and unsupported stuff like \
> > *TRACED-FUN-LIST*.") "LVAR-VALUE"
> > "MACRO-POLICY-DECLS"
> > "MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK"
> > - "MAKE-CLOSURE" "MAKE-CONSTANT-TN"
> > + "MAKE-CLOSURE" #+(or x86-64 arm64) "MAKE-CLOSURE-FROM-LABEL" \
> > "MAKE-CONSTANT-TN" "MAKE-FIXUP-NOTE"
> > "MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN"
> > "MAKE-RANDOM-TN"
> > diff --git a/src/compiler/arm/alloc.lisp b/src/compiler/arm/alloc.lisp
> > index 461d86e2e..8d49600e7 100644
> > --- a/src/compiler/arm/alloc.lisp
> > +++ b/src/compiler/arm/alloc.lisp
> > @@ -75,8 +75,7 @@
> >
> > (define-vop (make-closure)
> > (:args (function :to :save :scs (descriptor-reg)))
> > - (:info label length stack-allocate-p)
> > - (:ignore label)
> > + (:info length stack-allocate-p)
> > (:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
> > (:results (result :scs (descriptor-reg)))
> > (:generator 10
> > diff --git a/src/compiler/arm64/alloc.lisp b/src/compiler/arm64/alloc.lisp
> > index 78b46bdb9..d29d9bef5 100644
> > --- a/src/compiler/arm64/alloc.lisp
> > +++ b/src/compiler/arm64/alloc.lisp
> > @@ -92,22 +92,34 @@
> > (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
> > (storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
> >
> > -(define-vop (make-closure)
> > - (:info label length stack-allocate-p)
> > - (:temporary (:scs (non-descriptor-reg)) temp)
> > - (:temporary (:scs (non-descriptor-reg) :offset lr-offset) lr)
> > - (:results (result :scs (descriptor-reg)))
> > - (:generator 10
> > - (let* ((size (+ length closure-info-offset))
> > - (alloc-size (pad-data-block size)))
> > - (pseudo-atomic (lr :elide-if stack-allocate-p)
> > - (allocation nil alloc-size fun-pointer-lowtag result
> > - :flag-tn lr
> > - :stack-allocate-p stack-allocate-p)
> > - (load-immediate-word temp
> > - (logior (ash (1- size) n-widetag-bits) \
> > closure-widetag))
> > - (inst adr lr label (ash simple-fun-insts-offset word-shift))
> > - (storew-pair temp 0 lr closure-fun-slot tmp-tn)))))
> > +(macrolet
> > + ((frob (name labelp)
> > + `(define-vop (,name)
> > + ,@(unless labelp
> > + '((:args (function :to :save :scs (descriptor-reg)))))
> > + (:info ,@(when labelp '(label)) length stack-allocate-p)
> > + (:temporary (:scs (non-descriptor-reg)) temp)
> > + (:temporary (:scs (non-descriptor-reg) :offset lr-offset) lr)
> > + (:results (result :scs (descriptor-reg)))
> > + (:generator 10
> > + (let* ((size (+ length closure-info-offset))
> > + (alloc-size (pad-data-block size)))
> > + (pseudo-atomic (lr :elide-if stack-allocate-p)
> > + (allocation nil alloc-size fun-pointer-lowtag result
> > + :flag-tn lr
> > + :stack-allocate-p stack-allocate-p)
> > + (load-immediate-word temp
> > + (logior (ash (1- size) n-widetag-bits) \
> > closure-widetag)) + ,(cond (labelp
> > + `(progn
> > + (inst adr lr label (ash simple-fun-insts-offset \
> > word-shift)) + (storew-pair temp 0 lr closure-fun-slot \
> > tmp-tn))) + (t
> > + `(progn
> > + (inst sub lr function fun-pointer-lowtag)
> > + (storew-pair temp 0 lr closure-fun-slot \
> > tmp-tn)))))))))) + (frob make-closure nil)
> > + (frob make-closure-from-label t))
> >
> > ;;; The compiler likes to be able to directly make value cells.
> > ;;;
> > diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp
> > index 92a573524..afff1e3db 100644
> > --- a/src/compiler/dfo.lisp
> > +++ b/src/compiler/dfo.lisp
> > @@ -97,10 +97,10 @@
> > (values))
> >
> > ;;; This function is called on each block by FIND-INITIAL-DFO-AUX
> > -;;; before it walks the successors. It looks at the home CLAMBDA's
> > -;;; BIND block to see whether that block is in some other component:
> > +;;; before it walks the successors. It looks at the home lambda's
> > +;;; bind block to see whether that block is in some other component:
> > ;;; -- If the block is in the initial component, then do
> > -;;; DFO-SCAVENGE-DEPENDENCY-GRAPH on the home function to move it
> > +;;; DFO-WALK-CALL-GRAPH on the home function to move it
> > ;;; into COMPONENT.
> > ;;; -- If the block is in some other component, join COMPONENT into
> > ;;; it and return that component.
> > @@ -113,14 +113,14 @@
> > ;;; the same component, even when they might not seem reachable from
> > ;;; the environment entry. Consider the case of code that is only
> > ;;; reachable from a non-local exit.
> > -(defun scavenge-home-dependency-graph (block component)
> > +(defun walk-home-call-graph (block component)
> > (declare (type cblock block) (type component component))
> > (let ((home-lambda (block-home-lambda block)))
> > (if (eq (functional-kind home-lambda) :deleted)
> > component
> > (let ((home-component (lambda-component home-lambda)))
> > (cond ((eq (component-kind home-component) :initial)
> > - (dfo-scavenge-dependency-graph home-lambda component))
> > + (dfo-walk-call-graph home-lambda component))
> > ((eq home-component component)
> > component)
> > (t
> > @@ -151,7 +151,7 @@
> > ((block-flag block) component)
> > (t
> > (setf (block-flag block) t)
> > - (let ((current (scavenge-home-dependency-graph block component)))
> > + (let ((current (walk-home-call-graph block component)))
> > (dolist (succ (block-succ block))
> > (setq current (find-initial-dfo-aux succ current)))
> > (remove-from-dfo block)
> > @@ -186,17 +186,9 @@
> > (res home))))
> > (res)))
> >
> > -;;; If CLAMBDA is already in COMPONENT, just return that
> > -;;; component. Otherwise, move the code for CLAMBDA and all lambdas it
> > -;;; depends on (either because of calls or because of closure
> > -;;; relationships) into COMPONENT, or possibly into another COMPONENT
> > -;;; that we find to be related. Return whatever COMPONENT we actually
> > -;;; merged into.
> > -;;;
> > -;;; (Note: The analogous CMU CL code only scavenged call-based
> > -;;; dependencies, not closure dependencies. That seems to've been by
> > -;;; oversight, not by design, as per the bug reported by WHN on
> > -;;; cmucl-imp ca. 2001-11-29 and explained by DTC shortly after.)
> > +;;; Move the code for FUN and all functions called by it into
> > +;;; COMPONENT. If FUN is already in COMPONENT, just return that
> > +;;; component.
> > ;;;
> > ;;; If the function is in an initial component, then we move its head
> > ;;; and tail to COMPONENT and add it to COMPONENT's lambdas. It is
> > @@ -204,16 +196,16 @@
> > ;;; unreachable) because if the return is unreachable it (and its
> > ;;; successor link) will be deleted in the post-deletion pass.
> > ;;;
> > -;;; We then do a FIND-DFO-AUX starting at the head of CLAMBDA. If this
> > +;;; We then do a FIND-DFO-AUX starting at the head of FUN. If this
> > ;;; flow-graph walk encounters another component (which can only
> > ;;; happen due to a non-local exit), then we move code into that
> > ;;; component instead. We then recurse on all functions called from
> > -;;; CLAMBDA, moving code into whichever component the preceding call
> > +;;; FUN, moving code into whichever component the preceding call
> > ;;; returned.
> > ;;;
> > -;;; If CLAMBDA is in the initial component, but the BLOCK-FLAG is set
> > -;;; in the bind block, then we just return COMPONENT, since we must
> > -;;; have already reached this function in the current walk (or the
> > +;;; If FUN is in the initial component, but the BLOCK-FLAG is set in
> > +;;; the bind block, then we just return COMPONENT, since we must have
> > +;;; already reached this function in the current walk (or the
> > ;;; component would have been changed).
> > ;;;
> > ;;; If the function is an XEP, then we also walk all functions that
> > @@ -222,80 +214,48 @@
> > ;;; ensures that conversion of a full call to a local call won't
> > ;;; result in a need to join components, since the components will
> > ;;; already be one.
> > -(defun dfo-scavenge-dependency-graph (clambda component)
> > - (declare (type clambda clambda) (type component component))
> > - (aver (not (eql (lambda-kind clambda) :deleted)))
> > - (let* ((bind-block (node-block (lambda-bind clambda)))
> > - (old-lambda-component (block-component bind-block))
> > - (return (lambda-return clambda)))
> > +(defun dfo-walk-call-graph (fun component)
> > + (declare (type clambda fun) (type component component))
> > + (aver (not (eql (lambda-kind fun) :deleted)))
> > + (let* ((bind-block (node-block (lambda-bind fun)))
> > + (this (block-component bind-block))
> > + (return (lambda-return fun)))
> > (cond
> > - ((eq old-lambda-component component)
> > + ((eq this component)
> > component)
> > - ((not (eq (component-kind old-lambda-component) :initial))
> > - (join-components old-lambda-component component)
> > - old-lambda-component)
> > + ((not (eq (component-kind this) :initial))
> > + (join-components this component)
> > + this)
> > ((block-flag bind-block)
> > component)
> > (t
> > - (push clambda (component-lambdas component))
> > - (setf (component-lambdas old-lambda-component)
> > - (delete clambda (component-lambdas old-lambda-component)))
> > + (push fun (component-lambdas component))
> > + (setf (component-lambdas this)
> > + (delete fun (component-lambdas this)))
> > (link-blocks (component-head component) bind-block)
> > - (unlink-blocks (component-head old-lambda-component) bind-block)
> > + (unlink-blocks (component-head this) bind-block)
> > (when return
> > (let ((return-block (node-block return)))
> > (link-blocks return-block (component-tail component))
> > - (unlink-blocks return-block (component-tail old-lambda-component))))
> > + (unlink-blocks return-block (component-tail this))))
> > (let ((res (find-initial-dfo-aux bind-block component)))
> > (declare (type component res))
> > - ;; Scavenge related lambdas.
> > - (labels ((scavenge-lambda (clambda)
> > - (setf res
> > - (dfo-scavenge-dependency-graph (lambda-home clambda)
> > - res)))
> > - (scavenge-possibly-deleted-lambda (clambda)
> > - (unless (or (eql (lambda-kind clambda) :deleted)
> > - (eql (lambda-kind (lambda-home clambda)) \
> > :deleted))
> > - (scavenge-lambda clambda)))
> > - ;; Scavenge call relationship.
> > - (scavenge-call (called-lambda)
> > - (scavenge-lambda called-lambda))
> > - ;; Scavenge closure over a variable: if CLAMBDA
> > - ;; refers to a variable whose home lambda is not
> > - ;; CLAMBDA, then the home lambda should be in the
> > - ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
> > - ;; CL, didn't do this, leading to the occasional
> > - ;; failure when environment analysis, which is local
> > - ;; to each component, would bogusly conclude that a
> > - ;; closed-over variable was unused and thus delete
> > - ;; it. See e.g. cmucl-imp 2001-11-29.)
> > - (scavenge-closure-var (var)
> > - (when (lambda-var-refs var) ; unless var deleted
> > - (let ((var-home-home (lambda-home (lambda-var-home var))))
> > - (scavenge-possibly-deleted-lambda var-home-home))))
> > - ;; Scavenge closure over an entry for nonlocal exit.
> > - ;; This is basically parallel to closure over a
> > - ;; variable above.
> > - (scavenge-entry (entry)
> > - (declare (type entry entry))
> > - (let ((entry-home (node-home-lambda entry)))
> > - (scavenge-possibly-deleted-lambda entry-home))))
> > - (do-sset-elements (cc (lambda-calls-or-closes clambda))
> > - (etypecase cc
> > - (clambda (scavenge-call cc))
> > - (lambda-var (scavenge-closure-var cc))
> > - (entry (scavenge-entry cc))))
> > - (when (eq (lambda-kind clambda) :external)
> > - (mapc #'scavenge-call (find-reference-funs clambda))))
> > - ;; Voila.
> > - res)))))
> > + (flet ((walk (fun)
> > + (unless (eq (lambda-kind fun) :deleted)
> > + (setq res (dfo-walk-call-graph fun res)))))
> > + (do-sset-elements (fun (lambda-calls fun))
> > + (walk fun))
> > + (when (eq (lambda-kind fun) :external)
> > + (dolist (fun (find-reference-funs fun))
> > + (walk fun)))
> > + res))))))
> >
> > -;;; Return true if CLAMBDA either is an XEP or has EXITS to some of
> > -;;; its ENTRIES.
> > -(defun has-xep-or-nlx (clambda)
> > - (declare (type clambda clambda))
> > - (or (eq (functional-kind clambda) :external)
> > - (let ((entries (lambda-entries clambda)))
> > +;;; Return true if FUN either is an XEP or has EXITS to some of its
> > +;;; ENTRIES.
> > +(defun has-xep-or-nlx (fun)
> > + (declare (type clambda fun))
> > + (or (eq (functional-kind fun) :external)
> > + (let ((entries (lambda-entries fun)))
> > (and entries
> > (find-if #'entry-exits entries)))))
> >
> > @@ -307,8 +267,9 @@
> > ;;; sort are deleted.
> > (defun separate-toplevelish-components (components)
> > (declare (list components))
> > - (collect ((non-top)
> > - (top))
> > + (collect ((real)
> > + (top)
> > + (real-top))
> > (dolist (component components)
> > (unless (eq (block-next (component-head component))
> > (component-tail component))
> > @@ -326,26 +287,30 @@
> > ;; references from pure :TOPLEVEL components. -- WHN
> > has-external-references
> > (setf (component-kind component) :complex-toplevel)
> > - (non-top component))
> > + (real component)
> > + (real-top component))
> > ((or (some #'has-xep-or-nlx funs)
> > (and has-top (rest funs)))
> > (setf (component-name component)
> > (possibly-base-stringize
> > (find-component-name component)))
> > - (non-top component)
> > + (real component)
> > (when has-top
> > - (setf (component-kind component) :complex-toplevel)))
> > + (setf (component-kind component) :complex-toplevel)
> > + (real-top component)))
> > (has-top
> > (setf (component-kind component) :toplevel)
> > (setf (component-name component) "top level form")
> > (top component))
> > (t
> > (delete-component component))))))
> > - (values (non-top) (top))))
> > + (values (real) (top) (real-top))))
> >
> > -;;; Given a list of top level lambdas, return two lists of components
> > -;;; representing the actual component division. The first value is the
> > -;;; non-top-level components, and the second is the top-level ones.
> > +;;; Given a list of top-level lambdas, return three lists of components
> > +;;; representing the actual component division:
> > +;;; 1] the non-top-level components,
> > +;;; 2] and the second is the top-level components, and
> > +;;; 3] Components in [1] that also have a top-level lambda.
> > ;;;
> > ;;; We assign the DFO for each component, and delete any unreachable
> > ;;; blocks. We assume that the FLAGS have already been cleared.
> > @@ -367,8 +332,7 @@
> > (aver (member (functional-kind component-lambda)
> > '(:optional :external :toplevel nil :escape
> > > cleanup)))
> > - (let ((res (dfo-scavenge-dependency-graph component-lambda
> > - new)))
> > + (let ((res (dfo-walk-call-graph component-lambda new)))
> > (when (eq res new)
> > (aver (not (member new (components))))
> > (components new)
> > @@ -390,6 +354,9 @@
> > (do-blocks-backwards (block component :both)
> > (setf (block-number block) (incf num)))))
> >
> > + (dolist (component (components))
> > + (delete-if-no-entries component))
> > +
> > ;; Pull out top-level-ish code.
> > (separate-toplevelish-components (components))))
> >
> > diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp
> > index b0784c2d9..6a8603922 100644
> > --- a/src/compiler/entry.lisp
> > +++ b/src/compiler/entry.lisp
> > @@ -51,10 +51,8 @@
> > (declare (type clambda fun) (type entry-info info))
> > (let ((bind (lambda-bind fun))
> > (internal-fun (functional-entry-fun fun)))
> > - (setf (entry-info-closure-tn info)
> > - (if (environment-closure (lambda-environment fun))
> > - (make-normal-tn *backend-t-primitive-type*)
> > - nil))
> > + (setf (entry-info-closure-p info)
> > + (not (null (environment-closure (lambda-environment fun)))))
> > (setf (entry-info-offset info) (gen-label))
> > (setf (entry-info-name info)
> > (leaf-debug-name internal-fun))
> > diff --git a/src/compiler/envanal.lisp b/src/compiler/envanal.lisp
> > index aba7480a2..dd26564fc 100644
> > --- a/src/compiler/envanal.lisp
> > +++ b/src/compiler/envanal.lisp
> > @@ -32,6 +32,8 @@
> > (eq (functional-kind x) :deleted))
> > (component-new-functionals component)))
> > (setf (component-new-functionals component) ())
> > + (dolist (fun (component-lambdas component))
> > + (reinit-lambda-environment fun))
> > (mapc #'add-lambda-vars-and-let-vars-to-closures
> > (component-lambdas component))
> >
> > @@ -52,6 +54,21 @@
> >
> > (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 (add-lambda-vars-and-let-vars-to-closures lambda)
> > + (setq found-it t)))
> > + found-it))
> > +
> > ;;; If FUN has an environment, return it, otherwise assign an empty
> > ;;; one and return that.
> > (defun get-lambda-environment (fun)
> > @@ -64,6 +81,30 @@
> > (setf (lambda-environment lambda) res))
> > res))))
> >
> > +;;; If FUN has no environment, assign one, otherwise clean up
> > +;;; 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))
> > @@ -348,7 +389,7 @@
> > (let ((xep (functional-entry-fun fun)))
> > ;; We need to have a closure environment to dynamic-extent
> > ;; allocate.
> > - (when (and xep (environment-closure (get-lambda-environment xep)))
> > + (when (and xep (environment-closure (lambda-environment xep)))
> > (let ((enclose (functional-enclose fun)))
> > (when (and enclose (not (node-lvar enclose)))
> > (let ((lvar (make-lvar)))
> > diff --git a/src/compiler/ir1-translators.lisp \
> > b/src/compiler/ir1-translators.lisp index 7c614d500..780c41064 100644
> > --- a/src/compiler/ir1-translators.lisp
> > +++ b/src/compiler/ir1-translators.lisp
> > @@ -152,9 +152,6 @@ extent of the block."
> > (ir1-convert start value-ctran value-lvar value)
> > (push exit (entry-exits entry))
> > (link-node-to-previous-ctran exit value-ctran)
> > - (let ((home-lambda (ctran-home-lambda-or-null start)))
> > - (when home-lambda
> > - (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
> > (use-continuation exit exit-ctran (third found))))
> >
> > ;;; Return a list of the segments of a TAGBODY. Each segment looks
> > @@ -244,9 +241,6 @@ constrained to be used only within the dynamic extent of the \
> > TAGBODY." (exit (make-exit :entry entry)))
> > (push exit (entry-exits entry))
> > (link-node-to-previous-ctran exit start)
> > - (let ((home-lambda (ctran-home-lambda-or-null start)))
> > - (when home-lambda
> > - (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
> > (use-ctran exit (second found))))
> >
> > ;;;; translators for compiler-magic special forms
> > @@ -1240,9 +1234,6 @@ care."
> > (when (constant-p leaf)
> > (compiler-error "~S is a constant and thus can't be set." name))
> > (when (lambda-var-p leaf)
> > - (let ((home-lambda (ctran-home-lambda-or-null start)))
> > - (when (and home-lambda (neq (lambda-var-home leaf) home-lambda))
> > - (sset-adjoin leaf (lambda-calls-or-closes home-lambda))))
> > (when (lambda-var-ignorep leaf)
> > ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
> > ;; requires that this be a STYLE-WARNING, not a full warning.
> > diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
> > index cd7b15575..c6ea06952 100644
> > --- a/src/compiler/ir1opt.lisp
> > +++ b/src/compiler/ir1opt.lisp
> > @@ -343,16 +343,6 @@
> > ~% ~S~%*** possible internal error? Please report this."
> > (type-specifier rtype) (type-specifier node-type))))
> > (setf (node-derived-type node) int)
> > - ;; If the new type consists of only one object, replace the
> > - ;; node with a constant reference.
> > - (when (and (ref-p node)
> > - (lambda-var-p (ref-leaf node)))
> > - (let ((type (single-value-type int)))
> > - (when (and (member-type-p type)
> > - (eql (member-type-size type) 1)
> > - (not (preserve-single-use-debug-var-p node (ref-leaf \
> > node))))
> > - (change-ref-leaf node (find-constant
> > - (first (member-type-members type)))))))
> > (reoptimize-lvar lvar)))))
> > (values))
> >
> > @@ -2299,9 +2289,11 @@
> > (let ((use-component (node-component use)))
> > (substitute-leaf-if
> > (lambda (ref)
> > - ;; Some unreachable function may be in a different \
> > component,
> > - ;; don't worry about it
> > - (eq (node-component ref) use-component))
> > + (cond ((eq (node-component ref) use-component)
> > + t)
> > + (t
> > + (aver (lambda-toplevelish-p (lambda-home \
> > fun))) + nil)))
> > leaf var)))
> > t))))))
> > ((and arg
> > diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
> > index 17dd02a7a..c9316aa65 100644
> > --- a/src/compiler/ir1tran.lisp
> > +++ b/src/compiler/ir1tran.lisp
> > @@ -708,9 +708,6 @@
> > (etypecase var
> > (leaf
> > (when (lambda-var-p var)
> > - (let ((home (ctran-home-lambda-or-null start)))
> > - (when (and home (neq (lambda-var-home var) home))
> > - (sset-adjoin var (lambda-calls-or-closes home))))
> > (when (lambda-var-ignorep var)
> > ;; (ANSI's specification for the IGNORE declaration requires
> > ;; that this be a STYLE-WARNING, not a full WARNING.)
> > diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
> > index 8c3485e79..090a8b616 100644
> > --- a/src/compiler/ir1util.lisp
> > +++ b/src/compiler/ir1util.lisp
> > @@ -1629,13 +1629,8 @@
> > (defun delete-ref (ref)
> > (declare (type ref ref))
> > (let* ((leaf (ref-leaf ref))
> > - (refs (delq1 ref (leaf-refs leaf)))
> > - (home (node-home-lambda ref)))
> > + (refs (delq1 ref (leaf-refs leaf))))
> > (setf (leaf-refs leaf) refs)
> > - (when (and (typep leaf '(or clambda lambda-var))
> > - (not (find home refs :key #'node-home-lambda)))
> > - ;; It was the last reference from this lambda, remove it
> > - (sset-delete leaf (lambda-calls-or-closes home)))
> > (cond ((null refs)
> > (typecase leaf
> > (lambda-var
> > diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
> > index fb827cae8..fc7fe1b0a 100644
> > --- a/src/compiler/ir2tran.lisp
> > +++ b/src/compiler/ir2tran.lisp
> > @@ -53,7 +53,10 @@
> > (ir2-nlx-info-home (nlx-info-info thing)))
> > (clambda
> > (aver (xep-p thing))
> > - (entry-info-closure-tn (lambda-info thing))))
> > + (let ((entry-info (lambda-info thing)))
> > + (or (entry-info-closure-tn entry-info)
> > + (setf (entry-info-closure-tn entry-info)
> > + (make-normal-tn *backend-t-primitive-type*))))))
> > (bug "~@<~2I~_~S ~_not found in ~_~S~:>" thing env)))
> >
> > ;;; Return a TN that represents the value of LEAF, or NIL if LEAF
> > @@ -289,18 +292,28 @@
> > ;; If there is no XEP then no closure needs to be created.
> > (when (and xep (not (eq (functional-kind xep) :deleted)))
> > (aver (xep-p xep))
> > + (unless (leaf-info xep)
> > + (setf (leaf-info xep)
> > + (make-entry-info :name
> > + (functional-debug-name fun))))
> > (let ((closure (environment-closure (get-lambda-environment xep))))
> > (when closure
> > - (let* ((entry-info (lambda-info xep))
> > - (tn (entry-info-closure-tn entry-info))
> > - #-(or x86-64 arm64)
> > - (entry (make-load-time-constant-tn :entry xep))
> > - (env (node-environment node))
> > + (let* ((env (node-environment node))
> > + (tn (find-in-environment xep env))
> > (leaf-dx-p (and lvar (leaf-dynamic-extent fun))))
> > - (aver (entry-info-offset entry-info))
> > - (vop make-closure node ir2-block #-(or x86-64 arm64) entry
> > - (entry-info-offset entry-info) (length \
> > closure)
> > - leaf-dx-p tn)
> > + (cond
> > + #+(or x86-64 arm64)
> > + ((eq (node-component node)
> > + (lambda-component xep))
> > + (vop make-closure-from-label node ir2-block
> > + (entry-info-offset (lambda-info xep))
> > + (length closure)
> > + leaf-dx-p tn))
> > + (t
> > + (vop make-closure node ir2-block
> > + (make-load-time-constant-tn :entry xep)
> > + (length closure)
> > + leaf-dx-p tn)))
> > (loop for what in closure and n from 0 do
> > (unless (and (lambda-var-p what)
> > (null (leaf-refs what)))
> > diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
> > index 1e4524f4c..3e1852688 100644
> > --- a/src/compiler/locall.lisp
> > +++ b/src/compiler/locall.lisp
> > @@ -154,7 +154,7 @@
> > (declare (type ref ref) (type combination call) (type clambda fun))
> > (propagate-to-args call fun)
> > (setf (basic-combination-kind call) :local)
> > - (sset-adjoin fun (lambda-calls-or-closes (node-home-lambda call)))
> > + (sset-adjoin fun (lambda-calls (node-home-lambda call)))
> > (recognize-potentially-dynamic-extent-lvars call fun)
> > (merge-tail-sets call fun)
> > (change-ref-leaf ref fun)
> > @@ -603,7 +603,7 @@
> > (call-all-args-fixed-p call)))
> > (aver (= (optional-dispatch-min-args fun) 0))
> > (setf (basic-combination-kind call) :local)
> > - (sset-adjoin ep (lambda-calls-or-closes (node-home-lambda call)))
> > + (sset-adjoin ep (lambda-calls (node-home-lambda call)))
> > (merge-tail-sets call ep)
> > (change-ref-leaf ref ep)
> > (if (singleton-p args)
> > @@ -1034,13 +1034,12 @@
> > (setf (lambda-lets clambda) nil)
> >
> > ;; HOME no longer calls CLAMBDA, and owns all of CLAMBDA's old
> > - ;; DFO dependencies.
> > - (sset-union (lambda-calls-or-closes home)
> > - (lambda-calls-or-closes clambda))
> > - (sset-delete clambda (lambda-calls-or-closes home))
> > + ;; calls.
> > + (sset-union (lambda-calls home) (lambda-calls clambda))
> > + (sset-delete clambda (lambda-calls home))
> > ;; CLAMBDA no longer has an independent existence as an entity
> > - ;; which calls things or has DFO dependencies.
> > - (setf (lambda-calls-or-closes clambda) nil)
> > + ;; which calls things.
> > + (setf (lambda-calls clambda) nil)
> > ;; Make sure the exits that are no longer non-local are deleted
> > (loop for entry in (lambda-entries home)
> > do (loop for exit in (entry-exits entry)
> > @@ -1100,40 +1099,39 @@
> > ;;; all calls were TR.)
> > (defun unconvert-tail-calls (fun call next-block)
> > (let (maybe-terminate)
> > - (do-sset-elements (called (lambda-calls-or-closes fun))
> > - (when (lambda-p called)
> > - (dolist (ref (leaf-refs called))
> > - (let ((this-call (node-dest ref)))
> > - (when (and this-call
> > - (node-tail-p this-call)
> > - (not (node-to-be-deleted-p this-call))
> > - (eq (node-home-lambda this-call) fun))
> > - (setf (node-tail-p this-call) nil)
> > - (ecase (functional-kind called)
> > - ((nil :cleanup :optional)
> > - (let ((block (node-block this-call))
> > - (lvar (node-lvar call)))
> > - (unlink-blocks block (first (block-succ block)))
> > - (link-blocks block next-block)
> > - (if (eq (node-derived-type this-call) *empty-type*)
> > - ;; Delay terminating the block, because there may be more \
> > calls
> > - ;; to be processed here and this may prematurely delete \
> > NEXT-BLOCK
> > - ;; before we attach more preceding blocks to it.
> > - ;; Although probably if one call to a function
> > - ;; is derived to be NIL all other calls would
> > - ;; be NIL too, but that may not be available at the same \
> > time.
> > - ;; (Or something is smart in the future to
> > - ;; derive different results from different
> > - ;; calls.)
> > - (push this-call maybe-terminate)
> > - (add-lvar-use this-call lvar))))
> > - (:deleted)
> > - ;; The called function might be an assignment in the
> > - ;; case where we are currently converting that function.
> > - ;; In steady-state, assignments never appear as a called
> > - ;; function.
> > - (:assignment
> > - (aver (eq called fun)))))))))
> > + (do-sset-elements (called (lambda-calls fun))
> > + (dolist (ref (leaf-refs called))
> > + (let ((this-call (node-dest ref)))
> > + (when (and this-call
> > + (node-tail-p this-call)
> > + (not (node-to-be-deleted-p this-call))
> > + (eq (node-home-lambda this-call) fun))
> > + (setf (node-tail-p this-call) nil)
> > + (ecase (functional-kind called)
> > + ((nil :cleanup :optional)
> > + (let ((block (node-block this-call))
> > + (lvar (node-lvar call)))
> > + (unlink-blocks block (first (block-succ block)))
> > + (link-blocks block next-block)
> > + (if (eq (node-derived-type this-call) *empty-type*)
> > + ;; Delay terminating the block, because there may be more \
> > calls + ;; to be processed here and this may prematurely \
> > delete NEXT-BLOCK + ;; before we attach more preceding blocks \
> > to it. + ;; Although probably if one call to a function
> > + ;; is derived to be NIL all other calls would
> > + ;; be NIL too, but that may not be available at the same \
> > time. + ;; (Or something is smart in the future to
> > + ;; derive different results from different
> > + ;; calls.)
> > + (push this-call maybe-terminate)
> > + (add-lvar-use this-call lvar))))
> > + (:deleted)
> > + ;; The called function might be an assignment in the
> > + ;; case where we are currently converting that function.
> > + ;; In steady-state, assignments never appear as a called
> > + ;; function.
> > + (:assignment
> > + (aver (eq called fun))))))))
> > maybe-terminate))
> >
> > ;;; Deal with returning from a LET or assignment that we are
> > diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
> > index aa38f8202..c690d72e6 100644
> > --- a/src/compiler/main.lisp
> > +++ b/src/compiler/main.lisp
> > @@ -772,8 +772,6 @@ necessary, since type inference may take arbitrarily long to \
> > converge.") (environment-analyze component)
> > (dfo-as-needed component)
> >
> > - (delete-if-no-entries component)
> > -
> > (if (eq (block-next (component-head component))
> > (component-tail component))
> > (report-code-deletion)
> > @@ -848,7 +846,7 @@ necessary, since type inference may take arbitrarily long to \
> > converge.") (format t "~4TL~D: ~S~:[~; [closure]~]~%"
> > (label-id (entry-info-offset entry))
> > (entry-info-name entry)
> > - (entry-info-closure-tn entry)))
> > + (entry-info-closure-p entry)))
> > (terpri)
> > (pre-pack-tn-stats component *standard-output*)
> > (terpri)
> > @@ -1572,13 +1570,16 @@ necessary, since type inference may take arbitrarily long \
> > to converge.") (locall-analyze-clambdas-until-done lambdas)
> >
> > (maybe-mumble "IDFO ")
> > - (multiple-value-bind (components top-components)
> > + (multiple-value-bind (components top-components hairy-top)
> > (find-initial-dfo lambdas)
> > (when *check-consistency*
> > (maybe-mumble "[Check]~%")
> > (check-ir1-consistency (append components top-components)))
> >
> > (let ((top-level-closure nil))
> > + (dolist (component (append hairy-top top-components))
> > + (when (pre-environment-analyze-top-level component)
> > + (setq top-level-closure t)))
> > (dolist (component components)
> > (compile-component component)
> > (when (replace-toplevel-xeps component)
> > diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp
> > index 930e8210b..ea682105c 100644
> > --- a/src/compiler/mips/alloc.lisp
> > +++ b/src/compiler/mips/alloc.lisp
> > @@ -147,8 +147,7 @@
> >
> > (define-vop (make-closure)
> > (:args (function :to :save :scs (descriptor-reg)))
> > - (:info label length stack-allocate-p)
> > - (:ignore label)
> > + (:info length stack-allocate-p)
> > (:temporary (:scs (non-descriptor-reg)) temp)
> > (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
> > (:results (result :scs (descriptor-reg)))
> > diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
> > index 067c84ad1..7027bbbd9 100644
> > --- a/src/compiler/node.lisp
> > +++ b/src/compiler/node.lisp
> > @@ -711,13 +711,8 @@
> > (defstruct (environment (:copier nil))
> > ;; the function that allocates this environment
> > (lambda (missing-arg) :type clambda :read-only t)
> > - ;; 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
> > - ;; * 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
> > + ;; a list of all the LAMBDA-VARS and NLX-INFOs needed from enclosing
> > + ;; environments by code in this environment.
> > (closure nil :type list)
> > ;; a list of NLX-INFO structures describing all the non-local exits
> > ;; into this environment
> > @@ -1213,11 +1208,10 @@
> > (lets nil :type list)
> > ;; all the ENTRY nodes in this function and its LETs, or null in a LET
> > (entries nil :type list)
> > - ;; CLAMBDAs which are locally called by this lambda, and other
> > - ;; objects (closed-over LAMBDA-VARs and XEPs) which this lambda
> > - ;; depends on in such a way that DFO shouldn't put them in separate
> > - ;; components.
> > - (calls-or-closes (make-sset) :type (or null sset))
> > + ;; a set of all the functions directly called from this function
> > + ;; (or one of its LETs) using a non-LET local call. This may include
> > + ;; deleted functions because nobody bothers to clear them out.
> > + (calls (make-sset) :type (or null sset))
> > ;; the TAIL-SET that this LAMBDA is in. This is null during creation.
> > ;;
> > ;; In CMU CL, and old SBCL, this was also NILed out when LET
> > diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp
> > index da0288b20..1fedba1b1 100644
> > --- a/src/compiler/ppc/alloc.lisp
> > +++ b/src/compiler/ppc/alloc.lisp
> > @@ -155,8 +155,7 @@
> >
> > (define-vop (make-closure)
> > (:args (function :to :save :scs (descriptor-reg)))
> > - (:info label length stack-allocate-p)
> > - (:ignore label)
> > + (:info length stack-allocate-p)
> > (:temporary (:scs (non-descriptor-reg)) temp)
> > (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
> > (:results (result :scs (descriptor-reg)))
> > diff --git a/src/compiler/ppc64/alloc.lisp b/src/compiler/ppc64/alloc.lisp
> > index 6c49b49ad..5b6e87369 100644
> > --- a/src/compiler/ppc64/alloc.lisp
> > +++ b/src/compiler/ppc64/alloc.lisp
> > @@ -168,8 +168,7 @@
> >
> > (define-vop (make-closure)
> > (:args (function :to :save :scs (descriptor-reg)))
> > - (:info label length stack-allocate-p)
> > - (:ignore label)
> > + (:info length stack-allocate-p)
> > (:temporary (:scs (non-descriptor-reg)) temp)
> > (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
> > (:results (result :scs (descriptor-reg)))
> > diff --git a/src/compiler/riscv/alloc.lisp b/src/compiler/riscv/alloc.lisp
> > index 8ab305c0d..4ab07c344 100644
> > --- a/src/compiler/riscv/alloc.lisp
> > +++ b/src/compiler/riscv/alloc.lisp
> > @@ -129,8 +129,7 @@
> >
> > (define-vop (make-closure)
> > (:args (function :to :save :scs (descriptor-reg)))
> > - (:info label length stack-allocate-p)
> > - (:ignore label)
> > + (:info length stack-allocate-p)
> > (:temporary (:sc non-descriptor-reg) pa-flag)
> > (:results (result :scs (descriptor-reg)))
> > (:generator 10
> > diff --git a/src/compiler/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp
> > index 8188806f7..70ac49a22 100644
> > --- a/src/compiler/sparc/alloc.lisp
> > +++ b/src/compiler/sparc/alloc.lisp
> > @@ -72,8 +72,7 @@
> >
> > (define-vop (make-closure)
> > (:args (function :to :save :scs (descriptor-reg)))
> > - (:info label length stack-allocate-p)
> > - (:ignore label)
> > + (:info length stack-allocate-p)
> > (:temporary (:scs (non-descriptor-reg)) temp)
> > (:results (result :scs (descriptor-reg)))
> > (:generator 10
> > diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp
> > index c0aee1d89..b526c6caa 100644
> > --- a/src/compiler/vop.lisp
> > +++ b/src/compiler/vop.lisp
> > @@ -388,6 +388,8 @@
> > ;;; this case the slots aren't actually initialized until entry
> > ;;; analysis runs.
> > (defstruct (entry-info (:copier nil))
> > + ;; True if this function has a non-null closure environment.
> > + (closure-p nil :type boolean)
> > ;; TN, containing closure (if needed) for this function in the home
> > ;; environment.
> > (closure-tn nil :type (or null tn))
> > diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
> > index f7db0a91c..cc78bd249 100644
> > --- a/src/compiler/x86-64/alloc.lisp
> > +++ b/src/compiler/x86-64/alloc.lisp
> > @@ -854,43 +854,47 @@
> > (storew (make-fixup 'undefined-tramp :assembly-routine)
> > result fdefn-raw-addr-slot other-pointer-lowtag)))
> >
> > -(define-vop (make-closure)
> > - (:info label length stack-allocate-p)
> > - (:temporary (:sc any-reg) temp)
> > - #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
> > - (:results (result :scs (descriptor-reg)))
> > - (:node-var node)
> > - (:generator 10
> > - (let* ((words (+ length closure-info-offset)) ; including header
> > - (bytes (pad-data-block words))
> > - (header (logior (ash (1- words) n-widetag-bits) closure-widetag)))
> > - (unless stack-allocate-p
> > - (instrument-alloc closure-widetag bytes node (list result temp) \
> > thread-tn))
> > - (pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn)
> > - (if stack-allocate-p
> > - (stack-allocation bytes fun-pointer-lowtag result)
> > - (allocation nil bytes fun-pointer-lowtag result node temp \
> > thread-tn))
> > - (storew* #-immobile-space header ; write the widetag and size
> > - #+immobile-space ; ... plus the layout pointer
> > - (let ((layout #-sb-thread (static-symbol-value-ea \
> > 'function-layout)
> > - #+sb-thread (thread-slot-ea \
> > thread-function-layout-slot)))
> > - (cond ((typep header '(unsigned-byte 16))
> > - (inst mov temp layout)
> > - ;; emit a 2-byte constant, the low 4 of TEMP were \
> > zeroed
> > - (inst mov :word temp header))
> > - (t
> > - (inst mov temp header)
> > - (inst or temp layout)))
> > - temp)
> > - result 0 fun-pointer-lowtag (not stack-allocate-p)))
> > - ;; Finished with the pseudo-atomic instructions
> > - ;; TODO: gencgc does not need EMIT-GC-STORE-BARRIER here, but other other \
> > GC strategies might.
> > - (inst lea temp (rip-relative-ea label (ash simple-fun-insts-offset \
> > word-shift)))
> > - (storew temp result closure-fun-slot fun-pointer-lowtag)
> > - #+metaspace
> > - (let ((origin (sb-assem::asmstream-data-origin-label \
> > sb-assem:*asmstream*)))
> > - (inst lea temp (rip-relative-ea origin :code))
> > - (storew temp result closure-code-slot fun-pointer-lowtag)))))
> > +(macrolet
> > + ((frob (name labelp)
> > + `(define-vop (,name)
> > + ,@(unless labelp
> > + '((:args (function :to :save :scs (descriptor-reg)))))
> > + (:info ,@(when labelp '(label)) length stack-allocate-p)
> > + (:temporary (:sc any-reg) temp)
> > + #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
> > + (:results (result :scs (descriptor-reg)))
> > + (:node-var node)
> > + (:generator 10
> > + (let* ((words (+ length closure-info-offset)) ; including header
> > + (bytes (pad-data-block words))
> > + (header (logior (ash (1- words) n-widetag-bits) \
> > closure-widetag))) + (unless stack-allocate-p
> > + (instrument-alloc closure-widetag bytes node (list result temp) \
> > thread-tn)) + (pseudo-atomic (:elide-if stack-allocate-p :thread-tn \
> > thread-tn) + (if stack-allocate-p
> > + (stack-allocation bytes fun-pointer-lowtag result)
> > + (allocation nil bytes fun-pointer-lowtag result node temp \
> > thread-tn)) + (storew* #-immobile-space header ; write the widetag \
> > and size + #+immobile-space ; ... plus the layout \
> > pointer + (let ((layout #-sb-thread \
> > (static-symbol-value-ea 'function-layout) + \
> > #+sb-thread (thread-slot-ea thread-function-layout-slot))) + \
> > (cond ((typep header '(unsigned-byte 16)) + \
> > (inst mov temp layout) + ;; emit a 2-byte \
> > constant, the low 4 of TEMP were zeroed + (inst \
> > mov :word temp header)) + (t
> > + (inst mov temp header)
> > + (inst or temp layout)))
> > + temp)
> > + result 0 fun-pointer-lowtag (not stack-allocate-p)))
> > + ;; Finished with the pseudo-atomic instructions
> > + ;; TODO: gencgc does not need EMIT-GC-STORE-BARRIER here, but \
> > other other GC strategies might. + (inst lea temp ,(if labelp
> > + `(rip-relative-ea label (ash \
> > simple-fun-insts-offset word-shift)) + \
> > `(object-slot-ea function simple-fun-insts-offset fun-pointer-lowtag))) + \
> > (storew temp result closure-fun-slot fun-pointer-lowtag)))))) + (frob \
> > make-closure nil) + (frob make-closure-from-label t))
> >
> > ;;; The compiler likes to be able to directly make value cells.
> > (define-vop (make-value-cell)
> > diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
> > index 54b417855..50dd9c055 100644
> > --- a/src/compiler/x86/alloc.lisp
> > +++ b/src/compiler/x86/alloc.lisp
> > @@ -330,8 +330,7 @@
> >
> > (define-vop (make-closure)
> > (:args (function :to :save :scs (descriptor-reg)))
> > - (:info label length stack-allocate-p)
> > - (:ignore label)
> > + (:info length stack-allocate-p)
> > (:temporary (:sc any-reg) temp)
> > (:results (result :scs (descriptor-reg)))
> > (:node-var node)
> > diff --git a/tests/compiler-2.impure.lisp b/tests/compiler-2.impure.lisp
> > index 20545967f..de0ac9759 100644
> > --- a/tests/compiler-2.impure.lisp
> > +++ b/tests/compiler-2.impure.lisp
> > @@ -87,3 +87,55 @@
> > `(lambda (x) (declare (type vector x)) (reduce #'+ x))
> > ((#(1 2 3)) 6)
> > (((make-array 3 :element-type '(unsigned-byte 8) :initial-contents '(4 5 6))) \
> > 15))) +
> > +;;; We do not want functions closing over top level bindings to retain
> > +;;; load-time code in the component when not necessary.
> > +(with-test (:name :top-level-closure-separate-component)
> > + (ctu:file-compile
> > + `((let ((x (random 10)))
> > + (defun top-level-closure-1 ()
> > + x)
> > + (setq x 4)))
> > + :load t)
> > + ;; Check there's no top level code hanging out.
> > + (assert (= 1 (sb-kernel::code-n-entries (sb-kernel::fun-code-header \
> > (sb-kernel::%closure-fun #'top-level-closure-1))))) + (assert (= \
> > (top-level-closure-1) 4))) +
> > +(with-test (:name :top-level-closure-separate-component.2)
> > + (ctu:file-compile
> > + `((let ((x (random 10)))
> > + (flet ((bar () x))
> > + (defun top-level-closure-2 ()
> > + #'bar))
> > + (setq x 4)))
> > + :load t)
> > + ;; Check there's no top level code hanging out. (We expect to only
> > + ;; have (FLET BAR) and TOP-LEVEL-CLOSURE-2 present.)
> > + (assert (= 2 (sb-kernel::code-n-entries (sb-kernel::fun-code-header \
> > (sb-kernel::%closure-fun #'top-level-closure-2))))) + (assert (= (funcall \
> > (top-level-closure-2)) 4))) +
> > +(with-test (:name :dead-code-dfo-puking)
> > + (ctu:file-compile
> > + `((defun dead-code-puke-1 ()
> > + (let ((bar (read)))
> > + (labels ((emplace (thing)
> > + (print thing))
> > + (visit (thing)
> > + (case thing
> > + (0 (visit-code thing))
> > + (1 (visit-code thing))
> > + (2 (visit thing))
> > + (3 (visit thing))))
> > + (visit-code (thing)
> > + (when (read)
> > + (return-from visit-code))
> > + (print bar)
> > + (case thing
> > + (1 (visit thing))
> > + (2 (visit thing))
> > + (3 (map nil #'visit (list thing thing))))))
> > + (emplace nil)))))
> > + :load t)
> > + ;; EMPLACE will have been LET-converted. VISIT and VISIT-CODE should
> > + ;; have been separated out or simply deleted.
> > + (assert (= 1 (sb-kernel::code-n-entries (sb-kernel::fun-code-header \
> > #'dead-code-puke-1)))))
> > -----------------------------------------------------------------------
> >
> >
> > hooks/post-receive
> > --
> > SBCL
> >
> >
> > _______________________________________________
> > Sbcl-commits mailing list
> > Sbcl-commits@lists.sourceforge.net
> > https://lists.sourceforge.net/lists/listinfo/sbcl-commits
_______________________________________________
Sbcl-devel mailing list
Sbcl-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-devel
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic