Skip to content

Commit 6b333ee

Browse files
gus-massagus-massa
authored
Add reductions for + and - in cptypes (#959)
Reduce + and - 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>) (- <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 ...) (- <fl> 1 ...) => (fl- <fl> 1.0 ...) (- 1 <fl> ...) => (fl- 1.0 <fl> ...) (- <fl> 0 ...) => (fl- <fl> 0.0 ...) (- 0 <fl> ...) => (fl- -0.0 <fl> ...) * Add $fxx- primitive And small changes to the reductions of `abs` and `sub1` in cptypes
1 parent 6f80b4f commit 6b333ee

File tree

15 files changed

+540
-28
lines changed

15 files changed

+540
-28
lines changed

‎boot/pb/equates.h‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
/* equates.h for Chez Scheme Version 10.3.0-pre-release.2 */
1+
/* equates.h for Chez Scheme Version 10.3.0-pre-release.3 */
22

33
/* Do not edit this file. It is automatically generated and */
44
/* specifically tailored to the version of Chez Scheme named */
@@ -1015,7 +1015,7 @@ typedef uint64_t U64;
10151015
#define rtd_sealed 0x4
10161016
#define sbwp (ptr)0x4E
10171017
#define scaled_shot_1_shot_flag -0x8
1018-
#define scheme_version 0xA030002
1018+
#define scheme_version 0xA030003
10191019
#define seginfo_generation_disp 0x1
10201020
#define seginfo_list_bits_disp 0x8
10211021
#define seginfo_space_disp 0x0

‎boot/pb/petite.boot‎

24 KB
Binary file not shown.

‎boot/pb/scheme.boot‎

4.66 KB
Binary file not shown.

‎boot/pb/scheme.h‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
/* scheme.h for Chez Scheme Version 10.3.0-pre-release.2 (pb) */
1+
/* scheme.h for Chez Scheme Version 10.3.0-pre-release.3 (pb) */
22

33
/* Do not edit this file. It is automatically generated and */
44
/* specifically tailored to the version of Chez Scheme named */
@@ -40,7 +40,7 @@
4040
#endif
4141

4242
/* Chez Scheme Version and machine type */
43-
#define VERSION "10.3.0-pre-release.2"
43+
#define VERSION "10.3.0-pre-release.3"
4444
#define MACHINE_TYPE "pb"
4545

4646
/* Integer typedefs */

‎mats/cptypes.ms‎

