diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 29749e11b..0fafbfde0 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -651,47 +651,51 @@ (foreach single-float double-float #+long-float long-float)) (fround-float (dispatch-type divisor)))))) -(macrolet ((def (name mode docstring) - `(defun ,name (number &optional (divisor 1)) - ,docstring +(macrolet ((def (name mode docstring &optional values) + `(defun ,name (number ,@(if values + `(divisor) + `(&optional (divisor 1)))) (declare (explicit-check)) - (macrolet ((ftruncate-float (rtype) - `(let* ((float-div (coerce divisor ',rtype)) - (res (,(case rtype - (double-float 'sb-kernel:round-double) - (single-float 'sb-kernel:round-single)) - (/ number float-div) - ,,mode))) - (values res - (- number - (* (coerce res ',rtype) float-div))))) - (unary-ftruncate-float (rtype) - `(let* ((res (,(case rtype - (double-float 'sb-kernel:round-double) - (single-float 'sb-kernel:round-single)) - number - ,,mode))) - (values res (- number res))))) - (number-dispatch ((number real) (divisor real)) - (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) - (multiple-value-bind (q r) - (,(find-symbol (string mode) :cl) number divisor) - (if (and (zerop q) (or (and (minusp number) (not (minusp divisor))) - (and (not (minusp number)) (minusp divisor)))) - (values -0f0 r) - (values (float q) r)))) - (((foreach single-float double-float) - (or rational single-float)) - (if (eql divisor 1) - (unary-ftruncate-float (dispatch-type number)) - (ftruncate-float (dispatch-type number)))) - ((double-float (or single-float double-float)) - (ftruncate-float double-float)) - ((single-float double-float) - (ftruncate-float double-float)) - (((foreach fixnum bignum ratio) - (foreach single-float double-float)) - (ftruncate-float (dispatch-type divisor)))))))) + ,docstring + ,(wrap-if + values '(values) + `(macrolet ((ftruncate-float (rtype) + `(let* ((float-div (coerce divisor ',rtype)) + (res (,(case rtype + (double-float 'sb-kernel:round-double) + (single-float 'sb-kernel:round-single)) + (/ number float-div) + ,,mode))) + (values res + (- number + (* (coerce res ',rtype) float-div))))) + (unary-ftruncate-float (rtype) + `(let* ((res (,(case rtype + (double-float 'sb-kernel:round-double) + (single-float 'sb-kernel:round-single)) + number + ,,mode))) + (values res (- number res))))) + (number-dispatch ((number real) (divisor real)) + (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) + (multiple-value-bind (q r) + (,(find-symbol (string mode) :cl) number divisor) + (if (and (zerop q) (or (and (minusp number) (not (minusp divisor))) + (and (not (minusp number)) (minusp divisor)))) + (values -0f0 r) + (values (float q) r)))) + (((foreach single-float double-float) + (or rational single-float)) + (if (eql divisor 1) + (unary-ftruncate-float (dispatch-type number)) + (ftruncate-float (dispatch-type number)))) + ((double-float (or single-float double-float)) + (ftruncate-float double-float)) + ((single-float double-float) + (ftruncate-float double-float)) + (((foreach fixnum bignum ratio) + (foreach single-float double-float)) + (ftruncate-float (dispatch-type divisor))))))))) (def ftruncate :truncate "Same as TRUNCATE, but returns first value as a float.") @@ -701,6 +705,12 @@ (def fceiling :ceiling "Same as CEILING, but returns first value as a float.") + (def ftruncate1 :truncate nil t) + + (def ffloor1 :floor nil t) + + (def fceiling1 :ceiling nil t) + #+round-float (def fround :round "Same as ROUND, but returns first value as a float.") diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 5bfa703ef..c4edfd245 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -343,6 +343,9 @@ (defknown (sb-kernel::truncate1 sb-kernel::floor1 sb-kernel::ceiling1) (real real) integer (movable foldable flushable recursive no-verify-arg-count)) +(defknown (sb-kernel::ftruncate1 sb-kernel::ffloor1 sb-kernel::fceiling1) (real real) float + (movable foldable flushable recursive no-verify-arg-count)) + (defknown unary-truncate (real) (values integer real) (movable foldable flushable no-verify-arg-count)) diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index f38fad342..f937d5688 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -320,17 +320,15 @@ (mv-bind-unused-p lvar 1)) (let ((single-value-fun (getf '(truncate sb-kernel::truncate1 floor sb-kernel::floor1 - ceiling sb-kernel::ceiling1) + ceiling sb-kernel::ceiling1 + ftruncate sb-kernel::ftruncate1 + ffloor sb-kernel::ffloor1 + fceiling sb-kernel::fceiling1) combination-name))) (when single-value-fun (unless (cdr args) - (let* ((leaf (find-constant 1)) - (ref (make-ref leaf)) - (lvar (make-lvar combination))) - (use-lvar ref lvar) - (push ref (leaf-refs leaf)) - (insert-ref-before ref combination-name) - (setf (cdr args) (list lvar)))) + (setf (cdr args) + (list (insert-ref-before (find-constant 1) combination)))) (change-full-call combination single-value-fun) (setf (node-derived-type combination) (make-single-value-type (single-value-type (node-derived-type combination))))))))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 9bc7700bf..d01b7353d 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -927,13 +927,14 @@ cast)))) (defun insert-ref-before (leaf node) - (let ((ref (make-ref leaf)) - (lvar (make-lvar node))) - (insert-node-before node ref) - (push ref (leaf-refs leaf)) - (setf (leaf-ever-used leaf) t) - (use-lvar ref lvar) - lvar)) + (with-ir1-environment-from-node node + (let ((ref (make-ref leaf)) + (lvar (make-lvar node))) + (insert-node-before node ref) + (push ref (leaf-refs leaf)) + (setf (leaf-ever-used leaf) t) + (use-lvar ref lvar) + lvar))) ;;;; miscellaneous shorthand functions diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 7cf3207b8..cbb826894 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -236,6 +236,8 @@ (let ((kind (basic-combination-kind call)) (info (basic-combination-fun-info call))) + (rewrite-full-call call) + (dolist (arg (basic-combination-args call)) (unless (lvar-info arg) (setf (lvar-info arg) @@ -253,8 +255,7 @@ (when (basic-combination-info call) (signal-delayed-combination-condition call)) (setf (basic-combination-kind call) :full)) - (setf (basic-combination-info call) :full) - (rewrite-full-call call)))) + (setf (basic-combination-info call) :full)))) (annotate-fun-lvar (basic-combination-fun call)) (values))