(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)))))
;;; appropriate.)
;;;
;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV
-;;; combination, which may change the succesor of the call to be the
+;;; combination, which may change the successor of the call to be the
;;; called function, and if so, checks if the call can become an
;;; assignment. If we convert to an assignment, we abort, since the
;;; RETURN has been deleted.
#!+sb-show
(defvar *show-transforms-p* nil)
+(defun check-important-result (node info)
+ (when (and (null (node-lvar node))
+ (ir1-attributep (fun-info-attributes info) important-result))
+ (let ((*compiler-error-context* node))
+ (compiler-style-warn
+ "The return value of ~A should not be discarded."
+ (lvar-fun-name (basic-combination-fun node))))))
+
;;; Do IR1 optimizations on a COMBINATION node.
(declaim (ftype (function (combination) (values)) ir1-optimize-combination))
(defun ir1-optimize-combination (node)
(when arg
(setf (lvar-reoptimize arg) nil)))
(when info
+ (check-important-result node info)
(let ((fun (fun-info-destroyed-constant-args info)))
(when fun
(let ((destroyed-constant-args (funcall fun args)))
(when destroyed-constant-args
- (warn 'constant-modified
- :fun-name (lvar-fun-name
- (basic-combination-fun node)))
- (setf (basic-combination-kind node) :error)
- (return-from ir1-optimize-combination)))))
+ (let ((*compiler-error-context* node))
+ (warn 'constant-modified
+ :fun-name (lvar-fun-name
+ (basic-combination-fun node)))
+ (setf (basic-combination-kind node) :error)
+ (return-from ir1-optimize-combination))))))
(let ((fun (fun-info-derive-type info)))
(when fun
(let ((res (funcall fun node)))
(dolist (arg args)
(when arg
(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
- (warn 'constant-modified
- :fun-name (lvar-fun-name
- (basic-combination-fun node)))
+ (let ((*compiler-error-context* node))
+ (warn 'constant-modified
+ :fun-name (lvar-fun-name
+ (basic-combination-fun node)))
(setf (basic-combination-kind node) :error)
- (return-from ir1-optimize-combination)))))
+ (return-from ir1-optimize-combination))))))
(let ((attr (fun-info-attributes info)))
(when (and (ir1-attributep attr foldable)
(let ((fun (fun-info-optimizer info)))
(unless (and fun (funcall fun node))
- (dolist (x (fun-info-transforms info))
- #!+sb-show
- (when *show-transforms-p*
- (let* ((lvar (basic-combination-fun node))
- (fname (lvar-fun-name lvar t)))
- (/show "trying transform" x (transform-function x) "for" fname)))
- (unless (ir1-transform node x)
- #!+sb-show
- (when *show-transforms-p*
- (/show "quitting because IR1-TRANSFORM result was NIL"))
- (return))))))))
+ ;; First give the VM a peek at the call
+ (multiple-value-bind (style transform)
+ (combination-implementation-style node)
+ (ecase style
+ (:direct
+ ;; The VM knows how to handle this.
+ )
+ (:transform
+ ;; The VM mostly knows how to handle this. We need
+ ;; to massage the call slightly, though.
+ (transform-call node transform (combination-fun-source-name node)))
+ (:default
+ ;; Let transforms have a crack at it.
+ (dolist (x (fun-info-transforms info))
+ #!+sb-show
+ (when *show-transforms-p*
+ (let* ((lvar (basic-combination-fun node))
+ (fname (lvar-fun-name lvar t)))
+ (/show "trying transform" x (transform-function x) "for" fname)))
+ (unless (ir1-transform node x)
+ #!+sb-show
+ (when *show-transforms-p*
+ (/show "quitting because IR1-TRANSFORM result was NIL"))
+ (return)))))))))))
(values))
+(defun xep-tail-combination-p (node)
+ (and (combination-p node)
+ (let* ((lvar (combination-lvar node))
+ (dest (when (lvar-p lvar) (lvar-dest lvar)))
+ (lambda (when (return-p dest) (return-lambda dest))))
+ (and (lambda-p lambda)
+ (eq :external (lambda-kind lambda))))))
+
;;; If NODE doesn't return (i.e. return type is NIL), then terminate
;;; the block there, and link it to the component tail.
;;;
(declare (ignore lvar))
(unless (or (and (eq node (block-last block)) (eq succ tail))
(block-delete-p block))
- (when (eq (node-derived-type node) *empty-type*)
+ ;; Even if the combination will never return, don't terminate if this
+ ;; is the tail call of a XEP: doing that would inhibit TCO.
+ (when (and (eq (node-derived-type node) *empty-type*)
+ (not (xep-tail-combination-p node)))
(cond (ir1-converting-not-optimizing-p
(cond
((block-last block)
((nil :maybe-inline) (policy call (zerop space))))
(defined-fun-p leaf)
(defined-fun-inline-expansion leaf)
- (let ((fun (defined-fun-functional leaf)))
- (or (not fun)
- (and (eq inlinep :inline) (functional-kind fun))))
(inline-expansion-ok call))
- (flet (;; FIXME: Is this what the old CMU CL internal documentation
- ;; called semi-inlining? A more descriptive name would
- ;; be nice. -- WHN 2002-01-07
- (frob ()
- (let ((res (let ((*allow-instrumenting* t))
- (ir1-convert-lambda-for-defun
- (defined-fun-inline-expansion leaf)
- leaf t
- #'ir1-convert-inline-lambda))))
+ ;; Inline: if the function has already been converted at another call
+ ;; site in this component, we point this REF to the functional. If not,
+ ;; we convert the expansion.
+ ;;
+ ;; For :INLINE case local call analysis will copy the expansion later,
+ ;; but for :MAYBE-INLINE and NIL cases we only get one copy of the
+ ;; expansion per component.
+ ;;
+ ;; FIXME: We also convert in :INLINE & FUNCTIONAL-KIND case below. What
+ ;; is it for?
+ (flet ((frob ()
+ (let* ((name (leaf-source-name leaf))
+ (res (ir1-convert-inline-expansion
+ name
+ (defined-fun-inline-expansion leaf)
+ leaf
+ inlinep
+ (info :function :info name))))
+ ;; allow backward references to this function from
+ ;; following top level forms
(setf (defined-fun-functional leaf) res)
(change-ref-leaf ref res))))
- (if ir1-converting-not-optimizing-p
- (frob)
- (with-ir1-environment-from-node call
- (frob)
- (locall-analyze-component *current-component*))))
-
- (values (ref-leaf (lvar-uses (basic-combination-fun call)))
- nil))
+ (let ((fun (defined-fun-functional leaf)))
+ (if (or (not fun)
+ (and (eq inlinep :inline) (functional-kind fun)))
+ ;; Convert.
+ (if ir1-converting-not-optimizing-p
+ (frob)
+ (with-ir1-environment-from-node call
+ (frob)
+ (locall-analyze-component *current-component*)))
+ ;; If we've already converted, change ref to the converted functional.
+ (change-ref-leaf ref fun))))
+ (values (ref-leaf ref) nil))
(t
(let ((info (info :function :info (leaf-source-name leaf))))
(if info
;;; syntax check, arg/result type processing, but still call
;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
;;; and that checking is done by local call analysis.
-(defun validate-call-type (call type ir1-converting-not-optimizing-p)
+(defun validate-call-type (call type defined-type ir1-converting-not-optimizing-p)
(declare (type combination call) (type ctype type))
(cond ((not (fun-type-p type))
(aver (multiple-value-bind (val win)
(csubtypep type (specifier-type 'function))
(or val (not win))))
+ ;; In the commonish case where the function has been defined
+ ;; in another file, we only get FUNCTION for the type; but we
+ ;; can check whether the current call is valid for the
+ ;; existing definition, even if only to STYLE-WARN about it.
+ (when defined-type
+ (valid-fun-use call defined-type
+ :argument-test #'always-subtypep
+ :result-test nil
+ :lossage-fun #'compiler-style-warn
+ :unwinnage-fun #'compiler-notify))
(recognize-known-call call ir1-converting-not-optimizing-p))
((valid-fun-use call type
:argument-test #'always-subtypep
(derive-node-type call (tail-set-type (lambda-tail-set fun))))))
(:full
(multiple-value-bind (leaf info)
- (validate-call-type call (lvar-type fun-lvar) nil)
+ (validate-call-type call (lvar-type fun-lvar) nil nil)
(cond ((functional-p leaf)
(convert-call-if-possible
(lvar-uses (basic-combination-fun call))
(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)))
+ :debug-name (debug-name 'lambda-inlined source-name)
+ :system-lambda t))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
(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:
(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)
+ (or (eq (combination-fun-source-name set-use) '+)
+ (eq (combination-fun-source-name set-use) '-)))
+ :exit-if-null)
+ (minusp (eq (combination-fun-source-name set-use) '-))
(+-args (basic-combination-args set-use))
(() (and (proper-list-of-length-p +-args 2 2)
(let ((first (principal-lvar-use
(first +-args))))
(and (ref-p first)
(eq (ref-leaf first) var))))
- :exit-if-null)
+ :exit-if-null)
(step-type (lvar-type (second +-args)))
(set-type (lvar-type (set-value set))))
(when (and (numeric-type-p initial-type)
(numeric-type-p step-type)
- (numeric-type-equal initial-type step-type))
+ (or (numeric-type-equal initial-type step-type)
+ ;; Detect cases like (LOOP FOR 1.0 to 5.0 ...), where
+ ;; the initial and the step are of different types,
+ ;; and the step is less contagious.
+ (numeric-type-equal initial-type
+ (numeric-contagion initial-type
+ step-type))))
(labels ((leftmost (x y cmp cmp=)
(cond ((eq x nil) nil)
((eq y nil) nil)
(t (if (funcall cmp x y) x y))))
(max* (x y) (leftmost x y #'> #'>=))
(min* (x y) (leftmost x y #'< #'<=)))
- (declare (inline compare))
(multiple-value-bind (low high)
- (cond ((csubtypep step-type (specifier-type '(real 0 *)))
- (values (numeric-type-low initial-type)
- (when (and (numeric-type-p set-type)
- (numeric-type-equal set-type initial-type))
- (max* (numeric-type-high initial-type)
- (numeric-type-high set-type)))))
- ((csubtypep step-type (specifier-type '(real * 0)))
- (values (when (and (numeric-type-p set-type)
- (numeric-type-equal set-type initial-type))
- (min* (numeric-type-low initial-type)
- (numeric-type-low set-type)))
- (numeric-type-high initial-type)))
- (t
- (values nil nil)))
+ (let ((step-type-non-negative (csubtypep step-type (specifier-type
+ '(real 0 *))))
+ (step-type-non-positive (csubtypep step-type (specifier-type
+ '(real * 0)))))
+ (cond ((or (and step-type-non-negative (not minusp))
+ (and step-type-non-positive minusp))
+ (values (numeric-type-low initial-type)
+ (when (and (numeric-type-p set-type)
+ (numeric-type-equal set-type initial-type))
+ (max* (numeric-type-high initial-type)
+ (numeric-type-high set-type)))))
+ ((or (and step-type-non-positive (not minusp))
+ (and step-type-non-negative minusp))
+ (values (when (and (numeric-type-p set-type)
+ (numeric-type-equal set-type initial-type))
+ (min* (numeric-type-low initial-type)
+ (numeric-type-low set-type)))
+ (numeric-type-high initial-type)))
+ (t
+ (values nil nil))))
(modified-numeric-type initial-type
:low low
:high high
;;; 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*)
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))
(substitute-single-use-lvar arg var)))
(t
(propagate-to-refs var (lvar-type arg))))))
;;; 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))
(unless do-not-optimize
(setf (node-reoptimize cast) nil)))
+
+(deftransform make-symbol ((string) (simple-string))
+ `(%make-symbol string))