From ae71f7472d0fc907e11b1539efa248c54c67514c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 21 Jan 2019 10:51:16 -0700
Subject: [PATCH] add enable-arithmetic-left-associative

Add a parameter to constrain the compiler (off by default) to
implement `+`, `*`, and variants as left-associative when given
multiple arguments.

original commit: d126ba3364893e66263c65af1cd6dbdd8b021439
---
 LOG              |   2 +
 csug/system.stex |  13 +++
 mats/cp0.ms      | 216 ++++++++++++++++++++++++++++++++++++++++++++++-
 s/compile.ss     |   3 +-
 s/cp0.ss         | 108 +++++++++++++-----------
 s/front.ss       |   2 +
 s/primdata.ss    |   1 +
 7 files changed, 295 insertions(+), 50 deletions(-)

diff --git a/LOG b/LOG
index e5aae978a0..6931af9f5f 100644
--- a/LOG
+++ b/LOG
@@ -1027,3 +1027,5 @@
     cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms
 - added initialization of seginfo sorted and trigger_ephemerons fields.
     segment.c
+- added enable-arithmetic-left-associative
+    cp0.ss, compile.ss, primdata.ss, front.ss, cp0.ms, system.stex
diff --git a/csug/system.stex b/csug/system.stex
index 19231adccc..2e1ab91279 100644
--- a/csug/system.stex
+++ b/csug/system.stex
@@ -1130,6 +1130,7 @@ generate-procedure-source-information
 compile-profile
 generate-interrupt-trap
 enable-cross-library-optimization
+enable-arithmetic-left-associative
 \endschemedisplay
 
 It restores the values after the file has been compiled.
