suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add enable-arithmetic-left-associative

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

original commit: d126ba3364893e66263c65af1cd6dbdd8b021439
This commit is contained in:
Matthew Flatt 2019-01-21 10:51:16 -07:00
parent 03a33fb4fc
commit ae71f7472d
7 changed files with 295 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
LOG
View File

@ -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

13
csug/system.stex
View File

@ -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}

216
mats/cp0.ms
View File

@ -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

3
s/compile.ss
View File

@ -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)))

108
s/cp0.ss
View File

@ -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 ()

2
s/front.ss
View File

@ -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)))

1
s/primdata.ss
View File

@ -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])