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

Commits:

16 changed files:

Changes:

  • .gitlab-ci.yml
    1 1
     variables:
    
    2 2
       download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2023/08"
    
    3
    -  version: "2023-08-x86"
    
    4
    -  bootstrap: "-B boot-2023-08"
    
    3
    +  version: "xoroshiro-assembly-x86"
    
    4
    +  bootstrap: ""
    
    5 5
     
    
    6 6
     
    
    7 7
     stages:
    
    ... ... @@ -48,7 +48,9 @@ linux:build:
    48 48
         # Regular build using the cross-compiled result or snapshot
    
    49 49
         - bin/build.sh $bootstrap -R -C "x86_linux_clang" -o snapshot/bin/lisp
    
    50 50
         # - bin/build.sh $bootstrap -R -C "x86_linux" -o snapshot/bin/lisp
    
    51
    -    - bin/make-dist.sh -I dist linux-4
    
    51
    +    # Use -V to specify the version in case some tag makes git
    
    52
    +    # describe return something that make-dist.sh doesn't like.
    
    53
    +    - bin/make-dist.sh -V `git describe --dirty` -I dist linux-4
    
    52 54
     
    
    53 55
     linux:test:
    
    54 56
       stage: test
    
    ... ... @@ -131,7 +133,9 @@ osx:build:
    131 133
         # Regular build using the cross-compiled result or snapshot.
    
    132 134
         # Need /opt/local/bin to get msgmerge and msgfmt programs.
    
    133 135
         - PATH=/opt/local/bin:$PATH bin/build.sh $bootstrap -R -C "" -o snapshot/bin/lisp
    
    134
    -    - bin/make-dist.sh -I dist darwin-4
    
    136
    +    # Use -V to specify the version in case some tag makes git
    
    137
    +    # describe return something that make-dist.sh doesn't like.
    
    138
    +    - bin/make-dist.sh -V `git describe --dirty` -I dist darwin-4
    
    135 139
     
    
    136 140
     osx:test:
    
    137 141
       stage: test
    

  • bin/make-dist.sh
    ... ... @@ -98,6 +98,8 @@ def_arch_os
    98 98
     # ("snapshot-yyyy-mm") or a release number..
    
    99 99
     GIT_HASH="`(cd src; git describe --dirty 2>/dev/null)`"
    
    100 100
     
    
    101
    +echo GIT_HASH = ${GIT_HASH}
    
    102
    +
    
    101 103
     if expr "X${GIT_HASH}" : 'Xsnapshot-[0-9][0-9][0-9][0-9]-[01][0-9]' > /dev/null; then
    
    102 104
         DEFAULT_VERSION=`expr "${GIT_HASH}" : "snapshot-\(.*\)"`
    
    103 105
     fi
    

  • src/assembly/assemfile.lisp
    ... ... @@ -209,7 +209,61 @@
    209 209
     				    ,(reg-spec-temp res))))
    
    210 210
     		     results))))))
    
    211 211
     
    
    212
    +;;; Define-Assembly-Routine -- Public
    
    213
    +;;;
    
    214
    +;;;   Parse the code to produce an assembly routine and create a VOP
    
    215
    +;;;   that calls the assembly routine.
    
    212 216
     (defmacro define-assembly-routine (name&options vars &rest code)
    
    217
    +  "Define-Assembly-Routine (Name&Options Vars Code*)
    
    218
    +  Define a Lisp assembly routine, and a VOP to that calls the assembly
    
    219
    +  routine, if enabled.  (A VOP is not created if the reader
    
    220
    +  conditional #+assembler precedes the definition of the assembly
    
    221
    +  routine.)
    
    222
    +
    
    223
    +  Name&Options
    
    224
    +    A list giving the name of the assembly routine and options
    
    225
    +    describing the assembly routine options and VOP options.  The
    
    226
    +    format is (Name ({Key Value})*) where Name is the name of the
    
    227
    +    assembly routine.  Options is a list of options:
    
    228
    +
    
    229
    +    Options
    
    230
    +
    
    231
    +      :Cost Cost
    
    232
    +        The cost of the VOP.  This is used in the generated VOP.
    
    233
    +
    
    234
    +      :Policy {:Small | :Fast | :Safe | :Fast-Safe}
    
    235
    +        The policy for the VOP.
    
    236
    +
    
    237
    +      :Translate Name
    
    238
    +        The translation for the VOP.
    
    239
    +
    
    240
    +      :Arg-Types arg-types
    
    241
    +      :Result-Types result-types
    
    242
    +        The template restrictions for the arguments of the VOP and the
    
    243
    +        results of the VOP.
    
    244
    +
    
    245
    +      :Return-Style {:Raw :Full-Call :None}
    
    246
    + 
    
    247
    +    Vars is a list of the arguments and returned results and
    
    248
    +    temporaries used by the assembly routine.
    
    249
    +
    
    250
    +      :Arg Arg-Name (SC*) SC-Offset
    
    251
    +        Input argument for the assembly routine with the name
    
    252
    +        Arg-Name.  The argument must be one of the SC types.  The register
    
    253
    +        assigned to this argument is given by SC-Offset which must be
    
    254
    +        the offset for the register holding this argument.
    
    255
    +
    
    256
    +      :Res Res-Name SC SC-Offset
    
    257
    +        Result of the assembly routine with the name Res-Name.  The
    
    258
    +        result must be a register of the specified storage class SC.  The
    
    259
    +        Sc-offset is the register used for the result.
    
    260
    +
    
    261
    +      :Temp Temp-Name SC SC-Offset
    
    262
    +        Like :Res, except this names a temporary register that the
    
    263
    +        assembly routine can use.
    
    264
    +
    
    265
    +  Code
    
    266
    +    The code for the assembly routine."
    
    213 267
       (multiple-value-bind (name options)
    
    214 268
     		       (if (atom name&options)
    
    215 269
     			   (values name&options nil)
    

  • src/assembly/x86/arith.lisp
    ... ... @@ -411,3 +411,121 @@
    411 411
       (inst pop y)
    
    412 412
       (inst pop k)
    
    413 413
       (inst ret))
    
    414
    +
    
    415
    +;;; Support for the xoroshiro128** generator.  See
    
    416
    +;;; https://prng.di.unimi.it/xoroshiro128starstar.c for the official
    
    417
    +;;; code.
    
    418
    +;;;
    
    419
    +;;; This is what we're implementing, where s[] is our state vector.
    
    420
    +;;;
    
    421
    +;;; static uint64_t s[2];
    
    422
    +;;; static inline uint64_t rotl(const uint64_t x, int k) {
    
    423
    +;;;   return (x << k) | (x >> (64 - k));
    
    424
    +;;; }
    
    425
    +;;;
    
    426
    +;;; uint64_t next(void) {
    
    427
    +;;;   const uint64_t s0 = s[0];
    
    428
    +;;; 	 uint64_t s1 = s[1];
    
    429
    +;;; 	 const uint64_t result = rotl(s0 * 5, 7) * 9;
    
    430
    +;;; 
    
    431
    +;;; 	 s1 ^= s0;
    
    432
    +;;; 	 s[0] = rotl(s0, 24) ^ s1 ^ (s1 << 16); // a, b
    
    433
    +;;; 	 s[1] = rotl(s1, 37); // c
    
    434
    +;;; 
    
    435
    +;;; 	 return result;
    
    436
    +;;; }
    
    437
    +;;;
    
    438
    +;;; A VOP is also generated to call this assembly routine.  This
    
    439
    +;;; routine computes a new 64-bit random number and also updates the
    
    440
    +;;; state, which is (simple-array (double-float) (2)).
    
    441
    +#+random-xoroshiro
    
    442
    +(define-assembly-routine
    
    443
    +  (xoroshiro-update
    
    444
    +   (:translate kernel::random-xoroshiro-update)
    
    445
    +   (:return-style :raw)
    
    446
    +   (:cost 30)
    
    447
    +   (:policy :fast-safe)
    
    448
    +   (:arg-types simple-array-double-float)
    
    449
    +   (:result-types unsigned-num unsigned-num))
    
    450
    +  ((:arg state descriptor-reg edx-offset)
    
    451
    +   (:res r1 unsigned-reg ecx-offset)
    
    452
    +   (:res r0 unsigned-reg ebx-offset)
    
    453
    +   (:temp s0 double-reg xmm0-offset)
    
    454
    +   (:temp s1 double-reg xmm1-offset)
    
    455
    +   (:temp t0 double-reg xmm2-offset)
    
    456
    +   (:temp t1 double-reg xmm3-offset))
    
    457
    +
    
    458
    +  ;; s0 = state[0]
    
    459
    +  (inst movsd s0 (make-ea :dword :base state
    
    460
    +                                 :disp (- (+ (* vm:vector-data-offset
    
    461
    +					        vm:word-bytes)
    
    462
    +				             (* 8 0))
    
    463
    +				          vm:other-pointer-type)))
    
    464
    +  ;; t0 = s0 * 5 = s0 << 2 + s0
    
    465
    +  (inst movapd t0 s0)                   ; t0 = s0
    
    466
    +  (inst psllq t0 2)                     ; t0 = t0 << 2 = 4*t0
    
    467
    +  (inst paddq t0 s0)                    ; t0 = t0 + s0 = 5*t0
    
    468
    +
    
    469
    +  ;; t0 = rotl(t0, 7) = t0 << 7 | t0 >> (64-7)
    
    470
    +  ;;    = rotl(s0*5, 7)
    
    471
    +  (inst movapd t1 t0)          ; t1 = t0
    
    472
    +  (inst psllq t1 7)            ; t1 = t0 << 7
    
    473
    +  (inst psrlq t0 (- 64 7))     ; t0 = t0 >> 57
    
    474
    +  (inst orpd t0 t1)            ; t0 = t0 << 7 | t0 >> 57 = rotl(t0, 7)
    
    475
    +
    
    476
    +  ;; t0 = t0 * 9 = t0 << 3 + t0
    
    477
    +  ;;    = rotl(s0*5, 7) * 9
    
    478
    +  (inst movapd t1 t0)                   ; t1 = t0
    
    479
    +  (inst psllq t1 3)                     ; t1 = t0 << 3
    
    480
    +  (inst paddq t0 t1)                    ; t0 = t0 << 3 + t0 = 9*t0
    
    481
    +
    
    482
    +  ;; Save the result as two 32-bit results.  r1 is the high 32 bits
    
    483
    +  ;; and r0 is the low 32.
    
    484
    +  (inst movd r0 t0)
    
    485
    +  (inst psrlq t0 32)
    
    486
    +  (inst movd r1 t0)
    
    487
    +
    
    488
    +  ;; s1 = state[1]
    
    489
    +  (inst movsd s1 (make-ea :dword :base state
    
    490
    +			         :disp (- (+ (* vm:vector-data-offset
    
    491
    +					        vm:word-bytes)
    
    492
    +				             (* 8 1))
    
    493
    +				          vm:other-pointer-type)))
    
    494
    +  (inst xorpd s1 s0)                    ; s1 = s1 ^ s0
    
    495
    +
    
    496
    +  ;; s0 can now be reused as a temp.
    
    497
    +  ;; s0 = rotl(s0, 24)
    
    498
    +  (inst movapd t0 s0)                   ; t0 = s0
    
    499
    +  (inst psllq t0 24)                    ; t0 = s0 << 24
    
    500
    +  (inst psrlq s0 (- 64 24))             ; s0 = s0 >> 40
    
    501
    +  (inst orpd s0 t0)                     ; s0 = s0 | t0 = rotl(s0, 24)
    
    502
    +
    
    503
    +  ;; s0 = s0 ^ s1 = rotl(s0, 24) ^ s1
    
    504
    +  (inst xorpd s0 s1)
    
    505
    +
    
    506
    +  ;; s0 = s0 ^ (s1 << 16)
    
    507
    +  (inst movapd t0 s1)            ; t0 = s1
    
    508
    +  (inst psllq t0 16)             ; t0 = s1 << 16
    
    509
    +  (inst xorpd s0 t0)             ; s0 = rotl(s0, 24) ^ s1 ^ (s1 << 16)
    
    510
    +
    
    511
    +  ;; Save s0 to state[0]
    
    512
    +  (inst movsd (make-ea :dword :base state
    
    513
    +			      :disp (- (+ (* vm:vector-data-offset
    
    514
    +					     vm:word-bytes)
    
    515
    +				          (* 8 0))
    
    516
    +				       vm:other-pointer-type))
    
    517
    +        s0)
    
    518
    +
    
    519
    +  ;; s1 = rotl(s1, 37)
    
    520
    +  (inst movapd t0 s1)                   ; t0 = s1
    
    521
    +  (inst psllq t0 37)                    ; t0 = s1 << 37
    
    522
    +  (inst psrlq s1 (- 64 37))             ; s1 = s1 >> 27
    
    523
    +  (inst orpd s1 t0)                     ; s1 = t0 | s1 = rotl(s1, 37)
    
    524
    +
    
    525
    +  ;; Save s1 to state[1]
    
    526
    +  (inst movsd (make-ea :dword :base state
    
    527
    +			      :disp (- (+ (* vm:vector-data-offset
    
    528
    +					     vm:word-bytes)
    
    529
    +				          (* 8 1))
    
    530
    +				       vm:other-pointer-type))
    
    531
    +        s1))

  • src/assembly/x86/support.lisp
    ... ... @@ -39,7 +39,7 @@
    39 39
     (def-vm-support-routine generate-return-sequence (style)
    
    40 40
       (ecase style
    
    41 41
         (:raw
    
    42
    -     `(inst ret))
    
    42
    +     `((inst ret)))
    
    43 43
         (:full-call
    
    44 44
          `(
    
    45 45
            (inst pop eax-tn)
    

  • src/bootfiles/21e/boot-2023-08.lisp
    ... ... @@ -2,3 +2,46 @@
    2 2
     ;; *SOFTWARE-VERSION* from the LISP package to the SYSTEM package.
    
    3 3
     (ext:without-package-locks
    
    4 4
         (unintern 'lisp::*software-version* "LISP"))
    
    5
    +
    
    6
    +#+(or random-mt19937 random-xoroshiro)
    
    7
    +(in-package "C")
    
    8
    +#+(or random-mt19937 random-xoroshiro)
    
    9
    +(deftransform random ((num &optional state)
    
    10
    +		      ((integer 1 #.(expt 2 32)) &optional *))
    
    11
    +  _N"use inline (unsigned-byte 32) operations"
    
    12
    +  (let* ((num-type (continuation-type num))
    
    13
    +	 (num-high (cond ((numeric-type-p num-type)
    
    14
    +			  (numeric-type-high num-type))
    
    15
    +			 ((union-type-p num-type)
    
    16
    +			  ;; Find the maximum of the union type.  We
    
    17
    +			  ;; know this works because if we're in this
    
    18
    +			  ;; routine, NUM must be a subtype of
    
    19
    +			  ;; (INTEGER 1 2^32), so each member of the
    
    20
    +			  ;; union must be a subtype too.
    
    21
    +			  (reduce #'max (union-type-types num-type)
    
    22
    +				  :key #'numeric-type-high))
    
    23
    +			 (t
    
    24
    +			  (give-up)))))
    
    25
    +    ;; Rather than doing (rem (random-chunk) num-high), we do,
    
    26
    +    ;; essentially, (rem (* num-high (random-chunk)) #x100000000).  I
    
    27
    +    ;; (rtoy) believe this approach doesn't have the bias issue with
    
    28
    +    ;; doing rem.  This method works by treating (random-chunk) as if
    
    29
    +    ;; it were a 32-bit fraction between 0 and 1, exclusive.  Multiply
    
    30
    +    ;; this by num-high to get a random number between 0 and num-high,
    
    31
    +    ;; This should have no bias.
    
    32
    +    (cond ((constant-continuation-p num)
    
    33
    +	   (if (= num-high (expt 2 32))
    
    34
    +	       '(random-chunk (or state *random-state*))
    
    35
    +	       '(values (bignum::%multiply 
    
    36
    +			 (random-chunk (or state *random-state*))
    
    37
    +			 num))))
    
    38
    +	  ((< num-high (expt 2 32))
    
    39
    +	   '(values (bignum::%multiply (random-chunk (or state *random-state*))
    
    40
    +		     num)))
    
    41
    +	  ((= num-high (expt 2 32))
    
    42
    +	   '(if (= num (expt 2 32))
    
    43
    +		(random-chunk (or state *random-state*))
    
    44
    +		(values (bignum::%multiply (random-chunk (or state *random-state*))
    
    45
    +					   num))))
    
    46
    +	  (t
    
    47
    +	   (error (intl:gettext "Shouldn't happen"))))))

  • src/code/exports.lisp
    ... ... @@ -1591,7 +1591,8 @@
    1591 1591
     	   "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
    
    1592 1592
     	   "FLOAT-SIGNALING-NAN-P"
    
    1593 1593
     	   "WITH-FLOAT-TRAPS-MASKED"
    
    1594
    -	   "WITH-FLOAT-TRAPS-ENABLED")
    
    1594
    +	   "WITH-FLOAT-TRAPS-ENABLED"
    
    1595
    +           "WITH-FLOAT-ROUNDING-MODE")
    
    1595 1596
       ;; More float extensions
    
    1596 1597
       #+double-double
    
    1597 1598
       (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT"
    

  • src/code/float-trap.lisp
    ... ... @@ -27,7 +27,8 @@
    27 27
     	  decode-floating-point-modes
    
    28 28
     	  encode-floating-point-modes
    
    29 29
     	  with-float-traps-masked
    
    30
    -	  with-float-traps-enabled))
    
    30
    +	  with-float-traps-enabled
    
    31
    +          with-float-rounding-mode))
    
    31 32
     (in-package "VM")
    
    32 33
     
    
    33 34
     (eval-when (compile load eval)
    
    ... ... @@ -495,3 +496,34 @@
    495 496
       accrued exceptions are cleared at the start of the body to support
    
    496 497
       their testing within, and restored on exit."))
    
    497 498
     
    
    499
    +(defmacro with-float-rounding-mode ((rounding-mode) &body body)
    
    500
    +  _N"Execute BODY with the floating-point rounding mode set to
    
    501
    +  ROUNDING-MODE.  ROUNDING-MODE must be a one:
    
    502
    +
    
    503
    +   :NEAREST
    
    504
    +       the default mode of round to nearest even.
    
    505
    +   :ZERO
    
    506
    +       round numbers down towards zero.  Positive numbers round down
    
    507
    +       and negative numbers round up.
    
    508
    +   :POSITIVE-INFINITY
    
    509
    +       round numbers up towards positive infinity.
    
    510
    +   :NEGATIVE-INFINITY
    
    511
    +       round numbers down towards negative infinity.
    
    512
    +
    
    513
    +  These are the same as the possible values for the rounding mode in
    
    514
    +  SET-FLOATING-POINT-MODES.
    
    515
    +
    
    516
    +  Only the rounding mode is restored on exit; other floating-point
    
    517
    +  modes are not modified."
    
    518
    +  (let ((old-mode (gensym "OLD-MODE-"))
    
    519
    +        (new-mode (gensym "NEW-MODE-")))
    
    520
    +  `(let ((,old-mode (ldb float-rounding-mode (floating-point-modes)))
    
    521
    +         (,new-mode (cdr (assoc ,rounding-mode rounding-mode-alist))))
    
    522
    +     (unwind-protect
    
    523
    +          (progn
    
    524
    +            (setf (floating-point-modes)
    
    525
    +                  (dpb ,new-mode float-rounding-mode (floating-point-modes)))
    
    526
    +            ,@body)
    
    527
    +       ;; Restore just the rounding mode to the original value.
    
    528
    +       (setf (floating-point-modes)
    
    529
    +             (dpb ,old-mode float-rounding-mode (floating-point-modes)))))))

  • src/code/pprint.lisp
    ... ... @@ -2088,6 +2088,7 @@ When annotations are present, invoke them at the right positions."
    2088 2088
         (c:define-vop pprint-define-vop)
    
    2089 2089
         (c:sc-case pprint-sc-case)
    
    2090 2090
         (c:define-assembly-routine pprint-define-assembly)
    
    2091
    +    (new-assem:assemble pprint-multiple-value-bind)
    
    2091 2092
         (c:deftransform pprint-defun)
    
    2092 2093
         (c:defoptimizer pprint-defun)
    
    2093 2094
         (ext:with-float-traps-masked pprint-with-like)
    

  • src/code/rand-xoroshiro.lisp
    ... ... @@ -238,7 +238,7 @@
    238 238
       being the first value."
    
    239 239
       (declare (type (simple-array double-float (2)) state)
    
    240 240
     	   (optimize (speed 3) (safety 0)))
    
    241
    -  (vm::xoroshiro-next state))
    
    241
    +  (kernel::random-xoroshiro-update state))
    
    242 242
     
    
    243 243
     #-x86
    
    244 244
     (defun xoroshiro-gen (state)
    
    ... ... @@ -490,11 +490,8 @@
    490 490
       (declare (inline %random-single-float %random-double-float))
    
    491 491
       (cond
    
    492 492
         ((typep arg '(integer 1 #x100000000))
    
    493
    -     ;; Do the same thing as the deftransform would do.
    
    494
    -     (if (= arg (expt 2 32))
    
    495
    -	 (random-chunk state)
    
    496
    -	 (values (bignum::%multiply (random-chunk state)
    
    497
    -				    arg))))
    
    493
    +     ;; Let the compiler deftransform take care of this case.
    
    494
    +     (random arg state))
    
    498 495
         ((and (typep arg 'single-float) (> arg 0.0F0))
    
    499 496
          (%random-single-float arg state))
    
    500 497
         ((and (typep arg 'double-float) (> arg 0.0D0))
    

  • src/code/reader.lisp
    ... ... @@ -1869,15 +1869,16 @@ the end of the stream."
    1869 1869
     
    
    1870 1870
       ;; Otherwise the number might fit, so we carefully compute the result.
    
    1871 1871
       (handler-case
    
    1872
    -      (let* ((ratio (/ (* (expt 10 exponent) number)
    
    1873
    -                       divisor))
    
    1874
    -	     (result (coerce ratio float-format)))
    
    1875
    -	(when (and (zerop result) (not (zerop number)))
    
    1876
    -	  ;; The number we've read is so small that it gets
    
    1877
    -	  ;; converted to 0.0, but is not actually zero.  Signal an
    
    1878
    -	  ;; error.  See CLHS 2.3.1.1.
    
    1879
    -          (error _"Underflow"))
    
    1880
    -        result)
    
    1872
    +      (with-float-traps-masked (:underflow)
    
    1873
    +        (let* ((ratio (/ (* (expt 10 exponent) number)
    
    1874
    +                         divisor))
    
    1875
    +	       (result (coerce ratio float-format)))
    
    1876
    +	  (when (and (zerop result) (not (zerop number)))
    
    1877
    +	    ;; The number we've read is so small that it gets
    
    1878
    +	    ;; converted to 0.0, but is not actually zero.  Signal an
    
    1879
    +	    ;; error.  See CLHS 2.3.1.1.
    
    1880
    +            (error 'floating-point-underflow))
    
    1881
    +          result))
    
    1881 1882
         (floating-point-underflow ()
    
    1882 1883
           ;; Resignal a reader error, but allow the user to continue with
    
    1883 1884
           ;; 0.
    

  • src/compiler/x86/arith.lisp
    ... ... @@ -1695,118 +1695,9 @@
    1695 1695
     
    
    1696 1696
     (in-package "VM")
    
    1697 1697
     
    
    1698
    +;; The update routine is a Lisp assembly routine with a corresponding
    
    1699
    +;; VOP.  This lets the compiler know about the VOP so we can use it.
    
    1698 1700
     #+random-xoroshiro
    
    1699
    -(progn
    
    1700
    -(defknown xoroshiro-next ((simple-array double-float (2)))
    
    1701
    +(defknown kernel::random-xoroshiro-update ((simple-array double-float (2)))
    
    1701 1702
       (values (unsigned-byte 32) (unsigned-byte 32))
    
    1702 1703
       (movable))
    1703
    -
    
    1704
    -(define-vop (xoroshiro-next)
    
    1705
    -  (:policy :fast-safe)
    
    1706
    -  (:translate xoroshiro-next)
    
    1707
    -  (:args (state :scs (descriptor-reg) :to (:result 3)))
    
    1708
    -  (:arg-types simple-array-double-float)
    
    1709
    -  (:results (r1 :scs (unsigned-reg))
    
    1710
    -	    (r0 :scs (unsigned-reg)))
    
    1711
    -  (:result-types unsigned-num unsigned-num)
    
    1712
    -  (:temporary (:sc double-reg) s0)
    
    1713
    -  (:temporary (:sc double-reg) s1)
    
    1714
    -  (:temporary (:sc double-reg) t0)
    
    1715
    -  (:temporary (:sc double-reg) t1)
    
    1716
    -  (:generator 10
    
    1717
    -    ;; See https://prng.di.unimi.it/xoroshiro128starstar.c for the official code.
    
    1718
    -    ;;
    
    1719
    -    ;; This is what we're implementing, where s[] is our state vector.
    
    1720
    -    ;;
    
    1721
    -    ;; static uint64_t s[2];
    
    1722
    -    ;; static inline uint64_t rotl(const uint64_t x, int k) {
    
    1723
    -    ;;   return (x << k) | (x >> (64 - k));
    
    1724
    -    ;; }
    
    1725
    -    ;;
    
    1726
    -    ;; uint64_t next(void) {
    
    1727
    -    ;;   const uint64_t s0 = s[0];
    
    1728
    -    ;; 	 uint64_t s1 = s[1];
    
    1729
    -    ;; 	 const uint64_t result = rotl(s0 * 5, 7) * 9;
    
    1730
    -    ;; 
    
    1731
    -    ;; 	 s1 ^= s0;
    
    1732
    -    ;; 	 s[0] = rotl(s0, 24) ^ s1 ^ (s1 << 16); // a, b
    
    1733
    -    ;; 	 s[1] = rotl(s1, 37); // c
    
    1734
    -    ;; 
    
    1735
    -    ;; 	 return result;
    
    1736
    -    ;; }
    
    1737
    -
    
    1738
    -    ;; s0 = state[0]
    
    1739
    -    (inst movsd s0 (make-ea :dword :base state
    
    1740
    -                            :disp (- (+ (* vm:vector-data-offset
    
    1741
    -					   vm:word-bytes)
    
    1742
    -				        (* 8 0))
    
    1743
    -				     vm:other-pointer-type)))
    
    1744
    -    ;; t0 = s0 * 5 = s0 << 2 + s0
    
    1745
    -    (inst movapd t0 s0)                 ; t0 = s0
    
    1746
    -    (inst psllq t0 2)                   ; t0 = t0 << 2 = 4*t0
    
    1747
    -    (inst paddq t0 s0)                  ; t0 = t0 + s0 = 5*t0
    
    1748
    -
    
    1749
    -    ;; t0 = rotl(t0, 7) = t0 << 7 | t0 >> (64-7)
    
    1750
    -    ;;    = rotl(s0*5, 7)
    
    1751
    -    (inst movapd t1 t0)        ; t1 = t0
    
    1752
    -    (inst psllq t1 7)          ; t1 = t0 << 7
    
    1753
    -    (inst psrlq t0 (- 64 7))   ; t0 = t0 >> 57
    
    1754
    -    (inst orpd t0 t1)          ; t0 = t0 << 7 | t0 >> 57 = rotl(t0, 7)
    
    1755
    -
    
    1756
    -    ;; t0 = t0 * 9 = t0 << 3 + t0
    
    1757
    -    ;;    = rotl(s0*5, 7) * 9
    
    1758
    -    (inst movapd t1 t0)                 ; t1 = t0
    
    1759
    -    (inst psllq t1 3)                   ; t1 = t0 << 3
    
    1760
    -    (inst paddq t0 t1)                  ; t0 = t0 << 3 + t0 = 9*t0
    
    1761
    -
    
    1762
    -    ;; Save the result as two 32-bit results.  r1 is the high 32 bits
    
    1763
    -    ;; and r0 is the low 32.
    
    1764
    -    (inst movd r0 t0)
    
    1765
    -    (inst psrlq t0 32)
    
    1766
    -    (inst movd r1 t0)
    
    1767
    -
    
    1768
    -    ;; s1 = state[1]
    
    1769
    -    (inst movsd s1 (make-ea :dword :base state
    
    1770
    -			    :disp (- (+ (* vm:vector-data-offset
    
    1771
    -					   vm:word-bytes)
    
    1772
    -				        (* 8 1))
    
    1773
    -				     vm:other-pointer-type)))
    
    1774
    -    (inst xorpd s1 s0)                  ; s1 = s1 ^ s0
    
    1775
    -
    
    1776
    -    ;; s0 can now be reused as a temp.
    
    1777
    -    ;; s0 = rotl(s0, 24)
    
    1778
    -    (inst movapd t0 s0)                 ; t0 = s0
    
    1779
    -    (inst psllq t0 24)                  ; t0 = s0 << 24
    
    1780
    -    (inst psrlq s0 (- 64 24))           ; s0 = s0 >> 40
    
    1781
    -    (inst orpd s0 t0)                   ; s0 = s0 | t0 = rotl(s0, 24)
    
    1782
    -
    
    1783
    -    ;; s0 = s0 ^ s1 = rotl(s0, 24) ^ s1
    
    1784
    -    (inst xorpd s0 s1)
    
    1785
    -
    
    1786
    -    ;; s0 = s0 ^ (s1 << 16)
    
    1787
    -    (inst movapd t0 s1)          ; t0 = s1
    
    1788
    -    (inst psllq t0 16)           ; t0 = s1 << 16
    
    1789
    -    (inst xorpd s0 t0)           ; s0 = rotl(s0, 24) ^ s1 ^ (s1 << 16)
    
    1790
    -
    
    1791
    -    ;; Save s0 to state[0]
    
    1792
    -    (inst movsd (make-ea :dword :base state
    
    1793
    -			 :disp (- (+ (* vm:vector-data-offset
    
    1794
    -					vm:word-bytes)
    
    1795
    -				     (* 8 0))
    
    1796
    -				  vm:other-pointer-type))
    
    1797
    -          s0)
    
    1798
    -
    
    1799
    -    ;; s1 = rotl(s1, 37)
    
    1800
    -    (inst movapd t0 s1)                 ; t0 = s1
    
    1801
    -    (inst psllq t0 37)                  ; t0 = s1 << 37
    
    1802
    -    (inst psrlq s1 (- 64 37))           ; s1 = s1 >> 27
    
    1803
    -    (inst orpd s1 t0)                   ; s1 = t0 | s1 = rotl(s1, 37)
    
    1804
    -
    
    1805
    -    ;; Save s1 to state[1]
    
    1806
    -    (inst movsd (make-ea :dword :base state
    
    1807
    -			 :disp (- (+ (* vm:vector-data-offset
    
    1808
    -					vm:word-bytes)
    
    1809
    -				     (* 8 1))
    
    1810
    -				  vm:other-pointer-type))
    
    1811
    -          s1)))
    
    1812
    -)

  • src/general-info/release-21f.md
    ... ... @@ -51,8 +51,8 @@ public domain.
    51 51
         * ~~#261~~ Remove `get-system-info` from "bsd-os.lisp"
    
    52 52
         * ~~#268~~ Can't clone ansi-test repo on Mac OS CI box
    
    53 53
         * ~~#265~~ CI for mac os is broken
    
    54
    -    * ~~#269~~ Add function to get user's home directory
    
    55 54
         * ~~#266~~ Support "~user" in namestrings
    
    55
    +    * ~~#269~~ Add function to get user's home directory
    
    56 56
         * ~~#271~~ Update ASDF to 3.3.7
    
    57 57
         * ~~#272~~ Move scavenge code for static vectors to its own function
    
    58 58
         * ~~#274~~ 1d99999999 hangs
    
    ... ... @@ -65,6 +65,7 @@ public domain.
    65 65
         * ~~#288~~ Re-enable `deftransform` for random integers.
    
    66 66
         * ~~#290~~ Pprint `with-float-traps-masked` better
    
    67 67
         * ~~#291~~ Pprint `handler-case` neatly.
    
    68
    +    * ~~#297~~ Pprint `new-assem:assemble` with less indentation.
    
    68 69
       * Other changes:
    
    69 70
       * Improvements to the PCL implementation of CLOS:
    
    70 71
       * Changes to building procedure:
    

  • src/i18n/locale/cmucl.pot
    ... ... @@ -4868,6 +4868,28 @@ msgid ""
    4868 4868
     "  their testing within, and restored on exit."
    
    4869 4869
     msgstr ""
    
    4870 4870
     
    
    4871
    +#: src/code/float-trap.lisp
    
    4872
    +msgid ""
    
    4873
    +"Execute BODY with the floating-point rounding mode set to\n"
    
    4874
    +"  ROUNDING-MODE.  ROUNDING-MODE must be a one:\n"
    
    4875
    +"\n"
    
    4876
    +"   :NEAREST\n"
    
    4877
    +"       the default mode of round to nearest even.\n"
    
    4878
    +"   :ZERO\n"
    
    4879
    +"       round numbers down towards zero.  Positive numbers round down\n"
    
    4880
    +"       and negative numbers round up.\n"
    
    4881
    +"   :POSITIVE-INFINITY\n"
    
    4882
    +"       round numbers up towards positive infinity.\n"
    
    4883
    +"   :NEGATIVE-INFINITY\n"
    
    4884
    +"       round numbers down towards negative infinity.\n"
    
    4885
    +"\n"
    
    4886
    +"  These are the same as the possible values for the rounding mode in\n"
    
    4887
    +"  SET-FLOATING-POINT-MODES.\n"
    
    4888
    +"\n"
    
    4889
    +"  Only the rounding mode is restored on exit; other floating-point\n"
    
    4890
    +"  modes are not modified."
    
    4891
    +msgstr ""
    
    4892
    +
    
    4871 4893
     #: src/code/float.lisp
    
    4872 4894
     msgid "Return true if the float X is denormalized."
    
    4873 4895
     msgstr ""
    
    ... ... @@ -8731,10 +8753,6 @@ msgstr ""
    8731 8753
     msgid "Number not representable as a ~S: ~S"
    
    8732 8754
     msgstr ""
    
    8733 8755
     
    
    8734
    -#: src/code/reader.lisp
    
    8735
    -msgid "Underflow"
    
    8736
    -msgstr ""
    
    8737
    -
    
    8738 8756
     #: src/code/reader.lisp
    
    8739 8757
     msgid "Floating point underflow when reading ~S: ~S"
    
    8740 8758
     msgstr ""
    

  • tests/float.lisp
    ... ... @@ -213,35 +213,37 @@
    213 213
       (assert-error 'reader-error (read-from-string "1.8d308"))
    
    214 214
       (assert-error 'reader-error (read-from-string "1d999999999")))
    
    215 215
     
    
    216
    -(define-test reader.float-underflow
    
    216
    +(defun rounding-test (x)
    
    217
    +  (declare (double-float x)
    
    218
    +           (optimize (speed 3)))
    
    219
    +  (* x (/ 1d0 x)))
    
    220
    +
    
    221
    +(define-test rounding-mode.nearest
    
    217 222
         (:tag :issues)
    
    218
    -  (lisp::with-float-traps-enabled (:underflow)
    
    219
    -    ;; A denormal
    
    220
    -    (assert-error 'reader-error
    
    221
    -                  (read-from-string "1e-40"))
    
    222
    -    (assert-error 'reader-error
    
    223
    -                  (read-from-string (format nil "~A" least-positive-single-float)))
    
    224
    -    ;; The same for double-floats
    
    225
    -    (assert-error 'reader-error
    
    226
    -                  (read-from-string "1d-308"))
    
    227
    -    (assert-error 'reader-error
    
    228
    -                  (read-from-string (format nil "~A" least-positive-double-float)))))
    
    229
    -
    
    230
    -(define-test reader.float-underflow
    
    223
    +  (ext:with-float-rounding-mode (:nearest)
    
    224
    +    (assert-equal 1d0 (rounding-test 3d0))))
    
    225
    +
    
    226
    +(define-test rounding-mode.zero.1
    
    231 227
         (:tag :issues)
    
    232
    -  (lisp::with-float-traps-enabled (:underflow)
    
    233
    -    ;; The expected string comes from make-float-aux.
    
    234
    -    (let ((expected "Floating point underflow when reading ~S: ~S"))
    
    235
    -      (flet ((test-reader-underflow (string)
    
    236
    -               ;; Test that the we got a reader-error when a number
    
    237
    -               ;; would underflow and that the message says we got an
    
    238
    -               ;; underflow.
    
    239
    -               (let ((condition (nth-value 1 (ignore-errors (read-from-string string)))))
    
    240
    -                 (assert-equal 'reader-error (type-of condition))
    
    241
    -                 (assert-equal expected (lisp::reader-error-format-control condition)))))
    
    242
    -        ;; Underflow single-floats
    
    243
    -        (test-reader-underflow "1e-40")
    
    244
    -        (test-reader-underflow (format nil "~A" least-positive-single-float))
    
    245
    -        ;; Underflow double-floats
    
    246
    -        (test-reader-underflow "1d-308")
    
    247
    -        (test-reader-underflow (format nil "~A" least-positive-double-float))))))
    228
    +  (ext:with-float-rounding-mode (:zero)
    
    229
    +    (assert-equal 0.9999999999999999d0
    
    230
    +                  (rounding-test 3d0))))
    
    231
    +
    
    232
    +(define-test rounding-mode.zero.2
    
    233
    +    (:tag :issues)
    
    234
    +  (ext:with-float-rounding-mode (:zero)
    
    235
    +    (assert-equal 0.9999999999999999d0
    
    236
    +                  (rounding-test -3d0))))
    
    237
    +
    
    238
    +(define-test rounding-mode.positive-infinity
    
    239
    +    (:tag :issues)
    
    240
    +  (ext:with-float-rounding-mode (:positive-infinity)
    
    241
    +    (assert-equal 1.0000000000000002d0
    
    242
    +                  (rounding-test 3d0))))
    
    243
    +
    
    244
    +(define-test rounding-mode.negative-infinity
    
    245
    +    (:tag :issues)
    
    246
    +  (ext:with-float-rounding-mode (:negative-infinity)
    
    247
    +    (assert-equal 0.9999999999999999d0
    
    248
    +                  (rounding-test 3d0))))
    
    249
    +

  • tests/pprint.lisp
    ... ... @@ -121,3 +121,17 @@
    121 121
                    (:no-error ()
    
    122 122
                     (format nil "Nothing bad happened.")))
    
    123 123
                  s))))
    
    124
    +
    
    125
    +(define-test pprint.assemble
    
    126
    +    (:tag :issues)
    
    127
    +  (assert-equal
    
    128
    +   "
    
    129
    +(NEW-ASSEM:ASSEMBLE (C:*CODE-SEGMENT* 'X86::XOROSHIRO-UPDATE)
    
    130
    +    X86::XOROSHIRO-UPDATE
    
    131
    +  (PUSH (CONS 'X86::XOROSHIRO-UPDATE X86::XOROSHIRO-UPDATE)
    
    132
    +        C::*ASSEMBLER-ROUTINES*))"
    
    133
    +   (with-output-to-string (s)
    
    134
    +     (pprint '(new-assem:assemble (c::*code-segment* 'vm::xoroshiro-update)
    
    135
    +               vm::xoroshiro-update
    
    136
    +               (push (cons 'vm::xoroshiro-update vm::xoroshiro-update) c::*assembler-routines*))
    
    137
    +             s))))