Skip to content

Commit 2af3b91

Browse files
gus-massagus-massa
committed
add reductions for + in cptypes
Reduce + with some combinations of values that are known at compile time to be real (+ <fx> <fx> ...) => ($fxx+ <fx> <fx> ...) (+ <fl> <fx> ...) => (fl+ <fl> (fixnum->flonum <fx>) ...) (+ <fl> <real> ...) => (fl+ <fl> (real->flonum <real>) ...) (+ <fl> <fl> ...) => (fl+ <fl> <fl>) with some special cases for 0, in particular (+ <fl> 1 ...) => (fl+ <fl> 1.0 ...) (+ <fl> 0 ...) => (fl+ <fl> -0.0 ...) (+ 1.0 0 ...) => (fl+ 1.0 0.0 ...)
1 parent 6f80b4f commit 2af3b91

File tree

9 files changed

+260
-11
lines changed

9 files changed

+260
-11
lines changed

‎mats/cptypes.ms‎

Lines changed: 115 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,23 @@
5959
#;[optimize-level (max (optimize-level) 2)])
6060
(expand/optimize y)))]))
6161
62+
(define-syntax cptypes/first-equivalent-expansion?
63+
; When run-cp0 is call, use first #3%$cptypes and
64+
; then twice the cp0 function provided.
65+
; This checks that cptypes.ss doesn't mess up unusual combinations
66+
; that are reduced by cp0.
67+
(syntax-rules ()
68+
[(_ x y)
69+
(equivalent-expansion?
70+
(parameterize ([run-cp0 (lambda (cp0 c) (cp0 (cp0 (#3%$cptypes c))))]
71+
[#%$suppress-primitive-inlining #f]
72+
#;[optimize-level (max (optimize-level) 2)])
73+
(expand/optimize x))
74+
(parameterize ([run-cp0 (lambda (cp0 c) (cp0 (cp0 (#3%$cptypes c))))]
75+
[#%$suppress-primitive-inlining #f]
76+
#;[optimize-level (max (optimize-level) 2)])
77+
(expand/optimize y)))]))
78+
6279
(mat cptypes-handcoded
6380
(cptypes-equivalent-expansion?
6481
'(vector? (vector)) ;actually reduced by folding, not cptypes
@@ -664,6 +681,7 @@
664681
(test-chain* '(fixnum? integer? real?))
665682
(test-chain* '(fixnum? exact? number?)) ; exact? may raise an error
666683
(test-chain* '(bignum? exact? number?)) ; exact? may raise an error
684+
(test-chain '(fixnum? (lambda (x) (and (integer? x) (exact? x))) (lambda (x) (and (number? x) (exact? x))) number?))
667685
(test-chain '((lambda (x) (eqv? x (expt 256 100))) bignum? integer? real? number?))
668686
(test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?))
669687
(test-chain '((lambda (x) (eqv? 0.0 x)) flonum? cflonum? number?))
@@ -1043,6 +1061,103 @@
10431061
'(flonum? real? (lambda (x) (and (integer? x) (exact? x)))))
10441062
)
10451063
1064+
(mat cptypes-plus
1065+
(test-closed1 '(+ (lambda (x) (+ x 1)) (lambda (x) (+ x x)))
1066+
'(flonum? real? (lambda (x) (and (integer? x) (exact? x))) (lambda (x) (and (number? x) (exact? x)))))
1067+
(not (cptypes-equivalent-expansion? ; integer? is not closed
1068+
'(lambda (x) (when (integer? x) (integer? (+ x x))))
1069+
'(lambda (x) (when (integer? x) (+ x x) #t))))
1070+
(cptypes-equivalent-expansion?
1071+
'(lambda (x y) (when (and (fixnum? x) (fixnum? y))
1072+
(+ x y)))
1073+
'(lambda (x y) (when (and (fixnum? x) (fixnum? y))
1074+
(#3%$fxx+ x y))))
1075+
(cptypes-equivalent-expansion?
1076+
'(lambda (x y) (when (and (flonum? x) (flonum? y))
1077+
(+ x y)))
1078+
'(lambda (x y) (when (and (flonum? x) (flonum? y))
1079+
(#3%fl+ x y))))
1080+
(cptypes-equivalent-expansion?
1081+
'(lambda (x y) (when (and (number? x) (number? y))
1082+
(+ x y)))
1083+
'(lambda (x y) (when (and (number? x) (number? y))
1084+
(#3%+ x y))))
1085+
; in cp0, partial-folder reverses (+ x 1) to (+ 1 x)
1086+
(cptypes-equivalent-expansion?
1087+
'(lambda (x) (when (fixnum? x)
1088+
(+ 1 x)))
1089+
'(lambda (x) (when (fixnum? x)
1090+
(#3%$fxx+ 1 x))))
1091+
(cptypes-equivalent-expansion?
1092+
'(lambda (x) (when (flonum? x)
1093+
(+ 1 x)))
1094+
'(lambda (x) (when (flonum? x)
1095+
(#3%fl+ 1.0 x))))
1096+
(cptypes-equivalent-expansion?
1097+
'(lambda (x) (when (number? x)
1098+
(+ 1 x)))
1099+
'(lambda (x) (when (number? x)
1100+
(#3%+ 1 x))))
1101+
(cptypes-equivalent-expansion?
1102+
'(lambda (x) (when (fixnum? x)
1103+
(+ 1.0 x)))
1104+
'(lambda (x) (when (fixnum? x)
1105+
(#3%fl+ 1.0 (fixnum->flonum x)))))
1106+
(cptypes-equivalent-expansion?
1107+
'(lambda (x) (when (fixnum? x)
1108+
(+ -0.0 x)))
1109+
'(lambda (x) (when (fixnum? x)
1110+
(#3%fl+ -0.0 (if (#3%eqv? x 0) -0.0 (fixnum->flonum x))))))
1111+
(cptypes-equivalent-expansion?
1112+
'(lambda (x) (when (bignum? x)
1113+
(+ -0.0 x)))
1114+
'(lambda (x) (when (bignum? x)
1115+
(#3%fl+ -0.0 (real->flonum x)))))
1116+
(cptypes-equivalent-expansion?
1117+
'(lambda (x) (when (flonum? x)
1118+
(+ 1.0 x)))
1119+
'(lambda (x) (when (flonum? x)
1120+
(#3%fl+ 1.0 x))))
1121+
(cptypes-equivalent-expansion?
1122+
'(lambda (x) (when (number? x)
1123+
(+ 1.0 x)))
1124+
'(lambda (x) (when (number? x)
1125+
(#3%+ 1.0 x))))
1126+
(cptypes-equivalent-expansion?
1127+
'(lambda (x) (when (fixnum? x)
1128+
(+ 1 x x)))
1129+
'(lambda (x) (when (fixnum? x)
1130+
(#3%$fxx+ 1 x x))))
1131+
(cptypes-equivalent-expansion?
1132+
'(lambda (x) (when (flonum? x)
1133+
(+ 1 x x)))
1134+
'(lambda (x) (when (flonum? x)
1135+
(#3%fl+ 1.0 x x))))
1136+
(cptypes-equivalent-expansion?
1137+
'(lambda (x) (when (number? x)
1138+
(+ 1 x x)))
1139+
'(lambda (x) (when (number? x)
1140+
(#3%+ 1 x x))))
1141+
(cptypes/first-equivalent-expansion?
1142+
'(lambda (x) (+))
1143+
'(lambda (x) 0))
1144+
(cptypes/first-equivalent-expansion?
1145+
'(lambda (x) (+ 0))
1146+
'(lambda (x) 0))
1147+
(cptypes/first-equivalent-expansion?
1148+
'(lambda (x) (+ 0 0))
1149+
'(lambda (x) 0))
1150+
(cptypes/first-equivalent-expansion?
1151+
'(lambda (x) (+ 0 0.0))
1152+
'(lambda (x) 0.0))
1153+
(cptypes/first-equivalent-expansion?
1154+
'(lambda (x) (+ 0 -0.0))
1155+
'(lambda (x) -0.0))
1156+
(cptypes/first-equivalent-expansion?
1157+
'(lambda (x) (+ 0.0 -0.0))
1158+
'(lambda (x) 0.0))
1159+
)
1160+
10461161
(mat cptypes-rest-argument
10471162
(cptypes/nocp0-equivalent-expansion?
10481163
'((lambda (x . r) (pair? r)) 1)

‎release_notes/release_notes.stex‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -139,6 +139,7 @@ and \scheme{inexact?}, .
139139
The type recovery pass has improved support for \scheme{cfl+} and
140140
similar functions. Also improve the support of predicates, in
141141
particular integer?, zero? and similar predicates.
142+
Also, add suport for \scheme{+}.
142143

143144
\subsection{Unicode 16.0.0 support (10.3.0)}
144145

‎s/cp0.ss‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3077,6 +3077,7 @@
30773077
; the multiply case. maybe shouldn't bother with nans anyway.
30783078
(partial-folder plus + + 0 generic-nan?)
30793079
(partial-folder plus fx+ + 0 (lambda (x) #f) 3)
3080+
(partial-folder plus $fxx+ + 0 (lambda (x) #f))
30803081
(r6rs-fixnum-partial-folder plus r6rs:fx+ fx+ + 0 (lambda (x) #f) 3)
30813082
(r6rs-fixnum-partial-folder plus fx+/wraparound fx+/wraparound + 0 (lambda (x) #f) 3)
30823083
(partial-folder plus fl+ fl+ -0.0 fl-nan? #f obviously-fl?)

‎s/cpprim.ss‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1750,12 +1750,16 @@
17501750
,t))
17511751
(goto ,Lfalse))))])
17521752
(define-inline 3 $fxx+
1753+
[() `(immediate ,(fix 0))]
1754+
[(e) (ensure-single-valued e)]
17531755
[(e1 e2)
17541756
(bind #t (e1 e2)
17551757
(bind #f ([t (%inline +/ovfl ,e1 ,e2)])
17561758
`(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code)
17571759
,(build-libcall #t src sexpr + e1 e2)
1758-
,t)))])
1760+
,t)))]
1761+
[e* #f])
1762+
17591763
(let ()
17601764
(define (go src sexpr e1 e2)
17611765
(let ([Llib (make-local-label 'Llib)])

‎s/cptypes-lattice.ss‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,11 @@
6969
real-pred
7070
number-pred
7171
flzero-pred
72+
flinteger-pred
73+
exact-real-pred
74+
exact-pred
75+
inexact-pred
76+
integer-pred
7277
$fixmediate-pred
7378
$list-pred ; immutable lists
7479
list-pair-pred

‎s/cptypes.ss‎

Lines changed: 110 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -355,6 +355,49 @@ Notes:
355355
[(ref ,maybe-src ,x) (and (not (prelex-assigned x)) x)]
356356
[else #f])))
357357

358+
(define (real-expr->flonum-expr x r)
359+
; Transform 0 into 0.0 as usual
360+
; Assume (predicate-implies r real-pred)
361+
(cond
362+
[(and (Lsrc? r)
363+
(nanopass-case (Lsrc Expr) r
364+
[(quote ,d) d]
365+
[else #f])) =>
366+
(lambda (d) (make-1seq 'value x `(quote ,(real->flonum d))))]
367+
[(predicate-implies? r flonum-pred)
368+
x]
369+
[else
370+
(let ([->flonum-name (if (predicate-implies? r fixnum-pred)
371+
'fixnum->flonum
372+
'real->flonum)])
373+
`(call ,(make-preinfo-call) ,(lookup-primref 3 ->flonum-name) ,x))]))
374+
375+
(define (real-expr->flonum-expr/- x r)
376+
; Transform 0 into -0.0 instead of 0.0
377+
; Assume (predicate-implies r real-pred)
378+
(cond
379+
[(and (Lsrc? r)
380+
(nanopass-case (Lsrc Expr) r
381+
[(quote ,d) d]
382+
[else #f])) =>
383+
(lambda (d) (make-1seq 'value x `(quote ,(if (eqv? d 0) -0.0 (real->flonum d)))))]
384+
[(predicate-implies? r flonum-pred)
385+
x]
386+
[else
387+
(let ([->flonum-name (if (predicate-implies? r fixnum-pred)
388+
'fixnum->flonum
389+
'real->flonum)])
390+
(cond
391+
[(predicate-disjoint? r `(quote 0))
392+
`(call ,(make-preinfo-call) ,(lookup-primref 3 ->flonum-name) ,x)]
393+
[else
394+
(build-let 'value (list x) (list r)
395+
(lambda (x*)
396+
(let ([x (car x*)])
397+
`(if (call ,(make-preinfo-call) ,(lookup-primref 3 'eqv?) ,x (quote 0))
398+
(quote -0.0)
399+
(call ,(make-preinfo-call) ,(lookup-primref 3 ->flonum-name) ,x)))))]))]))
400+
358401
(define (filter/head+rest pred? l)
359402
; (filter/head+rest odd? '(1 3 2 5 4 6))
360403
; ==> (values '(1 3) '(2 5 4 6))
@@ -1135,6 +1178,73 @@ Notes:
11351178
(and (eq? ctxt 'test)
11361179
(pred-env-add/ref ntypes val (rtd->record-predicate rtd #t) plxc))
11371180
#f)]))])
1181+
1182+
(let ()
1183+
(define (predicate-implies-real? r) (predicate-implies? r real-pred))
1184+
(define (predicate-implies-fixnum? r) (predicate-implies? r fixnum-pred))
1185+
(define (predicate-implies-integer? r) (predicate-implies? r integer-pred))
1186+
(define (predicate-implies-flonum? r) (predicate-implies? r flonum-pred))
1187+
(define (predicate-implies-exact? r) (predicate-implies? r exact-pred))
1188+
(define (predicate-implies-inexact? r) (predicate-implies? r inexact-pred))
1189+
1190+
(define (predicate-close/plus r*)
1191+
(cond
1192+
[(andmap predicate-implies-exact? r*)
1193+
(if (andmap predicate-implies-real? r*)
1194+
(if (andmap predicate-implies-integer? r*)
1195+
exact-integer-pred
1196+
exact-real-pred)
1197+
exact-pred)]
1198+
[(ormap predicate-implies-inexact? r*)
1199+
(if (andmap predicate-implies-real? r*)
1200+
flonum-pred
1201+
inexact-pred)]
1202+
[else
1203+
(if (andmap predicate-implies-real? r*)
1204+
real-pred
1205+
number-pred)]))
1206+
1207+
(define-specialize 2 +
1208+
[() (values `(quote 0) `(quote 0) ntypes #f #f)]
1209+
[(x) (values `(call ,preinfo ,pr ,x)
1210+
(predicate-intersect (get-type x) number-pred) ntypes #f #f)]
1211+
[x* ; x* has at least 2 arguments
1212+
(let* ([r* (get-type x*)]
1213+
[ret (predicate-close/plus
1214+
(map (lambda (r) (predicate-intersect r number-pred)) r*))]
1215+
[ir (and (andmap predicate-implies-real? r*)
1216+
(cond
1217+
[(andmap predicate-implies-fixnum? r*)
1218+
`(call ,preinfo ,(lookup-primref 3 '$fxx+) ,x* ...)]
1219+
[(cond
1220+
[(enable-arithmetic-left-associative)
1221+
; if they can't be reordered, check that at least
1222+
; one of the first two is a flonum
1223+
(or (predicate-implies-flonum? (car r*))
1224+
(predicate-implies-flonum? (cadr r*)))]
1225+
[else
1226+
; otherwise, checkt that all or all but one are flonums,
1227+
; in case they are reordered
1228+
(let-values ([(head* rest*)
1229+
(filter/head+rest predicate-implies-flonum? r*)])
1230+
(or (null? rest*)
1231+
(andmap predicate-implies-flonum? (cdr rest*))))])
1232+
(cond
1233+
[(ormap (lambda (r) (and (predicate-disjoint? r `(quote -0.0))
1234+
(predicate-disjoint? r `(quote 0))))
1235+
r*)
1236+
; If one argument is neither 0 or -0.0 it's possible
1237+
; to replace 0 with 0.0 instead of -0.0
1238+
; because the rounding mode is never FE_DOWNWARD
1239+
`(call ,preinfo ,(lookup-primref 3 'fl+)
1240+
,(map real-expr->flonum-expr x* r*) ...)]
1241+
[else
1242+
`(call ,preinfo ,(lookup-primref 3 'fl+)
1243+
,(map real-expr->flonum-expr/- x* r*) ...)])]
1244+
[else
1245+
#f]))])
1246+
(values (or ir `(call ,preinfo ,pr ,x* ...)) ret ntypes #f #f))])
1247+
)
11381248

11391249
(define-specialize 2 (add1 sub1 1+ 1- -1+)
11401250
[(n) (let ([r (get-type n)])

‎s/mathprims.ss‎

Lines changed: 21 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -524,10 +524,27 @@
524524
(#3%$fxu< x y)))
525525

526526
(set! $fxx+
527-
(lambda (x y)
528-
(unless (fixnum? x) (fxargerr '$fxx+ x))
529-
(unless (fixnum? y) (fxargerr '$fxx+ y))
530-
(#3%$fxx+ x y)))
527+
(case-lambda
528+
[(x1 x2)
529+
(unless (fixnum? x1) (fxargerr '$fxx+ x1))
530+
(unless (fixnum? x2) (fxargerr '$fxx+ x2))
531+
(#3%$fxx+ x1 x2)]
532+
[(x1 x2 x3)
533+
(unless (fixnum? x1) (fxargerr '$fxx+ x1))
534+
(unless (fixnum? x2) (fxargerr '$fxx+ x2))
535+
(unless (fixnum? x3) (fxargerr '$fxx+ x3))
536+
(#3%+ (#3%$fxx+ x1 x2) x3)]
537+
[(x1 x2 x3 . rest)
538+
(unless (fixnum? x1) (fxargerr '$fxx+ x1))
539+
(unless (fixnum? x2) (fxargerr '$fxx+ x2))
540+
(let loop ([x1 (#3%$fxx+ x1 x2)] [x3 x3] [rest rest])
541+
(unless (fixnum? x3) (fxargerr '$fxx+ x3))
542+
(let ([x (#3%+ x1 x3)])
543+
(if (null? rest) x (loop x (car rest) (cdr rest)))))]
544+
[(x1)
545+
(unless (fixnum? x1) (fxargerr '$fxx+ x1))
546+
x1]
547+
[() 0]))
531548

532549
(define-addop fxlogand)
533550
(define-addop fxlogior)

‎s/primdata.ss‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -211,7 +211,7 @@
211211
(nan? [sig [(real) -> (boolean)]] [pred nan] [flags pure mifoldable discard safeongoodargs cptypes2])
212212
(max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs cptypes2])
213213
(min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs cptypes2])
214-
(+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
214+
(+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs cptypes2])
215215
(* [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
216216
(- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
217217
(/ [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
@@ -2215,7 +2215,7 @@
22152215
($fxu< [flags single-valued pure cp02])
22162216
($fxvector-ref-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted pure])
22172217
($fxvector-set!-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted discard])
2218-
($fxx+ [sig [(fixnum fixnum) -> (sint)]] [flags arith-op safeongoodargs])
2218+
($fxx+ [sig [(fixnum ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
22192219
($gc-cpu-time [flags true])
22202220
($gc-real-time [flags true])
22212221
($generation [flags single-valued])

‎s/prims.ss‎

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -832,10 +832,6 @@
832832
(lambda (x y)
833833
($fx+? x y)))
834834

835-
(define $fxx+
836-
(lambda (x y)
837-
($fxx+ x y)))
838-
839835
(define $fx-?
840836
(lambda (x y)
841837
($fx-? x y)))

0 commit comments

Comments
 (0)