X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=f7e43181a0fc125fcbfe36ccedff2520ca765763;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=221743f1c1d8fa31c8f75f17b0f552f484165dc9;hpb=6a8fb906ba96395f2a60f821b2ec7649a2a3ae46;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 221743f..f7e4318 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -87,34 +87,31 @@ (defun %continuation-%externally-checkable-type (cont) (declare (type continuation cont)) (let ((dest (continuation-dest cont))) - (if (not (and dest (combination-p dest))) - ;; TODO: MV-COMBINATION - (setf (continuation-%externally-checkable-type cont) *wild-type*) - (let* ((fun (combination-fun dest)) - (args (combination-args dest)) - (fun-type (continuation-type fun))) - (setf (continuation-%externally-checkable-type fun) *wild-type*) - (if (or (not (fun-type-p fun-type)) - ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)). - (fun-type-wild-args fun-type)) - (progn (dolist (arg args) - (when arg - (setf (continuation-%externally-checkable-type arg) - *wild-type*))) - *wild-type*) - (let* ((arg-types (append (fun-type-required fun-type) - (fun-type-optional fun-type) - (let ((rest (list (or (fun-type-rest fun-type) - *wild-type*)))) - (setf (cdr rest) rest))))) - ;; TODO: &KEY - (loop - for arg of-type continuation in args - and type of-type ctype in arg-types - do (when arg - (setf (continuation-%externally-checkable-type arg) - (coerce-to-values type)))) - (continuation-%externally-checkable-type cont))))))) + (if (not (and dest + (combination-p dest))) + ;; TODO: MV-COMBINATION + (setf (continuation-%externally-checkable-type cont) *wild-type*) + (let* ((fun (combination-fun dest)) + (args (combination-args dest)) + (fun-type (continuation-type fun))) + (setf (continuation-%externally-checkable-type fun) *wild-type*) + (if (or (not (call-full-like-p dest)) + (not (fun-type-p fun-type)) + ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)). + (fun-type-wild-args fun-type)) + (dolist (arg args) + (when arg + (setf (continuation-%externally-checkable-type arg) + *wild-type*))) + (map-combination-args-and-types + (lambda (arg type) + (setf (continuation-%externally-checkable-type arg) + (acond ((continuation-%externally-checkable-type arg) + (values-type-intersection + it (coerce-to-values type))) + (t (coerce-to-values type))))) + dest))))) + (continuation-%externally-checkable-type cont)) (declaim (inline flush-continuation-externally-checkable-type)) (defun flush-continuation-externally-checkable-type (cont) (declare (type continuation cont)) @@ -220,37 +217,6 @@ (reoptimize-continuation cont) checked-value))))) -;;; Assert that CALL is to a function of the specified TYPE. It is -;;; assumed that the call is legal and has only constants in the -;;; keyword positions. -(defun assert-call-type (call type) - (declare (type combination call) (type fun-type type)) - (derive-node-type call (fun-type-returns type)) - (let ((args (combination-args call)) - (policy (lexenv-policy (node-lexenv call)))) - (dolist (req (fun-type-required type)) - (when (null args) (return-from assert-call-type)) - (let ((arg (pop args))) - (assert-continuation-type arg req policy))) - (dolist (opt (fun-type-optional type)) - (when (null args) (return-from assert-call-type)) - (let ((arg (pop args))) - (assert-continuation-type arg opt policy))) - - (let ((rest (fun-type-rest type))) - (when rest - (dolist (arg args) - (assert-continuation-type arg rest policy)))) - - (dolist (key (fun-type-keywords type)) - (let ((name (key-info-name key))) - (do ((arg args (cddr arg))) - ((null arg)) - (when (eq (continuation-value (first arg)) name) - (assert-continuation-type - (second arg) (key-info-type key) - policy)))))) - (values)) ;;;; IR1-OPTIMIZE @@ -753,7 +719,11 @@ ;; cross-compiler can't fold it because the ;; cross-compiler doesn't know how to evaluate it. #+sb-xc-host - (fboundp (combination-fun-source-name node))) + (or (fboundp (combination-fun-source-name node)) + (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%" + (combination-fun-source-name node) + (mapcar #'continuation-value args)) + nil))) (constant-fold-call node) (return-from ir1-optimize-combination))) @@ -1247,18 +1217,76 @@ (reoptimize-continuation cont)))))) (values)))) +;;; Iteration variable: exactly one SETQ of the form: +;;; +;;; (let ((var initial)) +;;; ... +;;; (setq var (+ var step)) +;;; ...) +(defun maybe-infer-iteration-var-type (var initial-type) + (binding* ((sets (lambda-var-sets var) :exit-if-null) + (set (first sets)) + (() (null (rest sets)) :exit-if-null) + (set-use (principal-continuation-use (set-value set))) + (() (and (combination-p set-use) + (fun-info-p (combination-kind set-use)) + (eq (combination-fun-source-name set-use) '+)) + :exit-if-null) + (+-args (basic-combination-args set-use)) + (() (and (proper-list-of-length-p +-args 2 2) + (let ((first (principal-continuation-use + (first +-args)))) + (and (ref-p first) + (eq (ref-leaf first) var)))) + :exit-if-null) + (step-type (continuation-type (second +-args))) + (set-type (continuation-type (set-value set)))) + (when (and (numeric-type-p initial-type) + (numeric-type-p step-type) + (numeric-type-equal initial-type step-type)) + (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)) + (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)) + (numeric-type-low set-type)) + (numeric-type-high initial-type))) + (t + (values nil nil))) + (modified-numeric-type initial-type + :low low + :high high + :enumerable nil))))) +(deftransform + ((x y) * * :result result) + "check for iteration variable reoptimization" + (let ((dest (principal-continuation-end result)) + (use (principal-continuation-use x))) + (when (and (ref-p use) + (set-p dest) + (eq (ref-leaf use) + (set-var dest))) + (reoptimize-continuation (set-value dest)))) + (give-up-ir1-transform)) + ;;; Figure out the type of a LET variable that has sets. We compute -;;; the union of the initial value TYPE and the types of all the set +;;; 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 type) - (collect ((res type type-union)) +(defun propagate-from-sets (var initial-type) + (collect ((res initial-type type-union)) (dolist (set (basic-var-sets var)) (let ((type (continuation-type (set-value set)))) (res type) (when (node-reoptimize set) (derive-node-type set (make-single-value-type type)) (setf (node-reoptimize set) nil)))) - (propagate-to-refs var (res))) + (let ((res (res))) + (awhen (maybe-infer-iteration-var-type var initial-type) + (setq res it)) + (propagate-to-refs var res))) (values)) ;;; If a LET variable, find the initial value's type and do @@ -1270,9 +1298,10 @@ (when (and (lambda-var-p var) (leaf-refs var)) (let ((home (lambda-var-home var))) (when (eq (functional-kind home) :let) - (let ((iv (let-var-initial-value var))) - (setf (continuation-reoptimize iv) nil) - (propagate-from-sets var (continuation-type iv))))))) + (let* ((initial-value (let-var-initial-value var)) + (initial-type (continuation-type initial-value))) + (setf (continuation-reoptimize initial-value) nil) + (propagate-from-sets var initial-type)))))) (derive-node-type node (make-single-value-type (continuation-type (set-value node))))