>From 4e7acb8860be0d76f18ece601c24f4360b4567e4 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell 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 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 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 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-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-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)