X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=8fa72f4a82cad48f27679075f746c98648aed822;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=41910d2bcce2135a06acd89c20d928431cb71b88;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 41910d2..8fa72f4 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -54,10 +54,10 @@ ;;;; 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) + find-in-physenv)) (defun find-in-physenv (thing physenv) - (declare (type (or nlx-info lambda-var) thing) (type physenv physenv) - (values tn)) - (or (cdr (assoc thing (ir2-physenv-environment (physenv-info physenv)))) + (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv)))) (etypecase thing (lambda-var ;; I think that a failure of this assertion means that we're @@ -109,7 +109,6 @@ (declare (type ref node) (type ir2-block block)) (let* ((cont (node-cont node)) (leaf (ref-leaf node)) - (name (leaf-name leaf)) (locs (continuation-result-tns cont (list (primitive-type (leaf-type leaf))))) (res (first locs))) @@ -122,16 +121,18 @@ (constant (if (legal-immediate-constant-p leaf) (emit-move node block (constant-tn leaf) res) - (let ((name-tn (emit-constant name))) + (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))))) (functional (ir2-convert-closure node block leaf res)) (global-var - (let ((unsafe (policy node (zerop safety)))) + (let ((unsafe (policy node (zerop safety))) + (name (leaf-source-name leaf))) (ecase (global-var-kind leaf) - ((:special :global :constant) + ((:special :global) (aver (symbolp name)) (let ((name-tn (emit-constant name))) (if unsafe @@ -149,15 +150,15 @@ ;;; This gets interesting when the referenced function is a closure: ;;; we must make the closure and move the closed over values into it. ;;; -;;; LEAF is either a :TOP-LEVEL-XEP functional or the XEP lambda for +;;; LEAF is either a :TOPLEVEL-XEP functional or the XEP lambda for ;;; the called function, since local call analysis converts all ;;; closure references. If a TL-XEP, we know it is not a closure. ;;; ;;; If a closed-over LAMBDA-VAR has no refs (is deleted), then we ;;; don't initialize that slot. This can happen with closures over -;;; top-level variables, where optimization of the closure deleted the +;;; top level variables, where optimization of the closure deleted the ;;; variable. Since we committed to the closure format when we -;;; pre-analyzed the top-level code, we just leave an empty slot. +;;; pre-analyzed the top level code, we just leave an empty slot. (defun ir2-convert-closure (node block leaf res) (declare (type ref node) (type ir2-block block) (type functional leaf) (type tn res)) @@ -168,7 +169,7 @@ (clambda (physenv-closure (get-lambda-physenv leaf))) (functional - (aver (eq (functional-kind leaf) :top-level-xep)) + (aver (eq (functional-kind leaf) :toplevel-xep)) nil)))) (cond (closure (let ((this-env (node-physenv node))) @@ -207,8 +208,8 @@ (global-var (ecase (global-var-kind leaf) ((:special :global) - (aver (symbolp (leaf-name leaf))) - (vop set node block (emit-constant (leaf-name leaf)) val))))) + (aver (symbolp (leaf-source-name leaf))) + (vop set node block (emit-constant (leaf-source-name leaf)) val))))) (when locs (emit-move node block val (first locs)) (move-continuation-result node block locs cont))) @@ -389,7 +390,7 @@ dest)) (values)) -;;; If necessary, emit coercion code needed to deliver the Results to +;;; If necessary, emit coercion code needed to deliver the RESULTS to ;;; the specified continuation. NODE and BLOCK provide context for ;;; emitting code. Although usually obtained from STANDARD-RESULT-TNs ;;; or CONTINUATION-RESULT-TNs, RESULTS my be a list of any type or @@ -648,7 +649,7 @@ (locs loc)))) (when old-fp - (dolist (thing (ir2-physenv-environment called-env)) + (dolist (thing (ir2-physenv-closure called-env)) (temps (find-in-physenv (car thing) this-1env)) (locs (cdr thing))) @@ -769,7 +770,7 @@ ((node-tail-p node) (ir2-convert-tail-local-call node block fun)) (t - (let ((start (block-label (node-block (lambda-bind fun)))) + (let ((start (block-label (lambda-block fun))) (returns (tail-set-info (lambda-tail-set fun))) (cont (node-cont node))) (ecase (if returns @@ -1014,7 +1015,7 @@ (declare (type bind node) (type ir2-block block) (type clambda fun)) (let ((start-label (entry-info-offset (leaf-info fun))) (env (physenv-info (node-physenv node)))) - (let ((ef (functional-entry-function fun))) + (let ((ef (functional-entry-fun fun))) (cond ((and (optional-dispatch-p ef) (optional-dispatch-more-entry ef)) ;; Special case the xep-allocate-frame + copy-more-arg case. (vop xep-allocate-frame node block start-label t) @@ -1022,17 +1023,17 @@ (t ;; No more args, so normal entry. (vop xep-allocate-frame node block start-label nil))) - (if (ir2-physenv-environment env) + (if (ir2-physenv-closure env) (let ((closure (make-normal-tn *backend-t-primitive-type*))) (vop setup-closure-environment node block start-label closure) (when (getf (functional-plist ef) :fin-function) (vop funcallable-instance-lexenv node block closure closure)) (let ((n -1)) - (dolist (loc (ir2-physenv-environment env)) + (dolist (loc (ir2-physenv-closure env)) (vop closure-ref node block closure (incf n) (cdr loc))))) (vop setup-environment node block start-label))) - (unless (eq (functional-kind fun) :top-level) + (unless (eq (functional-kind fun) :toplevel) (let ((vars (lambda-vars fun)) (n 0)) (when (leaf-refs (first vars)) @@ -1064,7 +1065,7 @@ (let* ((fun (bind-lambda node)) (env (physenv-info (lambda-physenv fun)))) (aver (member (functional-kind fun) - '(nil :external :optional :top-level :cleanup))) + '(nil :external :optional :toplevel :cleanup))) (when (external-entry-point-p fun) (init-xep-environment node block fun) @@ -1142,10 +1143,10 @@ ;;; 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) - (let ((env (physenv-info (node-physenv node)))) + (let ((ir2-physenv (physenv-info (node-physenv node)))) (move-continuation-result node block - (list (ir2-physenv-old-fp env) - (ir2-physenv-return-pc env)) + (list (ir2-physenv-old-fp ir2-physenv) + (ir2-physenv-return-pc ir2-physenv)) (node-cont node)))) ;;;; multiple values @@ -1261,7 +1262,7 @@ ;;; This is trivial, given our assumption of a shallow-binding ;;; implementation. (defoptimizer (%special-bind ir2-convert) ((var value) node block) - (let ((name (leaf-name (continuation-value var)))) + (let ((name (leaf-source-name (continuation-value var)))) (vop bind node block (continuation-tn node block value) (emit-constant name)))) (defoptimizer (%special-unbind ir2-convert) ((var) node block) @@ -1329,7 +1330,6 @@ (ir2-continuation-locs (continuation-info (second args))) nil)) (nil))) - (move-continuation-result node block () (node-cont node)) (values)) @@ -1561,7 +1561,9 @@ (eq (basic-combination-kind last) :full)) (let* ((fun (basic-combination-fun last)) (use (continuation-use fun)) - (name (and (ref-p use) (leaf-name (ref-leaf use))))) + (name (and (ref-p use) + (leaf-has-source-name-p (ref-leaf use)) + (leaf-source-name (ref-leaf use))))) (unless (or (node-tail-p last) (info :function :info name) (policy last (zerop safety)))