GitLab

at 2024-04-02T08:10:23-07:00

Fix #298: Add with-float-rounding-mode macro

Add `ext:with-float-rounding-mode` macro to set the FP rounding mode
to be used when executing the body.

Update cmucl.pot with new docstrings

Add tests for with-float-rounding-mode

Not 100% sure the expected results are right.  They seem plausible,
but I didn't actually analyze that the rounding is correct.

Reorder bug list to be numerically ascending.

No other changes.

Fix #297:  Print new-assem:assemble with less indentation

Merge branch 'issue-297-pprint-assemble' into 'master'

Fix #297:  Print new-assem:assemble with less indentation

Closes #297

See merge request cmucl/cmucl!203
Fix #300: Reduce code duplication in random

Merge branch 'issue-300-reduce-code-dup-in-random' into 'master'

Fix #300: Reduce code duplication in random

Closes #300

See merge request cmucl/cmucl!206
Make variable names consistent.
Fix #295:  Add docstring for define-assembly-routine

Merge branch 'issue-295-docstring-for-define-assembly-routine' into 'master'

Fix #295:  Add docstring for define-assembly-routine

Closes #295

See merge request cmucl/cmucl!204
Fix typos caused by renaming

We renamed `old-rounding-mode` to `old-mode`, but forgot to update all
uses.

Fix up docstring for with-float-rounding-mode

Mention that the allowed values are the same as the values for the
rounding-mode in `set-floating-point-modes`.

Change indentation of docstring slightly so that it prints nicely via
`describe`.  (Emacs doesn't indent the docstring by the right amount
for `describe`.)

Remove extra trailing space after period.

Fix #294: Implement assembly routine for xoroshiro update

Merge branch 'issue-294-xoroshiro-lisp-assem-routine' into 'master'

Fix #294: Implement assembly routine for xoroshiro update

Closes #294

See merge request cmucl/cmucl!202
Update cmucl.pot for changed docstring for with-float-rounding-mode.

Merge branch 'issue-298-with-float-rounding-mode' into 'master'

Fix #298: Add with-float-rounding-mode macro

Closes #298

See merge request cmucl/cmucl!205
Fix #299: Use xoroshiro assembly routine for x86

Merge branch 'issue-299-enable-xoroshiro-assem-routine' into 'master'

Fix #299: Use xoroshiro assembly routine for x86

Closes #299, #295, #300, #297, and #294

See merge request cmucl/cmucl!208
Add comment about using -V and use a better version

Explain why we use `-V` for `bin/make-dist.sh`.  And instead of using
"ci-build" as the version, use `git describe --dirty` as the version.
This lets us know better what version was actually used for the build.

Disable underflow trap when converting the ratio to a float.

Update cmucl.pot for the changed strings too.

Merge branch 'master' into issue-275b-signal-float-underflow

 variables:

   download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2023/08"

-  version: "2023-08-x86"

-  bootstrap: "-B boot-2023-08"

+  version: "xoroshiro-assembly-x86"

+  bootstrap: ""

 stages:

     # Regular build using the cross-compiled result or snapshot

     - bin/build.sh $bootstrap -R -C "x86_linux_clang" -o snapshot/bin/lisp

     # - bin/build.sh $bootstrap -R -C "x86_linux" -o snapshot/bin/lisp

-    - bin/make-dist.sh -I dist linux-4

+    # Use -V to specify the version in case some tag makes git

+    # describe return something that make-dist.sh doesn't like.

+    - bin/make-dist.sh -V `git describe --dirty` -I dist linux-4

 linux:test:

   stage: test

     # Regular build using the cross-compiled result or snapshot.

     # Need /opt/local/bin to get msgmerge and msgfmt programs.

     - PATH=/opt/local/bin:$PATH bin/build.sh $bootstrap -R -C "" -o snapshot/bin/lisp

-    - bin/make-dist.sh -I dist darwin-4

+    # Use -V to specify the version in case some tag makes git

