(values-type-union (node-derived-type (first current))
res))
(current (rest uses) (rest current)))
- ((null current) res)))
+ ((or (null current) (eq res *wild-type*))
+ res)))
(t
- (node-derived-type (lvar-uses lvar))))))
+ (node-derived-type uses)))))
;;; Return the derived type for LVAR's first value. This is guaranteed
;;; not to be a VALUES or FUNCTION type.
(lambda-var-p (ref-leaf node)))
(let ((type (single-value-type int)))
(when (and (member-type-p type)
- (null (rest (member-type-members type))))
+ (eql 1 (member-type-size type)))
(change-ref-leaf node (find-constant
(first (member-type-members type)))))))
(reoptimize-lvar lvar)))))
(when value
(derive-node-type node (lvar-derived-type value)))))
(cset
+ ;; PROPAGATE-FROM-SETS can do a better job if NODE-REOPTIMIZE
+ ;; is accurate till the node actually has been reoptimized.
+ (setf (node-reoptimize node) t)
(ir1-optimize-set node))
(cast
(ir1-optimize-cast node)))))
(setf (lvar-reoptimize arg) nil)))
(check-important-result node info)
(let ((fun (fun-info-destroyed-constant-args info)))
- (when fun
+ (when (and fun
+ ;; If somebody is really sure that they want to modify
+ ;; constants, let them.
+ (policy node (> check-constant-modification 0)))
(let ((destroyed-constant-args (funcall fun args)))
(when destroyed-constant-args
(let ((*compiler-error-context* node))
(aver (and (legal-fun-name-p source-name)
(not (eql source-name '.anonymous.))))
(node-ends-block call)
+ ;; The internal variables of a transform are not going to be
+ ;; interesting to the debugger, so there's no sense in
+ ;; suppressing the substitution of variables with only one use
+ ;; (the extra variables can slow down constraint propagation).
+ ;;
+ ;; This needs to be done before the WITH-IR1-ENVIRONMENT-FROM-NODE,
+ ;; so that it will bind *LEXENV* to the right environment.
+ (setf (combination-lexenv call)
+ (make-lexenv :default (combination-lexenv call)
+ :policy (process-optimize-decl
+ '(optimize
+ (preserve-single-use-debug-variables 0))
+ (lexenv-policy
+ (combination-lexenv call)))))
(with-ir1-environment-from-node call
(with-component-last-block (*current-component*
(block-next (node-block call)))
+
(let ((new-fun (ir1-convert-inline-lambda
res
:debug-name (debug-name 'lambda-inlined source-name)
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
- ;; The internal variables of a transform are not going to be
- ;; interesting to the debugger, so there's no sense in
- ;; suppressing the substitution of variables with only one use
- ;; (the extra variables can slow down constraint propagation).
- (setf (combination-lexenv call)
- (make-lexenv :default (combination-lexenv call)
- :policy (process-optimize-decl
- '(optimize
- (preserve-single-use-debug-variables 0))
- (lexenv-policy
- (combination-lexenv call)))))
(locall-analyze-component *current-component*))))
(values))
(let ((int (type-approx-intersection2 var-type type)))
(when (type/= int var-type)
(setf (leaf-type leaf) int)
- (dolist (ref (leaf-refs leaf))
- (derive-node-type ref (make-single-value-type int))
- ;; KLUDGE: LET var substitution
- (let* ((lvar (node-lvar ref)))
- (when (and lvar (combination-p (lvar-dest lvar)))
- (reoptimize-lvar lvar))))))
+ (let ((s-int (make-single-value-type int)))
+ (dolist (ref (leaf-refs leaf))
+ (derive-node-type ref s-int)
+ ;; KLUDGE: LET var substitution
+ (let* ((lvar (node-lvar ref)))
+ (when (and lvar (combination-p (lvar-dest lvar)))
+ (reoptimize-lvar lvar)))))))
(values))))
;;; Iteration variable: exactly one SETQ of the form:
;;; the union of the INITIAL-TYPE and the types of all the set
;;; values and to a PROPAGATE-TO-REFS with this type.
(defun propagate-from-sets (var initial-type)
- (collect ((res initial-type type-union))
- (dolist (set (basic-var-sets var))
+ (let ((changes (not (csubtypep (lambda-var-last-initial-type var) initial-type)))
+ (types nil))
+ (dolist (set (lambda-var-sets var))
(let ((type (lvar-type (set-value set))))
- (res type)
+ (push type types)
(when (node-reoptimize set)
- (derive-node-type set (make-single-value-type type))
+ (let ((old-type (node-derived-type set)))
+ (unless (values-subtypep old-type type)
+ (derive-node-type set (make-single-value-type type))
+ (setf changes t)))
(setf (node-reoptimize set) nil))))
- (let ((res (res)))
- (awhen (maybe-infer-iteration-var-type var initial-type)
- (setq res it))
- (propagate-to-refs var res)))
+ (when changes
+ (setf (lambda-var-last-initial-type var) initial-type)
+ (let ((res-type (or (maybe-infer-iteration-var-type var initial-type)
+ (apply #'type-union initial-type types))))
+ (propagate-to-refs var res-type))))
(values))
;;; If a LET variable, find the initial value's type and do
(initial-type (lvar-type initial-value)))
(setf (lvar-reoptimize initial-value) nil)
(propagate-from-sets var initial-type))))))
-
(derive-node-type node (make-single-value-type
(lvar-type (set-value node))))
+ (setf (node-reoptimize node) nil)
(values))
;;; Return true if the value of REF will always be the same (and is
*policy*)))
(setf (cast-type-to-check cast) *wild-type*)
(substitute-lvar-uses value arg
- ;; FIXME
- t)
+ ;; FIXME
+ t)
(%delete-lvar-use ref)
(add-lvar-use cast lvar)))))
(setf (node-derived-type ref) *wild-type*)
;;; right here.
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
-
(unless (or (functional-entry-fun fun)
(lambda-optional-dispatch fun))
(let* ((vars (lambda-vars fun))
(with-ir1-environment-from-node node
(let* ((dums (make-gensym-list count))
(ignore (gensym))
+ (leaf (ref-leaf ref))
(fun (ir1-convert-lambda
`(lambda (&optional ,@dums &rest ,ignore)
(declare (ignore ,ignore))
- (funcall ,(ref-leaf ref) ,@dums)))))
+ (%funcall ,leaf ,@dums))
+ :source-name (leaf-%source-name leaf)
+ :debug-name (leaf-%debug-name leaf))))
(change-ref-leaf ref fun)
(aver (eq (basic-combination-kind node) :full))
(locall-analyze-component *current-component*)
;;; TODO:
;;; - CAST chains;
+(defun delete-cast (cast)
+ (declare (type cast cast))
+ (let ((value (cast-value cast))
+ (lvar (node-lvar cast)))
+ (delete-filter cast lvar value)
+ (when lvar
+ (reoptimize-lvar lvar)
+ (when (lvar-single-value-p lvar)
+ (note-single-valuified-lvar lvar)))
+ (values)))
+
(defun ir1-optimize-cast (cast &optional do-not-optimize)
(declare (type cast cast))
(let ((value (cast-value cast))
(let ((lvar (node-lvar cast)))
(when (values-subtypep (lvar-derived-type value)
(cast-asserted-type cast))
- (delete-filter cast lvar value)
- (when lvar
- (reoptimize-lvar lvar)
- (when (lvar-single-value-p lvar)
- (note-single-valuified-lvar lvar)))
+ (delete-cast cast)
(return-from ir1-optimize-cast t))
(when (and (listp (lvar-uses value))
projects / sbcl.git / blobdiff