@@ -2443,6 +2444,18 @@ Setting the parameter to \scheme{#f} potentially reduces the sizes
 of the resulting object files and the exposure of near-source
 information via the object file.
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{enable-arithmetic-left-associative}{\categorythreadparameter}{enable-arithmetic-left-associative}
+\listlibraries
+\endentryheader
+
+This parameter controls whether the compiler is constrained to
+implement \scheme{+}, \scheme{fx+}, \scheme{fl+}, \scheme{cfl+},
+\scheme{*}, \scheme{fx*}, \scheme{fl*}, and \scheme{cfl*} as
+left-associative operations when given more than two arguments.
+The default is \scheme{#f}.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{generate-wpo-files}{\categorythreadparameter}{generate-wpo-files}
diff --git a/mats/cp0.ms b/mats/cp0.ms
index e1755e7b57..5eacfcfa66 100644
--- a/mats/cp0.ms
+++ b/mats/cp0.ms
@@ -1698,6 +1698,218 @@
        6 -5 (#3%fxlogxor x y) (#3%fxlogxor 10 x y) (#3%fxlogxor -11 x y) (#3%fxlogxor 10 x y)))
 )
 
+
+
+(mat cp0-partial-folding-left-assoc
+ ; check partial folding of +, fx+, fl+, and cfl+ when constraint to left-associative
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f] 
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (+) (+ 3) (+ 3 4) (+ x) (+ x 0) (+ 0 x) (+ x 3)
+           (+ x 3 4) (+ 3 x 4) (+ 3 x -3) (+ 3 x 4 y 5)
+           (+ +nan.0 x 4 y 5))))
+    '(#2%list 0 3 7 (#2%+ x) (#2%+ x 0) (#2%+ x) (#2%+ x 3)
+       (#2%+ x 3 4) (#2%+ 3 x 4) (#2%+ 3 x -3) (#2%+ 3 x 4 y 5)
+       (begin (#2%+ +nan.0 x 4 y 5) +nan.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (+) (+ 3) (+ 3 4) (+ x) (+ x 0) (+ 0 x) (+ x 3)
+           (+ x 3 4) (+ 3 x 4) (+ 3 x -3) (+ 3 x 4 y 5)
+           (+ +nan.0 x 4 y 5))))
+    '(#3%list 0 3 7 x (#3%+ x 0) x (#3%+ x 3)
+       (#3%+ x 3 4) (#3%+ 3 x 4) (#3%+ 3 x -3) (#3%+ 3 x 4 y 5)
+       +nan.0))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fx+) (fx+ 3) (fx+ 3 4) (fx+ x) (fx+ x 0) (fx+ 0 x) (fx+ x 3)
+           (fx+ x 3 4) (fx+ 3 x 4) (fx+ 3 x -3) (fx+ 3 x 4 y 5))))
+    '(#2%list 0 3 7 (#2%fx+ x) (#2%fx+ x 0) (#2%fx+ x) (#2%fx+ x 3)
+       (#2%fx+ x 3 4) (#2%fx+ 3 x 4) (#2%fx+ 3 x -3) (#2%fx+ 3 x 4 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fx+) (fx+ 3) (fx+ 3 4) (fx+ x) (fx+ x 0) (fx+ 0 x) (fx+ x 3)
+           (fx+ x 3 4) (fx+ 3 x 4) (fx+ 3 x -3) (fx+ 3 x 4 y 5))))
+    '(#3%list 0 3 7 x x x (#3%fx+ 3 x)
+       (#3%fx+ 7 x) (#3%fx+ 7 x) x (#3%fx+ 12 x y)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fl+) (fl+ 3.0) (fl+ 3.0 4.0) (fl+ x) (fl+ x 0.0) (fl+ x -0.0) (fl+ 0.0 x) (fl+ -0.0 x) (fl+ x 3.0)
+           (fl+ x 3.0 4.0) (fl+ 3.0 x 4.0) (fl+ 3.0 x -3.0) (fl+ (truncate -.5) x (/ -inf.0)) (fl+ 3.0 x 4.0 y 5.0)
+           (fl+ +nan.0 x 3.0 y 5.0) (fl+ 3.0 x +nan.0 y 5.0))))
+    '(#2%list 0.0 3.0 7.0 (#2%fl+ x) (#2%fl+ x 0.0) (#2%fl+ x -0.0) (#2%fl+ 0.0 x) (#2%fl+ x) (#2%fl+ x 3.0)
+       (#2%fl+ x 3.0 4.0) (#2%fl+ 3.0 x 4.0) (#2%fl+ 3.0 x -3.0) (#2%fl+ x -0.0) (#2%fl+ 3.0 x 4.0 y 5.0)
+       (begin (#2%fl+ +nan.0 x 3.0 y 5.0) +nan.0) (#2%fl+ 3.0 x +nan.0 y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fl+) (fl+ 3.0) (fl+ 3.0 4.0) (fl+ x) (fl+ x 0.0) (fl+ x -0.0) (fl+ 0.0 x) (fl+ -0.0 x) (fl+ x 3.0)
+           (fl+ x 3.0 4.0) (fl+ 3.0 x 4.0) (fl+ 3.0 x -3.0) (fl+ (truncate -.5) x (/ -inf.0)) (fl+ 3.0 x 4.0 y 5.0)
+           (fl+ +nan.0 x 3.0 y 5.0) (fl+ 3.0 x +nan.0 y 5.0))))
+    '(#3%list 0.0 3.0 7.0 x (#3%fl+ x 0.0) (#3%fl+ x -0.0) (#3%fl+ 0.0 x) x (#3%fl+ x 3.0)
+       (#3%fl+ x 3.0 4.0) (#3%fl+ 3.0 x 4.0) (#3%fl+ 3.0 x -3.0) (#3%fl+ x -0.0) (#3%fl+ 3.0 x 4.0 y 5.0)
+       +nan.0 (#3%fl+ 3.0 x +nan.0 y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (cfl+) (cfl+ 3.0) (cfl+ 3.0 4.0) (cfl+ x) (cfl+ x 0.0) (cfl+ x -0.0) (cfl+ 0.0 x) (cfl+ -0.0 x) (cfl+ x 3.0)
+           (cfl+ x 3.0 4.0) (cfl+ 3.0 x 4.0) (cfl+ 3.0 x -3.0) (cfl+ (truncate -.5) x (/ -inf.0)) (cfl+ 3.0 x 4.0 y 5.0)
+           (cfl+ +nan.0+nan.0i x 3.0 y 5.0) (cfl+ 3.0 x +nan.0+nan.0i y 5.0))))
+    '(#2%list 0.0 3.0 7.0 (#2%cfl+ x) (#2%cfl+ x 0.0) (#2%cfl+ x -0.0) (#2%cfl+ 0.0 x) (#2%cfl+ x) (#2%cfl+ x 3.0)
+       (#2%cfl+ x 3.0 4.0) (#2%cfl+ 3.0 x 4.0) (#2%cfl+ 3.0 x -3.0) (#2%cfl+ x -0.0) (#2%cfl+ 3.0 x 4.0 y 5.0)
+       (begin (#2%cfl+ +nan.0+nan.0i x 3.0 y 5.0) +nan.0+nan.0i) (#2%cfl+ 3.0 x +nan.0+nan.0i y 5.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (cfl+) (cfl+ 3.0) (cfl+ 3.0 4.0) (cfl+ x) (cfl+ x 0.0) (cfl+ x -0.0) (cfl+ 0.0 x) (cfl+ -0.0 x) (cfl+ x 3.0)
+           (cfl+ x 3.0 4.0) (cfl+ 3.0 x 4.0) (cfl+ 3.0 x -3.0) (cfl+ (truncate -.5) x (/ -inf.0)) (cfl+ 3.0 x 4.0 y 5.0)
+           (cfl+ +nan.0+nan.0i x 3.0 y 5.0) (cfl+ 3.0 x +nan.0+nan.0i y 5.0))))
+    '(#3%list 0.0 3.0 7.0 x (#3%cfl+ x 0.0) (#3%cfl+ x -0.0) (#3%cfl+ 0.0 x) x (#3%cfl+ x 3.0)
+       (#3%cfl+ x 3.0 4.0) (#3%cfl+ 3.0 x 4.0) (#3%cfl+ 3.0 x -3.0) (#3%cfl+ x -0.0) (#3%cfl+ 3.0 x 4.0 y 5.0)
+       +nan.0+nan.0i (#3%cfl+ 3.0 x +nan.0+nan.0i y 5.0)))
+
+ ; check partial folding of *, fx*, fl*, and cfl*
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (*) (* 3) (* 3 4) (* x) (* x 1) (* 1 x) (* x 3)
+           (* x 3 4) (* 3 x 4) (* 3 x 1/3) (* 3 x 4 y 5)
+           (* 0 x 3 y 5) (* 3 x 0 y 5))))
+    '(#2%list 1 3 12 (#2%* x) (#2%* x 1) (#2%* x) (#2%* x 3)
+       (#2%* x 3 4) (#2%* 3 x 4) (#2%* 3 x 1/3) (#2%* 3 x 4 y 5)
+       (begin (#2%* 0 x 3 y 5) 0) (#2%* 3 x 0 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (*) (* 3) (* 3 4) (* x) (* x 1) (* 1 x) (* x 3)
+           (* x 3 4) (* 3 x 4) (* 3 x 1/3) (* 3 x 4 y 5)
+           (* 0 x 3 y 5) (* 3 x 0 y 5))))
+    '(#3%list 1 3 12 x (#3%* x 1) x (#3%* x 3)
+       (#3%* x 3 4) (#3%* 3 x 4) (#3%* 3 x 1/3) (#3%* 3 x 4 y 5)
+       0 (#3%* 3 x 0 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fx*) (fx* 3) (fx* 3 4) (fx* x) (fx* x 1) (fx* 1 x) (fx* x 3)
+           (fx* x 3 4) (fx* 3 x 4) (fx* 1 x 1) (fx* 3 x 4 y 5)
+           (fx* 0 x 3 y 5) (fx* 3 x 0 y 5))))
+    '(#2%list 1 3 12 (#2%fx* x) (#2%fx* x 1) (#2%fx* x) (#2%fx* x 3)
+       (#2%fx* x 3 4) (#2%fx* 3 x 4) (#2%fx* x 1) (#2%fx* 3 x 4 y 5)
+       (begin (#2%fx* 0 x 3 y 5) 0) (#2%fx* 3 x 0 y 5)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fx*) (fx* 3) (fx* 3 4) (fx* x) (fx* x 1) (fx* 1 x) (fx* x 3)
+           (fx* x 3 4) (fx* 3 x 4) (fx* 1 x 1) (fx* 3 x 4 y 5)
+           (fx* 3 x 0 y 5))))
+    '(#3%list 1 3 12 x x x (#3%fx* 3 x)
+       (#3%fx* 12 x) (#3%fx* 12 x) x (#3%fx* 60 x y)
+       0))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (fl*) (fl* 3.0) (fl* 3.0 4.0) (fl* x) (fl* x 1.0) (fl* 1.0 x) (fl* x 3.0)
+           (fl* x 3.0 4.0) (fl* 3.0 x 4.0) (fl* 3.0 x #i1/3) (fl* 3.0 x 4.0 y 5.0)
+           (fl* +nan.0 x 3.0 y 4.0) (fl* 3.0 x 4.0 y +nan.0))))
+    '(#2%list 1.0 3.0 12.0 (#2%fl* x) (#2%fl* x 1.0) (#2%fl* x) (#2%fl* x 3.0)
+       (#2%fl* x 3.0 4.0) (#2%fl* 3.0 x 4.0) (#2%fl* 3.0 x #i1/3) (#2%fl* 3.0 x 4.0 y 5.0)
+       (begin (#2%fl* +nan.0 x 3.0 y 4.0) +nan.0) (#2%fl* +3.0 x 4.0 y +nan.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (fl*) (fl* 3.0) (fl* 3.0 4.0) (fl* x) (fl* x 1.0) (fl* 1.0 x) (fl* x 3.0)
+           (fl* x 3.0 4.0) (fl* 3.0 x 4.0) (fl* 3.0 x #i1/3) (fl* 3.0 x 4.0 y 5.0)
+           (fl* +nan.0 x 3.0 y 4.0) (fl* 3.0 x 4.0 y +nan.0))))
+    '(#3%list 1.0 3.0 12.0 x (#3%fl* x 1.0) x (#3%fl* x 3.0)
+       (#3%fl* x 3.0 4.0) (#3%fl* 3.0 x 4.0) (#3%fl* 3.0 x #i1/3) (#3%fl* 3.0 x 4.0 y 5.0)
+       +nan.0 (#3%fl* +3.0 x 4.0 y +nan.0)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 2])
+      (expand/optimize
+        '(list
+           (cfl*) (cfl* 3.0) (cfl* 3.0 4.0) (cfl* x) (cfl* x 1.0) (cfl* 1.0 x) (cfl* x 3.0)
+           (cfl* x 3.0 4.0) (cfl* 3.0 x 4.0) (cfl* 3.0 x #i1/3) (cfl* 3.0 x 4.0 y 5.0)
+           (cfl* +nan.0+nan.0i x 3.0 y 4.0) (cfl* 3.0 x 4.0 y +nan.0+nan.0i))))
+    '(#2%list 1.0 3.0 12.0 (#2%cfl* x) (#2%cfl* x 1.0) (#2%cfl* x) (#2%cfl* x 3.0)
+       (#2%cfl* x 3.0 4.0) (#2%cfl* 3.0 x 4.0) (#2%cfl* 3.0 x #i1/3) (#2%cfl* 3.0 x 4.0 y 5.0)
+       (begin (#2%cfl* +nan.0+nan.0i x 3.0 y 4.0) +nan.0+nan.0i) (#2%cfl* 3.0 x 4.0 y +nan.0+nan.0i)))
+  (equivalent-expansion?
+    (parameterize ([#%$suppress-primitive-inlining #f]
+                   [run-cp0 (lambda (cp0 x) (cp0 x))]
+                   [enable-arithmetic-left-associative #t]
+                   [optimize-level 3])
+      (expand/optimize
+        '(list
+           (cfl*) (cfl* 3.0) (cfl* 3.0 4.0) (cfl* x) (cfl* x 1.0) (cfl* 1.0 x) (cfl* x 3.0)
+           (cfl* x 3.0 4.0) (cfl* 3.0 x 4.0) (cfl* 3.0 x #i1/3) (cfl* 3.0 x 4.0 y 5.0)
+           (cfl* +nan.0+nan.0i x 3.0 y 4.0) (cfl* 3.0 x 4.0 y +nan.0+nan.0i))))
+    '(#3%list 1.0 3.0 12.0 x (#3%cfl* x 1.0) x (#3%cfl* x 3.0)
+       (#3%cfl* x 3.0 4.0) (#3%cfl* 3.0 x 4.0) (#3%cfl* 3.0 x #i1/3) (#3%cfl* 3.0 x 4.0 y 5.0)
+       +nan.0+nan.0i (#3%cfl* 3.0 x 4.0 y +nan.0+nan.0i)))
+  )
+
 (mat cp0-apply
   (begin
     (define $permutations
@@ -1781,8 +1993,8 @@
       (lambda (groups) (equivalent-expansion? expr `(begin ,@(apply append groups) 10)))
       ($permutations
         (if (= (optimize-level) 3)
-            '(((#3%write 'a)) ((#3%write 'b)) ((#3%write 'c) (#3%write 'd) (#3%write 'e)))
-            '(((#2%write 'a)) ((#2%write 'b)) ((#2%write 'c) (#2%write 'd) (#2%write 'e)))))))
+            '(((#3%write 'a)) ((#3%write 'b)) ((#3%write 'c) (#3%write 'e) (#3%write 'd)))
+            '(((#2%write 'a)) ((#2%write 'b)) ((#2%write 'c) (#2%write 'e) (#2%write 'd)))))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
diff --git a/s/compile.ss b/s/compile.ss
index 10a961e66b..6004d70637 100644
--- a/s/compile.ss
+++ b/s/compile.ss
@@ -568,7 +568,8 @@
                    [$compile-profile ($compile-profile)]
                    [generate-interrupt-trap (generate-interrupt-trap)]
                    [$optimize-closures ($optimize-closures)]
-                   [enable-cross-library-optimization (enable-cross-library-optimization)])
+                   [enable-cross-library-optimization (enable-cross-library-optimization)]
+                   [enable-arithmetic-left-associative (enable-arithmetic-left-associative)])
       (emit-header op (constant machine-type))
       (when hostop (emit-header hostop (host-machine-type)))
       (when wpoop (emit-header wpoop (host-machine-type)))
diff --git a/s/cp0.ss b/s/cp0.ss
index fc599722b4..ebc6c880f9 100644
--- a/s/cp0.ss
+++ b/s/cp0.ss
@@ -2197,35 +2197,45 @@
                             (let ([folded (generic-op a d)])
                               (and (target-fixnum? folded) folded)))))]
                 [else #f]))))
-        (define (partial-fold-plus level orig-arg* ctxt prim op generic-op ident bottom?)
+        (define (partial-fold-plus level orig-arg* ctxt prim op generic-op ident bottom? assoc-at-level)
           (define fold? (make-fold? op generic-op))
-          (let loop ([arg* (reverse orig-arg*)] [a ident] [val* '()] [used '()] [unused '()])
+          (let loop ([arg* orig-arg*] [a ident] [val* '()] [used '()] [unused '()])
             (if (null? arg*)
-                (cond
-                  [(bottom? a)
-                   (cond
-                     [(or (fx= level 3) (null? val*))
-                      (residualize-seq '() orig-arg* ctxt)
-                      `(quote ,a)]
-                     [else
-                       (residualize-seq used unused ctxt)
-                       `(seq
-                          ,(build-primcall (app-preinfo ctxt) level prim val*)
-                          (quote ,a))])]
-                  [else
-                    (residualize-seq used unused ctxt)
-                    (cond
-                      [(null? val*) `(quote ,a)]
-                      [(eqv? a ident)
-                       (if (and (fx= level 3) (null? (cdr val*)))
-                           (car val*)
-                           (build-primcall (app-preinfo ctxt) level prim val*))]
-                      [else
-                        (build-primcall (app-preinfo ctxt) level prim (cons `(quote ,a) val*))])])
+                (let ([val* (reverse val*)])
+                  (cond
+                   [(bottom? a)
+                     (cond
+                       [(or (fx= level 3) (null? val*))
+                        (residualize-seq '() orig-arg* ctxt)
+                        `(quote ,a)]
+                       [else
+                         (residualize-seq used unused ctxt)
+                         `(seq
+                           ,(build-primcall (app-preinfo ctxt) level prim
+                                            (if (enable-arithmetic-left-associative)
+                                                ;; May need bottom to avoid overflow
+                                                (cons `(quote ,a) val*)
+                                                val*))
+                           (quote ,a))])]
+                    [else
+                      (residualize-seq used unused ctxt)
+                      (cond
+                        [(null? val*) `(quote ,a)]
+                        [(eqv? a ident)
+                         (if (and (fx= level 3) (null? (cdr val*)))
+                             (car val*)
+                             (build-primcall (app-preinfo ctxt) level prim val*))]
+                        [else
+                          (build-primcall (app-preinfo ctxt) level prim (cons `(quote ,a) val*))])]))
                 (let* ([arg (car arg*)] [val (value-visit-operand! arg)])
                   (cond
                     [(fold? val a) =>
                      (lambda (a) (loop (cdr arg*) a val* used (cons arg unused)))]
+                    [(and (enable-arithmetic-left-associative)
+                          (not (and assoc-at-level (fx>= level assoc-at-level))))
+                     ;; preserve left-associative bahvior
+                     (let ([rest-val* (reverse (map value-visit-operand! (cdr arg*)))])
+                       (loop '() a (append rest-val* (cons val val*)) (append arg* used) unused))]
                     [else (loop (cdr arg*) a (cons val val*) (cons arg used) unused)])))))
 
         (define (partial-fold-minus level arg arg* ctxt prim op generic-op ident)
@@ -2270,17 +2280,19 @@
           ; partial-fold-plus assumes arg* is nonempty
           (syntax-rules (plus minus)
             [(_ plus prim generic-op ident)
-             (partial-folder plus prim generic-op ident (lambda (x) #f))]
+             (partial-folder plus prim generic-op ident (lambda (x) #f) #f)]
             [(_ plus prim generic-op ident bottom?)
+             (partial-folder plus prim generic-op ident bottom? #f)]
+            [(_ plus prim generic-op ident bottom? assoc-at-level)
              (begin
                (define-inline 2 prim
                  ; (fl+) might should return -0.0, but we force it to return +0.0 per TSPL4
                  [() (residualize-seq '() '() ctxt) `(quote ,(if (eqv? ident -0.0) +0.0 ident))]
-                 [arg* (partial-fold-plus 2 arg* ctxt 'prim prim generic-op ident bottom?)])
+                 [arg* (partial-fold-plus 2 arg* ctxt 'prim prim generic-op ident bottom? assoc-at-level)])
                (define-inline 3 prim
                  ; (fl+) might should return -0.0, but we force it to return +0.0 per TSPL4
                  [() (residualize-seq '() '() ctxt) `(quote ,(if (eqv? ident -0.0) +0.0 ident))]
-                 [arg* (partial-fold-plus 3 arg* ctxt 'prim prim generic-op ident bottom?)]))]
+                 [arg* (partial-fold-plus 3 arg* ctxt 'prim prim generic-op ident bottom? assoc-at-level)]))]
             [(_ minus prim generic-op ident)
              (begin
                (define-inline 2 prim
@@ -2294,13 +2306,15 @@
           ; fx+ and fx* limited to exactly two args, fx- limited to one or two args
           (syntax-rules (plus minus)
             [(_ plus r6rs:prim prim generic-op ident)
-             (r6rs-fixnum-partial-folder plus r6rs:prim prim generic-op ident (lambda (x) #f))]
+             (r6rs-fixnum-partial-folder plus r6rs:prim prim generic-op ident (lambda (x) #f) #f)]
             [(_ plus r6rs:prim prim generic-op ident bottom?)
+             (r6rs-fixnum-partial-folder plus r6rs:prim prim generic-op ident bottom? #f)]
+            [(_ plus r6rs:prim prim generic-op ident bottom? assoc-at-level)
              (begin
                (define-inline 2 r6rs:prim
-                 [(arg1 arg2) (partial-fold-plus 2 (list arg1 arg2) ctxt 'prim prim generic-op ident bottom?)])
+                 [(arg1 arg2) (partial-fold-plus 2 (list arg1 arg2) ctxt 'prim prim generic-op ident bottom? assoc-at-level)])
                (define-inline 3 r6rs:prim
-                 [(arg1 arg2) (partial-fold-plus 3 (list arg1 arg2) ctxt 'prim prim generic-op ident bottom?)]))]
+                 [(arg1 arg2) (partial-fold-plus 3 (list arg1 arg2) ctxt 'prim prim generic-op ident bottom? assoc-at-level)]))]
             [(_ minus r6rs:prim prim generic-op ident)
              (begin
                (define-inline 2 r6rs:prim
@@ -2315,14 +2329,14 @@
         ; handling nans here using the support for handling exact zero in
         ; the multiply case.  maybe shouldn't bother with nans anyway.
         (partial-folder plus + + 0 generic-nan?)
-        (partial-folder plus fx+ + 0)
-        (r6rs-fixnum-partial-folder plus r6rs:fx+ fx+ + 0)
+        (partial-folder plus fx+ + 0 (lambda (x) #f) 3)
+        (r6rs-fixnum-partial-folder plus r6rs:fx+ fx+ + 0 (lambda (x) #f) 3)
         (partial-folder plus fl+ fl+ -0.0 fl-nan?)
         (partial-folder plus cfl+ cfl+ -0.0 cfl-nan?)
 
         (partial-folder plus * * 1 exact-zero?)   ; exact zero trumps nan
-        (partial-folder plus fx* * 1 exact-zero?)
-        (r6rs-fixnum-partial-folder plus r6rs:fx* fx* * 1 exact-zero?)
+        (partial-folder plus fx* * 1 exact-zero? 3)
+        (r6rs-fixnum-partial-folder plus r6rs:fx* fx* * 1 exact-zero? 3)
         (partial-folder plus fl* fl* 1.0 fl-nan?)
         (partial-folder plus cfl* cfl* 1.0 cfl-nan?)
 
@@ -2341,20 +2355,20 @@
         (partial-folder minus fl/ fl/ 1.0)
         (partial-folder minus cfl/ cfl/ 1.0)
 
-        (partial-folder plus logior logior 0 exact-negone?)
-        (partial-folder plus logor logor 0 exact-negone?)
-        (partial-folder plus bitwise-ior bitwise-ior 0 exact-negone?)
-        (partial-folder plus fxlogior logor 0 exact-negone?)
-        (partial-folder plus fxior logor 0 exact-negone?)
-        (partial-folder plus fxlogor logor 0 exact-negone?)
-        (partial-folder plus logxor logxor 0)
-        (partial-folder plus bitwise-xor bitwise-xor 0)
-        (partial-folder plus fxlogxor logxor 0)
-        (partial-folder plus fxxor logxor 0)
-        (partial-folder plus logand logand -1 exact-zero?)
-        (partial-folder plus bitwise-and bitwise-and -1 exact-zero?)
-        (partial-folder plus fxlogand logand -1 exact-zero?)
-        (partial-folder plus fxand logand -1 exact-zero?)
+        (partial-folder plus logior logior 0 exact-negone? 2)
+        (partial-folder plus logor logor 0 exact-negone? 2)
+        (partial-folder plus bitwise-ior bitwise-ior 0 exact-negone? 2)
+        (partial-folder plus fxlogior logor 0 exact-negone? 2)
+        (partial-folder plus fxior logor 0 exact-negone? 2)
+        (partial-folder plus fxlogor logor 0 exact-negone? 2)
+        (partial-folder plus logxor logxor 0 (lambda (x) #f) 2)
+        (partial-folder plus bitwise-xor bitwise-xor 0 (lambda (x) #f) 2)
+        (partial-folder plus fxlogxor logxor 0 (lambda (x) #f) 2)
+        (partial-folder plus fxxor logxor 0 (lambda (x) #f) 2)
+        (partial-folder plus logand logand -1 exact-zero? 2)
+        (partial-folder plus bitwise-and bitwise-and -1 exact-zero? 2)
+        (partial-folder plus fxlogand logand -1 exact-zero? 2)
+        (partial-folder plus fxand logand -1 exact-zero? 2)
         )
 
       (let ()
diff --git a/s/front.ss b/s/front.ss
index 1ca36b0769..2912e468ff 100644
--- a/s/front.ss
+++ b/s/front.ss
@@ -104,6 +104,8 @@
 
 (define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
 
+(define enable-arithmetic-left-associative ($make-thread-parameter #f (lambda (x) (and x #t))))
+
 (define machine-type
   (lambda ()
     (constant machine-type-name)))
diff --git a/s/primdata.ss b/s/primdata.ss
index 244c957bd3..4b004da003 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -946,6 +946,7 @@
   (debug-on-exception [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (default-record-equal-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags])
   (default-record-hash-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags])
+  (enable-arithmetic-left-associative [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags])