X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=7e9171b7c5fd3bfddc93ee018be1675fa60d22ba;hb=86fca9c405f91d02784bcdd24b25a81dce549332;hp=fe648019e1a32f59546ad58e3de843ec6639f9ab;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index fe64801..7e9171b 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -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)) @@ -184,20 +184,19 @@ ;;; deliver values normally. We still annotate the function continuation, ;;; since IR2tran might decide to call after all. ;;; -;;; If not funny, we always flush arg type checks, but do it after -;;; annotation when the LTN-POLICY is safe, since we don't want to -;;; choose the TNs according to a type assertions that may not hold. +;;; If not funny, we flush arg type checks, when LTN-POLICY is not +;;; safe. ;;; ;;; Note that args may already be annotated because template selection can ;;; bail out to here. (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)) @@ -216,8 +215,7 @@ (make-ir2-continuation (primitive-type (continuation-type arg))))) - (annotate-1-value-continuation arg) - (when safe-p (flush-type-check arg)))) + (annotate-1-value-continuation arg))) (when (eq kind :error) (setf (basic-combination-kind call) :full)) (setf (basic-combination-info call) :full) @@ -270,7 +268,7 @@ ;;; 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))) @@ -389,9 +387,9 @@ (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)))) @@ -414,8 +412,7 @@ ;;; Make sure that a tail local call is linked directly to the bind ;;; node. Usually it will be, but calls from XEPs and calls that might have ;;; needed a cleanup after them won't have been swung over yet, since we -;;; weren't sure they would really be TR until now. Also called by byte -;;; compiler. +;;; weren't sure they would really be TR until now. (defun set-tail-local-call-successor (call) (let ((caller (node-home-lambda call)) (callee (combination-lambda call))) @@ -476,26 +473,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 +656,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 @@ -783,7 +760,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 +768,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 @@ -810,9 +787,9 @@ (lose1 "etc.") (return)) (let* ((type (template-type loser)) - (valid (valid-function-use call type)) - (strict-valid (valid-function-use call type - :strict-result t))) + (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)) @@ -820,9 +797,9 @@ ((and valid strict-valid) (strange-template-failure loser call ltn-policy #'lose1)) ((not valid) - (aver (not (valid-function-use call type - :lossage-fun #'lose1 - :unwinnage-fun #'lose1)))) + (aver (not (valid-fun-use call type + :lossage-fun #'lose1 + :unwinnage-fun #'lose1)))) (t (aver (ltn-policy-safe-p ltn-policy)) (lose1 "can't trust output type assertion under safe policy"))) @@ -845,7 +822,7 @@ ;;; unsafe, then we never do any checks. If our policy is safe, and ;;; we are using a safe template, then we can also flush arg and ;;; result type checks. Result type checks are only flushed when the -;;; continuation as a single use. Result type checks are not flush if +;;; continuation has a single use. Result type checks are not flush if ;;; the policy is safe because the selection of template for results ;;; readers assumes the type check is done (uses the derived type ;;; which is the intersection of the proven and asserted types). @@ -871,7 +848,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) @@ -900,8 +877,8 @@ (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-warn "~@