X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=7e9171b7c5fd3bfddc93ee018be1675fa60d22ba;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=66d201d80a911ad1d02545b866740f7ab96fe4dc;hpb=1a6def3955b715472eb2c75b15660912b9f90173;p=sbcl.git diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 66d201d..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,14 +268,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)) @@ -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))) @@ -424,7 +421,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 +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 @@ -730,18 +707,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 +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 @@ -801,37 +778,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)) @@ -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) @@ -895,22 +872,21 @@ ;; 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 "~@" - (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)