X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=922c8b2d7e680dd662107780a6a87249f0b124a0;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=f54563cf66cf956553ed23bb14311986999c97d6;hpb=5ef7f500a505f5711b1c76ff8c15f443d4815367;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index f54563c..922c8b2 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -559,6 +559,7 @@ (defun find-template-result-types (call template rtypes) (declare (type combination call) (type template template) (list rtypes)) + (declare (ignore template)) (let* ((dtype (node-derived-type call)) (type dtype) (types (mapcar #'primitive-type @@ -622,6 +623,10 @@ (r-refs (reference-tn-list results t))) (aver (= (length info-args) (template-info-arg-count template))) + #!+stack-grows-downward-not-upward + (when (and lvar (lvar-dynamic-extent lvar)) + (vop current-stack-pointer call block + (ir2-lvar-stack-pointer (lvar-info lvar)))) (if info-args (emit-template call block template args r-refs info-args) (emit-template call block template args r-refs)) @@ -857,6 +862,7 @@ ;;; lvar LOC. ;;; -- We don't know what it is. (defun fun-lvar-tn (node block lvar) + (declare (ignore node block)) (declare (type lvar lvar)) (let ((2lvar (lvar-info lvar))) (if (eq (ir2-lvar-kind 2lvar) :delayed) @@ -1208,16 +1214,16 @@ (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block) (let ((ir2-physenv (physenv-info (node-physenv node)))) (move-lvar-result node block - (list (ir2-physenv-old-fp ir2-physenv) - (ir2-physenv-return-pc ir2-physenv)) - (node-lvar node)))) + (list (ir2-physenv-old-fp ir2-physenv) + (ir2-physenv-return-pc ir2-physenv)) + (node-lvar node)))) ;;;; multiple values ;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates -;;; the lvarinuation for the correct number of values (with the lvar -;;; user responsible for defaulting), we can just pick them up from -;;; the lvar. +;;; the lvar for the correct number of values (with the lvar user +;;; responsible for defaulting), we can just pick them up from the +;;; lvar. (defun ir2-convert-mv-bind (node block) (declare (type mv-combination node) (type ir2-block block)) (let* ((lvar (first (basic-combination-args node))) @@ -1274,11 +1280,67 @@ ;;; Reset the stack pointer to the start of the specified ;;; unknown-values lvar (discarding it and all values globs on top of ;;; it.) -(defoptimizer (%pop-values ir2-convert) ((lvar) node block) - (let ((2lvar (lvar-info (lvar-value lvar)))) - (aver (eq (ir2-lvar-kind 2lvar) :unknown)) - (vop reset-stack-pointer node block - (first (ir2-lvar-locs 2lvar))))) +(defoptimizer (%pop-values ir2-convert) ((%lvar) node block) + (let* ((lvar (lvar-value %lvar)) + (2lvar (lvar-info lvar))) + (cond ((eq (ir2-lvar-kind 2lvar) :unknown) + (vop reset-stack-pointer node block + (first (ir2-lvar-locs 2lvar)))) + ((lvar-dynamic-extent lvar) + #!+stack-grows-downward-not-upward + (vop reset-stack-pointer node block + (ir2-lvar-stack-pointer 2lvar)) + #!-stack-grows-downward-not-upward + (vop %%pop-dx node block + (first (ir2-lvar-locs 2lvar)))) + (t (bug "Trying to pop a not stack-allocated LVAR ~S." + lvar))))) + +(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved + &rest moved) + node block) + (let* ( ;; pointer immediately after the nipped block + (after (lvar-value last-nipped)) + (2after (lvar-info after)) + ;; pointer to the first nipped word + (first (lvar-value last-preserved)) + (2first (lvar-info first)) + + (moved-tns (loop for lvar-ref in moved + for lvar = (lvar-value lvar-ref) + for 2lvar = (lvar-info lvar) + ;when 2lvar + collect (first (ir2-lvar-locs 2lvar))))) + (aver (or (eq (ir2-lvar-kind 2after) :unknown) + (lvar-dynamic-extent after))) + (aver (eq (ir2-lvar-kind 2first) :unknown)) + (when *check-consistency* + ;; we cannot move stack-allocated DX objects + (dolist (moved-lvar moved) + (aver (eq (ir2-lvar-kind (lvar-info (lvar-value moved-lvar))) + :unknown)))) + (flet ((nip-aligned (nipped) + (vop* %%nip-values node block + (nipped + (first (ir2-lvar-locs 2first)) + (reference-tn-list moved-tns nil)) + ((reference-tn-list moved-tns t)))) + #!-stack-grows-downward-not-upward + (nip-unaligned (nipped) + (vop* %%nip-dx node block + (nipped + (first (ir2-lvar-locs 2first)) + (reference-tn-list moved-tns nil)) + ((reference-tn-list moved-tns t))))) + (cond ((eq (ir2-lvar-kind 2after) :unknown) + (nip-aligned (first (ir2-lvar-locs 2after)))) + ((lvar-dynamic-extent after) + #!+stack-grows-downward-not-upward + (nip-aligned (ir2-lvar-stack-pointer 2after)) + #!-stack-grows-downward-not-upward + (nip-unaligned (ir2-lvar-stack-pointer 2after))) + (t + (bug "Trying to nip a not stack-allocated LVAR ~S." after)))))) ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) @@ -1331,9 +1393,6 @@ (defoptimizer (%special-unbind ir2-convert) ((var) node block) (vop unbind node block)) -(defoptimizer (%dynamic-extent-start ir2-convert) (() node block) node block) -(defoptimizer (%dynamic-extent-end ir2-convert) (() node block) node block) - ;;; ### It's not clear that this really belongs in this file, or ;;; should really be done this way, but this is the least violation of ;;; abstraction in the current setup. We don't want to wire @@ -1539,11 +1598,16 @@ (res (lvar-result-tns lvar (list (primitive-type (specifier-type 'list)))))) + #!+stack-grows-downward-not-upward + (when (and lvar (lvar-dynamic-extent lvar)) + (vop current-stack-pointer node block + (ir2-lvar-stack-pointer (lvar-info lvar)))) (vop* ,name node block (refs) ((first res) nil) (length args)) (move-lvar-result node block res lvar))))) (def list) (def list*)) + ;;; Convert the code in a component into VOPs. (defun ir2-convert (component)