;;; 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))
(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))
(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))))
(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
(: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-equal-or-intersect
:result-test
(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))
(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 (let ((funleaf (physenv-function (node-physenv call))))
+ (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)
+ (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)
projects / sbcl.git / blobdiff