diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index c12251c3a0f875ff069360309135acb1ff1ea3e3..ec37fd46134041781b1e3c0b4343204110f2187a 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1764,6 +1764,104 @@ (ftruncate-derive-type-quot-aux n divisor nil)) #'%unary-ftruncate))) +(defun round-quotient-bound (quot) + (flet ((round-it (quot) + (let ((lo (interval-low quot)) + (hi (interval-high quot))) + (setf lo (if lo + (round (bound-value lo)) + nil)) + ;; For the upper bound, we need to be careful + (setf hi (if hi + (round (bound-value hi)) + nil)) + (make-interval :low lo :high hi)))) + (case (interval-range-info quot) + (+ + (round-it quot)) + (- + (round-it quot)) + (otherwise + ;; Split the interval into positive and negative pieces, compute + ;; the result for each piece and put them back together. + (destructuring-bind (neg pos) + (interval-split 0 quot t t) + (interval-merge-pair (round-it neg) + (round-it pos))))))) + +(defun round-derive-type-quot (number-type divisor-type) + (let* ((rem-type (rem-result-type number-type divisor-type)) + (number-interval (numeric-type->interval number-type)) + (divisor-interval (numeric-type->interval divisor-type))) + (let ((quot (round-quotient-bound + (interval-div number-interval + divisor-interval)))) + (specifier-type `(integer ,(or (interval-low quot) '*) + ,(or (interval-high quot) '*)))))) + +(defun round-derive-type-rem (number-type divisor-type) + (let* ((rem-type (rem-result-type number-type divisor-type)) + (number-interval (numeric-type->interval number-type)) + (divisor-interval (numeric-type->interval divisor-type))) + (multiple-value-bind (class format) + (ecase rem-type + (integer + (values 'integer nil)) + (rational + (values 'rational nil)) + ((or single-float double-float #+long-float long-float + #+double-double double-double-float) + (values 'float rem-type)) + (float + (values 'float nil)) + (real + (values nil nil))) + #+nil + (when (member rem-type '(float single-float double-float + #+long-float long-float + #+double-double double-double-float)) + (setf rem (interval-func #'(lambda (x) + (coerce x rem-type)) + rem))) + (make-numeric-type :class class + :format format + :low nil + :high nil)))) + +(defun %unary-round-derive-type-aux (num) + (if (numeric-type-real-p num) + (round-derive-type-quot num (specifier-type '(integer 1 1))) + *empty-type*)) + +(defoptimizer (%unary-round derive-type) ((number)) + (one-arg-derive-type number + #'%unary-round-derive-type-aux + #'%unary-round)) + +(defun round-derive-type-quot-aux (num div same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p num) + (numeric-type-real-p div)) + (round-derive-type-quot num div) + *empty-type*)) + +(defun round-derive-type-rem-aux (num div same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p num) + (numeric-type-real-p div)) + (round-derive-type-rem num div) + *empty-type*)) + +(defoptimizer (round derive-type) ((number divisor)) + (let ((quot (two-arg-derive-type number divisor + #'round-derive-type-quot-aux #'round)) + (rem (two-arg-derive-type number divisor + #'round-derive-type-rem-aux + #'(lambda (x) + (nth-value 1 (round x)))))) + (when (and quot rem) + (make-values-type :required (list quot rem))))) + ;;; Define optimizers for floor and ceiling (macrolet ((frob-opt (name q-name r-name)