;;; (append x x x x sequence) => sequence
;;; (append fixnum x ...) => nil
(defun derive-append-type (args)
- (cond ((not args)
- (specifier-type 'null))
- (t
- (let ((cons-type (specifier-type 'cons))
- (null-type (specifier-type 'null))
- (list-type (specifier-type 'list))
- (last (lvar-type (car (last args)))))
- (or
- ;; Check that all but the last arguments are lists first
- (loop for (arg next) on args
- while next
- do
- (let ((lvar-type (lvar-type arg)))
- (unless (or (csubtypep list-type lvar-type)
- (csubtypep lvar-type list-type))
+ (when (null args)
+ (return-from derive-append-type (specifier-type 'null)))
+ (let* ((cons-type (specifier-type 'cons))
+ (null-type (specifier-type 'null))
+ (list-type (specifier-type 'list))
+ (last (lvar-type (car (last args)))))
+ ;; Derive the actual return type, assuming that all but the last
+ ;; arguments are LISTs (otherwise, APPEND/NCONC doesn't return).
+ (loop with all-nil = t ; all but the last args are NIL?
+ with some-cons = nil ; some args are conses?
+ for (arg next) on args
+ for lvar-type = (type-approx-intersection2 (lvar-type arg)
+ list-type)
+ while next
+ do (multiple-value-bind (typep definitely)
+ (ctypep nil lvar-type)
+ (cond ((type= lvar-type *empty-type*)
+ ;; type mismatch! insert an inline check that'll cause
+ ;; compile-time warnings.
(assert-lvar-type arg list-type
- (lexenv-policy *lexenv*))
- (return *empty-type*))))
- (loop with all-nil = t
- for (arg next) on args
- for lvar-type = (lvar-type arg)
- while next
- do
- (cond
- ;; Cons in the middle guarantees the result will be a cons
- ((csubtypep lvar-type cons-type)
- (return cons-type))
- ;; If all but the last are NIL the type of the last arg
- ;; can be used
- ((csubtypep lvar-type null-type))
- (all-nil
- (setf all-nil nil)))
- finally
- (return
- (cond (all-nil
- last)
- ((csubtypep last cons-type)
- cons-type)
- ((csubtypep last list-type)
- list-type)
- ;; If the last is SEQUENCE (or similar) it'll
- ;; be either that sequence or a cons, which is a
- ;; sequence
- ((csubtypep list-type last)
- last)))))))))
+ (lexenv-policy *lexenv*)))
+ (some-cons) ; we know result's a cons -- nothing to do
+ ((and (not typep) definitely) ; can't be NIL
+ (setf some-cons t)) ; must be a CONS
+ (all-nil
+ (setf all-nil (csubtypep lvar-type null-type)))))
+ finally
+ ;; if some of the previous arguments are CONSes so is the result;
+ ;; if all the previous values are NIL, we're a fancy identity;
+ ;; otherwise, could be either
+ (return (cond (some-cons cons-type)
+ (all-nil last)
+ (t (type-union last cons-type)))))))
(defoptimizer (append derive-type) ((&rest args))
(derive-append-type args))
"Convert %ASH/RIGHT by constant back to ASH"
`(ash integer ,(- (lvar-value amount))))
- (deftransform %ash/right ((integer amount) * (member -1 0) :node node)
- ;; constant-fold large shifts
+ (deftransform %ash/right ((integer amount) * * :node node)
+ "strength reduce large variable right shift"
(let ((return-type (single-value-type (node-derived-type node))))
(cond ((type= return-type (specifier-type '(eql 0)))
0)
((type= return-type (specifier-type '(eql -1)))
-1)
+ ((csubtypep return-type (specifier-type '(member -1 0)))
+ `(ash integer ,(- sb!vm:n-word-bits)))
(t
- (aver (csubtypep (lvar-type integer) (specifier-type 'sb!vm:signed-word)))
- `(ash integer ,(- 1 sb!vm:n-word-bits))))))
+ (give-up-ir1-transform)))))
(defun %ash/right-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
(setf (node-reoptimize node) t)
(setf (block-reoptimize (node-block node)) t)
(reoptimize-component (node-component node) :maybe))
+ (insert-lvar-cut (lvar)
+ "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
+ to the required bit width. Returns T if any change was made.
+
+ When the destination of LVAR will definitely cut LVAR's value
+ to width (i.e. it's a logand or mask-signed-field with constant
+ other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
+ (binding* ((dest (lvar-dest lvar) :exit-if-null)
+ (nil (combination-p dest) :exit-if-null)
+ (name (lvar-fun-name (combination-fun dest) t))
+ (args (combination-args dest)))
+ (case name
+ (logand
+ (when (= 2 (length args))
+ (let ((other (if (eql (first args) lvar)
+ (second args)
+ (first args))))
+ (when (and (constant-lvar-p other)
+ (ctypep (lvar-value other) type)
+ (not signedp))
+ (return-from insert-lvar-cut)))))
+ (mask-signed-field
+ (when (and signedp
+ (eql lvar (second args))
+ (constant-lvar-p (first args))
+ (<= (lvar-value (first args)) width))
+ (return-from insert-lvar-cut)))))
+ (filter-lvar lvar
+ (if signedp
+ `(mask-signed-field ,width 'dummy)
+ `(logand 'dummy ,(ldb (byte width 0) -1))))
+ (do-uses (node lvar)
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe))
+ t)
(cut-node (node &aux did-something)
+ "Try to cut a node to width. The primary return value is
+ whether we managed to cut (cleverly), and the second whether
+ anything was changed."
(when (block-delete-p (node-block node))
- (return-from cut-node))
+ (return-from cut-node (values t nil)))
(typecase node
(ref
(typecase (ref-leaf node)
(new-value (if signedp
(mask-signed-field width constant-value)
(ldb (byte width 0) constant-value))))
- (unless (= constant-value new-value)
- (change-ref-leaf node (make-constant new-value))
- (let ((lvar (node-lvar node)))
- (setf (lvar-%derived-type lvar)
- (and (lvar-has-single-use-p lvar)
- (make-values-type :required (list (ctype-of new-value))))))
- (setf (block-reoptimize (node-block node)) t)
- (reoptimize-component (node-component node) :maybe)
- t)))
- (lambda-var
- (binding* ((dest (lvar-dest lvar) :exit-if-null)
- (nil (combination-p dest) :exit-if-null)
- (name (lvar-fun-name (combination-fun dest))))
- ;; we're about to insert an m-s-f/logand between a ref to
- ;; a variable and another m-s-f/logand. No point in doing
- ;; that; the parent m-s-f/logand was already cut to width
- ;; anyway.
- (unless (or (cond (signedp
- (and (eql name 'mask-signed-field)
- (eql lvar (second
- (combination-args
- dest)))))
- (t
- (eql name 'logand)))
- (csubtypep (lvar-type lvar) type))
- (filter-lvar lvar
- (if signedp
- `(mask-signed-field ,width 'dummy)
- `(logand 'dummy ,(ldb (byte width 0) -1))))
- (setf (block-reoptimize (node-block node)) t)
- (reoptimize-component (node-component node) :maybe)
- t)))))
+ (cond ((= constant-value new-value)
+ (values t nil)) ; we knew what to do and did nothing
+ (t
+ (change-ref-leaf node (make-constant new-value)
+ :recklessly t)
+ (let ((lvar (node-lvar node)))
+ (setf (lvar-%derived-type lvar)
+ (and (lvar-has-single-use-p lvar)
+ (make-values-type :required (list (ctype-of new-value))))))
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe)
+ (values t t)))))))
(combination
(when (eq (basic-combination-kind node) :known)
(let* ((fun-ref (lvar-use (combination-fun node)))
(setq did-something t))))
(when did-something
(reoptimize-node node name))
- did-something)))))))
- (cut-lvar (lvar &aux did-something)
+ (values t did-something))))))))
+ (cut-lvar (lvar &aux did-something must-insert)
+ "Cut all the LVAR's use nodes. If any of them wasn't handled
+ and its type is too wide for the operation we wish to perform
+ insert an explicit bit-width narrowing operation (LOGAND or
+ MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
+ The narrowing operation might not be inserted if the LVAR's
+ destination is already such an operation, to avoid endless
+ recursion.
+
+ (*) We can't easily do that for each node, and doing so might
+ result in code bloat, anyway. (I'm also not sure it would be
+ correct for complicated C/D FG)"
(do-uses (node lvar)
- (when (cut-node node)
- (setq did-something t)))
+ (multiple-value-bind (handled any-change)
+ (cut-node node)
+ (setf did-something (or did-something any-change)
+ must-insert (or must-insert
+ (not (or handled
+ (csubtypep (single-value-type
+ (node-derived-type node))
+ type)))))))
+ (when must-insert
+ (setf did-something (or (insert-lvar-cut lvar) did-something)))
did-something))
(cut-lvar lvar))))
(if (and (constant-lvar-p x)
(not (constant-lvar-p y)))
`(,(lvar-fun-name (basic-combination-fun node))
- y
+ (truly-the ,(lvar-type y) y)
,(lvar-value x))
(give-up-ir1-transform)))
-(dolist (x '(= char= + * logior logand logxor))
+(dolist (x '(= char= + * logior logand logxor logtest))
(%deftransform x '(function * *) #'commutative-arg-swap
"place constant arg last"))
(splice-fun-args x '%negate 1)
'(the rational x))
+(deftransform %negate ((x) (number))
+ "Combine %negate/*"
+ (let ((use (lvar-uses x))
+ arg)
+ (unless (and (combination-p use)
+ (eql '* (lvar-fun-name (combination-fun use)))
+ (constant-lvar-p (setf arg (second (combination-args use))))
+ (numberp (setf arg (lvar-value arg))))
+ (give-up-ir1-transform))
+ (splice-fun-args x '* 2)
+ `(lambda (x y)
+ (declare (ignore y))
+ (* x ,(- arg)))))
+
;;; Return T if in an arithmetic op including lvars X and Y, the
;;; result type is not affected by the type of X. That is, Y is at
;;; least as contagious as X.
(policy-quality-name-p (lvar-value quality-name)))
(give-up-ir1-transform))
'(%policy-quality policy quality-name))
+\f
+(deftransform encode-universal-time
+ ((second minute hour date month year &optional time-zone)
+ ((constant-arg (mod 60)) (constant-arg (mod 60))
+ (constant-arg (mod 24))
+ (constant-arg (integer 1 31))
+ (constant-arg (integer 1 12))
+ (constant-arg (integer 1899))
+ (constant-arg (rational -24 24))))
+ (let ((second (lvar-value second))
+ (minute (lvar-value minute))
+ (hour (lvar-value hour))
+ (date (lvar-value date))
+ (month (lvar-value month))
+ (year (lvar-value year))
+ (time-zone (lvar-value time-zone)))
+ (if (zerop (rem time-zone 1/3600))
+ (encode-universal-time second minute hour date month year time-zone)
+ (give-up-ir1-transform))))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
+ `(sb!unix:nanosleep seconds 0))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((constant-arg (real 0))))
+ (let ((seconds-value (lvar-value seconds)))
+ (multiple-value-bind (seconds nano)
+ (sb!impl::split-seconds-for-sleep seconds-value)
+ (if (> seconds (expt 10 8))
+ (give-up-ir1-transform)
+ `(sb!unix:nanosleep ,seconds ,nano)))))
projects / sbcl.git / blobdiff