X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fltn.lisp;h=a728e2e0623604ca1b1ee7998e8cc75b0623e9e6;hb=c1aeac123df223746249567a9c0d2f656d1222cb;hp=e102f6431ee3e3669fc1ae9a4b0de650953b6a4b;hpb=79953929196409f21fe505b29b15d2a9281884b7;p=sbcl.git diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index e102f64..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))) @@ -105,7 +105,7 @@ (defun annotate-1-value-continuation (cont) (declare (type continuation cont)) (let ((info (continuation-info cont))) - (assert (eq (ir2-continuation-kind info) :fixed)) + (aver (eq (ir2-continuation-kind info) :fixed)) (cond ((continuation-delayed-leaf cont) (setf (ir2-continuation-kind info) :delayed)) @@ -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) @@ -419,12 +419,12 @@ (defun set-tail-local-call-successor (call) (let ((caller (node-home-lambda call)) (callee (combination-lambda call))) - (assert (eq (lambda-tail-set caller) - (lambda-tail-set (lambda-home callee)))) + (aver (eq (lambda-tail-set caller) + (lambda-tail-set (lambda-home callee)))) (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. @@ -473,7 +473,7 @@ (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node ltn-policy) - (declare (ignore ltn-policy)) + ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil)) @@ -721,7 +721,7 @@ (funcall frob "This shouldn't happen! Bug?") (multiple-value-bind (win why) (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) - (assert (not win)) + (aver (not win)) (ecase why (:guard (funcall frob "template guard failed")) @@ -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,25 +813,25 @@ (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 ((and valid strict-valid) (strange-template-failure loser call ltn-policy #'frob)) ((not valid) - (assert (not (valid-function-use call type - :error-function #'frob - :warning-function #'frob)))) + (aver (not (valid-function-use call type + :error-function #'frob + :warning-function #'frob)))) (t - (assert (ltn-policy-safe-p ltn-policy)) + (aver (ltn-policy-safe-p ltn-policy)) (frob "can't trust output type assertion under safe policy"))) (count 1)))) (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,17 +895,18 @@ ;; 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 "recursion in known function definition~2I ~ - ~_arg types=~S" + (compiler-warning "~@" + (lexenv-policy (node-lexenv call)) (mapcar (lambda (arg) (type-specifier (continuation-type arg))) @@ -963,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 @@ -975,7 +977,11 @@ (declare (type component component)) (let ((2comp (component-info component))) (do-blocks (block component) - (assert (not (block-info block))) + ;; 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) (ltn-analyze-block block) @@ -991,6 +997,6 @@ (defun ltn-analyze-belated-block (block) (declare (type cblock block)) (ltn-analyze-block block) - (assert (not (ir2-block-popped (block-info block)))) + (aver (not (ir2-block-popped (block-info block)))) (values))