X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fltn.lisp;h=a728e2e0623604ca1b1ee7998e8cc75b0623e9e6;hb=c1aeac123df223746249567a9c0d2f656d1222cb;hp=ba40a142f093a4e444b1c8207bbcb6f64e810252;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index ba40a14..a728e2e 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -78,7 +78,7 @@ ;;; values cannot, since we must preserve EQLness. (defun legal-immediate-constant-p (leaf) (declare (type constant leaf)) - (or (null (leaf-name leaf)) + (or (not (leaf-has-source-name-p leaf)) (typecase (constant-value leaf) ((or number character) t) (symbol (symbol-package (constant-value leaf))) @@ -152,7 +152,7 @@ (continuation-proven-type cont))))) (info (make-ir2-continuation ptype))) (setf (continuation-info cont) info) - (let ((name (continuation-function-name cont t))) + (let ((name (continuation-fun-name cont t))) (if (and delay name) (setf (ir2-continuation-kind info) :delayed) (setf (ir2-continuation-locs info) @@ -300,9 +300,9 @@ ;;; Annotate the result continuation for a function. We use the ;;; RETURN-INFO computed by GTN to determine how to represent the ;;; return values within the function: -;;; ---- If the tail-set has a fixed values count, then use that +;;; * If the TAIL-SET has a fixed values count, then use that ;;; many values. -;;; ---- If the actual uses of the result continuation in this function +;;; * If the actual uses of the result continuation in this function ;;; have a fixed number of values (after intersection with the ;;; assertion), then use that number. We throw out TAIL-P :FULL ;;; and :LOCAL calls, since we know they will truly end up as TR @@ -316,7 +316,7 @@ ;;; the result continuation before it reaches the RETURN. In ;;; perverse code, we may annotate for unknown values when we ;;; didn't have to. -;;; ---- Otherwise, we must annotate the continuation for unknown values. +;;; * Otherwise, we must annotate the continuation for unknown values. (defun ltn-analyze-return (node ltn-policy) (declare (type creturn node) (type ltn-policy ltn-policy)) (let* ((cont (return-result node)) @@ -382,7 +382,7 @@ (declare (type mv-combination call) (type ltn-policy ltn-policy)) (let ((fun (basic-combination-fun call)) (args (basic-combination-args call))) - (cond ((eq (continuation-function-name fun) '%throw) + (cond ((eq (continuation-fun-name fun) '%throw) (setf (basic-combination-info call) :funny) (annotate-ordinary-continuation (first args) ltn-policy) (annotate-unknown-values-continuation (second args) ltn-policy) @@ -424,7 +424,7 @@ (node-ends-block call) (let ((block (node-block call))) (unlink-blocks block (first (block-succ block))) - (link-blocks block (node-block (lambda-bind callee))))) + (link-blocks block (lambda-block callee)))) (values)) ;;; Annotate the value continuation. @@ -793,8 +793,9 @@ (and (template-note try) (valid-function-use call (template-type try) - :argument-test #'types-intersect - :result-test #'values-types-intersect)))) + :argument-test #'types-equal-or-intersect + :result-test + #'values-types-equal-or-intersect)))) (losers try))))) (when (losers) @@ -812,7 +813,7 @@ (valid (valid-function-use call type)) (strict-valid (valid-function-use call type :strict-result t))) - (frob "unable to do ~A (cost ~D) because:" + (frob "unable to do ~A (cost ~W) because:" (or (template-note loser) (template-name loser)) (template-cost loser)) (cond @@ -830,7 +831,7 @@ (let ((*compiler-error-context* call)) (compiler-note "~{~?~^~&~6T~}" (if template - `("forced to do ~A (cost ~D)" + `("forced to do ~A (cost ~W)" (,(or (template-note template) (template-name template)) ,(template-cost template)) @@ -894,14 +895,14 @@ ;; to implement an out-of-line version in terms of inline ;; transforms or VOPs or whatever. (unless template - (when (and (eq (continuation-function-name (combination-fun call)) - (leaf-name - (environment-function - (node-environment call)))) - (let ((info (basic-combination-kind call))) - (not (or (function-info-ir2-convert info) - (ir1-attributep (function-info-attributes info) - recursive))))) + (when (let ((funleaf (physenv-lambda (node-physenv call)))) + (and (leaf-has-source-name-p funleaf) + (eq (continuation-fun-name (combination-fun call)) + (leaf-source-name funleaf)) + (let ((info (basic-combination-kind call))) + (not (or (function-info-ir2-convert info) + (ir1-attributep (function-info-attributes info) + recursive)))))) (let ((*compiler-error-context* call)) (compiler-warning "~@" @@ -964,7 +965,7 @@ ;;; Loop over the blocks in COMPONENT, doing stuff to nodes that ;;; receive values. In addition to the stuff done by FROB, we also see ;;; whether there are any unknown values receivers, making notations -;;; in the components Generators and Receivers as appropriate. +;;; in the components' GENERATORS and RECEIVERS as appropriate. ;;; ;;; If any unknown-values continations are received by this block (as ;;; indicated by IR2-BLOCK-POPPED), then we add the block to the @@ -976,6 +977,10 @@ (declare (type component component)) (let ((2comp (component-info component))) (do-blocks (block component) + ;; This assertion seems to protect us from compiling a component + ;; twice. As noted above, "this is where we allocate IR2-BLOCKS + ;; because it is the first place we need them", so if one is + ;; already allocated here, something is wrong. -- WHN 2001-09-14 (aver (not (block-info block))) (let ((2block (make-ir2-block block))) (setf (block-info block) 2block)