X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=a4fda56c91a2c9f25e3ed3ea1129073dbd193662;hb=56a2dbbb9d79a62db99cc4061e50fca74fcf907e;hp=34fe3881c781a308c6b952fb920373afa2cf5c7f;hpb=578d987735906eb05829f0c2235a3ba9225c2bc4;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 34fe388..a4fda56 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -52,12 +52,11 @@ (emit-move-template node block (type-check-template type) value result) (values)) -;;; Allocate an indirect value cell. Maybe do some clever stack -;;; allocation someday. +;;; Allocate an indirect value cell. (defevent make-value-cell-event "Allocate heap value cell for lexical var.") (defun emit-make-value-cell (node block value res) (event make-value-cell-event node) - (vop make-value-cell node block value res)) + (vop make-value-cell node block value nil res)) ;;;; leaf reference @@ -126,30 +125,41 @@ (res (first locs))) (etypecase leaf (lambda-var - (let ((tn (find-in-physenv leaf (node-physenv node)))) - (if (lambda-var-indirect leaf) - (vop value-cell-ref node block tn res) - (emit-move node block tn res)))) + (let ((tn (find-in-physenv leaf (node-physenv node))) + (indirect (lambda-var-indirect leaf)) + (explicit (lambda-var-explicit-value-cell leaf))) + (cond + ((and indirect explicit) + (vop value-cell-ref node block tn res)) + ((and indirect + (not (eq (node-physenv node) + (lambda-physenv (lambda-var-home leaf))))) + (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 - (if (legal-immediate-constant-p leaf) - (emit-move node block (constant-tn leaf) res) - (let* ((name (leaf-source-name leaf)) - (name-tn (emit-constant name))) - (if (policy node (zerop safety)) - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res))))) + (emit-move node block (constant-tn leaf) res)) (functional (ir2-convert-closure node block leaf res)) (global-var (let ((unsafe (policy node (zerop safety))) (name (leaf-source-name leaf))) (ecase (global-var-kind leaf) - ((:special :global) + ((:special :unknown) (aver (symbolp name)) (let ((name-tn (emit-constant name))) - (if unsafe + (if (or unsafe (info :variable :always-bound name)) (vop fast-symbol-value node block name-tn res) (vop symbol-value node block name-tn res)))) + (:global + (aver (symbolp name)) + (let ((name-tn (emit-constant name))) + (if (or unsafe (info :variable :always-bound name)) + (vop fast-symbol-global-value node block name-tn res) + (vop symbol-global-value node block name-tn res)))) (:global-function (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) (if unsafe @@ -233,6 +243,21 @@ (emit-move ref ir2-block entry res))))) (values)) +(defun closure-initial-value (what this-env current-fp) + (declare (type (or nlx-info lambda-var clambda) what) + (type physenv this-env) + (type (or tn null) current-fp)) + ;; If we have an indirect LAMBDA-VAR that does not require an + ;; EXPLICIT-VALUE-CELL, and is from this environment (not from being + ;; closed over), we need to store the current frame pointer. + (if (and (lambda-var-p what) + (lambda-var-indirect what) + (not (lambda-var-explicit-value-cell what)) + (eq (lambda-physenv (lambda-var-home what)) + this-env)) + current-fp + (find-in-physenv what this-env))) + (defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy) ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) (when (lvar-dynamic-extent leaves) @@ -249,7 +274,11 @@ (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) + (binding* ((xep (awhen (functional-entry-fun leaf) + ;; if the xep's been deleted then we can skip it + (if (eq (functional-kind it) :deleted) + nil it)) + :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) @@ -270,11 +299,16 @@ ;; 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))))))) + (delayed (list tn (find-in-physenv what this-env) n)) + (let ((initial-value (closure-initial-value + what this-env nil))) + (if initial-value + (vop closure-init call 2block + tn initial-value n) + ;; An initial-value of NIL means to stash + ;; the frame pointer... which requires a + ;; different VOP. + (vop closure-init-from-fp call 2block tn n))))))))) (loop for (tn what n) in (delayed) do (vop closure-init call 2block tn what n)))) @@ -296,15 +330,29 @@ (etypecase leaf (lambda-var (when (leaf-refs leaf) - (let ((tn (find-in-physenv leaf (node-physenv node)))) - (if (lambda-var-indirect leaf) - (vop value-cell-set node block tn val) - (emit-move node block val tn))))) + (let ((tn (find-in-physenv leaf (node-physenv node))) + (indirect (lambda-var-indirect leaf)) + (explicit (lambda-var-explicit-value-cell leaf))) + (cond + ((and indirect explicit) + (vop value-cell-set node block tn val)) + ((and indirect + (not (eq (node-physenv node) + (lambda-physenv (lambda-var-home 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))) (ecase (global-var-kind leaf) - ((:special :global) - (aver (symbolp (leaf-source-name leaf))) - (vop set node block (emit-constant (leaf-source-name leaf)) val))))) + ((:special) + (vop set node block (emit-constant (leaf-source-name leaf)) val)) + ((:global) + (vop %set-symbol-global-value node + block (emit-constant (leaf-source-name leaf)) val))))) (when locs (emit-move node block val (first locs)) (move-lvar-result node block locs lvar))) @@ -574,18 +622,32 @@ (declare (type node node) (type ir2-block block) (type template template) (type (or tn-ref null) args) (list info-args) (type cif if) (type boolean not-p)) - (aver (= (template-info-arg-count template) (+ (length info-args) 2))) (let ((consequent (if-consequent if)) - (alternative (if-alternative if))) - (cond ((drop-thru-p if consequent) + (alternative (if-alternative if)) + (flags (and (consp (template-result-types template)) + (rest (template-result-types template))))) + (aver (= (template-info-arg-count template) + (+ (length info-args) + (if flags 0 2)))) + (when not-p + (rotatef consequent alternative) + (setf not-p nil)) + (when (drop-thru-p if consequent) + (rotatef consequent alternative) + (setf not-p t)) + (cond ((not flags) (emit-template node block template args nil - (list* (block-label alternative) (not not-p) - info-args))) + (list* (block-label consequent) not-p + info-args)) + (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 - (list* (block-label consequent) not-p info-args)) - (unless (drop-thru-p if alternative) - (vop branch node block (block-label alternative))))))) + (emit-template node block template args nil info-args) + (vop branch-if node block (block-label consequent) flags not-p) + (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) @@ -597,61 +659,49 @@ (ir2-convert-conditional node block (template-or-lose 'if-eq) test-ref () node t))) -;;; Return a list of primitive-types that we can pass to -;;; LVAR-RESULT-TNS describing the result types we want for a -;;; template call. We duplicate here the determination of output type -;;; that was done in initially selecting the template, so we know that -;;; the types we find are allowed by the template output type -;;; restrictions. -(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 - (if (values-type-p type) - (append (values-type-required type) - (values-type-optional type)) - (list type))))) - (let ((nvals (length rtypes)) - (ntypes (length types))) - (cond ((< ntypes nvals) - (append types - (make-list (- nvals ntypes) - :initial-element *backend-t-primitive-type*))) - ((> ntypes nvals) - (subseq types 0 nvals)) - (t - types))))) - -;;; Return a list of TNs usable in a CALL to TEMPLATE delivering -;;; values to LVAR. As an efficiency hack, we pick off the common case -;;; where the LVAR is fixed values and has locations that satisfy the -;;; result restrictions. This can fail when there is a type check or a -;;; values count mismatch. -(defun make-template-result-tns (call lvar template rtypes) +;;; Return a list of primitive-types that we can pass to LVAR-RESULT-TNS +;;; describing the result types we want for a template call. We are really +;;; only interested in the number of results required: in normal case +;;; TEMPLATE-RESULTS-OK has already checked them. +(defun find-template-result-types (call rtypes) + (let* ((type (node-derived-type call)) + (types + (mapcar #'primitive-type + (if (values-type-p type) + (append (args-type-required type) + (args-type-optional type)) + (list type)))) + (primitive-t *backend-t-primitive-type*)) + (loop for rtype in rtypes + for type = (or (pop types) primitive-t) + collect type))) + +;;; Return a list of TNs usable in a CALL to TEMPLATE delivering values to +;;; LVAR. As an efficiency hack, we pick off the common case where the LVAR is +;;; fixed values and has locations that satisfy the result restrictions. This +;;; can fail when there is a type check or a values count mismatch. +(defun make-template-result-tns (call lvar rtypes) (declare (type combination call) (type (or lvar null) lvar) - (type template template) (list rtypes)) + (list rtypes)) (let ((2lvar (when lvar (lvar-info lvar)))) (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed)) (let ((locs (ir2-lvar-locs 2lvar))) (if (and (= (length rtypes) (length locs)) (do ((loc locs (cdr loc)) - (rtype rtypes (cdr rtype))) + (rtypes rtypes (cdr rtypes))) ((null loc) t) (unless (operand-restriction-ok - (car rtype) + (car rtypes) (tn-primitive-type (car loc)) :t-ok nil) (return nil)))) locs (lvar-result-tns lvar - (find-template-result-types call template rtypes)))) + (find-template-result-types call rtypes)))) (lvar-result-tns lvar - (find-template-result-types call template rtypes))))) + (find-template-result-types call rtypes))))) ;;; Get the operands into TNs, make TN-REFs for them, and then call ;;; the template emit function. @@ -663,10 +713,10 @@ (multiple-value-bind (args info-args) (reference-args call block (combination-args call) template) (aver (not (template-more-results-type template))) - (if (eq rtypes :conditional) + (if (template-conditional-p template) (ir2-convert-conditional call block template args info-args (lvar-dest lvar) nil) - (let* ((results (make-template-result-tns call lvar template rtypes)) + (let* ((results (make-template-result-tns call lvar rtypes)) (r-refs (reference-tn-list results t))) (aver (= (length info-args) (template-info-arg-count template))) @@ -690,12 +740,12 @@ (info (lvar-value info)) (lvar (node-lvar call)) (rtypes (template-result-types template)) - (results (make-template-result-tns call lvar template rtypes)) + (results (make-template-result-tns call lvar rtypes)) (r-refs (reference-tn-list results t))) (multiple-value-bind (args info-args) (reference-args call block (cddr (combination-args call)) template) (aver (not (template-more-results-type template))) - (aver (not (eq rtypes :conditional))) + (aver (not (template-conditional-p template))) (aver (null info-args)) (if info @@ -704,6 +754,12 @@ (move-lvar-result call block results lvar))) (values)) + +(defoptimizer (%%primitive derive-type) ((template info &rest args)) + (let ((type (template-type (lvar-value template)))) + (if (fun-type-p type) + (fun-type-returns type) + *wild-type*))) ;;;; local call @@ -718,7 +774,8 @@ (when arg (let ((src (lvar-tn node block arg)) (dest (leaf-info var))) - (if (lambda-var-indirect var) + (if (and (lambda-var-indirect var) + (lambda-var-explicit-value-cell var)) (emit-make-value-cell node block src dest) (emit-move node block src dest))))) (lambda-vars fun) (basic-combination-args node)) @@ -736,9 +793,15 @@ ;;; OLD-FP. If null, then the call is to the same environment (an ;;; :ASSIGNMENT), so we only move the arguments, and leave the ;;; environment alone. -(defun emit-psetq-moves (node block fun old-fp) +;;; +;;; CLOSURE-FP is for calling a closure that has "implicit" value +;;; cells (stored in the allocating stack frame), and is the frame +;;; pointer TN to use for values allocated in the outbound stack +;;; frame. This is distinct from OLD-FP for the specific case of a +;;; tail-local-call. +(defun emit-psetq-moves (node block fun old-fp &optional (closure-fp old-fp)) (declare (type combination node) (type ir2-block block) (type clambda fun) - (type (or tn null) old-fp)) + (type (or tn null) old-fp closure-fp)) (let ((actuals (mapcar (lambda (x) (when x (lvar-tn node block x))) @@ -750,7 +813,8 @@ (loc (leaf-info var))) (when actual (cond - ((lambda-var-indirect var) + ((and (lambda-var-indirect var) + (lambda-var-explicit-value-cell var)) (let ((temp (make-normal-tn *backend-t-primitive-type*))) (emit-make-value-cell node block actual temp) @@ -767,7 +831,7 @@ (let ((this-1env (node-physenv node)) (called-env (physenv-info (lambda-physenv fun)))) (dolist (thing (ir2-physenv-closure called-env)) - (temps (find-in-physenv (car thing) this-1env)) + (temps (closure-initial-value (car thing) this-1env closure-fp)) (locs (cdr thing))) (temps old-fp) (locs (ir2-physenv-old-fp called-env)))) @@ -780,9 +844,16 @@ ;;; function's passing location. (defun ir2-convert-tail-local-call (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) - (let ((this-env (physenv-info (node-physenv node)))) + (let ((this-env (physenv-info (node-physenv node))) + (current-fp (make-stack-pointer-tn))) (multiple-value-bind (temps locs) - (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env)) + (emit-psetq-moves node block fun + (ir2-physenv-old-fp this-env) current-fp) + + ;; If we're about to emit a move from CURRENT-FP then we need to + ;; initialize it. + (when (find current-fp temps) + (vop current-fp node block current-fp)) (mapc (lambda (temp loc) (emit-move node block temp loc)) @@ -886,7 +957,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 @@ -1143,7 +1214,8 @@ (when (leaf-refs arg) (let ((pass (standard-arg-location n)) (home (leaf-info arg))) - (if (lambda-var-indirect arg) + (if (and (lambda-var-indirect arg) + (lambda-var-explicit-value-cell arg)) (emit-make-value-cell node block pass home) (emit-move node block pass home)))) (incf n)))) @@ -1180,8 +1252,10 @@ (ir2-physenv-return-pc env)) #!+unwind-to-frame-and-call-vop - (when (and (policy fun (>= insert-debug-catch 2)) - (lambda-return fun)) + (when (and (lambda-allow-instrumenting fun) + (not (lambda-inline-expanded fun)) + (lambda-return fun) + (policy fun (>= insert-debug-catch 2))) (vop sb!vm::bind-sentinel node block)) (let ((lab (gen-label))) @@ -1210,7 +1284,9 @@ (return-pc (ir2-physenv-return-pc env)) (returns (tail-set-info (lambda-tail-set fun)))) #!+unwind-to-frame-and-call-vop - (when (policy fun (>= insert-debug-catch 2)) + (when (and (lambda-allow-instrumenting fun) + (not (lambda-inline-expanded fun)) + (policy fun (>= insert-debug-catch 2))) (vop sb!vm::unbind-sentinel node block)) (cond ((and (eq (return-info-kind returns) :fixed) @@ -1246,15 +1322,21 @@ (values)) ;;;; debugger hooks +;;;; +;;;; These are used by the debugger to find the top function on the +;;;; stack. They return the OLD-FP and RETURN-PC for the current +;;;; function as multiple values. + +(defoptimizer (%caller-frame ir2-convert) (() node block) + (let ((ir2-physenv (physenv-info (node-physenv node)))) + (move-lvar-result node block + (list (ir2-physenv-old-fp ir2-physenv)) + (node-lvar node)))) -;;; This is used by the debugger to find the top function on the -;;; stack. It returns the OLD-FP and RETURN-PC for the current -;;; function as multiple values. -(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block) +(defoptimizer (%caller-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)) + (list (ir2-physenv-return-pc ir2-physenv)) (node-lvar node)))) ;;;; multiple values @@ -1272,7 +1354,8 @@ (mapc (lambda (src var) (when (leaf-refs var) (let ((dest (leaf-info var))) - (if (lambda-var-indirect var) + (if (and (lambda-var-indirect var) + (lambda-var-explicit-value-cell var)) (emit-make-value-cell node block src dest) (emit-move node block src dest))))) (lvar-tns node block lvar @@ -1434,20 +1517,36 @@ (progn (labels ((,unbind (vars) (declare (optimize (speed 2) (debug 0))) - (dolist (var vars) - (%primitive bind nil var) - (makunbound var))) + (let ((unbound-marker (%primitive make-other-immediate-type + 0 sb!vm:unbound-marker-widetag))) + (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. + (about-to-modify-symbol-value var 'progv) + (%primitive bind unbound-marker var)))) (,bind (vars vals) - (declare (optimize (speed 2) (debug 0))) + (declare (optimize (speed 2) (debug 0) + (insert-debug-catch 0))) (cond ((null vars)) ((null vals) (,unbind vars)) - (t (%primitive bind - (car vals) - (car vars)) - (,bind (cdr vars) (cdr vals)))))) + (t + (let ((val (car vals)) + (var (car vars))) + (about-to-modify-symbol-value var 'progv val t) + (%primitive bind val var)) + (,bind (cdr vars) (cdr vals)))))) (,bind ,vars ,vals)) nil ,@body) + ;; Technically ANSI CL doesn't allow declarations at the + ;; start of the cleanup form. SBCL happens to allow for + ;; them, due to the way the UNWIND-PROTECT ir1 translation + ;; is implemented; the cleanup forms are directly spliced + ;; into an FLET definition body. And a declaration here + ;; actually has exactly the right scope for what we need + ;; (ensure that debug instrumentation is not emitted for the + ;; cleanup function). -- JES, 2007-06-16 + (declare (optimize (insert-debug-catch 0))) (%primitive unbind-to-here ,n-save-bs)))))) ;;;; non-local exit @@ -1720,7 +1819,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))