Lines changed: 297 additions & 6 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?))
@@ -980,7 +998,7 @@
980998
'(lambda (x) (when (fixnum? x)
981999
(sub1 x)))
9821000
'(lambda (x) (when (fixnum? x)
983-
(#3%$fxx+ x -1))))
1001+
(#3%$fxx- x 1))))
9841002
(not (cptypes-equivalent-expansion?
9851003
'(lambda (x) (when (fixnum? x)
9861004
(fixnum? (sub1 x))))
@@ -1000,7 +1018,7 @@
10001018
'(lambda (x) (when (fixnum? x)
10011019
(1- x)))
10021020
'(lambda (x) (when (fixnum? x)
1003-
(#3%$fxx+ x -1))))
1021+
(#3%$fxx- x 1))))
10041022
(cptypes-equivalent-expansion?
10051023
'(lambda (x) (when (flonum? x)
10061024
(1- x)))
@@ -1010,7 +1028,7 @@
10101028
'(lambda (x) (when (fixnum? x)
10111029
(-1+ x)))
10121030
'(lambda (x) (when (fixnum? x)
1013-
(#3%$fxx+ x -1))))
1031+
(#3%$fxx- x 1))))
10141032
(cptypes-equivalent-expansion?
10151033
'(lambda (x) (when (flonum? x)
10161034
(-1+ x)))
@@ -1026,9 +1044,9 @@
10261044
(abs x)))
10271045
'(lambda (x) (when (fixnum? x)
10281046
(let ([t x])
1029-
(if (#3%fx= t (most-negative-fixnum))
1030-
(pariah (- (most-negative-fixnum)))
1031-
(#3%fxabs t))))))
1047+
(if (#3%fx>= t 0)
1048+
t
1049+
(#3%$fxx- t))))))
10321050
(cptypes-equivalent-expansion? ; unexpected, but correct
10331051
'(lambda (x) (when (bignum? x)
10341052
(bignum? (abs x))))
@@ -1043,6 +1061,279 @@
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+
1161+
(mat cptypes-minus
1162+
(test-closed1 '(- (lambda (x) (- x 1)) (lambda (x) (- 1 x)) (lambda (x) (- x x)))
1163+
'(flonum? real? (lambda (x) (and (integer? x) (exact? x))) (lambda (x) (and (number? x) (exact? x)))))
1164+
(not (cptypes-equivalent-expansion? ; integer? is not closed
1165+
'(lambda (x y) (when (and (integer? x) (integer? y)) (integer? (- x y))))
1166+
'(lambda (x y) (when (and (integer? x) (integer? y)) (- x y) #t))))
1167+
(cptypes-equivalent-expansion?
1168+
'(lambda (x y) (when (and (fixnum? x) (fixnum? y))
1169+
(- x y)))
1170+
'(lambda (x y) (when (and (fixnum? x) (fixnum? y))
1171+
(#3%$fxx- x y))))
1172+
(cptypes-equivalent-expansion?
1173+
'(lambda (x y) (when (and (flonum? x) (flonum? y))
1174+
(- x y)))
1175+
'(lambda (x y) (when (and (flonum? x) (flonum? y))
1176+
(#3%fl- x y))))
1177+
(cptypes-equivalent-expansion?
1178+
'(lambda (x y) (when (and (number? x) (number? y))
1179+
(- x y)))
1180+
'(lambda (x y) (when (and (number? x) (number? y))
1181+
(#3%- x y))))
1182+
(cptypes-equivalent-expansion?
1183+
'(lambda (x) (when (fixnum? x)
1184+
(- 1 x)))
1185+
'(lambda (x) (when (fixnum? x)
1186+
(#3%$fxx- 1 x))))
1187+
(cptypes-equivalent-expansion?
1188+
'(lambda (x) (when (flonum? x)
1189+
(- 1 x)))
1190+
'(lambda (x) (when (flonum? x)
1191+
(#3%fl- 1.0 x))))
1192+
(cptypes-equivalent-expansion?
1193+
'(lambda (x) (when (number? x)
1194+
(- 1 x)))
1195+
'(lambda (x) (when (number? x)
1196+
(#3%- 1 x))))
1197+
(cptypes-equivalent-expansion?
1198+
'(lambda (x) (when (fixnum? x)
1199+
(- x 1)))
1200+
'(lambda (x) (when (fixnum? x)
1201+
(#3%$fxx- x 1))))
1202+
(cptypes-equivalent-expansion?
1203+
'(lambda (x) (when (flonum? x)
1204+
(- x 1)))
1205+
'(lambda (x) (when (flonum? x)
1206+
(#3%fl- x 1.0))))
1207+
(cptypes-equivalent-expansion?
1208+
'(lambda (x) (when (number? x)
1209+
(- x 1)))
1210+
'(lambda (x) (when (number? x)
1211+
(#3%- x 1))))
1212+
(cptypes-equivalent-expansion?
1213+
'(lambda (x) (when (fixnum? x)
1214+
(- 1.0 x)))
1215+
'(lambda (x) (when (fixnum? x)
1216+
(#3%fl- 1.0 (fixnum->flonum x)))))
1217+
(cptypes-equivalent-expansion?
1218+
'(lambda (x) (when (fixnum? x)
1219+
(- x 1.0)))
1220+
'(lambda (x) (when (fixnum? x)
1221+
(#3%fl- (fixnum->flonum x) 1.0))))
1222+
(cptypes-equivalent-expansion?
1223+
'(lambda (x) (when (fixnum? x)
1224+
(- -0.0 x)))
1225+
'(lambda (x) (when (fixnum? x)
1226+
(#3%fl- -0.0 (fixnum->flonum x)))))
1227+
(cptypes-equivalent-expansion?
1228+
'(lambda (x) (when (bignum? x)
1229+
(- -0.0 x)))
1230+
'(lambda (x) (when (bignum? x)
1231+
(#3%fl- -0.0 (real->flonum x)))))
1232+
(cptypes-equivalent-expansion?
1233+
'(lambda (x) (when (fixnum? x)
1234+
(- x -0.0)))
1235+
'(lambda (x) (when (fixnum? x)
1236+
(#3%fl- (fixnum->flonum x) -0.0))))
1237+
(cptypes-equivalent-expansion?
1238+
'(lambda (x) (when (bignum? x)
1239+
(- x -0.0)))
1240+
'(lambda (x) (when (bignum? x)
1241+
(#3%fl- (real->flonum x) -0.0))))
1242+
(cptypes-equivalent-expansion?
1243+
'(lambda (x) (when (fixnum? x)
1244+
(- 0.0 x)))
1245+
'(lambda (x) (when (fixnum? x)
1246+
(#3%fl- 0.0 (fixnum->flonum x)))))
1247+
(cptypes-equivalent-expansion?
1248+
'(lambda (x) (when (bignum? x)
1249+
(- 0.0 x)))
1250+
'(lambda (x) (when (bignum? x)
1251+
(#3%fl- 0.0 (real->flonum x)))))
1252+
(cptypes-equivalent-expansion?
1253+
'(lambda (x) (when (fixnum? x)
1254+
(- x 0.0)))
1255+
'(lambda (x) (when (fixnum? x)
1256+
(#3%fl- (if (#3%eqv? x 0) -0.0 (fixnum->flonum x)) 0.0))))
1257+
(cptypes-equivalent-expansion?
1258+
'(lambda (x) (when (bignum? x)
1259+
(- x 0.0)))
1260+
'(lambda (x) (when (bignum? x)
1261+
(#3%fl- (real->flonum x) 0.0))))
1262+
(cptypes-equivalent-expansion?
1263+
'(lambda (x) (when (flonum? x)
1264+
(- 1.0 x)))
1265+
'(lambda (x) (when (flonum? x)
1266+
(#3%fl- 1.0 x))))
1267+
(cptypes-equivalent-expansion?
1268+
'(lambda (x) (when (number? x)
1269+
(- 1.0 x)))
1270+
'(lambda (x) (when (number? x)
1271+
(#3%- 1.0 x))))
1272+
(cptypes-equivalent-expansion?
1273+
'(lambda (x) (when (flonum? x)
1274+
(- x 1.0)))
1275+
'(lambda (x) (when (flonum? x)
1276+
(#3%fl- x 1.0))))
1277+
(cptypes-equivalent-expansion?
1278+
'(lambda (x) (when (number? x)
1279+
(- x 1.0)))
1280+
'(lambda (x) (when (number? x)
1281+
(#3%- x 1.0))))
1282+
(cptypes-equivalent-expansion?
1283+
'(lambda (x) (when (number? x)
1284+
(- x 1.0)))
1285+
'(lambda (x) (when (number? x)
1286+
(#3%- x 1.0))))
1287+
(cptypes-equivalent-expansion?
1288+
'(lambda (x) (when (fixnum? x)
1289+
(- 1 x x)))
1290+
'(lambda (x) (when (fixnum? x)
1291+
(#3%$fxx- 1 x x))))
1292+
(cptypes-equivalent-expansion?
1293+
'(lambda (x) (when (flonum? x)
1294+
(- 1 x x)))
1295+
'(lambda (x) (when (flonum? x)
1296+
(#3%fl- 1.0 x x))))
1297+
(cptypes-equivalent-expansion?
1298+
'(lambda (x) (when (number? x)
1299+
(- 1 x x)))
1300+
'(lambda (x) (when (number? x)
1301+
(#3%- 1 x x))))
1302+
(cptypes-equivalent-expansion?
1303+
'(lambda (x) (when (fixnum? x)
1304+
(- x 1 x)))
1305+
'(lambda (x) (when (fixnum? x)
1306+
(#3%$fxx- x 1 x))))
1307+
(cptypes-equivalent-expansion?
1308+
'(lambda (x) (when (flonum? x)
1309+
(- x 1 x)))
1310+
'(lambda (x) (when (flonum? x)
1311+
(#3%fl- x 1.0 x))))
1312+
(cptypes-equivalent-expansion?
1313+
'(lambda (x) (when (number? x)
1314+
(- x 1 x)))
1315+
'(lambda (x) (when (number? x)
1316+
(#3%- x 1 x))))
1317+
(cptypes/first-equivalent-expansion?
1318+
'(lambda (x) (- 0))
1319+
'(lambda (x) 0))
1320+
(cptypes/first-equivalent-expansion?
1321+
'(lambda (x) (- 0 0))
1322+
'(lambda (x) 0))
1323+
(cptypes/first-equivalent-expansion?
1324+
'(lambda (x) (- 0 0.0))
1325+
'(lambda (x) -0.0))
1326+
(cptypes/first-equivalent-expansion?
1327+
'(lambda (x) (- 0 -0.0))
1328+
'(lambda (x) 0.0))
1329+
(cptypes/first-equivalent-expansion?
1330+
'(lambda (x) (- 0.0 -0.0))
1331+
'(lambda (x) 0.0))
1332+
(cptypes/first-equivalent-expansion?
1333+
'(lambda (x) (- -0.0 0.0))
1334+
'(lambda (x) -0.0))
1335+
)
1336+
10461337
(mat cptypes-rest-argument
10471338
(cptypes/nocp0-equivalent-expansion?
10481339
'((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{+} abd \scheme{-}.
142143

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

‎s/cmacros.ss‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -357,7 +357,7 @@
357357
;; ---------------------------------------------------------------------
358358
;; Version and machine types:
359359

360-
(define-constant scheme-version #x0a030002)
360+
(define-constant scheme-version #x0a030003)
361361

362362
(define-syntax define-machine-types
363363
(lambda (x)

0 commit comments

Comments
 (0)