GitLab

at 2024-03-08T15:31:41+00:00

Fix #278: Add more debugging prints for gencgc

Merge branch 'issue-278-more-gencgc-debug-prints' into 'master'

Fix #278: Add more debugging prints for gencgc

Closes #278

See merge request cmucl/cmucl!193
Fix #277: return least-positive float for rationals close to it

Merge branch 'issue-277-float-ratio-float-least-positive-float' into 'master'

Fix #277: return least-positive float for rationals close to it

Closes #277

See merge request cmucl/cmucl!191
Fix #274: 1d999999 hangs cmucl

Merge branch 'issue-274-make-float-of-huge-numbers' into 'master'

Fix #274: 1d999999 hangs cmucl

Closes #274

See merge request cmucl/cmucl!189
Merge branch 'master' into 'issue-276-xoroshiro128starstar'

# Conflicts:
#   src/general-info/release-21f.md
 			      (floatit (ash bits -1))

 			    #+nil

 			    (progn

-			      (format t "1: f0, f1 = ~A ~A~%" f0 f1)

+                              (format t "x = ~A~%" x)

+			      (format t "1: f0, f1 = ~A~%" f0)

 			      (format t "   scale = ~A~%" (1+ scale)))

 			    (scale-float f0 (1+ scale))))

 			      (floatit bits)

 			    #+nil

 			    (progn

-			      (format t "2: f0, f1 = ~A ~A~%" f0 f1)

+			      (format t "2: f0, f1 = ~A~%" f0)

 			      (format t "   scale = ~A~%" scale)

-			      (format t "scale-float f0 = ~A~%" (scale-float f0 scale))

-			      (when f1

-				(format t "scale-float f1 = ~A~%"

-					(scale-float f1 (- scale 53)))))

-			    

-				(scale-float f0 scale))))))

+			      (format t "scale-float f0 = ~A~%" (scale-float f0 scale)))

