;;; 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)))
(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))
;;; 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))
(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)
(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))
;;; 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))
;;; 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
;;; 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))
(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))))
(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.
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))
\f
;;;; known call annotation
(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
(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"))
(: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"))
(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))
(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-intersect
- :result-test #'values-types-intersect))))
+ :argument-test #'types-equal-or-intersect
+ :result-test
+ #'values-types-equal-or-intersect))))
(losers try)))))
(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)
- (assert (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
- (assert (ltn-policy-safe-p ltn-policy))
- (frob "can't trust output type assertion under safe policy")))
+ (aver (ltn-policy-safe-p ltn-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))
(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)
;; 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 "recursion in known function definition~2I ~
- ~_policy=~S ~_arg types=~S"
- (lexenv-policy (node-lexenv call))
- (mapcar (lambda (arg)
- (type-specifier (continuation-type
- arg)))
- args))))
+ (compiler-warn "~@<recursion in known function definition~2I ~
+ ~_policy=~S ~_arg types=~S~:>"
+ (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)
;;; 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
(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)
(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))
projects / sbcl.git / blobdiff