* Allocate closures at the beginning of FLET/LABELS form.
... fix bug 125.
* Partial support of stack allocation of dynamic-extent
closures on x86.
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
- (#<FUNCTION {500A9EF9}>)
- 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,
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
;; :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
;; 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
# 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
#+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
(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
(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))
(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
(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)))
(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
(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)))
\f
;;;; FUNCALL
(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))
(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))))
(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
;;;
. ,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
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
: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
;; 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)))))))
\f
;;;; the THE special operator, and friends
(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
(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))))
(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))))
`(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))
(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))))))
;;;; 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))))
(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
(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)))
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
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)
+
\f
;;;; known call annotation
(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)
;; 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)))
(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)))
;; 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
;; 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)
(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
(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))
\f
;;;; non-local exit
(note-non-local-exit target-physenv exit))))))
(values))
\f
-;;;; 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))
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)))))))
(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)))
(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
(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
;;; 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))
(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)
(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))))
;;; 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))))
;;; 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"
projects / sbcl.git / commitdiff