nil)
((basic-combination-p dest)
(let ((kind (basic-combination-kind dest)))
- (cond ((eq cont (basic-combination-fun dest)) t)
- ((eq kind :local) t)
- ((eq kind :full)
- (and (combination-p dest)
- (not (values-subtypep ; explicit THE
- (continuation-externally-checkable-type cont)
- (continuation-type-to-check cont)))))
-
- ((eq kind :error) nil)
- ;; :ERROR means that we have an invalid syntax of
- ;; the call and the callee will detect it before
- ;; thinking about types.
-
- ((fun-info-ir2-convert kind) t)
- (t
- (dolist (template (fun-info-templates kind) nil)
- (when (eq (template-ltn-policy template) :fast-safe)
- (multiple-value-bind (val win)
- (valid-fun-use dest (template-type template))
- (when (or val (not win)) (return t)))))))))
+ (cond
+ ((eq cont (basic-combination-fun dest)) t)
+ (t
+ (ecase kind
+ (:local t)
+ (:full
+ (and (combination-p dest)
+ (not (values-subtypep ; explicit THE
+ (continuation-externally-checkable-type cont)
+ (continuation-type-to-check cont)))))
+ ;; :ERROR means that we have an invalid syntax of
+ ;; the call and the callee will detect it before
+ ;; thinking about types.
+ (:error nil)
+ (:known
+ (let ((info (basic-combination-fun-info dest)))
+ (if (fun-info-ir2-convert info)
+ t
+ (dolist (template (fun-info-templates info) nil)
+ (when (eq (template-ltn-policy template)
+ :fast-safe)
+ (multiple-value-bind (val win)
+ (valid-fun-use dest (template-type template))
+ (when (or val (not win)) (return t)))))))))))))
(t t))))
;;; Return a lambda form that we can convert to do a hairy type check
(let ((kind (basic-combination-kind node)))
(format t "~(~A~A ~A~) "
(if (node-tail-p node) "tail " "")
- (if (fun-info-p kind) "known" kind)
+ kind
(type-of node))
(print-lvar (basic-combination-fun node))
(dolist (arg (basic-combination-args node))
(defun note-failed-optimization (node failures)
(declare (type combination node) (list failures))
(unless (or (node-deleted node)
- (not (fun-info-p (combination-kind node))))
+ (not (eq :known (combination-kind node))))
(let ((*compiler-error-context* node))
(dolist (failure failures)
(let ((what (cdr failure))
(delete-ref node)
(unlink-node node))
(combination
- (let ((info (combination-kind node)))
- (when (fun-info-p info)
+ (let ((kind (combination-kind node))
+ (info (combination-fun-info node)))
+ (when (and (eq kind :known) (fun-info-p info))
(let ((attr (fun-info-attributes info)))
(when (and (not (ir1-attributep attr call))
;; ### For now, don't delete potentially
(propagate-fun-change node)
(maybe-terminate-block node nil))
(let ((args (basic-combination-args node))
- (kind (basic-combination-kind node)))
- (case kind
+ (kind (basic-combination-kind node))
+ (info (basic-combination-fun-info node)))
+ (ecase kind
(:local
(let ((fun (combination-lambda node)))
(if (eq (functional-kind fun) :let)
(propagate-let-args node fun)
(propagate-local-call-args node fun))))
- ((:full :error)
+ (:error
(dolist (arg args)
(when arg
(setf (lvar-reoptimize arg) nil))))
- (t
+ (:full
+ (dolist (arg args)
+ (when arg
+ (setf (lvar-reoptimize arg) nil)))
+ (when info
+ (let ((fun (fun-info-derive-type info)))
+ (when fun
+ (let ((res (funcall fun node)))
+ (when res
+ (derive-node-type node (coerce-to-values res))
+ (maybe-terminate-block node nil)))))))
+ (:known
+ (aver info)
(dolist (arg args)
(when arg
(setf (lvar-reoptimize arg) nil)))
- (let ((attr (fun-info-attributes kind)))
+ (let ((attr (fun-info-attributes info)))
(when (and (ir1-attributep attr foldable)
;; KLUDGE: The next test could be made more sensitive,
;; only suppressing constant-folding of functions with
(constant-fold-call node)
(return-from ir1-optimize-combination)))
- (let ((fun (fun-info-derive-type kind)))
+ (let ((fun (fun-info-derive-type info)))
(when fun
(let ((res (funcall fun node)))
(when res
(derive-node-type node (coerce-to-values res))
(maybe-terminate-block node nil)))))
- (let ((fun (fun-info-optimizer kind)))
+ (let ((fun (fun-info-optimizer info)))
(unless (and fun (funcall fun node))
- (dolist (x (fun-info-transforms kind))
+ (dolist (x (fun-info-transforms info))
#!+sb-show
(when *show-transforms-p*
(let* ((lvar (basic-combination-fun node))
(defined-fun-inlinep leaf)
:no-chance)))
(cond
- ((eq inlinep :notinline) (values nil nil))
+ ((eq inlinep :notinline)
+ (let ((info (info :function :info (leaf-source-name leaf))))
+ (when info
+ (setf (basic-combination-fun-info call) info))
+ (values nil nil)))
((not (and (global-var-p leaf)
(eq (global-var-kind leaf) :global-function)))
(values leaf nil))
(t
(let ((info (info :function :info (leaf-source-name leaf))))
(if info
- (values leaf (setf (basic-combination-kind call) info))
+ (values leaf
+ (progn
+ (setf (basic-combination-kind call) :known)
+ (setf (basic-combination-fun-info call) info)))
(values leaf nil)))))))
;;; Check whether CALL satisfies TYPE. If so, apply the type to the
(() (null (rest sets)) :exit-if-null)
(set-use (principal-lvar-use (set-value set)))
(() (and (combination-p set-use)
- (fun-info-p (combination-kind set-use))
+ (eq (combination-kind set-use) :known)
+ (fun-info-p (combination-fun-info set-use))
(not (node-to-be-deleted-p set-use))
(eq (combination-fun-source-name set-use) '+))
:exit-if-null)
(append before-args inside-args after-args))
(change-ref-leaf (lvar-uses inside-fun)
(find-free-fun 'list "???"))
- (setf (combination-kind inside)
- (info :function :info 'list))
+ (setf (combination-fun-info inside) (info :function :info 'list)
+ (combination-kind inside) :known)
(setf (node-derived-type inside) *wild-type*)
(flush-dest lvar)
(values))))))
(declare (type combination call))
(let ((kind (basic-combination-kind call)))
(or (eq kind :full)
- (and (fun-info-p kind)
- (not (fun-info-ir2-convert kind))
- (dolist (template (fun-info-templates kind) t)
- (when (eq (template-ltn-policy template) :fast-safe)
- (multiple-value-bind (val win)
- (valid-fun-use call (template-type template))
- (when (or val (not win)) (return nil)))))))))
+ (and (eq kind :known)
+ (let ((info (basic-combination-fun-info call)))
+ (and
+ (not (fun-info-ir2-convert info))
+ (dolist (template (fun-info-templates info) t)
+ (when (eq (template-ltn-policy template) :fast-safe)
+ (multiple-value-bind (val win)
+ (valid-fun-use call (template-type template))
+ (when (or val (not win)) (return nil)))))))))))
\f
;;;; careful call
(ir2-convert-ref node 2block)))))
(combination
(let ((kind (basic-combination-kind node)))
- (case kind
+ (ecase kind
(:local
(ir2-convert-local-call node 2block))
(:full
(ir2-convert-full-call node 2block))
- (t
- (let ((fun (fun-info-ir2-convert kind)))
+ (:known
+ (let* ((info (basic-combination-fun-info node))
+ (fun (fun-info-ir2-convert info)))
(cond (fun
(funcall fun node 2block))
((eq (basic-combination-info node) :full)
;;; can bail out to here.
(defun ltn-default-call (call)
(declare (type combination call))
- (let ((kind (basic-combination-kind call)))
+ (let ((kind (basic-combination-kind call))
+ (info (basic-combination-fun-info call)))
(annotate-fun-lvar (basic-combination-fun call))
(dolist (arg (basic-combination-args call))
(annotate-1-value-lvar arg))
(cond
- ((and (fun-info-p kind)
- (fun-info-ir2-convert kind))
+ ((and (eq kind :known)
+ (fun-info-p info)
+ (fun-info-ir2-convert info))
(setf (basic-combination-info call) :funny)
(setf (node-tail-p call) nil))
(t
(declare (type combination call)
(type ltn-policy ltn-policy))
(let ((safe-p (ltn-policy-safe-p ltn-policy))
- (current (fun-info-templates (basic-combination-kind call)))
+ (current (fun-info-templates (basic-combination-fun-info call)))
(fallback nil)
(rejected nil))
(loop
(or template
(template-or-lose 'call-named)))
*efficiency-note-cost-threshold*)))
- (dolist (try (fun-info-templates (basic-combination-kind call)))
+ (dolist (try (fun-info-templates (basic-combination-fun-info 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))
(defun ltn-analyze-known-call (call)
(declare (type combination call))
(let ((ltn-policy (node-ltn-policy call))
- (method (fun-info-ltn-annotate (basic-combination-kind call)))
+ (method (fun-info-ltn-annotate (basic-combination-fun-info call)))
(args (basic-combination-args call)))
(when method
(funcall method call ltn-policy)
(and (leaf-has-source-name-p funleaf)
(eq (lvar-fun-name (combination-fun call))
(leaf-source-name funleaf))
- (let ((info (basic-combination-kind call)))
+ (let ((info (basic-combination-fun-info call)))
(not (or (fun-info-ir2-convert info)
(ir1-attributep (fun-info-attributes info)
recursive))))))
(etypecase node
(ref)
(combination
- (case (basic-combination-kind node)
+ (ecase (basic-combination-kind node)
(:local (ltn-analyze-local-call node))
((:full :error) (ltn-default-call node))
- (t
+ (:known
(ltn-analyze-known-call node))))
(cif (ltn-analyze-if node))
(creturn (ltn-analyze-return node))
(args nil :type list)
;; the kind of function call being made. :LOCAL means that this is a
;; local call to a function in the same component, and that argument
- ;; syntax checking has been done, etc. Calls to known global
- ;; functions are represented by storing the FUN-INFO for the
- ;; function in this slot. :FULL is a call to an (as yet) unknown
- ;; function. :ERROR is like :FULL, but means that we have discovered
- ;; that the call contains an error, and should not be reconsidered
- ;; for optimization.
- (kind :full :type (or (member :local :full :error) fun-info))
+ ;; syntax checking has been done, etc. Calls to known global
+ ;; functions are represented by storing :KNOWN in this slot and the
+ ;; FUN-INFO for that function in the FUN-INFO slot. :FULL is a call
+ ;; to an (as yet) unknown function, or to a known function declared
+ ;; NOTINLINE. :ERROR is like :FULL, but means that we have
+ ;; discovered that the call contains an error, and should not be
+ ;; reconsidered for optimization.
+ (kind :full :type (member :local :full :error :known))
+ ;; if a call to a known global function, contains the FUN-INFO.
+ (fun-info nil :type (or fun-info null))
;; some kind of information attached to this node by the back end
(info nil))
(cut-node (node &aux did-something)
(when (and (not (block-delete-p (node-block node)))
(combination-p node)
- (fun-info-p (basic-combination-kind node)))
+ (eq (basic-combination-kind node) :known))
(let* ((fun-ref (lvar-use (combination-fun node)))
(fun-name (leaf-source-name (ref-leaf fun-ref)))
(modular-fun (find-modular-version fun-name width)))
(type (unsigned-byte 32) i))
(deref a i))))
(compiler-note () (error "The code is not optimized.")))
+
+(handler-case
+ (compile nil '(lambda (x)
+ (declare (type (integer -100 100) x))
+ (declare (optimize speed))
+ (declare (notinline identity))
+ (1+ (identity x))))
+ (compiler-note () (error "IDENTITY derive-type not applied.")))
;;; An &AUX variable in a boa-constructor without a default value
;;; means "do not initialize slot" and does not cause type error
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
+
(defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c))))
(a #\! :type (integer 1 2))
(b #\? :type (integer 3 4))
(c #\# :type (integer 5 6)))
(let ((s (make-boa-saux)))
- (declare (notinline identity))
(locally (declare (optimize (safety 3))
(inline boa-saux-a))
- (assert (raises-error? (identity (boa-saux-a s)) type-error)))
+ (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error)))
(setf (boa-saux-a s) 1)
(setf (boa-saux-c s) 5)
(assert (eql (boa-saux-a s) 1))
; these two checks should be
; kept separated
(let ((s (make-boa-saux)))
- (declare (notinline identity))
(locally (declare (optimize (safety 0))
(inline boa-saux-a))
- (assert (eql (identity (boa-saux-a s)) 0)))
+ (assert (eql (opaque-identity (boa-saux-a s)) 0)))
(setf (boa-saux-a s) 1)
(setf (boa-saux-c s) 5)
(assert (eql (boa-saux-a s) 1))
(assert (eql (boa-saux-c s) 5)))
(let ((s (make-boa-saux)))
- (declare (notinline identity))
(locally (declare (optimize (safety 3))
(notinline boa-saux-a))
- (assert (raises-error? (identity (boa-saux-a s)) type-error)))
+ (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error)))
(setf (boa-saux-a s) 1)
(setf (boa-saux-c s) 5)
(assert (eql (boa-saux-a s) 1))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.9.15"
+"0.8.9.16"
projects / sbcl.git / commitdiff