+    # describe return something that make-dist.sh doesn't like.

+    - bin/make-dist.sh -V `git describe --dirty` -I dist darwin-4

 osx:test:

   stage: test

 # ("snapshot-yyyy-mm") or a release number..

 GIT_HASH="`(cd src; git describe --dirty 2>/dev/null)`"

+echo GIT_HASH = ${GIT_HASH}

+

 if expr "X${GIT_HASH}" : 'Xsnapshot-[0-9][0-9][0-9][0-9]-[01][0-9]' > /dev/null; then

     DEFAULT_VERSION=`expr "${GIT_HASH}" : "snapshot-\(.*\)"`

 fi

 				    ,(reg-spec-temp res))))

 		     results))))))

+;;; Define-Assembly-Routine -- Public

+;;;

+;;;   Parse the code to produce an assembly routine and create a VOP

+;;;   that calls the assembly routine.

 (defmacro define-assembly-routine (name&options vars &rest code)

+  "Define-Assembly-Routine (Name&Options Vars Code*)

+  Define a Lisp assembly routine, and a VOP to that calls the assembly

+  routine, if enabled.  (A VOP is not created if the reader

+  conditional #+assembler precedes the definition of the assembly

+  routine.)

+

+  Name&Options

+    A list giving the name of the assembly routine and options

+    describing the assembly routine options and VOP options.  The

+    format is (Name ({Key Value})*) where Name is the name of the

+    assembly routine.  Options is a list of options:

+

+    Options

+

+      :Cost Cost

+        The cost of the VOP.  This is used in the generated VOP.

+

+      :Policy {:Small | :Fast | :Safe | :Fast-Safe}

+        The policy for the VOP.

+

+      :Translate Name

+        The translation for the VOP.

+

+      :Arg-Types arg-types

+      :Result-Types result-types

+        The template restrictions for the arguments of the VOP and the

+        results of the VOP.

+

+      :Return-Style {:Raw :Full-Call :None}

+ 

+    Vars is a list of the arguments and returned results and

+    temporaries used by the assembly routine.

+

+      :Arg Arg-Name (SC*) SC-Offset

+        Input argument for the assembly routine with the name

+        Arg-Name.  The argument must be one of the SC types.  The register

+        assigned to this argument is given by SC-Offset which must be

+        the offset for the register holding this argument.

+

+      :Res Res-Name SC SC-Offset

+        Result of the assembly routine with the name Res-Name.  The

+        result must be a register of the specified storage class SC.  The

+        Sc-offset is the register used for the result.

+

+      :Temp Temp-Name SC SC-Offset

+        Like :Res, except this names a temporary register that the

+        assembly routine can use.

+

+  Code

+    The code for the assembly routine."

   (multiple-value-bind (name options)

 		       (if (atom name&options)

 			   (values name&options nil)

   (inst pop y)

   (inst pop k)

   (inst ret))

+

+;;; Support for the xoroshiro128** generator.  See

+;;; https://prng.di.unimi.it/xoroshiro128starstar.c for the official

+;;; code.

+;;;

+;;; This is what we're implementing, where s[] is our state vector.

+;;;

+;;; static uint64_t s[2];

+;;; static inline uint64_t rotl(const uint64_t x, int k) {

+;;;   return (x << k) | (x >> (64 - k));

+;;; }

+;;;

+;;; uint64_t next(void) {

+;;;   const uint64_t s0 = s[0];

+;;; 	 uint64_t s1 = s[1];

+;;; 	 const uint64_t result = rotl(s0 * 5, 7) * 9;

+;;; 

+;;; 	 s1 ^= s0;

+;;; 	 s[0] = rotl(s0, 24) ^ s1 ^ (s1 << 16); // a, b

+;;; 	 s[1] = rotl(s1, 37); // c

+;;; 

+;;; 	 return result;

+;;; }

+;;;

+;;; A VOP is also generated to call this assembly routine.  This

+;;; routine computes a new 64-bit random number and also updates the

+;;; state, which is (simple-array (double-float) (2)).

+#+random-xoroshiro

+(define-assembly-routine

+  (xoroshiro-update

+   (:translate kernel::random-xoroshiro-update)

+   (:return-style :raw)

+   (:cost 30)

+   (:policy :fast-safe)

+   (:arg-types simple-array-double-float)

+   (:result-types unsigned-num unsigned-num))

+  ((:arg state descriptor-reg edx-offset)

+   (:res r1 unsigned-reg ecx-offset)

+   (:res r0 unsigned-reg ebx-offset)

+   (:temp s0 double-reg xmm0-offset)

+   (:temp s1 double-reg xmm1-offset)

+   (:temp t0 double-reg xmm2-offset)

+   (:temp t1 double-reg xmm3-offset))

+

+  ;; s0 = state[0]

+  (inst movsd s0 (make-ea :dword :base state

+                                 :disp (- (+ (* vm:vector-data-offset

+					        vm:word-bytes)

+				             (* 8 0))

+				          vm:other-pointer-type)))

+  ;; t0 = s0 * 5 = s0 << 2 + s0

+  (inst movapd t0 s0)                   ; t0 = s0

+  (inst psllq t0 2)                     ; t0 = t0 << 2 = 4*t0

+  (inst paddq t0 s0)                    ; t0 = t0 + s0 = 5*t0

+

+  ;; t0 = rotl(t0, 7) = t0 << 7 | t0 >> (64-7)

+  ;;    = rotl(s0*5, 7)

+  (inst movapd t1 t0)          ; t1 = t0

+  (inst psllq t1 7)            ; t1 = t0 << 7

+  (inst psrlq t0 (- 64 7))     ; t0 = t0 >> 57

+  (inst orpd t0 t1)            ; t0 = t0 << 7 | t0 >> 57 = rotl(t0, 7)

+

+  ;; t0 = t0 * 9 = t0 << 3 + t0

+  ;;    = rotl(s0*5, 7) * 9

+  (inst movapd t1 t0)                   ; t1 = t0

+  (inst psllq t1 3)                     ; t1 = t0 << 3

+  (inst paddq t0 t1)                    ; t0 = t0 << 3 + t0 = 9*t0

+

+  ;; Save the result as two 32-bit results.  r1 is the high 32 bits

+  ;; and r0 is the low 32.

+  (inst movd r0 t0)

+  (inst psrlq t0 32)

+  (inst movd r1 t0)

+

+  ;; s1 = state[1]

+  (inst movsd s1 (make-ea :dword :base state

+			         :disp (- (+ (* vm:vector-data-offset

+					        vm:word-bytes)

+				             (* 8 1))

+				          vm:other-pointer-type)))

+  (inst xorpd s1 s0)                    ; s1 = s1 ^ s0

+

+  ;; s0 can now be reused as a temp.

+  ;; s0 = rotl(s0, 24)

+  (inst movapd t0 s0)                   ; t0 = s0

+  (inst psllq t0 24)                    ; t0 = s0 << 24

+  (inst psrlq s0 (- 64 24))             ; s0 = s0 >> 40

+  (inst orpd s0 t0)                     ; s0 = s0 | t0 = rotl(s0, 24)

+

+  ;; s0 = s0 ^ s1 = rotl(s0, 24) ^ s1

+  (inst xorpd s0 s1)

+

+  ;; s0 = s0 ^ (s1 << 16)

+  (inst movapd t0 s1)            ; t0 = s1

+  (inst psllq t0 16)             ; t0 = s1 << 16

+  (inst xorpd s0 t0)             ; s0 = rotl(s0, 24) ^ s1 ^ (s1 << 16)

+

+  ;; Save s0 to state[0]

+  (inst movsd (make-ea :dword :base state

+			      :disp (- (+ (* vm:vector-data-offset

+					     vm:word-bytes)

+				          (* 8 0))

+				       vm:other-pointer-type))

+        s0)

+

+  ;; s1 = rotl(s1, 37)

+  (inst movapd t0 s1)                   ; t0 = s1

+  (inst psllq t0 37)                    ; t0 = s1 << 37

+  (inst psrlq s1 (- 64 37))             ; s1 = s1 >> 27

+  (inst orpd s1 t0)                     ; s1 = t0 | s1 = rotl(s1, 37)

+

+  ;; Save s1 to state[1]

+  (inst movsd (make-ea :dword :base state

+			      :disp (- (+ (* vm:vector-data-offset

+					     vm:word-bytes)

+				          (* 8 1))

+				       vm:other-pointer-type))

+        s1))
 (def-vm-support-routine generate-return-sequence (style)

   (ecase style

     (:raw

-     `(inst ret))

+     `((inst ret)))

     (:full-call

      `(

        (inst pop eax-tn)

 ;; *SOFTWARE-VERSION* from the LISP package to the SYSTEM package.

 (ext:without-package-locks

     (unintern 'lisp::*software-version* "LISP"))

+

+#+(or random-mt19937 random-xoroshiro)

+(in-package "C")

+#+(or random-mt19937 random-xoroshiro)

+(deftransform random ((num &optional state)

+		      ((integer 1 #.(expt 2 32)) &optional *))

+  _N"use inline (unsigned-byte 32) operations"

+  (let* ((num-type (continuation-type num))

+	 (num-high (cond ((numeric-type-p num-type)

+			  (numeric-type-high num-type))

+			 ((union-type-p num-type)

+			  ;; Find the maximum of the union type.  We

+			  ;; know this works because if we're in this

+			  ;; routine, NUM must be a subtype of

+			  ;; (INTEGER 1 2^32), so each member of the

+			  ;; union must be a subtype too.

+			  (reduce #'max (union-type-types num-type)

+				  :key #'numeric-type-high))

+			 (t

+			  (give-up)))))

+    ;; Rather than doing (rem (random-chunk) num-high), we do,

+    ;; essentially, (rem (* num-high (random-chunk)) #x100000000).  I

+    ;; (rtoy) believe this approach doesn't have the bias issue with

+    ;; doing rem.  This method works by treating (random-chunk) as if

+    ;; it were a 32-bit fraction between 0 and 1, exclusive.  Multiply

+    ;; this by num-high to get a random number between 0 and num-high,

+    ;; This should have no bias.

+    (cond ((constant-continuation-p num)

+	   (if (= num-high (expt 2 32))

+	       '(random-chunk (or state *random-state*))

+	       '(values (bignum::%multiply 

+			 (random-chunk (or state *random-state*))

+			 num))))

+	  ((< num-high (expt 2 32))

+	   '(values (bignum::%multiply (random-chunk (or state *random-state*))

+		     num)))

+	  ((= num-high (expt 2 32))

+	   '(if (= num (expt 2 32))

+		(random-chunk (or state *random-state*))

+		(values (bignum::%multiply (random-chunk (or state *random-state*))

+					   num))))

+	  (t

+	   (error (intl:gettext "Shouldn't happen"))))))
 	   "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"

 	   "FLOAT-SIGNALING-NAN-P"

 	   "WITH-FLOAT-TRAPS-MASKED"

-	   "WITH-FLOAT-TRAPS-ENABLED")

+	   "WITH-FLOAT-TRAPS-ENABLED"

+           "WITH-FLOAT-ROUNDING-MODE")

   ;; More float extensions

   #+double-double

   (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT"

 	  decode-floating-point-modes

 	  encode-floating-point-modes

 	  with-float-traps-masked

-	  with-float-traps-enabled))

+	  with-float-traps-enabled

+          with-float-rounding-mode))

 (in-package "VM")

 (eval-when (compile load eval)

   accrued exceptions are cleared at the start of the body to support

   their testing within, and restored on exit."))

+(defmacro with-float-rounding-mode ((rounding-mode) &body body)

+  _N"Execute BODY with the floating-point rounding mode set to

+  ROUNDING-MODE.  ROUNDING-MODE must be a one:

+

+   :NEAREST

+       the default mode of round to nearest even.

+   :ZERO

+       round numbers down towards zero.  Positive numbers round down

+       and negative numbers round up.

+   :POSITIVE-INFINITY

+       round numbers up towards positive infinity.

+   :NEGATIVE-INFINITY

+       round numbers down towards negative infinity.

+

+  These are the same as the possible values for the rounding mode in

+  SET-FLOATING-POINT-MODES.

+

+  Only the rounding mode is restored on exit; other floating-point

+  modes are not modified."

+  (let ((old-mode (gensym "OLD-MODE-"))

+        (new-mode (gensym "NEW-MODE-")))

+  `(let ((,old-mode (ldb float-rounding-mode (floating-point-modes)))

+         (,new-mode (cdr (assoc ,rounding-mode rounding-mode-alist))))

+     (unwind-protect

+          (progn

+            (setf (floating-point-modes)

+                  (dpb ,new-mode float-rounding-mode (floating-point-modes)))

+            ,@body)

+       ;; Restore just the rounding mode to the original value.

+       (setf (floating-point-modes)

+             (dpb ,old-mode float-rounding-mode (floating-point-modes)))))))
     (c:define-vop pprint-define-vop)

     (c:sc-case pprint-sc-case)

     (c:define-assembly-routine pprint-define-assembly)

+    (new-assem:assemble pprint-multiple-value-bind)

     (c:deftransform pprint-defun)

     (c:defoptimizer pprint-defun)

     (ext:with-float-traps-masked pprint-with-like)

   being the first value."

   (declare (type (simple-array double-float (2)) state)

 	   (optimize (speed 3) (safety 0)))

-  (vm::xoroshiro-next state))

+  (kernel::random-xoroshiro-update state))

 #-x86

 (defun xoroshiro-gen (state)

   (declare (inline %random-single-float %random-double-float))

   (cond

     ((typep arg '(integer 1 #x100000000))

-     ;; Do the same thing as the deftransform would do.

-     (if (= arg (expt 2 32))

-	 (random-chunk state)

-	 (values (bignum::%multiply (random-chunk state)

-				    arg))))

+     ;; Let the compiler deftransform take care of this case.

+     (random arg state))

     ((and (typep arg 'single-float) (> arg 0.0F0))

      (%random-single-float arg state))

     ((and (typep arg 'double-float) (> arg 0.0D0))

   ;; Otherwise the number might fit, so we carefully compute the result.

   (handler-case

-      (let* ((ratio (/ (* (expt 10 exponent) number)

-                       divisor))

-	     (result (coerce ratio float-format)))

-	(when (and (zerop result) (not (zerop number)))

-	  ;; The number we've read is so small that it gets

-	  ;; converted to 0.0, but is not actually zero.  Signal an

-	  ;; error.  See CLHS 2.3.1.1.

-          (error _"Underflow"))

-        result)

+      (with-float-traps-masked (:underflow)

+        (let* ((ratio (/ (* (expt 10 exponent) number)

+                         divisor))

+	       (result (coerce ratio float-format)))

+	  (when (and (zerop result) (not (zerop number)))

+	    ;; The number we've read is so small that it gets

+	    ;; converted to 0.0, but is not actually zero.  Signal an

+	    ;; error.  See CLHS 2.3.1.1.

+            (error 'floating-point-underflow))

+          result))

     (floating-point-underflow ()

       ;; Resignal a reader error, but allow the user to continue with

       ;; 0.

 (in-package "VM")

+;; The update routine is a Lisp assembly routine with a corresponding

+;; VOP.  This lets the compiler know about the VOP so we can use it.

 #+random-xoroshiro

-(progn

-(defknown xoroshiro-next ((simple-array double-float (2)))

+(defknown kernel::random-xoroshiro-update ((simple-array double-float (2)))

   (values (unsigned-byte 32) (unsigned-byte 32))

   (movable))
-

-(define-vop (xoroshiro-next)

-  (:policy :fast-safe)

-  (:translate xoroshiro-next)

-  (:args (state :scs (descriptor-reg) :to (:result 3)))

-  (:arg-types simple-array-double-float)

-  (:results (r1 :scs (unsigned-reg))

-	    (r0 :scs (unsigned-reg)))

-  (:result-types unsigned-num unsigned-num)

-  (:temporary (:sc double-reg) s0)

-  (:temporary (:sc double-reg) s1)

-  (:temporary (:sc double-reg) t0)

-  (:temporary (:sc double-reg) t1)

-  (:generator 10

-    ;; See https://prng.di.unimi.it/xoroshiro128starstar.c for the official code.

-    ;;

-    ;; This is what we're implementing, where s[] is our state vector.

-    ;;

-    ;; static uint64_t s[2];

-    ;; static inline uint64_t rotl(const uint64_t x, int k) {

-    ;;   return (x << k) | (x >> (64 - k));

-    ;; }

-    ;;

-    ;; uint64_t next(void) {

-    ;;   const uint64_t s0 = s[0];

-    ;; 	 uint64_t s1 = s[1];

-    ;; 	 const uint64_t result = rotl(s0 * 5, 7) * 9;

-    ;; 

-    ;; 	 s1 ^= s0;

-    ;; 	 s[0] = rotl(s0, 24) ^ s1 ^ (s1 << 16); // a, b

-    ;; 	 s[1] = rotl(s1, 37); // c

-    ;; 

-    ;; 	 return result;

-    ;; }

-

-    ;; s0 = state[0]

-    (inst movsd s0 (make-ea :dword :base state

-                            :disp (- (+ (* vm:vector-data-offset

-					   vm:word-bytes)

-				        (* 8 0))

-				     vm:other-pointer-type)))

-    ;; t0 = s0 * 5 = s0 << 2 + s0

-    (inst movapd t0 s0)                 ; t0 = s0

-    (inst psllq t0 2)                   ; t0 = t0 << 2 = 4*t0

-    (inst paddq t0 s0)                  ; t0 = t0 + s0 = 5*t0

-

-    ;; t0 = rotl(t0, 7) = t0 << 7 | t0 >> (64-7)

-    ;;    = rotl(s0*5, 7)

-    (inst movapd t1 t0)        ; t1 = t0

-    (inst psllq t1 7)          ; t1 = t0 << 7

-    (inst psrlq t0 (- 64 7))   ; t0 = t0 >> 57

-    (inst orpd t0 t1)          ; t0 = t0 << 7 | t0 >> 57 = rotl(t0, 7)

-

-    ;; t0 = t0 * 9 = t0 << 3 + t0

-    ;;    = rotl(s0*5, 7) * 9

-    (inst movapd t1 t0)                 ; t1 = t0

-    (inst psllq t1 3)                   ; t1 = t0 << 3

-    (inst paddq t0 t1)                  ; t0 = t0 << 3 + t0 = 9*t0

-

-    ;; Save the result as two 32-bit results.  r1 is the high 32 bits

-    ;; and r0 is the low 32.

-    (inst movd r0 t0)

-    (inst psrlq t0 32)

-    (inst movd r1 t0)

-

-    ;; s1 = state[1]

-    (inst movsd s1 (make-ea :dword :base state

-			    :disp (- (+ (* vm:vector-data-offset

-					   vm:word-bytes)

-				        (* 8 1))

-				     vm:other-pointer-type)))

-    (inst xorpd s1 s0)                  ; s1 = s1 ^ s0

-

-    ;; s0 can now be reused as a temp.

-    ;; s0 = rotl(s0, 24)

-    (inst movapd t0 s0)                 ; t0 = s0

-    (inst psllq t0 24)                  ; t0 = s0 << 24

-    (inst psrlq s0 (- 64 24))           ; s0 = s0 >> 40

-    (inst orpd s0 t0)                   ; s0 = s0 | t0 = rotl(s0, 24)

-

-    ;; s0 = s0 ^ s1 = rotl(s0, 24) ^ s1

-    (inst xorpd s0 s1)

-

-    ;; s0 = s0 ^ (s1 << 16)

-    (inst movapd t0 s1)          ; t0 = s1

-    (inst psllq t0 16)           ; t0 = s1 << 16

-    (inst xorpd s0 t0)           ; s0 = rotl(s0, 24) ^ s1 ^ (s1 << 16)

-

-    ;; Save s0 to state[0]

-    (inst movsd (make-ea :dword :base state

-			 :disp (- (+ (* vm:vector-data-offset

-					vm:word-bytes)

-				     (* 8 0))

-				  vm:other-pointer-type))

-          s0)

-

-    ;; s1 = rotl(s1, 37)

-    (inst movapd t0 s1)                 ; t0 = s1

-    (inst psllq t0 37)                  ; t0 = s1 << 37

-    (inst psrlq s1 (- 64 37))           ; s1 = s1 >> 27

-    (inst orpd s1 t0)                   ; s1 = t0 | s1 = rotl(s1, 37)

-

-    ;; Save s1 to state[1]

-    (inst movsd (make-ea :dword :base state

-			 :disp (- (+ (* vm:vector-data-offset

-					vm:word-bytes)

-				     (* 8 1))

-				  vm:other-pointer-type))

-          s1)))

-)
     * ~~#261~~ Remove `get-system-info` from "bsd-os.lisp"

     * ~~#268~~ Can't clone ansi-test repo on Mac OS CI box

     * ~~#265~~ CI for mac os is broken

-    * ~~#269~~ Add function to get user's home directory

     * ~~#266~~ Support "~user" in namestrings

+    * ~~#269~~ Add function to get user's home directory

     * ~~#271~~ Update ASDF to 3.3.7

     * ~~#272~~ Move scavenge code for static vectors to its own function

     * ~~#274~~ 1d99999999 hangs

     * ~~#288~~ Re-enable `deftransform` for random integers.

     * ~~#290~~ Pprint `with-float-traps-masked` better

     * ~~#291~~ Pprint `handler-case` neatly.

+    * ~~#297~~ Pprint `new-assem:assemble` with less indentation.

   * Other changes:

   * Improvements to the PCL implementation of CLOS:

   * Changes to building procedure:

 "  their testing within, and restored on exit."

 msgstr ""

+#: src/code/float-trap.lisp

+msgid ""

+"Execute BODY with the floating-point rounding mode set to\n"

+"  ROUNDING-MODE.  ROUNDING-MODE must be a one:\n"

+"\n"

+"   :NEAREST\n"

+"       the default mode of round to nearest even.\n"

+"   :ZERO\n"

+"       round numbers down towards zero.  Positive numbers round down\n"

+"       and negative numbers round up.\n"

+"   :POSITIVE-INFINITY\n"

+"       round numbers up towards positive infinity.\n"

+"   :NEGATIVE-INFINITY\n"

+"       round numbers down towards negative infinity.\n"

+"\n"

+"  These are the same as the possible values for the rounding mode in\n"

+"  SET-FLOATING-POINT-MODES.\n"

+"\n"

+"  Only the rounding mode is restored on exit; other floating-point\n"

+"  modes are not modified."

+msgstr ""

+

 #: src/code/float.lisp

 msgid "Return true if the float X is denormalized."

 msgstr ""

 msgid "Number not representable as a ~S: ~S"

 msgstr ""

-#: src/code/reader.lisp

-msgid "Underflow"

-msgstr ""

-

 #: src/code/reader.lisp

 msgid "Floating point underflow when reading ~S: ~S"

 msgstr ""

   (assert-error 'reader-error (read-from-string "1.8d308"))

   (assert-error 'reader-error (read-from-string "1d999999999")))

-(define-test reader.float-underflow

+(defun rounding-test (x)

+  (declare (double-float x)

+           (optimize (speed 3)))

+  (* x (/ 1d0 x)))

+

+(define-test rounding-mode.nearest

     (:tag :issues)

-  (lisp::with-float-traps-enabled (:underflow)

-    ;; A denormal

-    (assert-error 'reader-error

-                  (read-from-string "1e-40"))

-    (assert-error 'reader-error

-                  (read-from-string (format nil "~A" least-positive-single-float)))

-    ;; The same for double-floats

-    (assert-error 'reader-error

-                  (read-from-string "1d-308"))

-    (assert-error 'reader-error

-                  (read-from-string (format nil "~A" least-positive-double-float)))))

-

-(define-test reader.float-underflow

+  (ext:with-float-rounding-mode (:nearest)

+    (assert-equal 1d0 (rounding-test 3d0))))

+

+(define-test rounding-mode.zero.1

     (:tag :issues)

-  (lisp::with-float-traps-enabled (:underflow)

-    ;; The expected string comes from make-float-aux.

-    (let ((expected "Floating point underflow when reading ~S: ~S"))

-      (flet ((test-reader-underflow (string)

-               ;; Test that the we got a reader-error when a number

-               ;; would underflow and that the message says we got an

-               ;; underflow.

-               (let ((condition (nth-value 1 (ignore-errors (read-from-string string)))))

-                 (assert-equal 'reader-error (type-of condition))

-                 (assert-equal expected (lisp::reader-error-format-control condition)))))

-        ;; Underflow single-floats

-        (test-reader-underflow "1e-40")

-        (test-reader-underflow (format nil "~A" least-positive-single-float))

-        ;; Underflow double-floats

-        (test-reader-underflow "1d-308")

-        (test-reader-underflow (format nil "~A" least-positive-double-float))))))
+  (ext:with-float-rounding-mode (:zero)

+    (assert-equal 0.9999999999999999d0

+                  (rounding-test 3d0))))

+

+(define-test rounding-mode.zero.2

+    (:tag :issues)

+  (ext:with-float-rounding-mode (:zero)

+    (assert-equal 0.9999999999999999d0

+                  (rounding-test -3d0))))

+

+(define-test rounding-mode.positive-infinity

+    (:tag :issues)

+  (ext:with-float-rounding-mode (:positive-infinity)

+    (assert-equal 1.0000000000000002d0

+                  (rounding-test 3d0))))

+

+(define-test rounding-mode.negative-infinity

+    (:tag :issues)

+  (ext:with-float-rounding-mode (:negative-infinity)

+    (assert-equal 0.9999999999999999d0

+                  (rounding-test 3d0))))

+
                (:no-error ()

                 (format nil "Nothing bad happened.")))

              s))))

+

+(define-test pprint.assemble

+    (:tag :issues)

+  (assert-equal

+   "

+(NEW-ASSEM:ASSEMBLE (C:*CODE-SEGMENT* 'X86::XOROSHIRO-UPDATE)

+    X86::XOROSHIRO-UPDATE

+  (PUSH (CONS 'X86::XOROSHIRO-UPDATE X86::XOROSHIRO-UPDATE)

+        C::*ASSEMBLER-ROUTINES*))"

+   (with-output-to-string (s)

+     (pprint '(new-assem:assemble (c::*code-segment* 'vm::xoroshiro-update)

+               vm::xoroshiro-update

+               (push (cons 'vm::xoroshiro-update vm::xoroshiro-update) c::*assembler-routines*))

+             s))))

Raymond Toy pushed to branch issue-275b-signal-float-underflow at cmucl / cmucl

Commits:

16 changed files:

Changes: