X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir2tran.lisp;h=22b43322977ea4b7ee9dd8b6f4090d4ca8cef511;hb=fae139755a81c0431e7f12f2af9b5f3abc1326dc;hp=7c4e321918777a86564573e36f3adfd063e0b346;hpb=7b384da95e6a30e1434523213aeeed3a90448c78;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 7c4e321..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 @@ -623,6 +681,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)) @@ -1276,33 +1338,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 (%nip-values ir2-convert) ((last-nipped last-preserved &rest moved) +(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) - #!-x86 - (bug "%NIP-VALUES is not implemented on this platform.") - #!+x86 - (let ((2after (lvar-info (lvar-value last-nipped))) - ; pointer immediately after the nipped block - (2first (lvar-info (lvar-value last-preserved))) - ; pointer to the first nipped word - (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 (eq (ir2-lvar-kind 2after) :unknown)) + (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)) - (vop* %%nip-values node block - ((first (ir2-lvar-locs 2after)) - (first (ir2-lvar-locs 2first)) - (reference-tn-list moved-tns nil)) - ((reference-tn-list moved-tns t))))) + (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) @@ -1355,9 +1451,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 @@ -1563,11 +1656,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)