:specialized-element-type (array-type-specialized-element-type type))
;; Simple arrays cannot change at all.
type))
+ ((union-type-p type)
+ ;; Conservative union type is an union of conservative types.
+ (let ((res *empty-type*))
+ (dolist (part (union-type-types type) res)
+ (setf res (type-union res (conservative-type part))))))
(t
+ ;; Catch-all.
+ ;;
;; If the type contains some CONS types, the conservative type contains all
;; of them.
(when (types-equal-or-intersect type (specifier-type 'cons))
it (coerce-to-values type)))
(t (coerce-to-values type)))))
dest)))))
- (lvar-%externally-checkable-type lvar))
+ (or (lvar-%externally-checkable-type lvar) *wild-type*))
#!-sb-fluid(declaim (inline flush-lvar-externally-checkable-type))
(defun flush-lvar-externally-checkable-type (lvar)
(declare (type lvar lvar))
'(optimize
(preserve-single-use-debug-variables 0))
(lexenv-policy
- (combination-lexenv call)))))
+ (combination-lexenv call)))))
(with-ir1-environment-from-node call
(with-component-last-block (*current-component*
(block-next (node-block call)))
leaf var)))
t)))))
((and (null (rest (leaf-refs var)))
- ;; Don't substitute single-ref variables on high-debug /
- ;; low speed, to improve the debugging experience.
- (policy call (< preserve-single-use-debug-variables 3))
+ (not (preserve-single-use-debug-var-p call var))
(substitute-single-use-lvar arg var)))
(t
(propagate-to-refs var (lvar-type arg))))))
;;; If the function has an entry-fun, then we don't do anything: since
;;; it has a XEP we would not discover anything.
;;;
+;;; If the function is an optional-entry-point, we will just make sure
+;;; &REST lists are known to be lists. Doing the regular rigamarole
+;;; can erronously propagate too strict types into refs: see
+;;; BUG-655203-REGRESSION in tests/compiler.pure.lisp.
+;;;
;;; We can clear the LVAR-REOPTIMIZE flags for arguments in all calls
;;; corresponding to changed arguments in CALL, since the only use in
;;; IR1 optimization of the REOPTIMIZE flag for local call args is
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
(unless (functional-entry-fun fun)
- (let* ((vars (lambda-vars fun))
- (union (mapcar (lambda (arg var)
- (when (and arg
- (lvar-reoptimize arg)
- (null (basic-var-sets var)))
- (lvar-type arg)))
- (basic-combination-args call)
- vars))
- (this-ref (lvar-use (basic-combination-fun call))))
-
- (dolist (arg (basic-combination-args call))
- (when arg
- (setf (lvar-reoptimize arg) nil)))
-
- (dolist (ref (leaf-refs fun))
- (let ((dest (node-dest ref)))
- (unless (or (eq ref this-ref) (not dest))
- (setq union
- (mapcar (lambda (this-arg old)
- (when old
- (setf (lvar-reoptimize this-arg) nil)
- (type-union (lvar-type this-arg) old)))
- (basic-combination-args dest)
- union)))))
-
- (loop for var in vars
- and type in union
- when type do (propagate-to-refs var type))))
+ (if (lambda-optional-dispatch fun)
+ ;; We can still make sure &REST is known to be a list.
+ (loop for var in (lambda-vars fun)
+ do (let ((info (lambda-var-arg-info var)))
+ (when (and info (eq :rest (arg-info-kind info)))
+ (propagate-from-sets var (specifier-type 'list)))))
+ ;; The normal case.
+ (let* ((vars (lambda-vars fun))
+ (union (mapcar (lambda (arg var)
+ (when (and arg
+ (lvar-reoptimize arg)
+ (null (basic-var-sets var)))
+ (lvar-type arg)))
+ (basic-combination-args call)
+ vars))
+ (this-ref (lvar-use (basic-combination-fun call))))
+
+ (dolist (arg (basic-combination-args call))
+ (when arg
+ (setf (lvar-reoptimize arg) nil)))
+
+ (dolist (ref (leaf-refs fun))
+ (let ((dest (node-dest ref)))
+ (unless (or (eq ref this-ref) (not dest))
+ (setq union
+ (mapcar (lambda (this-arg old)
+ (when old
+ (setf (lvar-reoptimize this-arg) nil)
+ (type-union (lvar-type this-arg) old)))
+ (basic-combination-args dest)
+ union)))))
+
+ (loop for var in vars
+ and type in union
+ when type do (propagate-to-refs var type)))))
(values))
\f
(unlink-node call)
(when vals
(reoptimize-lvar (first vals)))
+ ;; Propagate derived types from the VALUES call to its args:
+ ;; transforms can leave the VALUES call with a better type
+ ;; than its args have, so make sure not to throw that away.
+ (let ((types (values-type-types (node-derived-type use))))
+ (dolist (val vals)
+ (when types
+ (let ((type (pop types)))
+ (assert-lvar-type val type '((type-check . 0)))))))
+ ;; Propagate declared types of MV-BIND variables.
(propagate-to-args use fun)
(reoptimize-call use))
t)))
(flush-lvar-externally-checkable-type arg))
(setf (combination-args use) nil)
(flush-dest list)
+ (flush-combination use)
(setf (combination-args node) args))
t)))
(unless (eq value-type *empty-type*)
;; FIXME: Do it in one step.
- (filter-lvar
- value
- (if (cast-single-value-p cast)
- `(list 'dummy)
- `(multiple-value-call #'list 'dummy)))
- (filter-lvar
- (cast-value cast)
- ;; FIXME: Derived type.
- `(%compile-time-type-error 'dummy
- ',(type-specifier atype)
- ',(type-specifier value-type)))
+ (let ((context (cons (node-source-form cast)
+ (lvar-source (cast-value cast)))))
+ (filter-lvar
+ value
+ (if (cast-single-value-p cast)
+ `(list 'dummy)
+ `(multiple-value-call #'list 'dummy)))
+ (filter-lvar
+ (cast-value cast)
+ ;; FIXME: Derived type.
+ `(%compile-time-type-error 'dummy
+ ',(type-specifier atype)
+ ',(type-specifier value-type)
+ ',context)))
;; KLUDGE: FILTER-LVAR does not work for non-returning
;; functions, so we declare the return type of
;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
projects / sbcl.git / blobdiff