X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=cf5662b6e1d4f04dc387e5e01051753e13938ab9;hb=bf4aee82dd12d132a82fa39355d66f2ac67c8fc5;hp=1ce7180f2e8816dd16886e9d11b6da9cffb25fb5;hpb=a8fa26a6e9804d3548f5bca9361a91345a689099;p=sbcl.git diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 1ce7180..cf5662b 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))) @@ -140,7 +140,7 @@ ;;; Unlike for an argument, we only clear the type check flag when the ;;; LTN-POLICY is unsafe, since the check for a valid function ;;; object must be done before the call. -(defun annotate-function-continuation (cont ltn-policy &optional (delay t)) +(defun annotate-fun-continuation (cont ltn-policy &optional (delay t)) (declare (type continuation cont) (type ltn-policy ltn-policy)) (unless (ltn-policy-safe-p ltn-policy) (flush-type-check cont)) @@ -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) @@ -193,11 +193,11 @@ (defun ltn-default-call (call ltn-policy) (declare (type combination call) (type ltn-policy ltn-policy)) (let ((kind (basic-combination-kind call))) - (annotate-function-continuation (basic-combination-fun call) ltn-policy) + (annotate-fun-continuation (basic-combination-fun call) ltn-policy) (cond - ((and (function-info-p kind) - (function-info-ir2-convert kind)) + ((and (fun-info-p kind) + (fun-info-ir2-convert kind)) (setf (basic-combination-info call) :funny) (setf (node-tail-p call) nil) (dolist (arg (basic-combination-args call)) @@ -270,14 +270,14 @@ ;;; we annotate for the number of values indicated by TYPES, but only ;;; use proven type information. (defun annotate-fixed-values-continuation (cont ltn-policy types) - (declare (continuation cont) (ltn-policy ltn-policy) (list types)) + (declare (type continuation cont) (type ltn-policy ltn-policy) (list types)) (unless (ltn-policy-safe-p ltn-policy) (flush-type-check cont)) (let ((res (make-ir2-continuation nil))) (if (member (continuation-type-check cont) '(:deleted nil)) (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types)) - (let* ((proven (mapcar #'(lambda (x) - (make-normal-tn (primitive-type x))) + (let* ((proven (mapcar (lambda (x) + (make-normal-tn (primitive-type x))) (values-types (continuation-proven-type cont)))) (num-proven (length proven)) @@ -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,16 +382,16 @@ (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) (setf (node-tail-p call) nil)) (t (setf (basic-combination-info call) :full) - (annotate-function-continuation (basic-combination-fun call) - ltn-policy - nil) + (annotate-fun-continuation (basic-combination-fun call) + ltn-policy + nil) (dolist (arg (reverse args)) (annotate-unknown-values-continuation arg ltn-policy)) (flush-full-call-tail-transfer call)))) @@ -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. @@ -476,26 +476,6 @@ ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil)) - -;;; Both of these functions need special LTN-annotate methods, since -;;; we only want to clear the TYPE-CHECK in unsafe policies. If we -;;; allowed the call to be annotated as a full call, then no type -;;; checking would be done. -;;; -;;; We also need a special LTN annotate method for %SLOT-SETTER so -;;; that the function is ignored. This is because the reference to a -;;; SETF function can't be delayed, so IR2 conversion would have -;;; already emitted a call to FDEFINITION by the time the IR2 convert -;;; method got control. -(defoptimizer (%slot-accessor ltn-annotate) ((struct) node ltn-policy) - (setf (basic-combination-info node) :funny) - (setf (node-tail-p node) nil) - (annotate-ordinary-continuation struct ltn-policy)) -(defoptimizer (%slot-setter ltn-annotate) ((struct value) node ltn-policy) - (setf (basic-combination-info node) :funny) - (setf (node-tail-p node) nil) - (annotate-ordinary-continuation struct ltn-policy) - (annotate-ordinary-continuation value ltn-policy)) ;;;; known call annotation @@ -679,7 +659,7 @@ (declare (type combination call) (type ltn-policy ltn-policy)) (let ((safe-p (ltn-policy-safe-p ltn-policy)) - (current (function-info-templates (basic-combination-kind call))) + (current (fun-info-templates (basic-combination-kind call))) (fallback nil) (rejected nil)) (loop @@ -730,18 +710,18 @@ (:arg-types (funcall frob "argument types invalid") (funcall frob "argument primitive types:~% ~S" - (mapcar #'(lambda (x) - (primitive-type-name - (continuation-ptype x))) + (mapcar (lambda (x) + (primitive-type-name + (continuation-ptype x))) (combination-args call))) (funcall frob "argument type assertions:~% ~S" - (mapcar #'(lambda (x) - (if (atom x) - x - (ecase (car x) - (:or `(:or .,(mapcar #'primitive-type-name - (cdr x)))) - (:constant `(:constant ,(third x)))))) + (mapcar (lambda (x) + (if (atom x) + x + (ecase (car x) + (:or `(:or .,(mapcar #'primitive-type-name + (cdr x)))) + (:constant `(:constant ,(third x)))))) (template-arg-types template)))) (:conditional (funcall frob "conditional in a non-conditional context")) @@ -783,7 +763,7 @@ (or template (template-or-lose 'call-named))) *efficiency-note-cost-threshold*))) - (dolist (try (function-info-templates (basic-combination-kind call))) + (dolist (try (fun-info-templates (basic-combination-kind call))) (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner. (let ((guard (template-guard try))) (when (and (or (not guard) (funcall guard)) @@ -791,7 +771,7 @@ (ltn-policy-safe-p (template-ltn-policy try))) (or verbose-p (and (template-note try) - (valid-function-use + (valid-fun-use call (template-type try) :argument-test #'types-equal-or-intersect :result-test @@ -801,37 +781,37 @@ (when (losers) (collect ((messages) (count 0 +)) - (flet ((frob (string &rest stuff) + (flet ((lose1 (string &rest stuff) (messages string) (messages stuff))) (dolist (loser (losers)) (when (and *efficiency-note-limit* (>= (count) *efficiency-note-limit*)) - (frob "etc.") + (lose1 "etc.") (return)) (let* ((type (template-type loser)) - (valid (valid-function-use call type)) - (strict-valid (valid-function-use call type - :strict-result t))) - (frob "unable to do ~A (cost ~D) because:" - (or (template-note loser) (template-name loser)) - (template-cost loser)) + (valid (valid-fun-use call type)) + (strict-valid (valid-fun-use call type + :strict-result t))) + (lose1 "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)) + (strange-template-failure loser call ltn-policy #'lose1)) ((not valid) - (aver (not (valid-function-use call type - :error-function #'frob - :warning-function #'frob)))) + (aver (not (valid-fun-use call type + :lossage-fun #'lose1 + :unwinnage-fun #'lose1)))) (t (aver (ltn-policy-safe-p ltn-policy)) - (frob "can't trust output type assertion under safe policy"))) + (lose1 "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)) @@ -871,7 +851,7 @@ (defun ltn-analyze-known-call (call ltn-policy) (declare (type combination call) (type ltn-policy ltn-policy)) - (let ((method (function-info-ltn-annotate (basic-combination-kind call))) + (let ((method (fun-info-ltn-annotate (basic-combination-kind call))) (args (basic-combination-args call))) (when method (funcall method call ltn-policy) @@ -895,22 +875,21 @@ ;; 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 (fun-info-ir2-convert info) + (ir1-attributep (fun-info-attributes info) + recursive)))))) (let ((*compiler-error-context* call)) - (compiler-warning "~@" - (lexenv-policy (node-lexenv call)) - (mapcar (lambda (arg) - (type-specifier (continuation-type - arg))) - args)))) + (compiler-warn "~@" + (lexenv-policy (node-lexenv call)) + (mapcar (lambda (arg) + (type-specifier (continuation-type arg))) + args)))) (ltn-default-call call ltn-policy) (return-from ltn-analyze-known-call (values))) (setf (basic-combination-info call) template) @@ -965,7 +944,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 @@ -977,6 +956,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)