;;; FIXME: Classic CMU CL went to some trouble to cache LTN-POLICY
;;; values in LTN-ANALYZE so that they didn't have to be recomputed on
;;; every block. I stripped that out (the whole DEFMACRO FROB thing)
;;; FIXME: Classic CMU CL went to some trouble to cache LTN-POLICY
;;; values in LTN-ANALYZE so that they didn't have to be recomputed on
;;; every block. I stripped that out (the whole DEFMACRO FROB thing)
;;; new uncached code spends an unreasonable amount of time in
;;; this lookup function. This function should be profiled, and if
;;; it's a significant contributor to runtime, we can cache it in
;;; new uncached code spends an unreasonable amount of time in
;;; this lookup function. This function should be profiled, and if
;;; it's a significant contributor to runtime, we can cache it in
- (let ((eff-space (max space
- ;; on the theory that if the code is
- ;; smaller, it will take less time to
- ;; compile (could lose if the smallest
- ;; case is out of line, and must
- ;; allocate many linkage registers):
- compilation-speed)))
- (if (zerop safety)
- (if (>= speed eff-space) :fast :small)
- (if (>= speed eff-space) :fast-safe :safe)))))
+ (let ((eff-space (max space
+ ;; on the theory that if the code is
+ ;; smaller, it will take less time to
+ ;; compile (could lose if the smallest
+ ;; case is out of line, and must
+ ;; allocate many linkage registers):
+ compilation-speed)))
+ (if (zerop safety)
+ (if (>= speed eff-space) :fast :small)
+ (if (>= speed eff-space) :fast-safe :safe)))))
-;;; Return true if a constant LEAF is of a type which we can legally
-;;; directly reference in code. Named constants with arbitrary pointer
-;;; values cannot, since we must preserve EQLness.
-(defun legal-immediate-constant-p (leaf)
- (declare (type constant leaf))
- (or (not (leaf-has-source-name-p leaf))
- (typecase (constant-value leaf)
- ((or number character) t)
- (symbol (symbol-package (constant-value leaf)))
- (t nil))))
-
;;; If LVAR is used only by a REF to a leaf that can be delayed, then
;;; return the leaf, otherwise return NIL.
(defun lvar-delayed-leaf (lvar)
(declare (type lvar lvar))
;;; If LVAR is used only by a REF to a leaf that can be delayed, then
;;; return the leaf, otherwise return NIL.
(defun lvar-delayed-leaf (lvar)
(declare (type lvar lvar))
- (let ((use (lvar-uses lvar)))
- (and (ref-p use)
- (let ((leaf (ref-leaf use)))
- (etypecase leaf
- (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
- (constant (if (legal-immediate-constant-p leaf) leaf nil))
- ((or functional global-var) nil))))))
+ (unless (lvar-dynamic-extent lvar)
+ (let ((use (lvar-uses lvar)))
+ (and (ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (etypecase leaf
+ (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
+ (constant leaf)
+ ((or functional global-var) nil)))))))
(setf (ir2-lvar-kind info) :delayed))
(t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info))))
(setf (ir2-lvar-locs info) (list tn))
(setf (ir2-lvar-kind info) :delayed))
(t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info))))
(setf (ir2-lvar-locs info) (list tn))
(when (lvar-dynamic-extent lvar)
(setf (ir2-lvar-stack-pointer info)
(make-stack-pointer-tn)))))))
(when (lvar-dynamic-extent lvar)
(setf (ir2-lvar-stack-pointer info)
(make-stack-pointer-tn)))))))
(defun annotate-ordinary-lvar (lvar)
(declare (type lvar lvar))
(let ((info (make-ir2-lvar
(defun annotate-ordinary-lvar (lvar)
(declare (type lvar lvar))
(let ((info (make-ir2-lvar
(declare (type lvar lvar))
(aver (not (lvar-dynamic-extent lvar)))
(let* ((tn-ptype (primitive-type (lvar-type lvar)))
(declare (type lvar lvar))
(aver (not (lvar-dynamic-extent lvar)))
(let* ((tn-ptype (primitive-type (lvar-type lvar)))
- (setf (ir2-lvar-kind info) :delayed)
- (setf (ir2-lvar-locs info)
- (list (make-normal-tn tn-ptype))))))
+ (setf (ir2-lvar-kind info) :delayed)
+ (setf (ir2-lvar-locs info)
+ (list (make-normal-tn tn-ptype))))))
(defun flush-full-call-tail-transfer (call)
(declare (type basic-combination call))
(let ((tails (and (node-tail-p call)
(defun flush-full-call-tail-transfer (call)
(declare (type basic-combination call))
(let ((tails (and (node-tail-p call)
- (node-ends-block call)
- (let ((block (node-block call)))
- (unlink-blocks block (first (block-succ block)))
- (link-blocks block (component-tail (block-component block)))))
- (t
- (setf (node-tail-p call) nil)))))
+ (node-ends-block call)
+ (let ((block (node-block call)))
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block (component-tail (block-component block)))))
+ (t
+ (setf (node-tail-p call) nil)))))
(defun ltn-default-call (call)
(declare (type combination call))
(let ((kind (basic-combination-kind call))
(defun ltn-default-call (call)
(declare (type combination call))
(let ((kind (basic-combination-kind call))
(fun-info-ir2-convert info))
(setf (basic-combination-info call) :funny)
(setf (node-tail-p call) nil))
(fun-info-ir2-convert info))
(setf (basic-combination-info call) :funny)
(setf (node-tail-p call) nil))
;;; specified primitive TYPES.
(defun annotate-fixed-values-lvar (lvar types)
(declare (type lvar lvar) (list types))
;;; specified primitive TYPES.
(defun annotate-fixed-values-lvar (lvar types)
(declare (type lvar lvar) (list types))
- (aver (not (lvar-dynamic-extent lvar))) ; XXX
- (let ((res (make-ir2-lvar nil)))
- (setf (ir2-lvar-locs res) (mapcar #'make-normal-tn types))
- (setf (lvar-info lvar) res))
+ (let ((info (make-ir2-lvar nil)))
+ (setf (ir2-lvar-locs info) (mapcar #'make-normal-tn types))
+ (setf (lvar-info lvar) info)
+ (when (lvar-dynamic-extent lvar)
+ (aver (proper-list-of-length-p types 1))
+ (setf (ir2-lvar-stack-pointer info)
+ (make-stack-pointer-tn))))
(defun ltn-analyze-return (node)
(declare (type creturn node))
(let* ((lvar (return-result node))
(defun ltn-analyze-return (node)
(declare (type creturn node))
(let* ((lvar (return-result node))
- (fun (return-lambda node))
- (returns (tail-set-info (lambda-tail-set fun)))
- (types (return-info-types returns)))
+ (fun (return-lambda node))
+ (returns (tail-set-info (lambda-tail-set fun)))
+ (types (return-info-types returns)))
- (collect ((res *empty-type* values-type-union))
- (do-uses (use (return-result node))
- (unless (and (node-tail-p use)
- (basic-combination-p use)
- (member (basic-combination-info use) '(:local :full)))
- (res (node-derived-type use))))
-
- (let ((int (res)))
- (multiple-value-bind (types kind)
+ (collect ((res *empty-type* values-type-union))
+ (do-uses (use (return-result node))
+ (unless (and (node-tail-p use)
+ (basic-combination-p use)
+ (member (basic-combination-info use) '(:local :full)))
+ (res (node-derived-type use))))
+
+ (let ((int (res)))
+ (multiple-value-bind (types kind)
- (if (eq kind :unknown)
- (annotate-unknown-values-lvar lvar)
- (annotate-fixed-values-lvar
- lvar (mapcar #'primitive-type types))))))
- (annotate-fixed-values-lvar lvar types)))
+ (if (eq kind :unknown)
+ (annotate-unknown-values-lvar lvar)
+ (annotate-fixed-values-lvar
+ lvar (mapcar #'primitive-type types))))))
+ (annotate-fixed-values-lvar lvar types)))
(defun ltn-analyze-mv-call (call)
(declare (type mv-combination call))
(let ((fun (basic-combination-fun call))
(defun ltn-analyze-mv-call (call)
(declare (type mv-combination call))
(let ((fun (basic-combination-fun call))
- (setf (basic-combination-info call) :funny)
- (annotate-ordinary-lvar (first args))
- (annotate-unknown-values-lvar (second args))
- (setf (node-tail-p call) nil))
- (t
- (setf (basic-combination-info call) :full)
- (annotate-fun-lvar (basic-combination-fun call) nil)
- (dolist (arg (reverse args))
- (annotate-unknown-values-lvar arg))
- (flush-full-call-tail-transfer call))))
+ (setf (basic-combination-info call) :funny)
+ (annotate-ordinary-lvar (first args))
+ (annotate-unknown-values-lvar (second args))
+ (setf (node-tail-p call) nil))
+ (t
+ (setf (basic-combination-info call) :full)
+ (annotate-fun-lvar (basic-combination-fun call) nil)
+ (dolist (arg (reverse args))
+ (annotate-unknown-values-lvar arg))
+ (flush-full-call-tail-transfer call))))
;;; weren't sure they would really be TR until now.
(defun set-tail-local-call-successor (call)
(let ((caller (node-home-lambda call))
;;; weren't sure they would really be TR until now.
(defun set-tail-local-call-successor (call)
(let ((caller (node-home-lambda call))
;;; converted the reference to the escape function into a constant
;;; reference to the NLX-INFO.)
(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup)
;;; converted the reference to the escape function into a constant
;;; reference to the NLX-INFO.)
(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup)
ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil))
ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil))
- (:or
- (dolist (mem (rest restr) nil)
- (when (or (and t-ok (eq mem *backend-t-primitive-type*))
- (eq mem type))
- (return t))))
- (:constant
- (cond (lvar
- (and (constant-lvar-p lvar)
- (funcall (second restr) (lvar-value lvar))))
- (tn
- (and (eq (tn-kind tn) :constant)
- (funcall (second restr) (tn-value tn))))
- (t
- (error "Neither LVAR nor TN supplied.")))))))
+ (:or
+ (dolist (mem (rest restr) nil)
+ (when (or (and t-ok (eq mem *backend-t-primitive-type*))
+ (eq mem type))
+ (return t))))
+ (:constant
+ (cond (lvar
+ (and (constant-lvar-p lvar)
+ (funcall (second restr) (lvar-value lvar))))
+ (tn
+ (and (eq (tn-kind tn) :constant)
+ (funcall (second restr) (tn-value tn))))
+ (t
+ (error "Neither LVAR nor TN supplied.")))))))
;;; Check that the argument type restriction for TEMPLATE are
;;; satisfied in call. If an argument's TYPE-CHECK is :NO-CHECK and
;;; our policy is safe, then only :SAFE templates are OK.
(defun template-args-ok (template call safe-p)
(declare (type template template)
;;; Check that the argument type restriction for TEMPLATE are
;;; satisfied in call. If an argument's TYPE-CHECK is :NO-CHECK and
;;; our policy is safe, then only :SAFE templates are OK.
(defun template-args-ok (template call safe-p)
(declare (type template template)
(declare (ignore safe-p))
(let ((mtype (template-more-args-type template)))
(do ((args (basic-combination-args call) (cdr args))
(declare (ignore safe-p))
(let ((mtype (template-more-args-type template)))
(do ((args (basic-combination-args call) (cdr args))
;;; we run out of result types, then we always win.
(defun template-results-ok (template result-type)
(declare (type template template)
;;; we run out of result types, then we always win.
(defun template-results-ok (template result-type)
(declare (type template template)
(when (template-more-results-type template)
(error "~S has :MORE results with :TRANSLATE." (template-name template)))
(let ((types (template-result-types template)))
(cond
((values-type-p result-type)
(do ((ltypes (append (args-type-required result-type)
(when (template-more-results-type template)
(error "~S has :MORE results with :TRANSLATE." (template-name template)))
(let ((types (template-result-types template)))
(cond
((values-type-p result-type)
(do ((ltypes (append (args-type-required result-type)
- (args-type-optional result-type))
- (rest ltypes))
- (types types (rest types)))
- ((null ltypes)
- (dolist (type types t)
- (unless (eq type '*)
- (return nil))))
- (when (null types) (return t))
- (let ((type (first types)))
- (unless (operand-restriction-ok type
- (primitive-type (first ltypes)))
- (return nil)))))
+ (args-type-optional result-type))
+ (rest ltypes))
+ (types types (rest types)))
+ ((null ltypes)
+ (dolist (type types t)
+ (unless (eq type '*)
+ (return nil))))
+ (when (null types) (return t))
+ (let ((type (first types)))
+ (unless (operand-restriction-ok type
+ (primitive-type (first ltypes)))
+ (return nil)))))
(defun is-ok-template-use (template call safe-p)
(declare (type template template) (type combination call))
(let* ((guard (template-guard template))
(defun is-ok-template-use (template call safe-p)
(declare (type template template) (type combination call))
(let* ((guard (template-guard template))
- (values nil :guard))
- ((not (template-args-ok template call safe-p))
- (values nil
- (if (and safe-p (template-args-ok template call nil))
- :arg-check
- :arg-types)))
- ((eq (template-result-types template) :conditional)
- (let ((dest (lvar-dest lvar)))
- (if (and (if-p dest)
- (immediately-used-p (if-test dest) call))
- (values t nil)
- (values nil :conditional))))
- ((template-results-ok template dtype)
- (values t nil))
- (t
- (values nil :result-types)))))
+ (values nil :guard))
+ ((not (template-args-ok template call safe-p))
+ (values nil
+ (if (and safe-p (template-args-ok template call nil))
+ :arg-check
+ :arg-types)))
+ ((template-conditional-p template)
+ (let ((dest (lvar-dest lvar)))
+ (if (and (if-p dest)
+ (immediately-used-p (if-test dest) call))
+ (values t nil)
+ (values nil :conditional))))
+ ((template-results-ok template dtype)
+ (values t nil))
+ (t
+ (values nil :result-types)))))
(values nil rejected nil))
(let ((template (first templates)))
(when (is-ok-template-use template call safe-p)
(values nil rejected nil))
(let ((template (first templates)))
(when (is-ok-template-use template call safe-p)
;;; small and fast as well.
(defun find-template-for-ltn-policy (call ltn-policy)
(declare (type combination call)
;;; small and fast as well.
(defun find-template-for-ltn-policy (call ltn-policy)
(declare (type combination call)
- (cond ((eq tcpolicy ltn-policy)
- (return (values template rejected)))
- ((eq tcpolicy :safe)
- (return (values (or fallback template) rejected)))
- ((or (not safe-p) (eq tcpolicy :fast-safe))
- (unless fallback
- (setq fallback template)))))))))
+ (cond ((eq tcpolicy ltn-policy)
+ (return (values template rejected)))
+ ((eq tcpolicy :safe)
+ (return (values (or fallback template) rejected)))
+ ((or (not safe-p) (eq tcpolicy :fast-safe))
+ (unless fallback
+ (setq fallback template)))))))))
;;; the VM definition is messed up somehow.
(defun strange-template-failure (template call ltn-policy frob)
(declare (type template template) (type combination call)
;;; the VM definition is messed up somehow.
(defun strange-template-failure (template call ltn-policy frob)
(declare (type template template) (type combination call)
(funcall frob "This shouldn't happen! Bug?")
(multiple-value-bind (win why)
(is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
(funcall frob "This shouldn't happen! Bug?")
(multiple-value-bind (win why)
(is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
- (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))))
+ (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))))
- (verbose-p (policy call (= inhibit-warnings 0)))
- (max-cost (- (template-cost
- (or template
- (template-or-lose 'call-named)))
- *efficiency-note-cost-threshold*)))
+ (verbose-p (policy call (= inhibit-warnings 0)))
+ (max-cost (- (template-cost
+ (or template
+ (template-or-lose 'call-named)))
+ *efficiency-note-cost-threshold*)))
- (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
- (let ((guard (template-guard try)))
- (when (and (or (not guard) (funcall guard))
- (or (not safe-p)
- (ltn-policy-safe-p (template-ltn-policy try)))
+ (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
+ (let ((guard (template-guard try)))
+ (when (and (or (not guard) (funcall guard))
+ (or (not safe-p)
+ (ltn-policy-safe-p (template-ltn-policy try)))
;; :SAFE is also considered to be :SMALL-SAFE,
;; while the template cost describes time cost;
;; so the fact that (< (t-cost try) (t-cost
;; template)) does not mean that TRY is better
(not (and (eq ltn-policy :safe)
(eq (template-ltn-policy try) :fast-safe)))
;; :SAFE is also considered to be :SMALL-SAFE,
;; while the template cost describes time cost;
;; so the fact that (< (t-cost try) (t-cost
;; template)) does not mean that TRY is better
(not (and (eq ltn-policy :safe)
(eq (template-ltn-policy try) :fast-safe)))
- (or verbose-p
- (and (template-note try)
- (valid-fun-use
- call (template-type try)
- :argument-test #'types-equal-or-intersect
- :result-test
- #'values-types-equal-or-intersect))))
- (losers try)))))
+ (or verbose-p
+ (and (template-note try)
+ (valid-fun-use
+ call (template-type try)
+ :argument-test #'types-equal-or-intersect
+ :result-test
+ #'values-types-equal-or-intersect))))
+ (losers try)))))
- (notes 0 +))
- (flet ((lose1 (string &rest stuff)
- (messages string)
- (messages stuff)))
- (dolist (loser (losers))
- (when (and *efficiency-note-limit*
- (>= (notes) *efficiency-note-limit*))
- (lose1 "etc.")
- (return))
- (let* ((type (template-type loser))
- (valid (valid-fun-use call type))
- (strict-valid (valid-fun-use call type)))
- (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 #'lose1))
- ((not valid)
- (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")))
- (notes 1))))
-
- (let ((*compiler-error-context* call))
- (compiler-notify "~{~?~^~&~6T~}"
- (if template
- `("forced to do ~A (cost ~W)"
- (,(or (template-note template)
- (template-name template))
- ,(template-cost template))
- . ,(messages))
- `("forced to do full call"
- nil
- . ,(messages))))))))
+ (notes 0 +))
+ (flet ((lose1 (string &rest stuff)
+ (messages string)
+ (messages stuff)))
+ (dolist (loser (losers))
+ (when (and *efficiency-note-limit*
+ (>= (notes) *efficiency-note-limit*))
+ (lose1 "etc.")
+ (return))
+ (let* ((type (template-type loser))
+ (valid (valid-fun-use call type))
+ (strict-valid (valid-fun-use call type)))
+ (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 #'lose1))
+ ((not valid)
+ (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")))
+ (notes 1))))
+
+ (let ((*compiler-error-context* call))
+ (compiler-notify "~{~?~^~&~6T~}"
+ (if template
+ `("forced to do ~A (cost ~W)"
+ (,(or (template-note template)
+ (template-name template))
+ ,(template-cost template))
+ . ,(messages))
+ `("forced to do full call"
+ nil
+ . ,(messages))))))))
(declare (type combination call))
(let ((ltn-policy (node-ltn-policy call))
(method (fun-info-ltn-annotate (basic-combination-fun-info call)))
(declare (type combination call))
(let ((ltn-policy (node-ltn-policy call))
(method (fun-info-ltn-annotate (basic-combination-fun-info call)))
;; If we are unable to use some templates due to unsatisfied
;; operand type restrictions and our policy enables efficiency
;; notes, then we call NOTE-REJECTED-TEMPLATES.
(when (and rejected
;; If we are unable to use some templates due to unsatisfied
;; operand type restrictions and our policy enables efficiency
;; notes, then we call NOTE-REJECTED-TEMPLATES.
(when (and rejected
;; If we are forced to do a full call, we check to see whether
;; the function called is the same as the current function. If
;; so, we give a warning, as this is probably a botched attempt
;; to implement an out-of-line version in terms of inline
;; transforms or VOPs or whatever.
(unless template
;; If we are forced to do a full call, we check to see whether
;; the function called is the same as the current function. If
;; so, we give a warning, as this is probably a botched attempt
;; to implement an out-of-line version in terms of inline
;; transforms or VOPs or whatever.
(unless template
- (when (let ((funleaf (physenv-lambda (node-physenv call))))
- (and (leaf-has-source-name-p funleaf)
- (eq (lvar-fun-name (combination-fun call))
- (leaf-source-name funleaf))
- (let ((info (basic-combination-fun-info call)))
- (not (or (fun-info-ir2-convert info)
- (ir1-attributep (fun-info-attributes info)
- recursive))))))
- (let ((*compiler-error-context* call))
- (compiler-warn "~@<recursion in known function definition~2I ~
+ (when (let ((funleaf (physenv-lambda (node-physenv call))))
+ (and (leaf-has-source-name-p funleaf)
+ (eq (lvar-fun-name (combination-fun call))
+ (leaf-source-name funleaf))
+ (let ((info (basic-combination-fun-info call)))
+ (not (or (fun-info-ir2-convert info)
+ (ir1-attributep (fun-info-attributes info)
+ recursive))))))
+ (let ((*compiler-error-context* call))
+ (compiler-warn "~@<recursion in known function definition~2I ~
- (lexenv-policy (node-lexenv call))
- (mapcar (lambda (arg)
- (type-specifier (lvar-type arg)))
- args))))
- (ltn-default-call call)
- (return-from ltn-analyze-known-call (values)))
+ (lexenv-policy (node-lexenv call))
+ (mapcar (lambda (arg)
+ (type-specifier (lvar-type arg)))
+ args))))
+ (ltn-default-call call)
+ (return-from ltn-analyze-known-call (values)))
;;; past the block end in that case.
(defun ltn-analyze-block (block)
(do* ((node (block-start-node block)
;;; past the block end in that case.
(defun ltn-analyze-block (block)
(do* ((node (block-start-node block)
- (:local (ltn-analyze-local-call node))
- ((:full :error) (ltn-default-call node))
- (:known
- (ltn-analyze-known-call node))))
+ (:local (ltn-analyze-local-call node))
+ ((:full :error) (ltn-default-call node))
+ (:known
+ (ltn-analyze-known-call node))))
(do-blocks (block component)
(aver (not (block-info block)))
(let ((2block (make-ir2-block block)))
(do-blocks (block component)
(aver (not (block-info block)))
(let ((2block (make-ir2-block block)))