X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=36d4218abcfbaa11007f8054090959b19a4b0bca;hb=203e2acb585b1c13159bbd6ec83c61ad9c095818;hp=a4fda56c91a2c9f25e3ed3ea1129073dbd193662;hpb=56a2dbbb9d79a62db99cc4061e50fca74fcf907e;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index a4fda56..36d4218 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -91,29 +91,41 @@ ;;; If LEAF already has a constant TN, return that, otherwise make a ;;; TN for it. -(defun constant-tn (leaf) +(defun constant-tn (leaf boxedp) (declare (type constant leaf)) - (or (leaf-info leaf) - (setf (leaf-info leaf) - (make-constant-tn leaf)))) + ;; When convenient we can have both a boxed and unboxed TN for + ;; constant. + (if boxedp + (or (constant-boxed-tn leaf) + (setf (constant-boxed-tn leaf) (make-constant-tn leaf t))) + (or (leaf-info leaf) + (setf (leaf-info leaf) (make-constant-tn leaf nil))))) ;;; Return a TN that represents the value of LEAF, or NIL if LEAF ;;; isn't directly represented by a TN. ENV is the environment that ;;; the reference is done in. -(defun leaf-tn (leaf env) +(defun leaf-tn (leaf env boxedp) (declare (type leaf leaf) (type physenv env)) (typecase leaf (lambda-var (unless (lambda-var-indirect leaf) (find-in-physenv leaf env))) - (constant (constant-tn leaf)) + (constant (constant-tn leaf boxedp)) (t nil))) ;;; This is used to conveniently get a handle on a constant TN during ;;; IR2 conversion. It returns a constant TN representing the Lisp ;;; object VALUE. (defun emit-constant (value) - (constant-tn (find-constant value))) + (constant-tn (find-constant value) t)) + +(defun boxed-ref-p (ref) + (let ((dest (lvar-dest (ref-lvar ref)))) + (cond ((and (basic-combination-p dest) (eq :full (basic-combination-kind dest))) + t) + ;; Other cases? + (t + nil)))) ;;; Convert a REF node. The reference must not be delayed. (defun ir2-convert-ref (node block) @@ -141,7 +153,7 @@ (vop ancestor-frame-ref node block tn (leaf-info leaf) res)))) (t (emit-move node block tn res))))) (constant - (emit-move node block (constant-tn leaf) res)) + (emit-move node block (constant-tn leaf (boxed-ref-p node)) res)) (functional (ir2-convert-closure node block leaf res)) (global-var @@ -378,7 +390,7 @@ (ecase (ir2-lvar-kind 2lvar) (:delayed (let ((ref (lvar-uses lvar))) - (leaf-tn (ref-leaf ref) (node-physenv ref)))) + (leaf-tn (ref-leaf ref) (node-physenv ref) (boxed-ref-p ref)))) (:fixed (aver (= (length (ir2-lvar-locs 2lvar)) 1)) (first (ir2-lvar-locs 2lvar))))) @@ -422,7 +434,7 @@ ;;; an lvar. ;;; ;;; If the lvar isn't annotated (meaning the values are discarded) or -;;; is unknown-values, the then we make temporaries for each supplied +;;; is unknown-values, then we make temporaries for each supplied ;;; value, providing a place to compute the result in until we decide ;;; what to do with it (if anything.) ;;; @@ -471,7 +483,7 @@ ;;; Return a list of TNs wired to the standard value passing ;;; conventions that can be used to receive values according to the -;;; unknown-values convention. This is used with together +;;; unknown-values convention. This is used together with ;;; MOVE-LVAR-RESULT for delivering unknown values to a fixed values ;;; lvar. ;;; @@ -529,7 +541,7 @@ ;;; If necessary, emit coercion code needed to deliver the RESULTS to ;;; the specified lvar. NODE and BLOCK provide context for emitting ;;; code. Although usually obtained from STANDARD-RESULT-TNs or -;;; LVAR-RESULT-TNs, RESULTS my be a list of any type or +;;; LVAR-RESULT-TNs, RESULTS may be a list of any type or ;;; number of TNs. ;;; ;;; If the lvar is fixed values, then move the results into the lvar @@ -667,7 +679,7 @@ (let* ((type (node-derived-type call)) (types (mapcar #'primitive-type - (if (values-type-p type) + (if (args-type-p type) (append (args-type-required type) (args-type-optional type)) (list type)))) @@ -1260,7 +1272,10 @@ (let ((lab (gen-label))) (setf (ir2-physenv-environment-start env) lab) - (vop note-environment-start node block lab))) + (vop note-environment-start node block lab) + #!+sb-safepoint + (unless (policy fun (>= inhibit-safepoints 2)) + (vop sb!vm::insert-safepoint node block)))) (values)) @@ -1482,7 +1497,17 @@ (binding* ((lvar (node-lvar node) :exit-if-null) (2lvar (lvar-info lvar))) (ecase (ir2-lvar-kind 2lvar) - (:fixed (ir2-convert-full-call node block)) + (:fixed + ;; KLUDGE: this is very much unsafe, and can leak random stack values. + ;; OTOH, I think the :FIXED case can only happen with (safety 0) in the + ;; first place. + ;; -PK + (loop for loc in (ir2-lvar-locs 2lvar) + for idx upfrom 0 + do (vop sb!vm::more-arg node block + (lvar-tn node block context) + (emit-constant idx) + loc))) (:unknown (let ((locs (ir2-lvar-locs 2lvar))) (vop* %more-arg-values node block @@ -1517,8 +1542,7 @@ (progn (labels ((,unbind (vars) (declare (optimize (speed 2) (debug 0))) - (let ((unbound-marker (%primitive make-other-immediate-type - 0 sb!vm:unbound-marker-widetag))) + (let ((unbound-marker (%primitive make-unbound-marker))) (dolist (var vars) ;; CLHS says "bound and then made to have no value" -- user ;; should not be able to tell the difference between that and this. @@ -1783,6 +1807,22 @@ 2block #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil num)))) + #!+sb-safepoint + (let ((first-node (block-start-node block))) + (unless (or (and (bind-p first-node) + (xep-p (bind-lambda first-node))) + (and (valued-node-p first-node) + (node-lvar first-node) + (eq (lvar-fun-name + (node-lvar first-node)) + '%nlx-entry))) + (when (and (rest (block-pred block)) + (block-loop block) + (member (loop-kind (block-loop block)) + '(:natural :strange)) + (eq block (loop-head (block-loop block))) + (policy first-node (< inhibit-safepoints 2))) + (vop sb!vm::insert-safepoint first-node 2block)))) (ir2-convert-block block) (incf num)))))) (values))