;;; 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))
(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)
;;; 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)
(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.
(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"))
(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)
((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))))
;; 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 ~
- ~_policy=~S ~_arg types=~S"
+ (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
;;; 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