X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=47968509f9416ffe6d288dc3002f35e66918c5d7;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=b19e6fa0a60caed7c973577b63d9ce1601468e9a;hpb=d4cc0f4fe1dd40a6745abf74f778a32a805bbc9c;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index b19e6fa..4796850 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -56,10 +56,13 @@ (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) - (let ((leaf (tn-leaf res))) + (let* ((leaf (tn-leaf res)) + (dx (when leaf (leaf-dynamic-extent leaf)))) + (when (and dx (neq :truly dx) (leaf-has-source-name-p leaf)) + (compiler-notify "cannot stack allocate value cell for ~S" (leaf-source-name leaf))) (vop make-value-cell node block value ;; FIXME: See bug 419 - (and leaf (eq :truly (leaf-dynamic-extent leaf))) + (eq :truly dx) res))) ;;;; leaf reference @@ -141,12 +144,18 @@ (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 @@ -246,7 +255,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) @@ -298,10 +311,13 @@ (vop value-cell-set node block tn val) (emit-move node block val tn))))) (global-var + (aver (symbolp (leaf-source-name leaf))) (ecase (global-var-kind leaf) ((:special) - (aver (symbolp (leaf-source-name leaf))) - (vop set node block (emit-constant (leaf-source-name leaf)) val))))) + (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))) @@ -571,16 +587,28 @@ (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)) + (unless (drop-thru-p if alternative) + (vop branch node block (block-label alternative)))) (t - (emit-template node block template args nil - (list* (block-label consequent) not-p info-args)) + (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))))))) @@ -648,7 +676,7 @@ (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 rtypes)) @@ -680,7 +708,7 @@ (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 @@ -1241,15 +1269,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 @@ -1434,7 +1468,7 @@ (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 "bind ~S") + (about-to-modify-symbol-value var 'progv) (%primitive bind unbound-marker var)))) (,bind (vars vals) (declare (optimize (speed 2) (debug 0) @@ -1444,7 +1478,7 @@ (t (let ((val (car vals)) (var (car vars))) - (about-to-modify-symbol-value var "bind ~S" val) + (about-to-modify-symbol-value var 'progv val t) (%primitive bind val var)) (,bind (cdr vars) (cdr vals)))))) (,bind ,vars ,vals))