+                            (let ((min-exponent

+                                    ;; Compute the min (unbiased) exponent

+                                    (ecase format

+                                      (single-float

+                                       (- vm:single-float-normal-exponent-min

+                                          vm:single-float-bias

+                                          vm:single-float-digits))

+                                      (double-float

+                                       (- vm:double-float-normal-exponent-min

+                                          vm:double-float-bias

+                                          vm:double-float-digits)))))

+                              ;; F0 is always between 0.5 and 1.  If

+                              ;; SCALE is the min exponent, we have a

+                              ;; denormal number just less than the

+                              ;; least-positive float.  We want to

+                              ;; return the least-positive-float so

+                              ;; multiply F0 by 2 (without adjusting

+                              ;; SCALE) to get the nearest float.

+                              (if (= scale min-exponent)

+                                  (scale-float (* 2 f0) scale)

+			          (scale-float f0 scale))))))))

 	       (floatit (bits)

 		 (let ((sign (if plusp 0 1)))

 		   (case format

     ;; Is there an exponent letter?

     (cond ((eofp char)

            ;; If not, we've read the whole number.

-           (let ((num (make-float-aux number divisor

+           (let ((num (make-float-aux 0 number divisor

                                       *read-default-float-format*

 				      stream)))

              (return-from make-float (if negative-fraction (- num) num))))

 				  #+double-double

 				  (#\W 'kernel:double-double-float)))

                   num)

-	     (setq num (make-float-aux (* (expt 10 exponent) number) divisor

+	     (setq num (make-float-aux exponent number divisor

 				       float-format stream))

 	     (return-from make-float (if negative-fraction

                                              num))))

 	  (t (error _"Internal error in floating point reader.")))))

-(defun make-float-aux (number divisor float-format stream)

+(defun make-float-aux (exponent number divisor float-format stream)

+  ;; Computes x = number*10^exponent/divisor.

+  ;;

+  ;; First check to see if x can possibly fit into a float of the

+  ;; given format.  So compute log2(x) to get an approximate value of

+  ;; the base 2 exponent of x.  If it's too large or too small, we can

+  ;; throw an error immediately.  We don't need to be super accurate

+  ;; with the limits.  The rest of the code will handle it correctly,

+  ;; even if we're too small or too large.

+  (unless (zerop number)

+    (flet ((fast-log2 (n)

+             ;;  For an integer, the integer-length is close enough to

+             ;;  the log2 of the number.

+             (integer-length n)))

+      ;; log2(x) = log(number*10^exponent/divisor)

+      ;;         = exponent*log2(10) + log2(number)-log2(divisor)

+      (let ((log2-num (+ (* exponent #.(kernel::log2 10d0))

+                         (fast-log2 number)

+                         (- (fast-log2 divisor)))))

+        (multiple-value-bind (log2-low log2-high)

+            (ecase float-format

+              ((short-float single-float)

+               ;; Single-float exponents range is -149 to 127, but we

+               ;; don't need to be super-accurate since we're

+               ;; multiplying the values by 2.

+               (values (* 2 (- vm:single-float-normal-exponent-min

+                               vm:single-float-bias

+                               vm:single-float-digits))

+                       (* 2 (- vm:single-float-normal-exponent-max

+                               vm:single-float-bias))))

+              ((double-float long-float

+                             #+double-double kernel:double-double-float)

+               (values (* 2 (- vm:double-float-normal-exponent-min

+                               vm:double-float-bias

+                               vm:double-float-digits))

+                       (* 2 (- vm:double-float-normal-exponent-max

+                               vm:double-float-bias)))))

+          ;; Double-float exponent range is -1074 to -1023

+          (unless (< log2-low log2-num log2-high)

+            ;; The number is definitely too large or too small to fit.

+            ;; Signal an error.

+            (%reader-error stream _"Number not representable as a ~S: ~S"

+			   float-format (read-buffer-to-string)))))))

+

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

   (handler-case

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

-	(let* ((ratio (/ number divisor))

+	(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

 	  result))

     (error ()

 	   (%reader-error stream _"Number not representable as a ~S: ~S"

-			  float-format (/ number divisor)))))

+			  float-format (read-buffer-to-string)))))

 (defun make-ratio (stream)

 msgstr ""

 #: src/code/reader.lisp

-msgid "Underflow"

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

 msgstr ""

 #: src/code/reader.lisp

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

+msgid "Underflow"

 msgstr ""

 #: src/code/reader.lisp

 {

     int i;

-#if 0

-    fprintf(stderr, "Starting one full scan of newspace generation %d\n",

-	    generation);

-#endif

+    DPRINTF(gencgc_verbose,

+            (stderr, "Starting one full scan of newspace generation %d\n",

+             generation));

     for (i = 0; i < last_free_page; i++) {

 	if (PAGE_ALLOCATED(i) && !PAGE_UNBOXED(i)

 	    i = last_page;

 	}

     }

-#if 0

-    fprintf(stderr, "Finished one full scan of newspace generation %d\n",

-	    generation);

-#endif

+

+    DPRINTF(gencgc_verbose,

+            (stderr, "Finished one full scan of newspace generation %d\n",

+             generation));

 }

 /* Scan all weak objects and reset weak object lists */

     struct new_area (*previous_new_areas)[] = NULL;

     int previous_new_areas_index;

-#if 0

-    fprintf(stderr, "Start scavenge_newspace_generation %d\n", generation);

-#endif

+    DPRINTF(gencgc_verbose,

+            (stderr, "Start scavenge_newspace_generation %d\n", generation));

 #define SC_NS_GEN_CK 0

 #if SC_NS_GEN_CK

 		    "*** scav.new.gen. %d: write protected page %d written to? dont_move=%d\n",

 		    generation, i, PAGE_DONT_MOVE(i));

 #endif

-#if 0

-    fprintf(stderr, "Finished scavenge_newspace_generation %d\n", generation);

-#endif

+

+    DPRINTF(gencgc_verbose,

+            (stderr, "Finished scavenge_newspace_generation %d\n", generation));

 }

     scavenge_control_stack();

 #endif

+    DPRINTF(gencgc_verbose,

+            (stderr, "Scavenging interrupt handlers ...\n"));

+

     scavenge_interrupt_handlers();

-#ifdef PRINTNOISE

-    printf("Scavenging the binding stack (%d bytes) ...\n",

-	   ((lispobj *) get_binding_stack_pointer() -

-	    binding_stack) * sizeof(lispobj));

-#endif

+    DPRINTF(gencgc_verbose,

+            (stderr, "Done scavenging interrupt handlers\n"));

+

+    DPRINTF(gencgc_verbose,

+            (stderr, "Scavenging the binding stack (%d bytes) ...\n",

+             ((lispobj *) get_binding_stack_pointer() -

+              binding_stack) * sizeof(lispobj)));

+

     /* Scavenge the binding stack. */

     scavenge(binding_stack,

 	     (lispobj *) get_binding_stack_pointer() - binding_stack);

-#ifdef PRINTNOISE

-    printf("Done scavenging the binding stack.\n");

-#endif

+    DPRINTF(gencgc_verbose,

+            (stderr, "Done scavenging the binding stack.\n"));

+

     /*

      * Scavenge the scavenge_hooks in case this refers to a hook added

      * in a prior generation GC. From here on the scavenger_hook will

      * doing here.

      */

-#ifdef PRINTNOISE

-    printf("Scavenging the scavenger hooks ...\n");

-#endif

+    DPRINTF(gencgc_verbose,

+            (stderr, "Scavenging the scavenger hooks ...\n"));

+

     scavenge(&scavenger_hooks, 1);

-#ifdef PRINTNOISE

-    printf("Done scavenging the scavenger hooks.\n");

-#endif

+

+    DPRINTF(gencgc_verbose,

+            (stderr, "Done scavenging the scavenger hooks.\n"));

     static_space_size = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER)

 	- static_space;

-    if (gencgc_verbose > 1)

-	fprintf(stderr, "Scavenge static space: %ld bytes\n",

-		static_space_size * sizeof(lispobj));

+

+    DPRINTF(gencgc_verbose,

+            (stderr, "Scavenge static space: %ld bytes\n",

+             static_space_size * sizeof(lispobj)));

+

     scavenge(static_space, static_space_size);

+    DPRINTF(gencgc_verbose,

+            (stderr, "Done scavenging static space\n"));

+

     /*

      * All generations but the generation being GCed need to be

      * scavenged. The new_space generation needs special handling as

      * objects may be moved in - it is handle separately below.

      */

-    for (i = 0; i < NUM_GENERATIONS; i++)

-	if (i != generation && i != new_space)

+    for (i = 0; i < NUM_GENERATIONS; i++) {

+	if (i != generation && i != new_space) {

+            DPRINTF(gencgc_verbose,

+                    (stderr, "Scavenge generation %lu (gen = %d, new space = %d)\n",

+                     i, generation, new_space));

+

 	    scavenge_generation(i);

+            DPRINTF(gencgc_verbose,

+                    (stderr, "Done scavenging generation %lu\n", i));

+        }

+    }

+

     /*

      * Finally scavenge the new_space generation.  Keep going until no

      * more objects are moved into the new generation.

 #include "lisp.h"

-#define DPRINTF(t,a) { if (t) fprintf a; }

+#if defined(__GNUC__) || defined(__clang__)

+#define UNLIKELY(x) __builtin_expect(!!(x), 0)

+#else

+#define UNLIKELY(x) (x)

+#endif

+

+#define DPRINTF(t,a) { if (UNLIKELY(t)) fprintf a; }

 #ifdef DARWIN

 #include "Darwin-os.h"

     (ext:with-float-traps-masked (:overflow)

       (* 100 most-negative-double-float)))))

-  

-   
+(define-test float-ratio.single

+    (:tag :issues)

+  ;; least-positive-single-float is 1.4012985e-45.  Let's test with

+  ;; some rationals from 7/10*10^-45 to 1.41*10^-45 to make sure they

+  ;; return 0 or least-positive-single-float

+  (let ((expo (expt 10 -45)))

+    ;; Need to make sure underflows are masked.

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

+      ;; 7/10*10^-45 is just under halfway between 0 and least-positive,

+      ;; so the answer is 0.

+      (assert-equal 0f0 (kernel::float-ratio-float (* 7/10 expo) 'single-float))

+

+      ;; These are all more than half way to

+      ;; least-positive-single-float, so they should return that.

+      (assert-equal least-positive-single-float

+                    (kernel::float-ratio-float (* 8/10 expo) 'single-float))

+      (assert-equal least-positive-single-float

+                    (kernel::float-ratio-float (* 1 expo) 'single-float))

+      (assert-equal least-positive-single-float

+                    (kernel::float-ratio-float (* 14/10 expo) 'single-float))

+      (assert-equal least-positive-single-float

+                    (kernel::float-ratio-float (* 2 expo) 'single-float)))))

+

+(define-test float-ratio.double

+    (:tag :issues)

+  ;; least-positive-double-float is 4.9406564584124654d-324.  Let's

+  ;; test with some rationals from about 2*10^-324 to 4.94*10^-324 to make

+  ;; sure they return 0 or least-positive-double-float

+  (let ((expo (expt 10 -324)))

+    ;; Need to make sure underflows are masked.

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

+      ;; 247/100*10^-324 is just under halfway between 0 and least-positive,

+      ;; so the answer is 0.

+      (assert-equal 0d0 (kernel::float-ratio-float (* 247/100 expo) 'double-float))

+

+      ;; These are all more than half way to

+      ;; least-positive-double-float, so they should return that.

+      (assert-equal least-positive-double-float

+                    (kernel::float-ratio-float (* 248/100 expo) 'double-float))

+      (assert-equal least-positive-double-float

+                    (kernel::float-ratio-float (* 4 expo) 'double-float))

+      (assert-equal least-positive-double-float

+                    (kernel::float-ratio-float (* 494/100 expo) 'double-float))

+      (assert-equal least-positive-double-float

+                    (kernel::float-ratio-float (* 988/100 expo) 'double-float)))))

+    

+(define-test reader-error.small-single-floats

+    (:tag :issues)

+  ;; Test a number less than half of least-positive-single-float,

+  ;; something a bit smaller, hen then something really small that

+  ;; used to appear to hang cmucl because it was trying to compute the

+  ;; a rational with a huge number of digits.

+  (dolist (num '("1e-46" "1e-80" "1e-999999999"))

+    (assert-error 'reader-error (read-from-string num)

+                  num)))

+

+(define-test reader-error.small-double-floats

+    (:tag :issues)

+  ;; Like reader-error.small-single-floats but for doubles

+  (dolist (num '("1d-324" "1d-600" "1d-999999999"))

+    (assert-error 'reader-error (read-from-string num)

+                  num)))

+

+(define-test reader-error.big-single-floats

+    (:tag :issues)

+  ;; Signal error for a number just a bit larger than

+  ;; most-positive-single-float.  And a really big single-float.

+  (assert-error 'reader-error (read-from-string "3.5e38"))

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

+

+(define-test reader-error.big-double-floats

+    (:tag :issues)

+  ;; Signal error for a number just a bit larger than

+  ;; most-positive-double-float.  And a really big single-float.

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

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

Raymond Toy pushed to branch issue-276-xoroshiro128starstar at cmucl / cmucl

Commits:

6 changed files:

Changes: