I haven't been able to do a complete test run on 32-bit systems for a
while. If I run `make check', it consistently runs out of memory
trying to compile test-floenv.scm or test-flonum.scm. However, if I
just compile the file in a fresh Scheme, it works fine, so
(a) there's probably some memory leak in the test suite, and
(b) there's probably some excessive compiler data structures.
I tried the attached string of patches to work around this, and it
worked to get test-floenv.scm compiling, and it made some progress
through test-flonum.scm, but it still runs out of memory partway
through.
This is not a very high priority so I'm not going to spend much more
time on it for a while.
>From 4e7acb8860be0d76f18ece601c24f4360b4567e4 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell+mit-sch...@mumble.net>
Date: Thu, 4 Jun 2020 23:13:18 +0000
Subject: [PATCH 1/4] Split up large top-level expression to give i386 compiler
a chance.
---
tests/runtime/test-floenv.scm | 57 ++++++++++++++++++++++-------------
1 file changed, 36 insertions(+), 21 deletions(-)
diff --git a/tests/runtime/test-floenv.scm b/tests/runtime/test-floenv.scm
index 5642a7034..09becf9ed 100644
--- a/tests/runtime/test-floenv.scm
+++ b/tests/runtime/test-floenv.scm
@@ -88,13 +88,16 @@ USA.
'EXPRESSION `(,name ,input))))
inputs outputs)))))
+(define no-op identity-procedure)
+(define rounding-inputs '(-2.0 -1.5 -1.0 -0.5 -0.0 0.0 0.5 1.0 1.5 2.0))
+(define infs '(-inf.0 +inf.0))
+
+;;; XXX Check NaNs without traps.
+
(for-each-rounding-mode
(lambda (mode)
- (define no-op identity-procedure)
- (define inputs '(-2.0 -1.5 -1.0 -0.5 -0.0 0.0 0.5 1.0 1.5 2.0))
- (define infs '(-inf.0 +inf.0))
- ;; XXX Check NaNs without traps.
- (let ((outputs '(-2.0 -1.0 -1.0 -0.0 -0.0 0.0 1.0 1.0 2.0 2.0)))
+ (let ((inputs rounding-inputs)
+ (outputs '(-2.0 -1.0 -1.0 -0.0 -0.0 0.0 1.0 1.0 2.0 2.0)))
(define-rounding-test 'CEILING/INLINE ceiling mode inputs outputs)
(define-rounding-test 'CEILING/INLINE ceiling mode infs infs)
(define-rounding-test 'CEILING (no-op ceiling) mode inputs outputs)
@@ -112,8 +115,12 @@ USA.
(define-rounding-test 'FLO:CEILING->EXACT/INLINE flo:ceiling->exact mode
inputs outputs)
(define-rounding-test 'FLO:CEILING->EXACT (no-op flo:ceiling->exact)
- mode inputs outputs)))
- (let ((outputs '(-2.0 -2.0 -1.0 -1.0 -0.0 0.0 0.0 1.0 1.0 2.0)))
+ mode inputs outputs)))))
+
+(for-each-rounding-mode
+ (lambda (mode)
+ (let ((inputs rounding-inputs)
+ (outputs '(-2.0 -2.0 -1.0 -1.0 -0.0 0.0 0.0 1.0 1.0 2.0)))
(define-rounding-test 'FLOOR/INLINE floor mode inputs outputs)
(define-rounding-test 'FLOOR/INLINE floor mode infs infs)
(define-rounding-test 'FLOOR (no-op floor) mode inputs outputs)
@@ -124,14 +131,18 @@ USA.
(define-rounding-test 'FLO:FLOOR (no-op flo:floor) mode infs infs)
(let ((outputs (map inexact->exact outputs)))
(define-rounding-test 'FLOOR->EXACT/INLINE floor->exact mode inputs
- outputs)
+ outputs)
(define-rounding-test 'FLOOR->EXACT (no-op floor->exact) mode inputs
- outputs)
+ outputs)
(define-rounding-test 'FLO:FLOOR->EXACT/INLINE flo:floor->exact mode
- inputs outputs)
+ inputs outputs)
(define-rounding-test 'FLO:FLOOR->EXACT (no-op flo:floor->exact) mode
- inputs outputs)))
- (let ((outputs'(-2.0 -2.0 -1.0 -0.0 -0.0 0.0 0.0 1.0 2.0 2.0)))
+ inputs outputs)))))
+
+(for-each-rounding-mode
+ (lambda (mode)
+ (let ((inputs rounding-inputs)
+ (outputs'(-2.0 -2.0 -1.0 -0.0 -0.0 0.0 0.0 1.0 2.0 2.0)))
(define-rounding-test 'ROUND/INLINE round mode inputs outputs)
(define-rounding-test 'ROUND/INLINE round mode infs infs)
(define-rounding-test 'ROUND (no-op round) mode inputs outputs)
@@ -142,14 +153,18 @@ USA.
(define-rounding-test 'FLO:ROUND (no-op flo:round) mode infs infs)
(let ((outputs (map inexact->exact outputs)))
(define-rounding-test 'ROUND->EXACT/INLINE round->exact mode inputs
- outputs)
+ outputs)
(define-rounding-test 'ROUND->EXACT (no-op round->exact) mode inputs
- outputs)
+ outputs)
(define-rounding-test 'FLO:ROUND->EXACT/INLINE flo:round->exact mode
- inputs outputs)
+ inputs outputs)
(define-rounding-test 'FLO:ROUND->EXACT (no-op flo:round->exact) mode
- inputs outputs)))
- (let ((outputs '(-2.0 -1.0 -1.0 -0.0 -0.0 0.0 0.0 1.0 1.0 2.0)))
+ inputs outputs)))))
+
+(for-each-rounding-mode
+ (lambda (mode)
+ (let ((inputs rounding-inputs)
+ (outputs '(-2.0 -1.0 -1.0 -0.0 -0.0 0.0 0.0 1.0 1.0 2.0)))
(define-rounding-test 'TRUNCATE/INLINE truncate mode inputs outputs)
(define-rounding-test 'TRUNCATE/INLINE truncate mode infs infs)
(define-rounding-test 'TRUNCATE (no-op truncate) mode inputs outputs)
@@ -162,13 +177,13 @@ USA.
(define-rounding-test 'FLO:TRUNCATE (no-op flo:truncate) mode infs infs)
(let ((outputs (map inexact->exact outputs)))
(define-rounding-test 'TRUNCATE->EXACT/INLINE truncate->exact mode
- inputs outputs)
+ inputs outputs)
(define-rounding-test 'TRUNCATE->EXACT (no-op truncate->exact) mode
- inputs outputs)
+ inputs outputs)
(define-rounding-test 'FLO:TRUNCATE->EXACT/INLINE flo:truncate->exact
- mode inputs outputs)
+ mode inputs outputs)
(define-rounding-test 'FLO:TRUNCATE->EXACT (no-op flo:truncate->exact)
- mode inputs outputs)))))
+ mode inputs outputs)))))
;++ Add tests for rounding-mode-dependent operations...
>From f3639693c21537865715629739e0872b130d0c53 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell+mit-sch...@mumble.net>
Date: Sat, 6 Jun 2020 17:03:01 +0000
Subject: [PATCH 2/4] Integrate let-bound variables in matcher to limit stack
depth.
Otherwise, the compiler generates a stack frame for every variable,
and for deeply nested stacks the RTL CSE is unable to handle it in a
32-bit compiler.
---
src/runtime/syntax-rules.scm | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index 0d392ff58..1333de6f0 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -181,7 +181,9 @@ USA.
(if (identifier? expression)
(generate-body expression)
(let ((temp (new-identifier 'temp)))
- `(,(rename 'let) ((,temp ,expression)) ,(generate-body temp)))))
+ `(,(rename 'let) ((,temp ,expression))
+ (,(rename 'declare) (integrate ,temp))
+ ,(generate-body temp)))))
(define (generate-output rename compare ellipsis r-rename sids template)
(let loop ((template template) (ellipses '()) (ellipsis* ellipsis))
>From 24301d7f8ca0b150fae310ce27cbd215fcf0ef6d Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell+mit-sch...@mumble.net>
Date: Sat, 6 Jun 2020 17:04:31 +0000
Subject: [PATCH 3/4] Eliminate `list' expansion.
This undoes the `list' optimization of syntax-rules.scm, and makes
for much more deeply nested combinations for the compiler to handle,
which the 32-bit compiler cannot.
---
src/sf/usiexp.scm | 14 --------------
1 file changed, 14 deletions(-)
diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm
index d75cf8f8a..516e31b8d 100644
--- a/src/sf/usiexp.scm
+++ b/src/sf/usiexp.scm
@@ -335,19 +335,6 @@ USA.
(ucode-primitive cons)
(car rest)
(cons*-expansion-loop #f block (cdr rest)))))
-
-(define (list-expansion expr operands block)
- (list-expansion-loop expr block operands))
-
-(define (list-expansion-loop expr block rest)
- (cond ((pair? rest)
- (pcall expr block (ucode-primitive cons)
- (car rest)
- (list-expansion-loop #f block (cdr rest))))
- ((null? rest)
- (constant/make (and expr (object/scode expr)) '()))
- (else
- (error "Improper list."))))
;;;; General CAR/CDR Encodings
@@ -852,7 +839,6 @@ USA.
(cons 'int:integer? exact-integer?-expansion)
(cons 'intern intern-expansion)
(cons 'interned-symbol? interned-symbol?-expansion)
- (cons 'list list-expansion)
(cons 'make-bytevector make-bytevector-expansion)
(cons 'negative? negative?-expansion)
(cons 'not not-expansion)
>From 3ac7f9cd8c513ebb61e478f8ee6286cd42545618 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell+mit-sch...@mumble.net>
Date: Sat, 6 Jun 2020 17:05:15 +0000
Subject: [PATCH 4/4] Split up large macros into smaller ones.
...in an attempt to make this digestible by the 32-bit compiler.
---
tests/runtime/test-flonum.scm | 302 +++++++++++++++++-----------------
1 file changed, 154 insertions(+), 148 deletions(-)
diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index 7ba66da44..ebba2618b 100644
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -612,45 +612,51 @@ USA.
(flo:sign-negative? (flo:negate x))))))
(define-syntax define-comparison-test
- (syntax-rules ()
- ((define-comparison-test name safe-compare unsafe-compare cases)
- (define-test name
+ (syntax-rules (quote)
+ ((define-comparison-test 'name safe-compare unsafe-compare cases)
+ (define-test 'name
(map (lambda (x)
(map (lambda (y)
(lambda ()
(with-test-properties
(lambda ()
- (assert-eqv
- (yes-traps (lambda () (safe-compare x y)))
- (if (or (flo:nan? x) (flo:nan? y))
- #f
- (unsafe-compare x y)))
- (assert-eqv
- (yes-traps (lambda () (not (safe-compare x y))))
- (if (or (flo:nan? x) (flo:nan? y))
- #t
- (not (unsafe-compare x y))))
- (if (safe-compare x y)
- (begin
- (assert-true (not (flo:nan? x)))
- (assert-true (not (flo:nan? y)))
- (assert-true (unsafe-compare x y))))
- (if (not (safe-compare x y))
- (begin
- (assert-true
- (or (flo:nan? x)
- (flo:nan? y)
- (not (unsafe-compare x y))))))
- (if (not (or (flo:nan? x) (flo:nan? y)))
- (begin
- (if (unsafe-compare x y)
- (assert-true (safe-compare x y)))
- (if (not (unsafe-compare x y))
- (assert-false (safe-compare x y))))))
+ (comparison-test safe-compare unsafe-compare x y))
'SEED (list x y))))
cases))
cases)))))
+(define-syntax comparison-test
+ (syntax-rules ()
+ ((comparison-test safe-compare unsafe-compare x y)
+ (begin
+ (assert-eqv
+ (yes-traps (lambda () (safe-compare x y)))
+ (if (or (flo:nan? x) (flo:nan? y))
+ #f
+ (unsafe-compare x y)))
+ (assert-eqv
+ (yes-traps (lambda () (not (safe-compare x y))))
+ (if (or (flo:nan? x) (flo:nan? y))
+ #t
+ (not (unsafe-compare x y))))
+ (if (safe-compare x y)
+ (begin
+ (assert-true (not (flo:nan? x)))
+ (assert-true (not (flo:nan? y)))
+ (assert-true (unsafe-compare x y))))
+ (if (not (safe-compare x y))
+ (begin
+ (assert-true
+ (or (flo:nan? x)
+ (flo:nan? y)
+ (not (unsafe-compare x y))))))
+ (if (not (or (flo:nan? x) (flo:nan? y)))
+ (begin
+ (if (unsafe-compare x y)
+ (assert-true (safe-compare x y)))
+ (if (not (unsafe-compare x y))
+ (assert-false (safe-compare x y)))))))))
+
(define-syntax define-snan-comparison-test
(syntax-rules ()
((define-snan-comparison-test name safe-compare unsafe-compare cases)
@@ -658,97 +664,97 @@ USA.
(map (lambda (x)
(lambda ()
(with-test-properties
- (lambda ()
- (let ((snan (identity-procedure (flo:snan 1234)))
- (mask
- (fix:andc (flo:supported-exceptions)
- ;; Not reliable.
- (flo:exception:subnormal-operand))))
- (assert-only-except/no-traps
- (flo:exception:invalid-operation)
- (lambda () (safe-compare x snan))
- mask)
- (assert-only-except/no-traps
- (flo:exception:invalid-operation)
- (lambda () (safe-compare snan x))
- mask)
- (assert-only-except/no-traps
- (flo:exception:invalid-operation)
- (lambda () (safe-compare snan snan)))
- (assert-false
- (no-traps (lambda () (safe-compare x snan))))
- (assert-false
- (no-traps (lambda () (safe-compare snan x))))
- (assert-false
- (no-traps (lambda () (safe-compare snan snan))))
- (assert-only-except/no-traps
- (flo:exception:invalid-operation)
- (lambda () (unsafe-compare x snan))
- mask)
- (assert-only-except/no-traps
- (flo:exception:invalid-operation)
- (lambda () (unsafe-compare snan x))
- mask)
- (assert-only-except/no-traps
- (flo:exception:invalid-operation)
- (lambda () (unsafe-compare snan snan)))
- (assert-false
- (no-traps (lambda () (unsafe-compare x snan))))
- (assert-false
- (no-traps (lambda () (unsafe-compare snan x))))
- (assert-false
- (no-traps (lambda () (unsafe-compare snan snan))))))
- 'SEED x)))
+ (lambda ()
+ (snan-comparison-test safe-compare unsafe-compare x))
+ 'SEED x)))
cases)))))
-(let* ((subnormal+ flo:smallest-positive-subnormal)
- (subnormal- (no-traps (lambda () (- subnormal+))))
- (cases
- `(-inf.0 -1. ,subnormal- -0. +0. ,subnormal+ +1. +inf.0 +nan.0)))
- (define-comparison-test '< flo:safe< flo:< cases)
- (define-comparison-test '> flo:safe> flo:> cases)
- (define-comparison-test '>= flo:safe>= flo:>= cases)
- (define-comparison-test '<= flo:safe<= flo:<= cases)
- (define-comparison-test '<> flo:safe<> flo:<> cases)
- (define-comparison-test '= flo:safe= flo:= cases)
- (define-snan-comparison-test '</snan flo:safe< flo:< cases)
- (define-snan-comparison-test '>/snan flo:safe> flo:> cases)
- (define-snan-comparison-test '>=/snan flo:safe>= flo:>= cases)
- (define-snan-comparison-test '<=/snan flo:safe<= flo:<= cases)
- (define-snan-comparison-test '<>/snan flo:safe<> flo:<> cases)
- (define-snan-comparison-test '=/snan flo:safe= flo:= cases)
- (define-test 'unordered?
- (map (lambda (x)
- (map (lambda (y)
- (lambda ()
- (assert-eqv (yes-traps (lambda () (flo:unordered? x y)))
- (or (flo:nan? x) (flo:nan? y)))
- (assert-eqv (yes-traps (lambda ()
- (not (flo:unordered? x y))))
- (not (or (flo:nan? x) (flo:nan? y))))
- (if (flo:unordered? x y)
- (assert-true (or (flo:nan? x) (flo:nan? y))))
- (if (not (flo:unordered? x y))
- (begin
- (assert-false (flo:nan? x))
- (assert-false (flo:nan? y))))))
- cases))
- cases))
- (define-test 'tetrachotomy
- (map (lambda (x)
- (map (lambda (y)
- (lambda ()
- (define (n b) (if b 1 0))
- (assert-eqv
- (yes-traps
- (lambda ()
- (+ (n (flo:safe< x y))
- (n (flo:safe> x y))
- (n (and (flo:safe<= x y) (flo:safe>= x y)))
- (n (flo:unordered? x y)))))
- 1)))
- cases))
- cases)))
+(define-syntax snan-comparison-test
+ (syntax-rules ()
+ ((snan-comparison-test safe-compare unsafe-compare x)
+ (let ((snan (identity-procedure (flo:snan 1234)))
+ (mask
+ (fix:andc (flo:supported-exceptions)
+ ;; Not reliable.
+ (flo:exception:subnormal-operand))))
+ (assert-only-except/no-traps
+ (flo:exception:invalid-operation)
+ (lambda () (safe-compare x snan))
+ mask)
+ (assert-only-except/no-traps
+ (flo:exception:invalid-operation)
+ (lambda () (safe-compare snan x))
+ mask)
+ (assert-only-except/no-traps
+ (flo:exception:invalid-operation)
+ (lambda () (safe-compare snan snan)))
+ (assert-false (no-traps (lambda () (safe-compare x snan))))
+ (assert-false (no-traps (lambda () (safe-compare snan x))))
+ (assert-false (no-traps (lambda () (safe-compare snan snan))))
+ (assert-only-except/no-traps
+ (flo:exception:invalid-operation)
+ (lambda () (unsafe-compare x snan))
+ mask)
+ (assert-only-except/no-traps
+ (flo:exception:invalid-operation)
+ (lambda () (unsafe-compare snan x))
+ mask)
+ (assert-only-except/no-traps
+ (flo:exception:invalid-operation)
+ (lambda () (unsafe-compare snan snan)))
+ (assert-false (no-traps (lambda () (unsafe-compare x snan))))
+ (assert-false (no-traps (lambda () (unsafe-compare snan x))))
+ (assert-false (no-traps (lambda () (unsafe-compare snan snan))))))))
+
+(define comparison-cases
+ `(-inf.0 -1. ,subnormal- -0. +0. ,subnormal+ +1. +inf.0 +nan.0))
+
+(define-comparison-test '< flo:safe< flo:< comparison-cases)
+(define-comparison-test '> flo:safe> flo:> comparison-cases)
+(define-comparison-test '>= flo:safe>= flo:>= comparison-cases)
+(define-comparison-test '<= flo:safe<= flo:<= comparison-cases)
+(define-comparison-test '<> flo:safe<> flo:<> comparison-cases)
+(define-comparison-test '= flo:safe= flo:= comparison-cases)
+(define-snan-comparison-test '</snan flo:safe< flo:< comparison-cases)
+(define-snan-comparison-test '>/snan flo:safe> flo:> comparison-cases)
+(define-snan-comparison-test '>=/snan flo:safe>= flo:>= comparison-cases)
+(define-snan-comparison-test '<=/snan flo:safe<= flo:<= comparison-cases)
+(define-snan-comparison-test '<>/snan flo:safe<> flo:<> comparison-cases)
+(define-snan-comparison-test '=/snan flo:safe= flo:= comparison-cases)
+
+(define-test 'unordered?
+ (map (lambda (x)
+ (map (lambda (y)
+ (lambda ()
+ (assert-eqv (yes-traps (lambda () (flo:unordered? x y)))
+ (or (flo:nan? x) (flo:nan? y)))
+ (assert-eqv (yes-traps (lambda ()
+ (not (flo:unordered? x y))))
+ (not (or (flo:nan? x) (flo:nan? y))))
+ (if (flo:unordered? x y)
+ (assert-true (or (flo:nan? x) (flo:nan? y))))
+ (if (not (flo:unordered? x y))
+ (begin
+ (assert-false (flo:nan? x))
+ (assert-false (flo:nan? y))))))
+ comparison-cases))
+ comparison-cases))
+
+(define-test 'tetrachotomy
+ (map (lambda (x)
+ (map (lambda (y)
+ (lambda ()
+ (define (n b) (if b 1 0))
+ (assert-eqv
+ (yes-traps
+ (lambda ()
+ (+ (n (flo:safe< x y))
+ (n (flo:safe> x y))
+ (n (and (flo:safe<= x y) (flo:safe>= x y)))
+ (n (flo:unordered? x y)))))
+ 1)))
+ comparison-cases))
+ comparison-cases))
(define-syntax define-*constcomp-test
(syntax-rules ()
@@ -758,38 +764,38 @@ USA.
(map (lambda (arguments)
(apply (lambda (y u v #!optional xfail)
d
- (let ((x x0))
- (declare (integrate x))
- (lambda ()
- (with-expected-failure xfail
- (lambda ()
- (assert-eqv
- (yes-traps (lambda () (safe-compare a b)))
- c)
- (assert-eqv
- (no-traps (lambda () (unsafe-compare a b)))
- c)
- (if (yes-traps (lambda () (safe-compare a b)))
- (begin
- (assert-true (not (flo:nan? a)))
- (assert-true (not (flo:nan? b)))
- (assert-true (unsafe-compare a b))))
- (if (yes-traps
- (lambda () (not (safe-compare a b))))
- (assert-true
- (or (flo:nan? a)
- (flo:nan? b)
- (not (unsafe-compare a b)))))
- (if (not (or (flo:nan? a) (flo:nan? b)))
- (begin
- (if (unsafe-compare a b)
- (assert-true (safe-compare a b)))
- (if (not (unsafe-compare a b))
- (assert-false
- (safe-compare a b))))))))))
+ (*constcomp-test safe-compare unsafe-compare x0
+ x y a b u v c xfail))
arguments))
cases)))))
+(define-syntax *constcomp-test
+ (syntax-rules ()
+ ((*constcomp-test safe-compare unsafe-compare x0 x y a b u v c xfail)
+ (let ((x x0))
+ (declare (integrate x))
+ (lambda ()
+ (with-expected-failure xfail
+ (lambda ()
+ (assert-eqv (yes-traps (lambda () (safe-compare a b))) c)
+ (assert-eqv (no-traps (lambda () (unsafe-compare a b))) c)
+ (if (yes-traps (lambda () (safe-compare a b)))
+ (begin
+ (assert-true (not (flo:nan? a)))
+ (assert-true (not (flo:nan? b)))
+ (assert-true (unsafe-compare a b))))
+ (if (yes-traps (lambda () (not (safe-compare a b))))
+ (assert-true
+ (or (flo:nan? a)
+ (flo:nan? b)
+ (not (unsafe-compare a b)))))
+ (if (not (or (flo:nan? a) (flo:nan? b)))
+ (begin
+ (if (unsafe-compare a b)
+ (assert-true (safe-compare a b)))
+ (if (not (unsafe-compare a b))
+ (assert-false (safe-compare a b))))))))))))
+
(define-syntax define-lconstcomp-test
(syntax-rules ()
((define-lconstcomp-test name safe-compare unsafe-compare x0 cases)
