From: Alexey Dejneka Date: Sat, 8 Jan 2005 09:41:46 +0000 (+0000) Subject: 0.8.18.20: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=fae139755a81c0431e7f12f2af9b5f3abc1326dc;p=sbcl.git 0.8.18.20: * Allocate closures at the beginning of FLET/LABELS form. ... fix bug 125. * Partial support of stack allocation of dynamic-extent closures on x86. --- diff --git a/BUGS b/BUGS index 49b4c25..a5e9e22 100644 --- a/BUGS +++ b/BUGS @@ -379,24 +379,6 @@ WORKAROUND: a STYLE-WARNING for references to variables similar to locals might be a good thing.) -125: - (as reported by Gabe Garza on cmucl-help 2001-09-21) - (defvar *tmp* 3) - (defun test-pred (x y) - (eq x y)) - (defun test-case () - (let* ((x *tmp*) - (func (lambda () x))) - (print (eq func func)) - (print (test-pred func func)) - (delete func (list func)))) - Now calling (TEST-CASE) gives output - NIL - NIL - (#) - Evidently Python thinks of the lambda as a code transformation so - much that it forgets that it's also an object. - 135: Ideally, uninterning a symbol would allow it, and its associated FDEFINITION and PROCLAIM data, to be reclaimed by the GC. However, diff --git a/NEWS b/NEWS index 1190b53..40dbd05 100644 --- a/NEWS +++ b/NEWS @@ -13,8 +13,12 @@ changes in sbcl-0.8.19 relative to sbcl-0.8.18: produces an error. (thanks to Vincent Arkesteijn) * bug fix: NAMESTRING on pathnames with :WILD components in their directories works correctly. (thanks to Artem V. Andreev) + * fixed bug 125: compiler preserves identity of closures. (reported + by Gabe Garza) * build fix: fixed the dependence on *LOAD-PATHNAME* and *COMPILE-FILE-PATHNAME* being absolute pathnames. + * on x86 compiler partially supports stack allocation of dynamic-extent + closures. * fixed some bugs related to Unicode integration: ** encoding and decoding errors are now much more robustly handled; it should now be possible to recover even from invalid diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index 622a1b4..08f1a71 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -272,7 +272,7 @@ ;; :control-stack-grows-downward-not-upward ;; On the X86, the Lisp control stack grows downward. On the ;; other supported CPU architectures as of sbcl-0.7.1.40, the - ;; system stack grows upward. + ;; system stack grows upward. ;; Note that there are other stack-related differences between the ;; X86 port and the other ports. E.g. on the X86, the Lisp control ;; stack coincides with the C stack, meaning that on the X86 there's @@ -281,6 +281,9 @@ ;; just parameterized by #!+X86, but it'd probably be better to ;; use new flags like :CONTROL-STACK-CONTAINS-C-STACK. ;; + ;; :stack-allocatable-closures + ;; The compiler can allocate dynamic-extent closures on stack. + ;; ;; operating system features: ;; :linux = We're intended to run under some version of Linux. ;; :bsd = We're intended to run under some version of BSD Unix. (This diff --git a/make-config.sh b/make-config.sh index 238bc8a..fe1981c 100644 --- a/make-config.sh +++ b/make-config.sh @@ -187,6 +187,7 @@ cd $original_dir # similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03 if [ "$sbcl_arch" = "x86" ]; then printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf + printf ' :stack-allocatable-closures' >> $ltf if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ]; then printf ' :linkage-table' >> $ltf fi diff --git a/make-target-2.sh b/make-target-2.sh index fc8aa53..fb27e27 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -90,6 +90,7 @@ echo //doing warm init #+sb-show (setf sb-int:*/show* nil) ;; The system is complete now, all standard functions are ;; defined. + (sb-kernel::ctype-of-cache-clear) (setq sb-c::*flame-on-necessarily-undefined-function* t) (sb-ext:save-lisp-and-die "output/sbcl.core" :purify t) EOF diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp index 36e7f0a..285910c 100644 --- a/src/compiler/alpha/alloc.lisp +++ b/src/compiler/alpha/alloc.lisp @@ -113,7 +113,8 @@ (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) - (:info length) + (:info length stack-allocate-p) + (:ignore stack-allocate-p) (:temporary (:scs (non-descriptor-reg)) temp) (:results (result :scs (descriptor-reg))) (:generator 10 diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 248d83e..5f955ee 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -36,8 +36,10 @@ (declare (type clambda fun) (type entry-info info)) (let ((bind (lambda-bind fun)) (internal-fun (functional-entry-fun fun))) - (setf (entry-info-closure-p info) - (not (null (physenv-closure (lambda-physenv fun))))) + (setf (entry-info-closure-tn info) + (if (physenv-closure (lambda-physenv fun)) + (make-normal-tn *backend-t-primitive-type*) + nil)) (setf (entry-info-offset info) (gen-label)) (setf (entry-info-name info) (leaf-debug-name internal-fun)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index d98fc92..7297776 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1382,6 +1382,7 @@ (defknown %%primitive (t t &rest t) *) (defknown %pop-values (t) t) (defknown %nip-values (t t &rest t) (values)) +(defknown %allocate-closures (t) *) (defknown %type-check-error (t t) nil) ;; FIXME: This function does not return, but due to the implementation diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 0c0d873..a6d56ea 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -68,7 +68,8 @@ (if (lambda-var-indirect thing) *backend-t-primitive-type* (primitive-type (leaf-type thing)))) - (nlx-info *backend-t-primitive-type*)))) + (nlx-info *backend-t-primitive-type*) + (clambda *backend-t-primitive-type*)))) (push (cons thing (make-normal-tn ptype)) reversed-ir2-physenv-alist))) diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp index ec83f9e..ec80da7 100644 --- a/src/compiler/hppa/alloc.lisp +++ b/src/compiler/hppa/alloc.lisp @@ -104,7 +104,8 @@ (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) - (:info length) + (:info length stack-allocate-p) + (:ignore stack-allocate-p) (:temporary (:scs (non-descriptor-reg)) temp) (:results (result :scs (descriptor-reg))) (:generator 10 diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 594999d..274ce42 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -440,23 +440,45 @@ (cond ((member (car thing) '(lambda named-lambda instance-lambda lambda-with-lexenv)) - (ir1-convert-lambdalike - thing - :debug-name (debug-namify "#'" thing))) + (values (ir1-convert-lambdalike + thing + :debug-name (debug-namify "#'" thing)) + t)) ((legal-fun-name-p thing) - (find-lexically-apparent-fun - thing "as the argument to FUNCTION")) + (values (find-lexically-apparent-fun + thing "as the argument to FUNCTION") + nil)) (t (compiler-error "~S is not a legal function name." thing))) - (find-lexically-apparent-fun - thing "as the argument to FUNCTION"))) + (values (find-lexically-apparent-fun + thing "as the argument to FUNCTION") + nil))) + +(def-ir1-translator %%allocate-closures ((&rest leaves) start next result) + (aver (eq result 'nil)) + (let ((lambdas leaves)) + (ir1-convert start next result `(%allocate-closures ',lambdas)) + (let ((allocator (node-dest (ctran-next start)))) + (dolist (lambda lambdas) + (setf (functional-allocator lambda) allocator))))) + +(defmacro with-fun-name-leaf ((leaf thing start) &body body) + `(multiple-value-bind (,leaf allocate-p) (fun-name-leaf ,thing) + (if allocate-p + (let ((.new-start. (make-ctran))) + (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf)) + (let ((,start .new-start.)) + ,@body)) + (locally + ,@body)))) (def-ir1-translator function ((thing) start next result) #!+sb-doc "FUNCTION Name Return the lexically apparent definition of the function Name. Name may also be a lambda expression." - (reference-leaf start next result (fun-name-leaf thing))) + (with-fun-name-leaf (leaf thing start) + (reference-leaf start next result leaf))) ;;;; FUNCALL @@ -474,8 +496,8 @@ (def-ir1-translator %funcall ((function &rest args) start next result) (if (and (consp function) (eq (car function) 'function)) - (ir1-convert start next result - `(,(fun-name-leaf (second function)) ,@args)) + (with-fun-name-leaf (leaf (second function) start) + (ir1-convert start next result `(,leaf ,@args))) (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) (ir1-convert start ctran fun-lvar `(the function ,function)) @@ -556,14 +578,14 @@ (fun-lvar (make-lvar)) ((next result) (processing-decls (decls vars nil next result) - (let ((fun (ir1-convert-lambda-body - forms - vars - :debug-name (debug-namify "LET S" - bindings)))) - (reference-leaf start ctran fun-lvar fun)) - (values next result)))) - (ir1-convert-combination-args fun-lvar ctran next result values))))) + (let ((fun (ir1-convert-lambda-body + forms + vars + :debug-name (debug-namify "LET S" + bindings)))) + (reference-leaf start ctran fun-lvar fun)) + (values next result)))) + (ir1-convert-combination-args fun-lvar ctran next result values))))) (t (compiler-error "Malformed LET bindings: ~S." bindings)))) @@ -578,14 +600,14 @@ (parse-body body :doc-string-allowed nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) (processing-decls (decls vars nil start next) - (ir1-convert-aux-bindings start - next - result - forms - vars - values)))) + (ir1-convert-aux-bindings start + next + result + forms + vars + values)))) (compiler-error "Malformed LET* bindings: ~S." bindings))) - + ;;; logic shared between IR1 translators for LOCALLY, MACROLET, ;;; and SYMBOL-MACROLET ;;; @@ -637,6 +659,29 @@ . ,forms)))))) (values (names) (defs)))) +(defun ir1-convert-fbindings (start next result funs body) + (let ((ctran (make-ctran)) + (dx-p (find-if #'leaf-dynamic-extent funs))) + (when dx-p + (ctran-starts-block ctran) + (ctran-starts-block next)) + (ir1-convert start ctran nil `(%%allocate-closures ,@funs)) + (cond (dx-p + (let* ((dummy (make-ctran)) + (entry (make-entry)) + (cleanup (make-cleanup :kind :dynamic-extent + :mess-up entry + :info (list (node-dest + (ctran-next start)))))) + (push entry (lambda-entries (lexenv-lambda *lexenv*))) + (setf (entry-cleanup entry) cleanup) + (link-node-to-previous-ctran entry ctran) + (use-ctran entry dummy) + + (let ((*lexenv* (make-lexenv :cleanup cleanup))) + (ir1-convert-progn-body dummy next result body)))) + (t (ir1-convert-progn-body ctran next result body))))) + (def-ir1-translator flet ((definitions &body body) start next result) #!+sb-doc @@ -656,10 +701,7 @@ names defs))) (processing-decls (decls nil fvars next result) (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) - (ir1-convert-progn-body start - next - result - forms))))))) + (ir1-convert-fbindings start next result fvars forms))))))) (def-ir1-translator labels ((definitions &body body) start next result) #!+sb-doc @@ -691,14 +733,14 @@ :debug-name (debug-namify "LABELS " name))) names defs)))) - + ;; Modify all the references to the dummy function leaves so ;; that they point to the real function leaves. (loop for real-fun in real-funs and placeholder-cons in placeholder-fenv do (substitute-leaf real-fun (cdr placeholder-cons)) (setf (cdr placeholder-cons) real-fun)) - + ;; Voila. (processing-decls (decls nil real-funs next result) (let ((*lexenv* (make-lexenv @@ -707,10 +749,7 @@ ;; lexical environment is used for inline ;; expansion we'll get the right functions. :funs (pairlis names real-funs)))) - (ir1-convert-progn-body start - next - result - forms))))))) + (ir1-convert-fbindings start next result real-funs forms))))))) ;;;; the THE special operator, and friends @@ -866,9 +905,11 @@ (ir1-convert-lambda `(lambda () (return-from ,tag (%unknown-values))) - :debug-name (debug-namify "escape function for " tag))))) + :debug-name (debug-namify "escape function for " tag)))) + (ctran (make-ctran))) (setf (functional-kind fun) :escape) - (reference-leaf start next result fun))) + (ir1-convert start ctran nil `(%%allocate-closures ,fun)) + (reference-leaf ctran next result fun))) ;;; Yet another special special form. This one looks up a local ;;; function and smashes it to a :CLEANUP function, as well as diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 45b1de9..3898e79 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1125,7 +1125,7 @@ (setf (lambda-var-ignorep var) t))))) (values)) -(defun process-dx-decl (names vars) +(defun process-dx-decl (names vars fvars) (flet ((maybe-notify (control &rest args) (when (policy *lexenv* (> speed inhibit-warnings)) (apply #'compiler-notify control args)))) @@ -1153,7 +1153,24 @@ (eq (car name) 'function) (null (cddr name)) (valid-function-name-p (cadr name))) - (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" name)) + (let* ((fname (cadr name)) + (bound-fun (find fname fvars + :key #'leaf-source-name + :test #'equal))) + (etypecase bound-fun + (leaf + #!+stack-allocatable-closures + (setf (leaf-dynamic-extent bound-fun) t) + #!-stack-allocatable-closures + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ + (not supported on this platform)." fname)) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) + (null + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + fname))))) (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))) @@ -1209,12 +1226,12 @@ `(values ,@types))))) res)) (dynamic-extent - (process-dx-decl (cdr spec) vars) + (process-dx-decl (cdr spec) vars fvars) res) ((disable-package-locks enable-package-locks) (make-lexenv :default res - :disabled-package-locks (process-package-lock-decl + :disabled-package-locks (process-package-lock-decl spec (lexenv-disabled-package-locks res)))) (t (unless (info :declaration :recognized (first spec)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 1e92d4e..5d74523 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1004,6 +1004,9 @@ (when (optional-dispatch-more-entry leaf) (frob (optional-dispatch-more-entry leaf))) (let ((main (optional-dispatch-main-entry leaf))) + (when entry + (setf (functional-entry-fun entry) main) + (setf (functional-entry-fun main) entry)) (when (eq (functional-kind main) :optional) (frob main)))))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 922c8b2..22b4332 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -59,7 +59,7 @@ ;;;; leaf reference ;;; Return the TN that holds the value of THING in the environment ENV. -(declaim (ftype (function ((or nlx-info lambda-var) physenv) tn) +(declaim (ftype (function ((or nlx-info lambda-var clambda) physenv) tn) find-in-physenv)) (defun find-in-physenv (thing physenv) (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv)))) @@ -81,7 +81,10 @@ (leaf-info thing)) (nlx-info (aver (eq physenv (block-physenv (nlx-info-target thing)))) - (ir2-nlx-info-home (nlx-info-info thing)))) + (ir2-nlx-info-home (nlx-info-info thing))) + (clambda + (aver (xep-p thing)) + (entry-info-closure-tn (lambda-info thing)))) (bug "~@<~2I~_~S ~_not found in ~_~S~:>" thing physenv))) ;;; If LEAF already has a constant TN, return that, otherwise make a @@ -210,8 +213,7 @@ (unless (leaf-info functional) (setf (leaf-info functional) (make-entry-info :name (functional-debug-name functional)))) - (let ((entry (make-load-time-constant-tn :entry functional)) - (closure (etypecase functional + (let ((closure (etypecase functional (clambda (assertions-on-ir2-converted-clambda functional) (physenv-closure (get-lambda-physenv functional))) @@ -220,17 +222,73 @@ nil)))) (cond (closure - (let ((this-env (node-physenv ref))) - (vop make-closure ref ir2-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 ref ir2-block - res - (find-in-physenv what this-env) - n))))) + (let* ((physenv (node-physenv ref)) + (tn (find-in-physenv functional physenv))) + (emit-move ref ir2-block tn res))) (t - (emit-move ref ir2-block entry res)))) + (let ((entry (make-load-time-constant-tn :entry functional))) + (emit-move ref ir2-block entry res))))) + (values)) + +(defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy) + ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) + (when (lvar-dynamic-extent leaves) + (let ((info (make-ir2-lvar *backend-t-primitive-type*))) + (setf (ir2-lvar-kind info) :delayed) + (setf (lvar-info leaves) info) + #!+stack-grows-upward-not-downward + (let ((tn (make-normal-tn *backend-t-primitive-type*))) + (setf (ir2-lvar-locs info) (list tn))) + #!+stack-grows-downward-not-upward + (setf (ir2-lvar-stack-pointer info) + (make-stack-pointer-tn))))) + +(defoptimizer (%allocate-closures ir2-convert) ((leaves) call 2block) + (let ((dx-p (lvar-dynamic-extent leaves)) + #!+stack-grows-upward-not-downward + (first-closure nil)) + (collect ((delayed)) + #!+stack-grows-downward-not-upward + (when dx-p + (vop current-stack-pointer call 2block + (ir2-lvar-stack-pointer (lvar-info leaves)))) + (dolist (leaf (lvar-value leaves)) + (binding* ((xep (functional-entry-fun leaf) :exit-if-null) + (nil (aver (xep-p xep))) + (entry-info (lambda-info xep) :exit-if-null) + (tn (entry-info-closure-tn entry-info) :exit-if-null) + (closure (physenv-closure (get-lambda-physenv xep))) + (entry (make-load-time-constant-tn :entry xep))) + (let ((this-env (node-physenv call)) + (leaf-dx-p (and dx-p (leaf-dynamic-extent leaf)))) + (vop make-closure call 2block entry (length closure) + leaf-dx-p tn) + #!+stack-grows-upward-not-downward + (when (and (not first-closure) leaf-dx-p) + (setq first-closure tn)) + (loop for what in closure and n from 0 do + (unless (and (lambda-var-p what) + (null (leaf-refs what))) + ;; In LABELS a closure may refer to another closure + ;; in the same group, so we must be sure that we + ;; store a closure only after its creation. + ;; + ;; TODO: Here is a simple solution: we postpone + ;; putting of all closures after all creations + ;; (though it may require more registers). + (if (lambda-p what) + (delayed (list tn (find-in-physenv what this-env) n)) + (vop closure-init call 2block + tn + (find-in-physenv what this-env) + n))))))) + #!+stack-grows-upward-not-downward + (when dx-p + (emit-move call 2block first-closure + (first (ir2-lvar-locs (lvar-info leaves))))) + (loop for (tn what n) in (delayed) + do (vop closure-init call 2block + tn what n)))) (values)) ;;; Convert a SET node. If the NODE's LVAR is annotated, then we also diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 9dce8b5..562825c 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -402,6 +402,17 @@ ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil)) + +;;; Make sure that arguments of magic functions are not annotated. +;;; (Otherwise the compiler may dump its internal structures as +;;; constants :-() +(defoptimizer (%pop-values ltn-annotate) ((%lvar) node ltn-policy) + %lvar node ltn-policy) +(defoptimizer (%nip-values ltn-annotate) ((last-nipped last-preserved + &rest moved) + node ltn-policy) + last-nipped last-preserved moved node ltn-policy) + ;;;; known call annotation diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index efb342c..c9a936e 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -669,7 +669,7 @@ (format t "~4TL~D: ~S~:[~; [closure]~]~%" (label-id (entry-info-offset entry)) (entry-info-name entry) - (entry-info-closure-p entry))) + (entry-info-closure-tn entry))) (terpri) (pre-pack-tn-stats component *standard-output*) (terpri) @@ -996,18 +996,12 @@ ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..) (locall-analyze-clambdas-until-done (list fun)) - + (multiple-value-bind (components-from-dfo top-components hairy-top) (find-initial-dfo (list fun)) + (declare (ignore hairy-top)) (let ((*all-components* (append components-from-dfo top-components))) - ;; FIXME: This is more monkey see monkey do based on CMU CL - ;; code. If anyone figures out why to only prescan HAIRY-TOP - ;; and TOP-COMPONENTS here, instead of *ALL-COMPONENTS* or - ;; some other combination of results from FIND-INITIAL-VALUES, - ;; it'd be good to explain it. - (mapc #'preallocate-physenvs-for-toplevelish-lambdas hairy-top) - (mapc #'preallocate-physenvs-for-toplevelish-lambdas top-components) (dolist (component-from-dfo components-from-dfo) (compile-component component-from-dfo) (replace-toplevel-xeps component-from-dfo))) diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp index 8dd772a..be64f8d 100644 --- a/src/compiler/mips/alloc.lisp +++ b/src/compiler/mips/alloc.lisp @@ -108,7 +108,8 @@ (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) - (:info length) + (:info length stack-allocate-p) + (:ignore 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 2a7aaf1..5c9d617 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -455,7 +455,9 @@ ;; For :DYNAMIC-EXTENT: a list of all DX LVARs, preserved by this ;; cleanup. This is filled when the cleanup is created (now by ;; locall call analysis) and is rechecked by physical environment - ;; analysis. + ;; analysis. (For closures this is a list of the allocating node - + ;; during IR1, and a list of the argument LVAR of the allocator - + ;; after physical environment analysis.) (info nil :type list)) (defprinter (cleanup :identity t) kind @@ -857,6 +859,9 @@ ;; the original function or macro lambda list, or :UNSPECIFIED if ;; this is a compiler created function (arg-documentation nil :type (or list (member :unspecified))) + ;; Node, allocating closure for this lambda. May be NIL when we are + ;; sure that no closure is needed. + (allocator nil :type (or null combination)) ;; various rare miscellaneous info that drives code generation & stuff (plist () :type list)) (defprinter (functional :identity t) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 037060d..3908aca 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -210,6 +210,10 @@ (setf did-something t))) did-something)) +(defun xep-allocator (xep) + (let ((entry (functional-entry-fun xep))) + (functional-allocator entry))) + ;;; Make sure that THING is closed over in REF-PHYSENV and in all ;;; PHYSENVs for the functions that reference REF-PHYSENV's function ;;; (not just calls). HOME-PHYSENV is THING's home environment. When we @@ -217,13 +221,31 @@ (defun close-over (thing ref-physenv home-physenv) (declare (type physenv ref-physenv home-physenv)) (let ((flooded-physenvs nil)) - (named-let flood ((flooded-physenv ref-physenv)) - (unless (or (eql flooded-physenv home-physenv) - (member flooded-physenv flooded-physenvs)) - (push flooded-physenv flooded-physenvs) - (pushnew thing (physenv-closure flooded-physenv)) - (dolist (ref (leaf-refs (physenv-lambda flooded-physenv))) - (flood (get-node-physenv ref)))))) + (labels ((flood (flooded-physenv) + (unless (or (eql flooded-physenv home-physenv) + (member flooded-physenv flooded-physenvs)) + (push flooded-physenv flooded-physenvs) + (unless (memq thing (physenv-closure flooded-physenv)) + (push thing (physenv-closure flooded-physenv)) + (let ((lambda (physenv-lambda flooded-physenv))) + (cond ((eq (functional-kind lambda) :external) + (let* ((alloc-node (xep-allocator lambda)) + (alloc-lambda (node-home-lambda alloc-node)) + (alloc-physenv (get-lambda-physenv alloc-lambda))) + (flood alloc-physenv) + (dolist (ref (leaf-refs lambda)) + (close-over lambda + (get-node-physenv ref) alloc-physenv)))) + (t (dolist (ref (leaf-refs lambda)) + ;; FIXME: This assertion looks + ;; reasonable, but does not work for + ;; :CLEANUPs. + #+nil + (let ((dest (node-dest ref))) + (aver (basic-combination-p dest)) + (aver (eq (basic-combination-kind dest) :local))) + (flood (get-node-physenv ref)))))))))) + (flood ref-physenv))) (values)) ;;;; non-local exit @@ -328,7 +350,7 @@ (note-non-local-exit target-physenv exit)))))) (values)) -;;;; final decision on stack allocation of dynamic-extent structores +;;;; final decision on stack allocation of dynamic-extent structures (defun recheck-dynamic-extent-lvars (component) (declare (type component component)) (dolist (lambda (component-lambdas component)) @@ -336,15 +358,37 @@ for cleanup = (entry-cleanup entry) do (when (eq (cleanup-kind cleanup) :dynamic-extent) (collect ((real-dx-lvars)) - (loop for lvar in (cleanup-info cleanup) - do (let ((use (lvar-uses lvar))) - (if (and (combination-p use) - (eq (basic-combination-kind use) :known) - (awhen (fun-info-stack-allocate-result - (basic-combination-fun-info use)) - (funcall it use))) - (real-dx-lvars lvar) - (setf (lvar-dynamic-extent lvar) nil)))) + (loop for what in (cleanup-info cleanup) + do (etypecase what + (lvar + (let* ((lvar what) + (use (lvar-uses lvar))) + (if (and (combination-p use) + (eq (basic-combination-kind use) :known) + (awhen (fun-info-stack-allocate-result + (basic-combination-fun-info use)) + (funcall it use))) + (real-dx-lvars lvar) + (setf (lvar-dynamic-extent lvar) nil)))) + (node ; DX closure + (let* ((call what) + (arg (first (basic-combination-args call))) + (funs (lvar-value arg)) + (dx nil)) + (dolist (fun funs) + (binding* ((() (leaf-dynamic-extent fun) + :exit-if-null) + (xep (functional-entry-fun fun) + :exit-if-null) + (closure (physenv-closure + (get-lambda-physenv xep)))) + (cond (closure + (setq dx t)) + (t + (setf (leaf-dynamic-extent fun) nil))))) + (when dx + (setf (lvar-dynamic-extent arg) cleanup) + (real-dx-lvars arg)))))) (setf (cleanup-info cleanup) (real-dx-lvars)) (setf (component-dx-lvars component) (append (real-dx-lvars) (component-dx-lvars component))))))) diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index 1a4573e..7fdcdca 100644 --- a/src/compiler/ppc/alloc.lisp +++ b/src/compiler/ppc/alloc.lisp @@ -109,7 +109,8 @@ (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) - (:info length) + (:info length stack-allocate-p) + (:ignore 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/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp index 2853582..bfdf74b 100644 --- a/src/compiler/sparc/alloc.lisp +++ b/src/compiler/sparc/alloc.lisp @@ -115,7 +115,8 @@ (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) - (:info length) + (:info length stack-allocate-p) + (:ignore stack-allocate-p) (:temporary (:scs (non-descriptor-reg)) temp) (:results (result :scs (descriptor-reg))) (:generator 10 diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index fccf4f8..b2b8a11 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -96,7 +96,6 @@ (let* ((generator (lvar-use lvar)) (block (node-block generator)) (2block (block-info block))) - (aver (eq generator (block-last block))) ;; DX objects, living in the LVAR, are ;; alive in the environment, protected by ;; the CLEANUP. We also cannot move them diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 24efbcb..5395e23 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -319,8 +319,9 @@ ;;; this case the slots aren't actually initialized until entry ;;; analysis runs. (defstruct (entry-info (:copier nil)) - ;; Does this function have 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)) ;; a label pointing to the entry vector for this function, or NIL ;; before ENTRY-ANALYZE runs (offset nil :type (or label null)) diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index a2300fb..3a5624c 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/src/compiler/x86-64/alloc.lisp @@ -110,7 +110,8 @@ (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) - (:info length) + (:info length stack-allocate-p) + (:ignore stack-allocate-p) (:temporary (:sc any-reg) temp) (:results (result :scs (descriptor-reg))) (:node-var node) diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp index 1278d10..bcf3483 100644 --- a/src/compiler/x86/alloc.lisp +++ b/src/compiler/x86/alloc.lisp @@ -115,18 +115,19 @@ (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) - (:info length) + (:info length stack-allocate-p) (:temporary (:sc any-reg) temp) (:results (result :scs (descriptor-reg))) (:node-var node) (:generator 10 - (pseudo-atomic - (let ((size (+ length closure-info-offset))) - (allocation result (pad-data-block size) node) - (inst lea result - (make-ea :byte :base result :disp fun-pointer-lowtag)) - (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag) - result 0 fun-pointer-lowtag)) + (maybe-pseudo-atomic stack-allocate-p + (let ((size (+ length closure-info-offset))) + (allocation result (pad-data-block size) node + stack-allocate-p) + (inst lea result + (make-ea :byte :base result :disp fun-pointer-lowtag)) + (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag) + result 0 fun-pointer-lowtag)) (loadw temp function closure-fun-slot fun-pointer-lowtag) (storew temp result closure-fun-slot fun-pointer-lowtag)))) diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp index 9521ae4..d5eede6 100644 --- a/tests/compiler.pure-cload.lisp +++ b/tests/compiler.pure-cload.lisp @@ -148,3 +148,12 @@ ;;; bug 261 (let ((x (list (the (values &optional fixnum) (eval '(values)))))) (assert (equal x '(nil)))) + +;;; Bug 125, reported by Gabe Garza: Python did not preserve identity +;;; of closures. +(flet ((test-case (test-pred x) + (let ((func (lambda () x))) + (list (eq func func) + (funcall test-pred func func) + (delete func (list func)))))) + (assert (equal '(t t nil) (funcall (eval #'test-case) #'eq 3)))) diff --git a/version.lisp-expr b/version.lisp-expr index a3d6b65..b2eb2e9 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.18.19" +"0.8.18.20"