Merge branch 'leftassoc' of github.com:mflatt/ChezScheme
original commit: 19d0cb77e6b6dd32fa4a7a26505ee952b4efa756
This commit is contained in:
Matthew Flatt
commit
67a0b0948f
3
LOG
3
LOG
|
|
@ -1070,3 +1070,6 @@
|
|||
- fix `string-titlecase` on special-casing characters like #\xDF and
|
||||
#\xFB00
|
||||
5_4.ss, 5_4.ms
|
||||
- added enable-arithmetic-left-associative
|
||||
cp0.ss, compile.ss, primdata.ss, front.ss, cp0.ms, 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.
|
||||
|
|
@ -2586,6 +2587,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
216
mats/cp0.ms
|
|
@ -1732,6 +1732,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
|
||||
|
|
@ -1815,8 +2027,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
|
||||
|
|
|
|||
|
|
@ -576,6 +576,7 @@
|
|||
[generate-interrupt-trap (generate-interrupt-trap)]
|
||||
[$optimize-closures ($optimize-closures)]
|
||||
[enable-cross-library-optimization (enable-cross-library-optimization)]
|
||||
[enable-arithmetic-left-associative (enable-arithmetic-left-associative)]
|
||||
[enable-type-recovery (enable-type-recovery)])
|
||||
(emit-header op (constant machine-type))
|
||||
(when hostop (emit-header hostop (host-machine-type)))
|
||||
|
|
|
|||
108
s/cp0.ss
108
s/cp0.ss
|
|
@ -2350,35 +2350,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)
|
||||
|
|
@ -2423,17 +2433,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
|
||||
|
|
@ -2447,13 +2459,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
|
||||
|
|
@ -2468,14 +2482,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?)
|
||||
|
||||
|
|
@ -2494,20 +2508,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 ()
|
||||
|
|
|
|||
|
|
@ -104,6 +104,7 @@
|
|||
|
||||
(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-who current-generate-id
|
||||
($make-thread-parameter
|
||||
|
|
@ -116,7 +117,6 @@
|
|||
|
||||
(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
|
||||
(define machine-type
|
||||
(lambda ()
|
||||
(constant machine-type-name)))
|
||||
|
|
|
|||
|
|
@ -948,6 +948,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-backreferences [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
|
||||
(enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user