[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-devel
Subject: Re: [Sbcl-devel] [Sbcl-commits] master: Transform (TRUNCATE x 1) to a function computing both values
From: Stas Boukarev <stassats () gmail ! com>
Date: 2022-07-05 13:05:10
Message-ID: CAF63=13L2tjG9QqXK_ojGMA2d_G0ZQTVoWHBYbpY-onLzt7tFw () mail ! gmail ! com
[Download RAW message or body]
And the error is bogus, it should be about a function being undefined.
On Tue, Jul 5, 2022 at 3:09 PM Stas Boukarev <stassats@gmail.com> wrote:
>
> It dies after adding just
> (defknown unary-truncate-double-float-to-bignum (double-float) (values
> bignum (eql $0d0))) into fndb.
>
> On Tue, Jul 5, 2022 at 2:42 AM Douglas Katzman via Sbcl-devel
> <sbcl-devel@lists.sourceforge.net> wrote:
> >
> > After this change ppc64 dies in cold-init with
> >
> > "obj/from-xcInternal error #108 "Object is not of type CTRAN." at 0x1000c375c4
> >
> > SC: 0, Offset: 0 $1= 0x00000604: list pointer(bad-address)
> >
> > Welcome to LDB, a low-level debugger for the Lisp runtime environment.
> >
> >
> > On Thu, Jun 30, 2022 at 7:04 PM stassats via Sbcl-commits <sbcl-commits@lists.sourceforge.net> wrote:
> >>
> >> The branch "master" has been updated in SBCL:
> >> via 1b5de544d8b2f07aabb9eafb997398472ba41044 (commit)
> >> from be6166284fda02feb969dde76363c9febd37ad41 (commit)
> >>
> >> - Log -----------------------------------------------------------------
> >> commit 1b5de544d8b2f07aabb9eafb997398472ba41044
> >> Author: Stas Boukarev <stassats@gmail.com>
> >> Date: Fri Jul 1 01:20:42 2022 +0300
> >>
> >> Transform (TRUNCATE x 1) to a function computing both values.
> >>
> >> Instead of transforming into %unary-truncate and then computing the
> >> remainder. The remainder can be more efficiently computed when the
> >> type is known.
> >> ---
> >> src/code/float.lisp | 35 +++++++++++++++++++++++++++++++++++
> >> src/code/target-sxhash.lisp | 5 +++--
> >> src/cold/exports.lisp | 5 ++++-
> >> src/compiler/float-tran.lisp | 43 ++++++++++++++++++++++++++++---------------
> >> src/compiler/fndb.lisp | 6 ++++++
> >> src/compiler/srctran.lisp | 16 ++++++++++++++++
> >> tests/compiler.pure.lisp | 21 ++++++++++-----------
> >> 7 files changed, 102 insertions(+), 29 deletions(-)
> >>
> >> diff --git a/src/code/float.lisp b/src/code/float.lisp
> >> index 5bfffa61b..12463aae9 100644
> >> --- a/src/code/float.lisp
> >> +++ b/src/code/float.lisp
> >> @@ -566,6 +566,41 @@
> >> bits)
> >> exp))))))
> >>
> >> +;;; Produce both values, unlike %unary-truncate
> >> +(defun unary-truncate (number)
> >> + (number-dispatch ((number real))
> >> + ((integer) (values number 0))
> >> + ((ratio)
> >> + (let ((truncated (truncate (numerator number) (denominator number))))
> >> + (values truncated
> >> + (- number truncated))))
> >> + (((foreach single-float double-float #+long-float long-float))
> >> + (if (and (<= (float most-negative-fixnum number) number)
> >> + (< number (float most-positive-fixnum number)))
> >> + (let* ((truncated (truly-the fixnum (%unary-truncate number))))
> >> + (values truncated
> >> + (- number
> >> + (coerce truncated '(dispatch-type number)))))
> >> + (multiple-value-bind (bits exp sign) (integer-decode-float number)
> >> + (values
> >> + (ash (if (minusp sign)
> >> + (- bits)
> >> + bits)
> >> + exp)
> >> + (coerce 0 '(dispatch-type number))))))))
> >> +
> >> +(macrolet ((def (type)
> >> + `(defun ,(symbolicate '%unary-truncate/ type '-to-bignum) (number)
> >> + (multiple-value-bind (bits exp sign) (integer-decode-float number)
> >> + (values
> >> + (ash (if (minusp sign)
> >> + (- bits)
> >> + bits)
> >> + exp)
> >> + (coerce 0 ',type))))))
> >> + (def double-float)
> >> + (def single-float))
> >> +
> >> ;;; Specialized versions for floats.
> >> (macrolet ((def (type name)
> >> `(defun ,name (number)
> >> diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp
> >> index 047e3bfcb..1bd42e9f1 100644
> >> --- a/src/code/target-sxhash.lisp
> >> +++ b/src/code/target-sxhash.lisp
> >> @@ -361,9 +361,10 @@
> >> (let ((lo (coerce most-negative-fixnum type))
> >> (hi (coerce most-positive-fixnum type)))
> >> `(let ((key ,key))
> >> - (cond ( ;; This clause allows FIXNUM-sized integer
> >> + (cond (;; This clause allows FIXNUM-sized integer
> >> ;; values to be handled without consing.
> >> - (<= ,lo key ,hi)
> >> + (and (<= ,lo key)
> >> + (< key ,hi))
> >> (multiple-value-bind (q r) (floor (the (,type ,lo ,hi) key))
> >> (if (zerop (the ,type r))
> >> (sxhash q)
> >> diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
> >> index 989103d41..5efeac428 100644
> >> --- a/src/cold/exports.lisp
> >> +++ b/src/cold/exports.lisp
> >> @@ -1956,10 +1956,13 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
> >> "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH"
> >> "THE*"
> >> "%UNARY-ROUND"
> >> - "%UNARY-TRUNCATE"
> >> + "%UNARY-TRUNCATE" "UNARY-TRUNCATE"
> >> "%UNARY-TRUNCATE/SINGLE-FLOAT"
> >> "%UNARY-TRUNCATE/DOUBLE-FLOAT"
> >> "%UNARY-FTRUNCATE"
> >> + "UNARY-TRUNCATE-SINGLE-FLOAT-TO-BIGNUM"
> >> + "UNARY-TRUNCATE-DOUBLE-FLOAT-TO-BIGNUM"
> >> +
> >> "%WITH-ARRAY-DATA"
> >> "%WITH-ARRAY-DATA/FP"
> >> "%WITH-ARRAY-DATA-MACRO"
> >> diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
> >> index 7421fdfbb..de2951811 100644
> >> --- a/src/compiler/float-tran.lisp
> >> +++ b/src/compiler/float-tran.lisp
> >> @@ -1553,23 +1553,40 @@
> >>
> >>
> >> ;;;; TRUNCATE, FLOOR, CEILING, and ROUND
> >> +(deftransform truncate ((x &optional by)
> >> + (t &optional (constant-arg (member 1))))
> >> + '(unary-truncate x))
> >>
> >> -(macrolet ((define-frobs (fun ufun)
> >> - `(deftransform ,fun ((x &optional by)
> >> - (t &optional (constant-arg (member 1))))
> >> - '(let ((res (,ufun x)))
> >> - (values res (locally
> >> - (declare (flushable %single-float
> >> - %double-float))
> >> - (- x res)))))))
> >> - (define-frobs truncate %unary-truncate)
> >> - (define-frobs round %unary-round))
> >> +(deftransform round ((x &optional by)
> >> + (t &optional (constant-arg (member 1))))
> >> + '(let ((res (%unary-round x)))
> >> + (values res (locally
> >> + (declare (flushable %single-float
> >> + %double-float))
> >> + (- x res)))))
> >>
> >> (deftransform %unary-truncate ((x) (single-float))
> >> `(%unary-truncate/single-float x))
> >> (deftransform %unary-truncate ((x) (double-float))
> >> `(%unary-truncate/double-float x))
> >>
> >> +(deftransform unary-truncate ((x) * * :result result)
> >> + (if (lvar-single-value-p result)
> >> + `(values (%unary-truncate x) x)
> >> + (give-up-ir1-transform)))
> >> +
> >> +(macrolet ((def (type)
> >> + `(deftransform unary-truncate ((number) (,type))
> >> + '(if (and (<= (float most-negative-fixnum number) number)
> >> + (< number (float most-positive-fixnum number)))
> >> + (let ((truncated (truly-the fixnum (%unary-truncate number))))
> >> + (values truncated
> >> + (- number
> >> + (coerce truncated ',type))))
> >> + (,(symbolicate 'unary-truncate- type '-to-bignum) number)))))
> >> + (def single-float)
> >> + (def double-float))
> >> +
> >> ;;; Convert (TRUNCATE x y) to the obvious implementation.
> >> ;;;
> >> ;;; ...plus hair: Insert explicit coercions to appropriate float types: Python
> >> @@ -1596,11 +1613,7 @@
> >> (if (or (not y)
> >> (and (constant-lvar-p y) (= 1 (lvar-value y))))
> >> (if compute-all
> >> - `(let ((res (,',unary x)))
> >> - (values res (- x (locally
> >> - ;; Can be flushed as it will produce no errors.
> >> - (declare (flushable ,',coerce))
> >> - (,',coerce res)))))
> >> + `(unary-truncate x)
> >> `(let ((res (,',unary x)))
> >> ;; Dummy secondary value!
> >> (values res x)))
> >> diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
> >> index 490b135be..eb461d717 100644
> >> --- a/src/compiler/fndb.lisp
> >> +++ b/src/compiler/fndb.lisp
> >> @@ -344,6 +344,12 @@
> >> (real &optional real) (values integer real)
> >> (movable foldable flushable recursive))
> >>
> >> +(defknown unary-truncate (real) (values integer real)
> >> + (movable foldable flushable))
> >> +
> >> +(defknown unary-truncate-single-float-to-bignum (single-float) (values bignum (eql $0f0)))
> >> +(defknown unary-truncate-double-float-to-bignum (double-float) (values bignum (eql $0d0)))
> >> +
> >> (defknown %multiply-high (word word) word
> >> (movable foldable flushable))
> >>
> >> diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
> >> index 7aca09265..53a293405 100644
> >> --- a/src/compiler/srctran.lisp
> >> +++ b/src/compiler/srctran.lisp
> >> @@ -1720,6 +1720,22 @@
> >> (one-arg-derive-type number
> >> #'%unary-truncate-derive-type-aux
> >> #'%unary-truncate))
> >> +
> >> +(defoptimizer (unary-truncate derive-type) ((number))
> >> + (let* ((one (specifier-type '(integer 1 1)))
> >> + (quot (one-arg-derive-type number
> >> + (lambda (x)
> >> + (truncate-derive-type-quot-aux x one nil))
> >> + #'truncate))
> >> + (rem (one-arg-derive-type number
> >> + (lambda (x) (truncate-derive-type-rem-aux x one nil))
> >> + #'rem)))
> >> + (when (and quot rem)
> >> + (make-values-type :required (list quot rem)))))
> >> +
> >> +(deftransform unary-truncate ((number) (integer))
> >> + '(values number 0))
> >> +
> >> #-round-float
> >> (progn
> >> (defun ftruncate-derive-type-quot (number-type divisor-type)
> >> diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
> >> index c812caed7..0a1adfd57 100644
> >> --- a/tests/compiler.pure.lisp
> >> +++ b/tests/compiler.pure.lisp
> >> @@ -4280,17 +4280,16 @@
> >> (((cons 1.0 2.0) :test '=) t)))
> >>
> >> (with-test (:name (compile truncate :wild-values))
> >> - (let ((sb-c::*check-consistency* t))
> >> - (checked-compile-and-assert ()
> >> - `(lambda (a)
> >> - (declare (type (member 1d0 2d0) a))
> >> - (block return-value-tag
> >> - (funcall
> >> - (the function
> >> - (catch 'debug-catch-tag
> >> - (return-from return-value-tag
> >> - (progn (truncate a))))))))
> >> - ((2d0) (values 2 0d0)))))
> >> + (checked-compile-and-assert ()
> >> + `(lambda (a)
> >> + (declare (type (member 1d0 2d0) a))
> >> + (block return-value-tag
> >> + (funcall
> >> + (the function
> >> + (catch 'debug-catch-tag
> >> + (return-from return-value-tag
> >> + (progn (truncate a))))))))
> >> + ((2d0) (values 2 0d0))))
> >>
> >> (with-test (:name (compile :boxed-fp-constant-for-full-call))
> >> (let ((fun (checked-compile
> >>
> >> -----------------------------------------------------------------------
> >>
> >>
> >> hooks/post-receive
> >> --
> >> SBCL
> >>
> >>
> >> _______________________________________________
> >> Sbcl-commits mailing list
> >> Sbcl-commits@lists.sourceforge.net
> >> https://lists.sourceforge.net/lists/listinfo/sbcl-commits
> >
> > _______________________________________________
> > Sbcl-devel mailing list
> > Sbcl-devel@lists.sourceforge.net
> > https://lists.sourceforge.net/lists/listinfo/sbcl-devel
_______________________________________________
Sbcl-devel mailing list
Sbcl-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-devel
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic