X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir2tran.lisp;h=4386573de1cfa91a19792d11819ecd6ff5813634;hb=40f6a8f39da1faba169a081dfd3aeb7ad8391f55;hp=ebec1131f016814ae24da2a43856543f3efa2bc4;hpb=818b7d2a5f74a4fd379b269c345f8301fbeb1b36;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index ebec113..4386573 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) @@ -134,10 +146,14 @@ ((and indirect (not (eq (node-physenv node) (lambda-physenv (lambda-var-home leaf))))) - (vop ancestor-frame-ref node block tn (leaf-info leaf) res)) + (let ((reffer (third (primitive-type-indirect-cell-type + (primitive-type (leaf-type leaf)))))) + (if reffer + (funcall reffer node block tn (leaf-info leaf) res) + (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 @@ -335,7 +351,11 @@ ((and indirect (not (eq (node-physenv node) (lambda-physenv (lambda-var-home leaf))))) - (vop ancestor-frame-set node block tn val (leaf-info leaf))) + (let ((setter (fourth (primitive-type-indirect-cell-type + (primitive-type (leaf-type leaf)))))) + (if setter + (funcall setter node block tn val (leaf-info leaf)) + (vop ancestor-frame-set node block tn val (leaf-info leaf))))) (t (emit-move node block val tn)))))) (global-var (aver (symbolp (leaf-source-name leaf))) @@ -370,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))))) @@ -631,13 +651,15 @@ (emit-template node block template args nil (list* (block-label consequent) not-p info-args)) - (unless (drop-thru-p if alternative) - (vop branch node block (block-label alternative)))) + (if (drop-thru-p if alternative) + (register-drop-thru alternative) + (vop branch node block (block-label alternative)))) (t (emit-template node block template args nil info-args) (vop branch-if node block (block-label consequent) flags not-p) - (unless (drop-thru-p if alternative) - (vop branch node block (block-label alternative))))))) + (if (drop-thru-p if alternative) + (register-drop-thru alternative) + (vop branch node block (block-label alternative))))))) ;;; Convert an IF that isn't the DEST of a conditional template. (defun ir2-convert-if (node block) @@ -657,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)))) @@ -947,7 +969,7 @@ ((node-tail-p node) (ir2-convert-tail-local-call node block fun)) (t - (let ((start (block-label (lambda-block fun))) + (let ((start (block-trampoline (lambda-block fun))) (returns (tail-set-info (lambda-tail-set fun))) (lvar (node-lvar node))) (ecase (if returns @@ -1472,7 +1494,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 @@ -1809,7 +1841,9 @@ (aver (not named)) tn))))))) ((not (eq (ir2-block-next 2block) (block-info target))) - (vop branch last 2block (block-label target))))))) + (vop branch last 2block (block-label target))) + (t + (register-drop-thru target)))))) (values))