Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009-2010,2014,2016-2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | (* | |
11 | * If you add new polymorphic primitives, you must modify extractTargs. | |
12 | *) | |
13 | ||
14 | functor Prim (S: PRIM_STRUCTS): PRIM = | |
15 | struct | |
16 | ||
17 | open S | |
18 | ||
19 | local | |
20 | open Const | |
21 | in | |
22 | structure RealX = RealX | |
23 | structure WordX = WordX | |
24 | structure WordXVector = WordXVector | |
25 | end | |
26 | ||
27 | structure Kind = | |
28 | struct | |
29 | datatype t = | |
30 | DependsOnState | |
31 | | Functional | |
32 | | Moveable | |
33 | | SideEffect | |
34 | end | |
35 | ||
36 | datatype 'a t = | |
37 | Array_alloc of {raw: bool} (* to rssa (as runtime C fn) *) | |
38 | | Array_copyArray (* to rssa (as runtime C fn) *) | |
39 | | Array_copyVector (* to rssa (as runtime C fn) *) | |
40 | | Array_length (* to rssa *) | |
41 | | Array_sub (* to ssa2 *) | |
42 | | Array_toArray (* to rssa *) | |
43 | | Array_toVector (* to rssa *) | |
44 | | Array_uninit (* to rssa *) | |
45 | | Array_uninitIsNop (* to rssa *) | |
46 | | Array_update (* to ssa2 *) | |
47 | | CPointer_add (* codegen *) | |
48 | | CPointer_diff (* codegen *) | |
49 | | CPointer_equal (* codegen *) | |
50 | | CPointer_fromWord (* codegen *) | |
51 | | CPointer_getCPointer (* to rssa *) | |
52 | | CPointer_getObjptr (* to rssa *) | |
53 | | CPointer_getReal of RealSize.t (* to rssa *) | |
54 | | CPointer_getWord of WordSize.t (* to rssa *) | |
55 | | CPointer_lt (* codegen *) | |
56 | | CPointer_setCPointer (* to rssa *) | |
57 | | CPointer_setObjptr (* to rssa *) | |
58 | | CPointer_setReal of RealSize.t (* to rssa *) | |
59 | | CPointer_setWord of WordSize.t (* to rssa *) | |
60 | | CPointer_sub (* codegen *) | |
61 | | CPointer_toWord (* codegen *) | |
62 | | Exn_extra (* implement exceptions *) | |
63 | | Exn_name (* implement exceptions *) | |
64 | | Exn_setExtendExtra (* implement exceptions *) | |
65 | | FFI of 'a CFunction.t (* to rssa *) | |
66 | | FFI_Symbol of {name: string, | |
67 | cty: CType.t option, | |
68 | symbolScope: CFunction.SymbolScope.t } (* codegen *) | |
69 | | GC_collect (* to rssa (as runtime C fn) *) | |
70 | | IntInf_add (* to rssa (as runtime C fn) *) | |
71 | | IntInf_andb (* to rssa (as runtime C fn) *) | |
72 | | IntInf_arshift (* to rssa (as runtime C fn) *) | |
73 | | IntInf_compare (* to rssa (as runtime C fn) *) | |
74 | | IntInf_gcd (* to rssa (as runtime C fn) *) | |
75 | | IntInf_lshift (* to rssa (as runtime C fn) *) | |
76 | | IntInf_mul (* to rssa (as runtime C fn) *) | |
77 | | IntInf_neg (* to rssa (as runtime C fn) *) | |
78 | | IntInf_notb (* to rssa (as runtime C fn) *) | |
79 | | IntInf_orb (* to rssa (as runtime C fn) *) | |
80 | | IntInf_quot (* to rssa (as runtime C fn) *) | |
81 | | IntInf_rem (* to rssa (as runtime C fn) *) | |
82 | | IntInf_sub (* to rssa (as runtime C fn) *) | |
83 | | IntInf_toString (* to rssa (as runtime C fn) *) | |
84 | | IntInf_toVector (* to rssa *) | |
85 | | IntInf_toWord (* to rssa *) | |
86 | | IntInf_xorb (* to rssa (as runtime C fn) *) | |
87 | (* of type unit -> 'a. | |
88 | * Makes a bogus value of any type. | |
89 | *) | |
90 | | MLton_bogus (* to rssa *) | |
91 | | MLton_bug (* to rssa (as impure C fn) *) | |
92 | | MLton_deserialize (* unused *) | |
93 | | MLton_eq (* to rssa (as Word_equal) *) | |
94 | | MLton_equal (* polymorphic equality *) | |
95 | | MLton_halt (* to rssa (as runtime C fn) *) | |
96 | | MLton_hash (* polymorphic hash *) | |
97 | (* MLton_handlesSignals and MLton_installSignalHandler work together | |
98 | * to inform the optimizer and basis library whether or not the | |
99 | * program uses signal handlers. | |
100 | * | |
101 | * MLton_installSignalHandler is called by MLton.Signal.setHandler, | |
102 | * and is effectively a noop, but is left in the program until, so | |
103 | * that the optimizer can test whether or not the program installs | |
104 | * signal handlers. | |
105 | * | |
106 | * MLton_handlesSignals is translated by closure conversion into | |
107 | * a boolean, and is true iff MLton_installsSignalHandler is called. | |
108 | *) | |
109 | | MLton_handlesSignals (* closure conversion *) | |
110 | | MLton_installSignalHandler (* to rssa (as nop) *) | |
111 | | MLton_serialize (* unused *) | |
112 | | MLton_share (* to rssa (as nop or runtime C fn) *) | |
113 | | MLton_size (* to rssa (as runtime C fn) *) | |
114 | | MLton_touch (* to rssa (as nop) or backend (as nop) *) | |
115 | | Real_Math_acos of RealSize.t (* codegen *) | |
116 | | Real_Math_asin of RealSize.t (* codegen *) | |
117 | | Real_Math_atan of RealSize.t (* codegen *) | |
118 | | Real_Math_atan2 of RealSize.t (* codegen *) | |
119 | | Real_Math_cos of RealSize.t (* codegen *) | |
120 | | Real_Math_exp of RealSize.t (* codegen *) | |
121 | | Real_Math_ln of RealSize.t (* codegen *) | |
122 | | Real_Math_log10 of RealSize.t (* codegen *) | |
123 | | Real_Math_sin of RealSize.t (* codegen *) | |
124 | | Real_Math_sqrt of RealSize.t (* codegen *) | |
125 | | Real_Math_tan of RealSize.t (* codegen *) | |
126 | | Real_abs of RealSize.t (* codegen *) | |
127 | | Real_add of RealSize.t (* codegen *) | |
128 | | Real_castToWord of RealSize.t * WordSize.t (* codegen *) | |
129 | | Real_div of RealSize.t (* codegen *) | |
130 | | Real_equal of RealSize.t (* codegen *) | |
131 | | Real_ldexp of RealSize.t (* codegen *) | |
132 | | Real_le of RealSize.t (* codegen *) | |
133 | | Real_lt of RealSize.t (* codegen *) | |
134 | | Real_mul of RealSize.t (* codegen *) | |
135 | | Real_muladd of RealSize.t (* codegen *) | |
136 | | Real_mulsub of RealSize.t (* codegen *) | |
137 | | Real_neg of RealSize.t (* codegen *) | |
138 | | Real_qequal of RealSize.t (* codegen *) | |
139 | | Real_rndToReal of RealSize.t * RealSize.t (* codegen *) | |
140 | | Real_rndToWord of RealSize.t * WordSize.t * {signed: bool} (* codegen *) | |
141 | | Real_round of RealSize.t (* codegen *) | |
142 | | Real_sub of RealSize.t (* codegen *) | |
143 | | Ref_assign (* to ssa2 *) | |
144 | | Ref_deref (* to ssa2 *) | |
145 | | Ref_ref (* to ssa2 *) | |
146 | | String_toWord8Vector (* defunctorize *) | |
147 | | Thread_atomicBegin (* to rssa *) | |
148 | | Thread_atomicEnd (* to rssa *) | |
149 | | Thread_atomicState (* to rssa *) | |
150 | | Thread_copy (* to rssa (as runtime C fn) *) | |
151 | | Thread_copyCurrent (* to rssa (as runtime C fn) *) | |
152 | | Thread_returnToC (* codegen *) | |
153 | (* switchTo has to be a _prim because we have to know that it | |
154 | * enters the runtime -- because everything must be saved | |
155 | * on the stack. | |
156 | *) | |
157 | | Thread_switchTo (* to rssa (as runtime C fn) *) | |
158 | | TopLevel_getHandler (* implement exceptions *) | |
159 | | TopLevel_getSuffix (* implement suffix *) | |
160 | | TopLevel_setHandler (* implement exceptions *) | |
161 | | TopLevel_setSuffix (* implement suffix *) | |
162 | | Vector_length (* to ssa2 *) | |
163 | | Vector_sub (* to ssa2 *) | |
164 | | Vector_vector (* to ssa2 *) | |
165 | | Weak_canGet (* to rssa (as runtime C fn) *) | |
166 | | Weak_get (* to rssa (as runtime C fn) *) | |
167 | | Weak_new (* to rssa (as runtime C fn) *) | |
168 | | Word_add of WordSize.t (* codegen *) | |
169 | | Word_addCheck of WordSize.t * {signed: bool} (* codegen *) | |
170 | | Word_andb of WordSize.t (* codegen *) | |
171 | | Word_castToReal of WordSize.t * RealSize.t (* codegen *) | |
172 | | Word_equal of WordSize.t (* codegen *) | |
173 | | Word_extdToWord of WordSize.t * WordSize.t * {signed: bool} (* codegen *) | |
174 | | Word_lshift of WordSize.t (* codegen *) | |
175 | | Word_lt of WordSize.t * {signed: bool} (* codegen *) | |
176 | | Word_mul of WordSize.t * {signed: bool} (* codegen *) | |
177 | | Word_mulCheck of WordSize.t * {signed: bool} (* codegen *) | |
178 | | Word_neg of WordSize.t (* codegen *) | |
179 | | Word_negCheck of WordSize.t (* codegen *) | |
180 | | Word_notb of WordSize.t (* codegen *) | |
181 | | Word_orb of WordSize.t (* codegen *) | |
182 | | Word_quot of WordSize.t * {signed: bool} (* codegen *) | |
183 | | Word_rem of WordSize.t * {signed: bool} (* codegen *) | |
184 | | Word_rndToReal of WordSize.t * RealSize.t * {signed: bool} (* codegen *) | |
185 | | Word_rol of WordSize.t (* codegen *) | |
186 | | Word_ror of WordSize.t (* codegen *) | |
187 | | Word_rshift of WordSize.t * {signed: bool} (* codegen *) | |
188 | | Word_sub of WordSize.t (* codegen *) | |
189 | | Word_subCheck of WordSize.t * {signed: bool} (* codegen *) | |
190 | | Word_toIntInf (* to rssa *) | |
191 | | Word_xorb of WordSize.t (* codegen *) | |
192 | | WordVector_toIntInf (* to rssa *) | |
193 | | WordArray_subWord of {seqSize:WordSize.t, eleSize:WordSize.t} (* to rssa *) | |
194 | | WordArray_updateWord of {seqSize: WordSize.t, eleSize: WordSize.t} (* to rssa *) | |
195 | | WordVector_subWord of {seqSize: WordSize.t, eleSize: WordSize.t} (* to rssa *) | |
196 | | Word8Vector_toString (* defunctorize *) | |
197 | | World_save (* to rssa (as runtime C fn) *) | |
198 | ||
199 | fun name p = p | |
200 | ||
201 | (* The values of these strings are important since they are referred to | |
202 | * in the basis library code. See basis-library/misc/primitive.sml. | |
203 | *) | |
204 | fun toString (n: 'a t): string = | |
205 | let | |
206 | fun real (s: RealSize.t, str: string): string = | |
207 | concat ["Real", RealSize.toString s, "_", str] | |
208 | fun sign {signed} = if signed then "WordS" else "WordU" | |
209 | fun word (s: WordSize.t, str: string): string = | |
210 | concat ["Word", WordSize.toString s, "_", str] | |
211 | fun wordSeq (seqSize: WordSize.t, seqKind: string, oper: string, eleSize: WordSize.t): string = | |
212 | concat ["Word", WordSize.toString seqSize, seqKind, "_", oper, "Word", WordSize.toString eleSize] | |
213 | fun wordS (s: WordSize.t, sg, str: string): string = | |
214 | concat [sign sg, WordSize.toString s, "_", str] | |
215 | val realC = ("Real", RealSize.toString) | |
216 | val wordC = ("Word", WordSize.toString) | |
217 | fun wordCS sg = (sign sg, WordSize.toString) | |
218 | fun coerce (k, (n, sizeToString), (n', sizeToString'), s, s'): string = | |
219 | concat [n, sizeToString s, "_", k ,"To", n', sizeToString' s'] | |
220 | fun cast (c, c', s, s') = coerce ("cast", c, c', s, s') | |
221 | fun extd (c, c', s, s') = coerce ("extd", c, c', s, s') | |
222 | fun rnd (c, c', s, s') = coerce ("rnd", c, c', s, s') | |
223 | fun cpointerGet (ty, s) = concat ["CPointer_get", ty, s] | |
224 | fun cpointerSet (ty, s) = concat ["CPointer_set", ty, s] | |
225 | in | |
226 | case n of | |
227 | Array_alloc {raw} => if raw then "Array_allocRaw" else "Array_alloc" | |
228 | | Array_copyArray => "Array_copyArray" | |
229 | | Array_copyVector => "Array_copyVector" | |
230 | | Array_length => "Array_length" | |
231 | | Array_sub => "Array_sub" | |
232 | | Array_toArray => "Array_toArray" | |
233 | | Array_toVector => "Array_toVector" | |
234 | | Array_uninit => "Array_uninit" | |
235 | | Array_uninitIsNop => "Array_uninitIsNop" | |
236 | | Array_update => "Array_update" | |
237 | | CPointer_add => "CPointer_add" | |
238 | | CPointer_diff => "CPointer_diff" | |
239 | | CPointer_equal => "CPointer_equal" | |
240 | | CPointer_fromWord => "CPointer_fromWord" | |
241 | | CPointer_getCPointer => "CPointer_getCPointer" | |
242 | | CPointer_getObjptr => "CPointer_getObjptr" | |
243 | | CPointer_getReal s => cpointerGet ("Real", RealSize.toString s) | |
244 | | CPointer_getWord s => cpointerGet ("Word", WordSize.toString s) | |
245 | | CPointer_lt => "CPointer_lt" | |
246 | | CPointer_setCPointer => "CPointer_setCPointer" | |
247 | | CPointer_setObjptr => "CPointer_setObjptr" | |
248 | | CPointer_setReal s => cpointerSet ("Real", RealSize.toString s) | |
249 | | CPointer_setWord s => cpointerSet ("Word", WordSize.toString s) | |
250 | | CPointer_sub => "CPointer_sub" | |
251 | | CPointer_toWord => "CPointer_toWord" | |
252 | | Exn_extra => "Exn_extra" | |
253 | | Exn_name => "Exn_name" | |
254 | | Exn_setExtendExtra => "Exn_setExtendExtra" | |
255 | | FFI f => (CFunction.Target.toString o CFunction.target) f | |
256 | | FFI_Symbol {name, ...} => name | |
257 | | GC_collect => "GC_collect" | |
258 | | IntInf_add => "IntInf_add" | |
259 | | IntInf_andb => "IntInf_andb" | |
260 | | IntInf_arshift => "IntInf_arshift" | |
261 | | IntInf_compare => "IntInf_compare" | |
262 | | IntInf_gcd => "IntInf_gcd" | |
263 | | IntInf_lshift => "IntInf_lshift" | |
264 | | IntInf_mul => "IntInf_mul" | |
265 | | IntInf_neg => "IntInf_neg" | |
266 | | IntInf_notb => "IntInf_notb" | |
267 | | IntInf_orb => "IntInf_orb" | |
268 | | IntInf_quot => "IntInf_quot" | |
269 | | IntInf_rem => "IntInf_rem" | |
270 | | IntInf_sub => "IntInf_sub" | |
271 | | IntInf_toString => "IntInf_toString" | |
272 | | IntInf_toVector => "IntInf_toVector" | |
273 | | IntInf_toWord => "IntInf_toWord" | |
274 | | IntInf_xorb => "IntInf_xorb" | |
275 | | MLton_bogus => "MLton_bogus" | |
276 | | MLton_bug => "MLton_bug" | |
277 | | MLton_deserialize => "MLton_deserialize" | |
278 | | MLton_eq => "MLton_eq" | |
279 | | MLton_equal => "MLton_equal" | |
280 | | MLton_halt => "MLton_halt" | |
281 | | MLton_hash => "MLton_hash" | |
282 | | MLton_handlesSignals => "MLton_handlesSignals" | |
283 | | MLton_installSignalHandler => "MLton_installSignalHandler" | |
284 | | MLton_serialize => "MLton_serialize" | |
285 | | MLton_share => "MLton_share" | |
286 | | MLton_size => "MLton_size" | |
287 | | MLton_touch => "MLton_touch" | |
288 | | Real_Math_acos s => real (s, "Math_acos") | |
289 | | Real_Math_asin s => real (s, "Math_asin") | |
290 | | Real_Math_atan s => real (s, "Math_atan") | |
291 | | Real_Math_atan2 s => real (s, "Math_atan2") | |
292 | | Real_Math_cos s => real (s, "Math_cos") | |
293 | | Real_Math_exp s => real (s, "Math_exp") | |
294 | | Real_Math_ln s => real (s, "Math_ln") | |
295 | | Real_Math_log10 s => real (s, "Math_log10") | |
296 | | Real_Math_sin s => real (s, "Math_sin") | |
297 | | Real_Math_sqrt s => real (s, "Math_sqrt") | |
298 | | Real_Math_tan s => real (s, "Math_tan") | |
299 | | Real_abs s => real (s, "abs") | |
300 | | Real_add s => real (s, "add") | |
301 | | Real_castToWord (s1, s2) => cast (realC, wordC, s1, s2) | |
302 | | Real_div s => real (s, "div") | |
303 | | Real_equal s => real (s, "equal") | |
304 | | Real_ldexp s => real (s, "ldexp") | |
305 | | Real_le s => real (s, "le") | |
306 | | Real_lt s => real (s, "lt") | |
307 | | Real_mul s => real (s, "mul") | |
308 | | Real_muladd s => real (s, "muladd") | |
309 | | Real_mulsub s => real (s, "mulsub") | |
310 | | Real_neg s => real (s, "neg") | |
311 | | Real_qequal s => real (s, "qequal") | |
312 | | Real_rndToReal (s1, s2) => rnd (realC, realC, s1, s2) | |
313 | | Real_rndToWord (s1, s2, sg) => rnd (realC, wordCS sg, s1, s2) | |
314 | | Real_round s => real (s, "round") | |
315 | | Real_sub s => real (s, "sub") | |
316 | | Ref_assign => "Ref_assign" | |
317 | | Ref_deref => "Ref_deref" | |
318 | | Ref_ref => "Ref_ref" | |
319 | | String_toWord8Vector => "String_toWord8Vector" | |
320 | | Thread_atomicBegin => "Thread_atomicBegin" | |
321 | | Thread_atomicEnd => "Thread_atomicEnd" | |
322 | | Thread_atomicState => "Thread_atomicState" | |
323 | | Thread_copy => "Thread_copy" | |
324 | | Thread_copyCurrent => "Thread_copyCurrent" | |
325 | | Thread_returnToC => "Thread_returnToC" | |
326 | | Thread_switchTo => "Thread_switchTo" | |
327 | | TopLevel_getHandler => "TopLevel_getHandler" | |
328 | | TopLevel_getSuffix => "TopLevel_getSuffix" | |
329 | | TopLevel_setHandler => "TopLevel_setHandler" | |
330 | | TopLevel_setSuffix => "TopLevel_setSuffix" | |
331 | | Vector_length => "Vector_length" | |
332 | | Vector_sub => "Vector_sub" | |
333 | | Vector_vector => "Vector_vector" | |
334 | | Weak_canGet => "Weak_canGet" | |
335 | | Weak_get => "Weak_get" | |
336 | | Weak_new => "Weak_new" | |
337 | | WordArray_subWord {seqSize, eleSize} => | |
338 | wordSeq (seqSize, "Array", "sub", eleSize) | |
339 | | WordArray_updateWord {seqSize, eleSize} => | |
340 | wordSeq (seqSize, "Array", "update", eleSize) | |
341 | | WordVector_subWord {seqSize, eleSize} => | |
342 | wordSeq (seqSize, "Vector", "sub", eleSize) | |
343 | | Word8Vector_toString => "Word8Vector_toString" | |
344 | | WordVector_toIntInf => "WordVector_toIntInf" | |
345 | | Word_add s => word (s, "add") | |
346 | | Word_addCheck (s, sg) => wordS (s, sg, "addCheck") | |
347 | | Word_andb s => word (s, "andb") | |
348 | | Word_castToReal (s1, s2) => cast (wordC, realC, s1, s2) | |
349 | | Word_equal s => word (s, "equal") | |
350 | | Word_extdToWord (s1, s2, sg) => extd (wordCS sg, wordC, s1, s2) | |
351 | | Word_lshift s => word (s, "lshift") | |
352 | | Word_lt (s, sg) => wordS (s, sg, "lt") | |
353 | | Word_mul (s, sg) => wordS (s, sg, "mul") | |
354 | | Word_mulCheck (s, sg) => wordS (s, sg, "mulCheck") | |
355 | | Word_neg s => word (s, "neg") | |
356 | | Word_negCheck s => word (s, "negCheck") | |
357 | | Word_notb s => word (s, "notb") | |
358 | | Word_orb s => word (s, "orb") | |
359 | | Word_quot (s, sg) => wordS (s, sg, "quot") | |
360 | | Word_rem (s, sg) => wordS (s, sg, "rem") | |
361 | | Word_rndToReal (s1, s2, sg) => rnd (wordCS sg, realC, s1, s2) | |
362 | | Word_rol s => word (s, "rol") | |
363 | | Word_ror s => word (s, "ror") | |
364 | | Word_rshift (s, sg) => wordS (s, sg, "rshift") | |
365 | | Word_sub s => word (s, "sub") | |
366 | | Word_subCheck (s, sg) => wordS (s, sg, "subCheck") | |
367 | | Word_toIntInf => "Word_toIntInf" | |
368 | | Word_xorb s => word (s, "xorb") | |
369 | | World_save => "World_save" | |
370 | end | |
371 | ||
372 | fun layout p = Layout.str (toString p) | |
373 | fun layoutFull (p, layoutX) = | |
374 | case p of | |
375 | FFI f => Layout.seq [Layout.str "FFI ", CFunction.layout (f, layoutX)] | |
376 | | FFI_Symbol {name, cty, symbolScope} => | |
377 | Layout.seq [Layout.str "FFI_Symbol ", | |
378 | Layout.record | |
379 | [("name", Layout.str name), | |
380 | ("cty", Option.layout CType.layout cty), | |
381 | ("symbolScope", CFunction.SymbolScope.layout symbolScope)]] | |
382 | | p => layout p | |
383 | ||
384 | val equals: 'a t * 'a t -> bool = | |
385 | fn (Array_alloc {raw = r}, Array_alloc {raw = r'}) => Bool.equals (r, r') | |
386 | | (Array_copyArray, Array_copyArray) => true | |
387 | | (Array_copyVector, Array_copyVector) => true | |
388 | | (Array_length, Array_length) => true | |
389 | | (Array_sub, Array_sub) => true | |
390 | | (Array_toArray, Array_toArray) => true | |
391 | | (Array_toVector, Array_toVector) => true | |
392 | | (Array_uninit, Array_uninit) => true | |
393 | | (Array_uninitIsNop, Array_uninitIsNop) => true | |
394 | | (Array_update, Array_update) => true | |
395 | | (CPointer_add, CPointer_add) => true | |
396 | | (CPointer_diff, CPointer_diff) => true | |
397 | | (CPointer_equal, CPointer_equal) => true | |
398 | | (CPointer_fromWord, CPointer_fromWord) => true | |
399 | | (CPointer_getCPointer, CPointer_getCPointer) => true | |
400 | | (CPointer_getObjptr, CPointer_getObjptr) => true | |
401 | | (CPointer_getReal s, CPointer_getReal s') => RealSize.equals (s, s') | |
402 | | (CPointer_getWord s, CPointer_getWord s') => WordSize.equals (s, s') | |
403 | | (CPointer_lt, CPointer_lt) => true | |
404 | | (CPointer_setCPointer, CPointer_setCPointer) => true | |
405 | | (CPointer_setObjptr, CPointer_setObjptr) => true | |
406 | | (CPointer_setReal s, CPointer_setReal s') => RealSize.equals (s, s') | |
407 | | (CPointer_setWord s, CPointer_setWord s') => WordSize.equals (s, s') | |
408 | | (CPointer_sub, CPointer_sub) => true | |
409 | | (CPointer_toWord, CPointer_toWord) => true | |
410 | | (Exn_extra, Exn_extra) => true | |
411 | | (Exn_name, Exn_name) => true | |
412 | | (Exn_setExtendExtra, Exn_setExtendExtra) => true | |
413 | | (FFI f, FFI f') => CFunction.equals (f, f') | |
414 | | (FFI_Symbol {name = n, ...}, FFI_Symbol {name = n', ...}) => n = n' | |
415 | | (GC_collect, GC_collect) => true | |
416 | | (IntInf_add, IntInf_add) => true | |
417 | | (IntInf_andb, IntInf_andb) => true | |
418 | | (IntInf_arshift, IntInf_arshift) => true | |
419 | | (IntInf_compare, IntInf_compare) => true | |
420 | | (IntInf_gcd, IntInf_gcd) => true | |
421 | | (IntInf_lshift, IntInf_lshift) => true | |
422 | | (IntInf_mul, IntInf_mul) => true | |
423 | | (IntInf_neg, IntInf_neg) => true | |
424 | | (IntInf_notb, IntInf_notb) => true | |
425 | | (IntInf_orb, IntInf_orb) => true | |
426 | | (IntInf_quot, IntInf_quot) => true | |
427 | | (IntInf_rem, IntInf_rem) => true | |
428 | | (IntInf_sub, IntInf_sub) => true | |
429 | | (IntInf_toString, IntInf_toString) => true | |
430 | | (IntInf_toVector, IntInf_toVector) => true | |
431 | | (IntInf_toWord, IntInf_toWord) => true | |
432 | | (IntInf_xorb, IntInf_xorb) => true | |
433 | | (MLton_bogus, MLton_bogus) => true | |
434 | | (MLton_bug, MLton_bug) => true | |
435 | | (MLton_deserialize, MLton_deserialize) => true | |
436 | | (MLton_eq, MLton_eq) => true | |
437 | | (MLton_equal, MLton_equal) => true | |
438 | | (MLton_halt, MLton_halt) => true | |
439 | | (MLton_hash, MLton_hash) => true | |
440 | | (MLton_handlesSignals, MLton_handlesSignals) => true | |
441 | | (MLton_installSignalHandler, MLton_installSignalHandler) => true | |
442 | | (MLton_serialize, MLton_serialize) => true | |
443 | | (MLton_share, MLton_share) => true | |
444 | | (MLton_size, MLton_size) => true | |
445 | | (MLton_touch, MLton_touch) => true | |
446 | | (Real_Math_acos s, Real_Math_acos s') => RealSize.equals (s, s') | |
447 | | (Real_Math_asin s, Real_Math_asin s') => RealSize.equals (s, s') | |
448 | | (Real_Math_atan s, Real_Math_atan s') => RealSize.equals (s, s') | |
449 | | (Real_Math_atan2 s, Real_Math_atan2 s') => RealSize.equals (s, s') | |
450 | | (Real_Math_cos s, Real_Math_cos s') => RealSize.equals (s, s') | |
451 | | (Real_Math_exp s, Real_Math_exp s') => RealSize.equals (s, s') | |
452 | | (Real_Math_ln s, Real_Math_ln s') => RealSize.equals (s, s') | |
453 | | (Real_Math_log10 s, Real_Math_log10 s') => RealSize.equals (s, s') | |
454 | | (Real_Math_sin s, Real_Math_sin s') => RealSize.equals (s, s') | |
455 | | (Real_Math_sqrt s, Real_Math_sqrt s') => RealSize.equals (s, s') | |
456 | | (Real_Math_tan s, Real_Math_tan s') => RealSize.equals (s, s') | |
457 | | (Real_abs s, Real_abs s') => RealSize.equals (s, s') | |
458 | | (Real_add s, Real_add s') => RealSize.equals (s, s') | |
459 | | (Real_castToWord (s1, s2), Real_castToWord (s1', s2')) => | |
460 | RealSize.equals (s1, s1') | |
461 | andalso WordSize.equals (s2, s2') | |
462 | | (Real_div s, Real_div s') => RealSize.equals (s, s') | |
463 | | (Real_equal s, Real_equal s') => RealSize.equals (s, s') | |
464 | | (Real_ldexp s, Real_ldexp s') => RealSize.equals (s, s') | |
465 | | (Real_le s, Real_le s') => RealSize.equals (s, s') | |
466 | | (Real_lt s, Real_lt s') => RealSize.equals (s, s') | |
467 | | (Real_mul s, Real_mul s') => RealSize.equals (s, s') | |
468 | | (Real_muladd s, Real_muladd s') => RealSize.equals (s, s') | |
469 | | (Real_mulsub s, Real_mulsub s') => RealSize.equals (s, s') | |
470 | | (Real_neg s, Real_neg s') => RealSize.equals (s, s') | |
471 | | (Real_qequal s, Real_qequal s') => RealSize.equals (s, s') | |
472 | | (Real_rndToReal (s1, s2), Real_rndToReal (s1', s2')) => | |
473 | RealSize.equals (s1, s1') andalso RealSize.equals (s2, s2') | |
474 | | (Real_rndToWord (s1, s2, sg), Real_rndToWord (s1', s2', sg')) => | |
475 | RealSize.equals (s1, s1') | |
476 | andalso WordSize.equals (s2, s2') | |
477 | andalso sg = sg' | |
478 | | (Real_round s, Real_round s') => RealSize.equals (s, s') | |
479 | | (Real_sub s, Real_sub s') => RealSize.equals (s, s') | |
480 | | (Ref_assign, Ref_assign) => true | |
481 | | (Ref_deref, Ref_deref) => true | |
482 | | (Ref_ref, Ref_ref) => true | |
483 | | (String_toWord8Vector, String_toWord8Vector) => true | |
484 | | (Thread_atomicBegin, Thread_atomicBegin) => true | |
485 | | (Thread_atomicEnd, Thread_atomicEnd) => true | |
486 | | (Thread_atomicState, Thread_atomicState) => true | |
487 | | (Thread_copy, Thread_copy) => true | |
488 | | (Thread_copyCurrent, Thread_copyCurrent) => true | |
489 | | (Thread_returnToC, Thread_returnToC) => true | |
490 | | (Thread_switchTo, Thread_switchTo) => true | |
491 | | (TopLevel_getHandler, TopLevel_getHandler) => true | |
492 | | (TopLevel_getSuffix, TopLevel_getSuffix) => true | |
493 | | (TopLevel_setHandler, TopLevel_setHandler) => true | |
494 | | (TopLevel_setSuffix, TopLevel_setSuffix) => true | |
495 | | (Vector_length, Vector_length) => true | |
496 | | (Vector_sub, Vector_sub) => true | |
497 | | (Vector_vector, Vector_vector) => true | |
498 | | (Weak_canGet, Weak_canGet) => true | |
499 | | (Weak_get, Weak_get) => true | |
500 | | (Weak_new, Weak_new) => true | |
501 | | (Word_add s, Word_add s') => WordSize.equals (s, s') | |
502 | | (Word_addCheck (s, sg), Word_addCheck (s', sg')) => | |
503 | WordSize.equals (s, s') andalso sg = sg' | |
504 | | (Word_andb s, Word_andb s') => WordSize.equals (s, s') | |
505 | | (Word_castToReal (s1, s2), Word_castToReal (s1', s2')) => | |
506 | WordSize.equals (s1, s1') | |
507 | andalso RealSize.equals (s2, s2') | |
508 | | (Word_extdToWord (s1, s2, sg), Word_extdToWord (s1', s2', sg')) => | |
509 | WordSize.equals (s1, s1') | |
510 | andalso WordSize.equals (s2, s2') | |
511 | andalso sg = sg' | |
512 | | (Word_equal s, Word_equal s') => WordSize.equals (s, s') | |
513 | | (Word_lshift s, Word_lshift s') => WordSize.equals (s, s') | |
514 | | (Word_lt (s, sg), Word_lt (s', sg')) => | |
515 | WordSize.equals (s, s') andalso sg = sg' | |
516 | | (Word_mul (s, sg), Word_mul (s', sg')) => | |
517 | WordSize.equals (s, s') andalso sg = sg' | |
518 | | (Word_mulCheck (s, sg), Word_mulCheck (s', sg')) => | |
519 | WordSize.equals (s, s') andalso sg = sg' | |
520 | | (Word_neg s, Word_neg s') => WordSize.equals (s, s') | |
521 | | (Word_negCheck s, Word_negCheck s') => WordSize.equals (s, s') | |
522 | | (Word_notb s, Word_notb s') => WordSize.equals (s, s') | |
523 | | (Word_orb s, Word_orb s') => WordSize.equals (s, s') | |
524 | | (Word_quot (s, sg), Word_quot (s', sg')) => | |
525 | WordSize.equals (s, s') andalso sg = sg' | |
526 | | (Word_rem (s, sg), Word_rem (s', sg')) => | |
527 | WordSize.equals (s, s') andalso sg = sg' | |
528 | | (Word_rndToReal (s1, s2, sg), Word_rndToReal (s1', s2', sg')) => | |
529 | WordSize.equals (s1, s1') | |
530 | andalso RealSize.equals (s2, s2') | |
531 | andalso sg = sg' | |
532 | | (Word_rol s, Word_rol s') => WordSize.equals (s, s') | |
533 | | (Word_ror s, Word_ror s') => WordSize.equals (s, s') | |
534 | | (Word_rshift (s, sg), Word_rshift (s', sg')) => | |
535 | WordSize.equals (s, s') andalso sg = sg' | |
536 | | (Word_sub s, Word_sub s') => WordSize.equals (s, s') | |
537 | | (Word_subCheck (s, sg), Word_subCheck (s', sg')) => | |
538 | WordSize.equals (s, s') andalso sg = sg' | |
539 | | (Word_toIntInf, Word_toIntInf) => true | |
540 | | (Word_xorb s, Word_xorb s') => WordSize.equals (s, s') | |
541 | | (WordVector_toIntInf, WordVector_toIntInf) => true | |
542 | | (WordArray_subWord {seqSize = seqSize, eleSize = eleSize}, | |
543 | WordArray_subWord {seqSize = seqSize', eleSize = eleSize'}) => | |
544 | WordSize.equals (seqSize, seqSize') | |
545 | andalso WordSize.equals (eleSize, eleSize') | |
546 | | (WordArray_updateWord {seqSize = seqSize, eleSize = eleSize}, | |
547 | WordArray_updateWord {seqSize = seqSize', eleSize = eleSize'}) => | |
548 | WordSize.equals (seqSize, seqSize') | |
549 | andalso WordSize.equals (eleSize, eleSize') | |
550 | | (WordVector_subWord {seqSize = seqSize, eleSize = eleSize}, | |
551 | WordVector_subWord {seqSize = seqSize', eleSize = eleSize'}) => | |
552 | WordSize.equals (seqSize, seqSize') | |
553 | andalso WordSize.equals (eleSize, eleSize') | |
554 | | (Word8Vector_toString, Word8Vector_toString) => true | |
555 | | (World_save, World_save) => true | |
556 | | _ => false | |
557 | ||
558 | val map: 'a t * ('a -> 'b) -> 'b t = | |
559 | fn (p, f) => | |
560 | case p of | |
561 | Array_alloc {raw} => Array_alloc {raw = raw} | |
562 | | Array_copyArray => Array_copyArray | |
563 | | Array_copyVector => Array_copyVector | |
564 | | Array_length => Array_length | |
565 | | Array_sub => Array_sub | |
566 | | Array_toArray => Array_toArray | |
567 | | Array_toVector => Array_toVector | |
568 | | Array_uninit => Array_uninit | |
569 | | Array_uninitIsNop => Array_uninitIsNop | |
570 | | Array_update => Array_update | |
571 | | CPointer_add => CPointer_add | |
572 | | CPointer_diff => CPointer_diff | |
573 | | CPointer_equal => CPointer_equal | |
574 | | CPointer_fromWord => CPointer_fromWord | |
575 | | CPointer_getCPointer => CPointer_getCPointer | |
576 | | CPointer_getObjptr => CPointer_getObjptr | |
577 | | CPointer_getReal z => CPointer_getReal z | |
578 | | CPointer_getWord z => CPointer_getWord z | |
579 | | CPointer_lt => CPointer_lt | |
580 | | CPointer_setCPointer => CPointer_setCPointer | |
581 | | CPointer_setObjptr => CPointer_setObjptr | |
582 | | CPointer_setReal z => CPointer_setReal z | |
583 | | CPointer_setWord z => CPointer_setWord z | |
584 | | CPointer_sub => CPointer_sub | |
585 | | CPointer_toWord => CPointer_toWord | |
586 | | Exn_extra => Exn_extra | |
587 | | Exn_name => Exn_name | |
588 | | Exn_setExtendExtra => Exn_setExtendExtra | |
589 | | FFI func => FFI (CFunction.map (func, f)) | |
590 | | FFI_Symbol {name, cty, symbolScope} => | |
591 | FFI_Symbol {name = name, cty = cty, symbolScope = symbolScope} | |
592 | | GC_collect => GC_collect | |
593 | | IntInf_add => IntInf_add | |
594 | | IntInf_andb => IntInf_andb | |
595 | | IntInf_arshift => IntInf_arshift | |
596 | | IntInf_compare => IntInf_compare | |
597 | | IntInf_gcd => IntInf_gcd | |
598 | | IntInf_lshift => IntInf_lshift | |
599 | | IntInf_mul => IntInf_mul | |
600 | | IntInf_neg => IntInf_neg | |
601 | | IntInf_notb => IntInf_notb | |
602 | | IntInf_orb => IntInf_orb | |
603 | | IntInf_quot => IntInf_quot | |
604 | | IntInf_rem => IntInf_rem | |
605 | | IntInf_sub => IntInf_sub | |
606 | | IntInf_toString => IntInf_toString | |
607 | | IntInf_toVector => IntInf_toVector | |
608 | | IntInf_toWord => IntInf_toWord | |
609 | | IntInf_xorb => IntInf_xorb | |
610 | | MLton_bogus => MLton_bogus | |
611 | | MLton_bug => MLton_bug | |
612 | | MLton_deserialize => MLton_deserialize | |
613 | | MLton_eq => MLton_eq | |
614 | | MLton_equal => MLton_equal | |
615 | | MLton_halt => MLton_halt | |
616 | | MLton_hash => MLton_hash | |
617 | | MLton_handlesSignals => MLton_handlesSignals | |
618 | | MLton_installSignalHandler => MLton_installSignalHandler | |
619 | | MLton_serialize => MLton_serialize | |
620 | | MLton_share => MLton_share | |
621 | | MLton_size => MLton_size | |
622 | | MLton_touch => MLton_touch | |
623 | | Real_Math_acos z => Real_Math_acos z | |
624 | | Real_Math_asin z => Real_Math_asin z | |
625 | | Real_Math_atan z => Real_Math_atan z | |
626 | | Real_Math_atan2 z => Real_Math_atan2 z | |
627 | | Real_Math_cos z => Real_Math_cos z | |
628 | | Real_Math_exp z => Real_Math_exp z | |
629 | | Real_Math_ln z => Real_Math_ln z | |
630 | | Real_Math_log10 z => Real_Math_log10 z | |
631 | | Real_Math_sin z => Real_Math_sin z | |
632 | | Real_Math_sqrt z => Real_Math_sqrt z | |
633 | | Real_Math_tan z => Real_Math_tan z | |
634 | | Real_abs z => Real_abs z | |
635 | | Real_add z => Real_add z | |
636 | | Real_castToWord z => Real_castToWord z | |
637 | | Real_div z => Real_div z | |
638 | | Real_equal z => Real_equal z | |
639 | | Real_ldexp z => Real_ldexp z | |
640 | | Real_le z => Real_le z | |
641 | | Real_lt z => Real_lt z | |
642 | | Real_mul z => Real_mul z | |
643 | | Real_muladd z => Real_muladd z | |
644 | | Real_mulsub z => Real_mulsub z | |
645 | | Real_neg z => Real_neg z | |
646 | | Real_qequal z => Real_qequal z | |
647 | | Real_rndToReal z => Real_rndToReal z | |
648 | | Real_rndToWord z => Real_rndToWord z | |
649 | | Real_round z => Real_round z | |
650 | | Real_sub z => Real_sub z | |
651 | | Ref_assign => Ref_assign | |
652 | | Ref_deref => Ref_deref | |
653 | | Ref_ref => Ref_ref | |
654 | | String_toWord8Vector => String_toWord8Vector | |
655 | | Thread_atomicBegin => Thread_atomicBegin | |
656 | | Thread_atomicEnd => Thread_atomicEnd | |
657 | | Thread_atomicState => Thread_atomicState | |
658 | | Thread_copy => Thread_copy | |
659 | | Thread_copyCurrent => Thread_copyCurrent | |
660 | | Thread_returnToC => Thread_returnToC | |
661 | | Thread_switchTo => Thread_switchTo | |
662 | | TopLevel_getHandler => TopLevel_getHandler | |
663 | | TopLevel_getSuffix => TopLevel_getSuffix | |
664 | | TopLevel_setHandler => TopLevel_setHandler | |
665 | | TopLevel_setSuffix => TopLevel_setSuffix | |
666 | | Vector_length => Vector_length | |
667 | | Vector_sub => Vector_sub | |
668 | | Vector_vector => Vector_vector | |
669 | | Weak_canGet => Weak_canGet | |
670 | | Weak_get => Weak_get | |
671 | | Weak_new => Weak_new | |
672 | | Word_add z => Word_add z | |
673 | | Word_addCheck z => Word_addCheck z | |
674 | | Word_andb z => Word_andb z | |
675 | | Word_castToReal z => Word_castToReal z | |
676 | | Word_equal z => Word_equal z | |
677 | | Word_extdToWord z => Word_extdToWord z | |
678 | | Word_lshift z => Word_lshift z | |
679 | | Word_lt z => Word_lt z | |
680 | | Word_mul z => Word_mul z | |
681 | | Word_mulCheck z => Word_mulCheck z | |
682 | | Word_neg z => Word_neg z | |
683 | | Word_negCheck z => Word_negCheck z | |
684 | | Word_notb z => Word_notb z | |
685 | | Word_orb z => Word_orb z | |
686 | | Word_quot z => Word_quot z | |
687 | | Word_rem z => Word_rem z | |
688 | | Word_rndToReal z => Word_rndToReal z | |
689 | | Word_rol z => Word_rol z | |
690 | | Word_ror z => Word_ror z | |
691 | | Word_rshift z => Word_rshift z | |
692 | | Word_sub z => Word_sub z | |
693 | | Word_subCheck z => Word_subCheck z | |
694 | | Word_toIntInf => Word_toIntInf | |
695 | | Word_xorb z => Word_xorb z | |
696 | | WordVector_toIntInf => WordVector_toIntInf | |
697 | | WordArray_subWord z => WordArray_subWord z | |
698 | | WordArray_updateWord z => WordArray_updateWord z | |
699 | | WordVector_subWord z => WordVector_subWord z | |
700 | | Word8Vector_toString => Word8Vector_toString | |
701 | | World_save => World_save | |
702 | ||
703 | val cast: 'a t -> 'b t = fn p => map (p, fn _ => Error.bug "Prim.cast") | |
704 | ||
705 | val arrayAlloc = fn {raw} => Array_alloc {raw = raw} | |
706 | val arrayLength = Array_length | |
707 | val arrayToVector = Array_toVector | |
708 | val arrayUpdate = Array_update | |
709 | val assign = Ref_assign | |
710 | val bogus = MLton_bogus | |
711 | val bug = MLton_bug | |
712 | val cpointerAdd = CPointer_add | |
713 | val cpointerDiff = CPointer_diff | |
714 | val cpointerEqual = CPointer_equal | |
715 | fun cpointerGet ctype = | |
716 | let datatype z = datatype CType.t | |
717 | in | |
718 | case ctype of | |
719 | CPointer => CPointer_getCPointer | |
720 | | Int8 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 8)) | |
721 | | Int16 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 16)) | |
722 | | Int32 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 32)) | |
723 | | Int64 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 64)) | |
724 | | Objptr => CPointer_getObjptr | |
725 | | Real32 => CPointer_getReal RealSize.R32 | |
726 | | Real64 => CPointer_getReal RealSize.R64 | |
727 | | Word8 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 8)) | |
728 | | Word16 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 16)) | |
729 | | Word32 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 32)) | |
730 | | Word64 => CPointer_getWord (WordSize.fromBits (Bits.fromInt 64)) | |
731 | end | |
732 | val cpointerLt = CPointer_lt | |
733 | fun cpointerSet ctype = | |
734 | let datatype z = datatype CType.t | |
735 | in | |
736 | case ctype of | |
737 | CPointer => CPointer_setCPointer | |
738 | | Int8 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 8)) | |
739 | | Int16 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 16)) | |
740 | | Int32 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 32)) | |
741 | | Int64 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 64)) | |
742 | | Objptr => CPointer_setObjptr | |
743 | | Real32 => CPointer_setReal RealSize.R32 | |
744 | | Real64 => CPointer_setReal RealSize.R64 | |
745 | | Word8 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 8)) | |
746 | | Word16 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 16)) | |
747 | | Word32 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 32)) | |
748 | | Word64 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 64)) | |
749 | end | |
750 | val cpointerSub = CPointer_sub | |
751 | val cpointerToWord = CPointer_toWord | |
752 | val deref = Ref_deref | |
753 | val eq = MLton_eq | |
754 | val equal = MLton_equal | |
755 | val ffi = FFI | |
756 | val ffiSymbol = FFI_Symbol | |
757 | val hash = MLton_hash | |
758 | val intInfToVector = IntInf_toVector | |
759 | val intInfToWord = IntInf_toWord | |
760 | val intInfNeg = IntInf_neg | |
761 | val intInfNotb = IntInf_notb | |
762 | val realCastToWord = Real_castToWord | |
763 | val reff = Ref_ref | |
764 | val touch = MLton_touch | |
765 | val vector = Vector_vector | |
766 | val vectorLength = Vector_length | |
767 | val vectorSub = Vector_sub | |
768 | val wordAdd = Word_add | |
769 | val wordAddCheck = Word_addCheck | |
770 | val wordAndb = Word_andb | |
771 | val wordCastToReal = Word_castToReal | |
772 | val wordEqual = Word_equal | |
773 | val wordExtdToWord = Word_extdToWord | |
774 | val wordLshift = Word_lshift | |
775 | val wordLt = Word_lt | |
776 | val wordMul = Word_mul | |
777 | val wordNeg = Word_neg | |
778 | val wordNegCheck = Word_negCheck | |
779 | val wordNotb = Word_notb | |
780 | val wordOrb = Word_orb | |
781 | val wordQuot = Word_quot | |
782 | val wordRshift = Word_rshift | |
783 | val wordSub = Word_sub | |
784 | val wordXorb = Word_xorb | |
785 | ||
786 | val isCommutative = | |
787 | fn MLton_eq => true | |
788 | | MLton_equal => true | |
789 | | Real_add _ => true | |
790 | | Real_mul _ => true | |
791 | | Real_equal _ => true | |
792 | | Real_qequal _ => true | |
793 | | Word_add _ => true | |
794 | | Word_addCheck _ => true | |
795 | | Word_andb _ => true | |
796 | | Word_equal _ => true | |
797 | | Word_mul _ => true | |
798 | | Word_mulCheck _ => true | |
799 | | Word_orb _ => true | |
800 | | Word_xorb _ => true | |
801 | | _ => false | |
802 | ||
803 | val mayOverflow = | |
804 | fn Word_addCheck _ => true | |
805 | | Word_mulCheck _ => true | |
806 | | Word_negCheck _ => true | |
807 | | Word_subCheck _ => true | |
808 | | _ => false | |
809 | ||
810 | val kind: 'a t -> Kind.t = | |
811 | fn p => | |
812 | let | |
813 | datatype z = datatype Kind.t | |
814 | in | |
815 | case p of | |
816 | Array_alloc _ => Moveable | |
817 | | Array_copyArray => SideEffect | |
818 | | Array_copyVector => SideEffect | |
819 | | Array_length => Functional | |
820 | | Array_sub => DependsOnState | |
821 | | Array_toArray => DependsOnState | |
822 | | Array_toVector => DependsOnState | |
823 | | Array_uninit => SideEffect | |
824 | | Array_uninitIsNop => Functional | |
825 | | Array_update => SideEffect | |
826 | | CPointer_add => Functional | |
827 | | CPointer_diff => Functional | |
828 | | CPointer_equal => Functional | |
829 | | CPointer_fromWord => Functional | |
830 | | CPointer_getCPointer => DependsOnState | |
831 | | CPointer_getObjptr => DependsOnState | |
832 | | CPointer_getReal _ => DependsOnState | |
833 | | CPointer_getWord _ => DependsOnState | |
834 | | CPointer_lt => Functional | |
835 | | CPointer_setCPointer => SideEffect | |
836 | | CPointer_setObjptr => SideEffect | |
837 | | CPointer_setReal _ => SideEffect | |
838 | | CPointer_setWord _ => SideEffect | |
839 | | CPointer_sub => Functional | |
840 | | CPointer_toWord => Functional | |
841 | | Exn_extra => Functional | |
842 | | Exn_name => Functional | |
843 | | Exn_setExtendExtra => SideEffect | |
844 | | FFI (CFunction.T {kind, ...}) => (case kind of | |
845 | CFunction.Kind.Impure => SideEffect | |
846 | | CFunction.Kind.Pure => Functional | |
847 | | CFunction.Kind.Runtime _ => SideEffect) | |
848 | | FFI_Symbol _ => Functional | |
849 | | GC_collect => SideEffect | |
850 | | IntInf_add => Functional | |
851 | | IntInf_andb => Functional | |
852 | | IntInf_arshift => Functional | |
853 | | IntInf_compare => Functional | |
854 | | IntInf_gcd => Functional | |
855 | | IntInf_lshift => Functional | |
856 | | IntInf_mul => Functional | |
857 | | IntInf_neg => Functional | |
858 | | IntInf_notb => Functional | |
859 | | IntInf_orb => Functional | |
860 | | IntInf_quot => Functional | |
861 | | IntInf_rem => Functional | |
862 | | IntInf_sub => Functional | |
863 | | IntInf_toString => Functional | |
864 | | IntInf_toVector => Functional | |
865 | | IntInf_toWord => Functional | |
866 | | IntInf_xorb => Functional | |
867 | | MLton_bogus => Functional | |
868 | | MLton_bug => SideEffect | |
869 | | MLton_deserialize => Moveable | |
870 | | MLton_eq => Functional | |
871 | | MLton_equal => Functional | |
872 | | MLton_halt => SideEffect | |
873 | | MLton_hash => Functional | |
874 | | MLton_handlesSignals => Functional | |
875 | | MLton_installSignalHandler => SideEffect | |
876 | | MLton_serialize => DependsOnState | |
877 | | MLton_share => SideEffect | |
878 | | MLton_size => DependsOnState | |
879 | | MLton_touch => SideEffect | |
880 | | Real_Math_acos _ => DependsOnState (* depends on rounding mode *) | |
881 | | Real_Math_asin _ => DependsOnState (* depends on rounding mode *) | |
882 | | Real_Math_atan _ => DependsOnState (* depends on rounding mode *) | |
883 | | Real_Math_atan2 _ => DependsOnState (* depends on rounding mode *) | |
884 | | Real_Math_cos _ => DependsOnState (* depends on rounding mode *) | |
885 | | Real_Math_exp _ => DependsOnState (* depends on rounding mode *) | |
886 | | Real_Math_ln _ => DependsOnState (* depends on rounding mode *) | |
887 | | Real_Math_log10 _ => DependsOnState (* depends on rounding mode *) | |
888 | | Real_Math_sin _ => DependsOnState (* depends on rounding mode *) | |
889 | | Real_Math_sqrt _ => DependsOnState (* depends on rounding mode *) | |
890 | | Real_Math_tan _ => DependsOnState (* depends on rounding mode *) | |
891 | | Real_abs _ => Functional | |
892 | | Real_add _ => DependsOnState (* depends on rounding mode *) | |
893 | | Real_castToWord _ => Functional | |
894 | | Real_div _ => DependsOnState (* depends on rounding mode *) | |
895 | | Real_equal _ => Functional | |
896 | | Real_ldexp _ => DependsOnState (* depends on rounding mode *) | |
897 | | Real_le _ => Functional | |
898 | | Real_lt _ => Functional | |
899 | | Real_mul _ => DependsOnState (* depends on rounding mode *) | |
900 | | Real_muladd _ => DependsOnState (* depends on rounding mode *) | |
901 | | Real_mulsub _ => DependsOnState (* depends on rounding mode *) | |
902 | | Real_neg _ => Functional | |
903 | | Real_qequal _ => Functional | |
904 | | Real_rndToReal _ => DependsOnState (* depends on rounding mode *) | |
905 | | Real_rndToWord _ => Functional | |
906 | | Real_round _ => DependsOnState (* depends on rounding mode *) | |
907 | | Real_sub _ => DependsOnState (* depends on rounding mode *) | |
908 | | Ref_assign => SideEffect | |
909 | | Ref_deref => DependsOnState | |
910 | | Ref_ref => Moveable | |
911 | | String_toWord8Vector => Functional | |
912 | | Thread_atomicBegin => SideEffect | |
913 | | Thread_atomicEnd => SideEffect | |
914 | | Thread_atomicState => DependsOnState | |
915 | | Thread_copy => Moveable | |
916 | | Thread_copyCurrent => SideEffect | |
917 | | Thread_returnToC => SideEffect | |
918 | | Thread_switchTo => SideEffect | |
919 | | TopLevel_getHandler => DependsOnState | |
920 | | TopLevel_getSuffix => DependsOnState | |
921 | | TopLevel_setHandler => SideEffect | |
922 | | TopLevel_setSuffix => SideEffect | |
923 | | Vector_length => Functional | |
924 | | Vector_sub => Functional | |
925 | | Vector_vector => Functional | |
926 | | Weak_canGet => DependsOnState | |
927 | | Weak_get => DependsOnState | |
928 | | Weak_new => Moveable | |
929 | | WordArray_subWord _ => DependsOnState | |
930 | | WordArray_updateWord _ => SideEffect | |
931 | | WordVector_subWord _ => Functional | |
932 | | Word8Vector_toString => Functional | |
933 | | WordVector_toIntInf => Functional | |
934 | | Word_add _ => Functional | |
935 | | Word_addCheck _ => SideEffect | |
936 | | Word_andb _ => Functional | |
937 | | Word_castToReal _ => Functional | |
938 | | Word_equal _ => Functional | |
939 | | Word_extdToWord _ => Functional | |
940 | | Word_lshift _ => Functional | |
941 | | Word_lt _ => Functional | |
942 | | Word_mul _ => Functional | |
943 | | Word_mulCheck _ => SideEffect | |
944 | | Word_neg _ => Functional | |
945 | | Word_negCheck _ => SideEffect | |
946 | | Word_notb _ => Functional | |
947 | | Word_orb _ => Functional | |
948 | | Word_quot _ => Functional | |
949 | | Word_rem _ => Functional | |
950 | | Word_rndToReal _ => DependsOnState (* depends on rounding mode *) | |
951 | | Word_rol _ => Functional | |
952 | | Word_ror _ => Functional | |
953 | | Word_rshift _ => Functional | |
954 | | Word_sub _ => Functional | |
955 | | Word_subCheck _ => SideEffect | |
956 | | Word_toIntInf => Functional | |
957 | | Word_xorb _ => Functional | |
958 | | World_save => SideEffect | |
959 | end | |
960 | ||
961 | fun isFunctional p = Kind.Functional = kind p | |
962 | ||
963 | fun maySideEffect p = Kind.SideEffect = kind p | |
964 | ||
965 | local | |
966 | fun reals (s: RealSize.t) = | |
967 | [(Real_Math_acos s), | |
968 | (Real_Math_asin s), | |
969 | (Real_Math_atan s), | |
970 | (Real_Math_atan2 s), | |
971 | (Real_Math_cos s), | |
972 | (Real_Math_exp s), | |
973 | (Real_Math_ln s), | |
974 | (Real_Math_log10 s), | |
975 | (Real_Math_sin s), | |
976 | (Real_Math_sqrt s), | |
977 | (Real_Math_tan s), | |
978 | (Real_abs s), | |
979 | (Real_add s), | |
980 | (Real_div s), | |
981 | (Real_equal s), | |
982 | (Real_ldexp s), | |
983 | (Real_le s), | |
984 | (Real_lt s), | |
985 | (Real_mul s), | |
986 | (Real_muladd s), | |
987 | (Real_mulsub s), | |
988 | (Real_neg s), | |
989 | (Real_qequal s), | |
990 | (Real_round s), | |
991 | (Real_sub s)] | |
992 | ||
993 | fun wordSigns (s: WordSize.t, signed: bool) = | |
994 | let | |
995 | val sg = {signed = signed} | |
996 | in | |
997 | List.map ([Word_addCheck, | |
998 | Word_lt, | |
999 | Word_mul, | |
1000 | Word_mulCheck, | |
1001 | Word_quot, | |
1002 | Word_rem, | |
1003 | Word_rshift, | |
1004 | Word_subCheck], | |
1005 | fn p => p (s, sg)) | |
1006 | end | |
1007 | ||
1008 | fun words (s: WordSize.t) = | |
1009 | [(Word_add s), | |
1010 | (Word_andb s), | |
1011 | (Word_equal s), | |
1012 | (Word_lshift s), | |
1013 | (Word_neg s), | |
1014 | (Word_negCheck s), | |
1015 | (Word_notb s), | |
1016 | (Word_orb s), | |
1017 | (Word_rol s), | |
1018 | (Word_ror s), | |
1019 | (Word_sub s), | |
1020 | (Word_xorb s)] | |
1021 | @ wordSigns (s, true) | |
1022 | @ wordSigns (s, false) | |
1023 | in | |
1024 | val all: unit t list = | |
1025 | [Array_alloc {raw = false}, | |
1026 | Array_alloc {raw = true}, | |
1027 | Array_copyArray, | |
1028 | Array_copyVector, | |
1029 | Array_length, | |
1030 | Array_sub, | |
1031 | Array_toArray, | |
1032 | Array_toVector, | |
1033 | Array_uninit, | |
1034 | Array_uninitIsNop, | |
1035 | Array_update, | |
1036 | CPointer_add, | |
1037 | CPointer_diff, | |
1038 | CPointer_equal, | |
1039 | CPointer_fromWord, | |
1040 | CPointer_getCPointer, | |
1041 | CPointer_getObjptr, | |
1042 | CPointer_lt, | |
1043 | CPointer_setCPointer, | |
1044 | CPointer_setObjptr, | |
1045 | CPointer_sub, | |
1046 | CPointer_toWord, | |
1047 | Exn_extra, | |
1048 | Exn_name, | |
1049 | Exn_setExtendExtra, | |
1050 | GC_collect, | |
1051 | IntInf_add, | |
1052 | IntInf_andb, | |
1053 | IntInf_arshift, | |
1054 | IntInf_compare, | |
1055 | IntInf_gcd, | |
1056 | IntInf_lshift, | |
1057 | IntInf_mul, | |
1058 | IntInf_notb, | |
1059 | IntInf_neg, | |
1060 | IntInf_orb, | |
1061 | IntInf_quot, | |
1062 | IntInf_rem, | |
1063 | IntInf_sub, | |
1064 | IntInf_toString, | |
1065 | IntInf_toVector, | |
1066 | IntInf_toWord, | |
1067 | IntInf_xorb, | |
1068 | MLton_bogus, | |
1069 | MLton_bug, | |
1070 | MLton_deserialize, | |
1071 | MLton_eq, | |
1072 | MLton_equal, | |
1073 | MLton_halt, | |
1074 | MLton_hash, | |
1075 | MLton_handlesSignals, | |
1076 | MLton_installSignalHandler, | |
1077 | MLton_serialize, | |
1078 | MLton_share, | |
1079 | MLton_size, | |
1080 | MLton_touch, | |
1081 | Ref_assign, | |
1082 | Ref_deref, | |
1083 | Ref_ref, | |
1084 | String_toWord8Vector, | |
1085 | Thread_atomicBegin, | |
1086 | Thread_atomicEnd, | |
1087 | Thread_atomicState, | |
1088 | Thread_copy, | |
1089 | Thread_copyCurrent, | |
1090 | Thread_returnToC, | |
1091 | Thread_switchTo, | |
1092 | TopLevel_getHandler, | |
1093 | TopLevel_getSuffix, | |
1094 | TopLevel_setHandler, | |
1095 | TopLevel_setSuffix, | |
1096 | Vector_length, | |
1097 | Vector_sub, | |
1098 | Vector_vector, | |
1099 | Weak_canGet, | |
1100 | Weak_get, | |
1101 | Weak_new, | |
1102 | Word_toIntInf, | |
1103 | WordVector_toIntInf, | |
1104 | Word8Vector_toString, | |
1105 | World_save] | |
1106 | @ List.concat [List.concatMap (RealSize.all, reals), | |
1107 | List.concatMap (WordSize.prims, words)] | |
1108 | @ let | |
1109 | val real = RealSize.all | |
1110 | val word = WordSize.prims | |
1111 | val wordNonPrim = | |
1112 | List.keepAll | |
1113 | (WordSize.all, fn s => not (List.contains (word, s, WordSize.equals))) | |
1114 | fun coerces (name, sizes, sizes', ac) = | |
1115 | List.fold | |
1116 | (sizes, ac, fn (s, ac) => | |
1117 | List.fold | |
1118 | (sizes', ac, fn (s', ac) => | |
1119 | name (s, s') :: ac)) | |
1120 | fun coercesS (name, sizes, sizes', ac) = | |
1121 | List.fold | |
1122 | ([false, true], ac, fn (signed, ac) => | |
1123 | coerces (fn (s, s') => name (s, s', {signed = signed}), | |
1124 | sizes, sizes', ac)) | |
1125 | fun casts (name, sizes, ac) = | |
1126 | List.fold (sizes, ac, fn (s, ac) => name s :: ac) | |
1127 | fun castsS (name, sizes, ac) = | |
1128 | List.fold | |
1129 | ([false, true], ac, fn (signed, ac) => | |
1130 | casts (fn s => name (s, {signed = signed}), | |
1131 | sizes, ac)) | |
1132 | in | |
1133 | casts (fn rs => Real_castToWord (rs, WordSize.fromBits (RealSize.bits rs)), real, | |
1134 | coerces (Real_rndToReal, real, real, | |
1135 | coercesS (Real_rndToWord, real, word, | |
1136 | casts (fn rs => Word_castToReal (WordSize.fromBits (RealSize.bits rs), rs), real, | |
1137 | coercesS (Word_extdToWord, word, word, | |
1138 | castsS (fn (s, signed) => Word_extdToWord (s, WordSize.roundUpToPrim s, signed), wordNonPrim, | |
1139 | castsS (fn (s, signed) => Word_extdToWord (WordSize.roundUpToPrim s, s, signed), wordNonPrim, | |
1140 | coercesS (Word_rndToReal, word, real, [])))))))) | |
1141 | end | |
1142 | @ List.concatMap | |
1143 | (WordSize.prims, fn seqSize => | |
1144 | List.concatMap | |
1145 | (WordSize.prims, fn eleSize => | |
1146 | List.map | |
1147 | ([WordArray_subWord, WordArray_updateWord, WordVector_subWord], fn p => | |
1148 | p {seqSize = seqSize, eleSize = eleSize}))) | |
1149 | @ let | |
1150 | fun doit (all, get, set) = | |
1151 | List.concatMap (all, fn s => [get s, set s]) | |
1152 | in | |
1153 | List.concat [doit (RealSize.all, CPointer_getReal, CPointer_setReal), | |
1154 | doit (WordSize.prims, CPointer_getWord, CPointer_setWord)] | |
1155 | end | |
1156 | end | |
1157 | ||
1158 | local | |
1159 | val table: {hash: word, | |
1160 | prim: unit t, | |
1161 | string: string} HashSet.t = | |
1162 | HashSet.new {hash = #hash} | |
1163 | val () = | |
1164 | List.foreach (all, fn prim => | |
1165 | let | |
1166 | val string = toString prim | |
1167 | val hash = String.hash string | |
1168 | val _ = | |
1169 | HashSet.lookupOrInsert (table, hash, | |
1170 | fn _ => false, | |
1171 | fn () => {hash = hash, | |
1172 | prim = prim, | |
1173 | string = string}) | |
1174 | in | |
1175 | () | |
1176 | end) | |
1177 | in | |
1178 | val fromString: string -> 'a t option = | |
1179 | fn name => | |
1180 | Option.map | |
1181 | (HashSet.peek | |
1182 | (table, String.hash name, fn {string, ...} => name = string), | |
1183 | fn {prim, ...} => cast prim) | |
1184 | end | |
1185 | ||
1186 | fun 'a checkApp (prim: 'a t, | |
1187 | {args: 'a vector, | |
1188 | result: 'a, | |
1189 | targs: 'a vector, | |
1190 | typeOps = {array: 'a -> 'a, | |
1191 | arrow: 'a * 'a -> 'a, | |
1192 | bool: 'a, | |
1193 | cpointer: 'a, | |
1194 | equals: 'a * 'a -> bool, | |
1195 | exn: 'a, | |
1196 | intInf: 'a, | |
1197 | real: RealSize.t -> 'a, | |
1198 | reff: 'a -> 'a, | |
1199 | thread: 'a, | |
1200 | unit: 'a, | |
1201 | vector: 'a -> 'a, | |
1202 | weak: 'a -> 'a, | |
1203 | word: WordSize.t -> 'a}}): bool = | |
1204 | let | |
1205 | fun arg i = Vector.sub (args, i) | |
1206 | fun noArgs () = | |
1207 | 0 = Vector.length args | |
1208 | fun oneArg arg0' () = | |
1209 | 1 = Vector.length args | |
1210 | andalso equals (arg0', arg 0) | |
1211 | fun twoArgs (arg0', arg1') () = | |
1212 | 2 = Vector.length args | |
1213 | andalso equals (arg0', arg 0) | |
1214 | andalso equals (arg1', arg 1) | |
1215 | fun threeArgs (arg0', arg1', arg2') () = | |
1216 | 3 = Vector.length args | |
1217 | andalso equals (arg0', arg 0) | |
1218 | andalso equals (arg1', arg 1) | |
1219 | andalso equals (arg2', arg 2) | |
1220 | fun fiveArgs (arg0', arg1', arg2', arg3', arg4') () = | |
1221 | 5 = Vector.length args | |
1222 | andalso equals (arg0', arg 0) | |
1223 | andalso equals (arg1', arg 1) | |
1224 | andalso equals (arg2', arg 2) | |
1225 | andalso equals (arg3', arg 3) | |
1226 | andalso equals (arg4', arg 4) | |
1227 | fun nArgs args' () = | |
1228 | Vector.equals (args', args, equals) | |
1229 | fun done (args, result') = | |
1230 | args () andalso equals (result', result) | |
1231 | fun targ i = Vector.sub (targs, i) | |
1232 | fun noTargs f = | |
1233 | 0 = Vector.length targs | |
1234 | andalso done (f ()) | |
1235 | fun oneTarg f = | |
1236 | 1 = Vector.length targs | |
1237 | andalso done (f (targ 0)) | |
1238 | local | |
1239 | fun make f s = let val t = f s | |
1240 | in noTargs (fn () => (oneArg t, t)) | |
1241 | end | |
1242 | in | |
1243 | val realUnary = make real | |
1244 | val wordUnary = make word | |
1245 | end | |
1246 | local | |
1247 | fun make f s = let val t = f s | |
1248 | in noTargs (fn () => (twoArgs (t, t), t)) | |
1249 | end | |
1250 | in | |
1251 | val realBinary = make real | |
1252 | val wordBinary = make word | |
1253 | end | |
1254 | local | |
1255 | fun make f s = let val t = f s | |
1256 | in noTargs (fn () => (twoArgs (t, t), bool)) | |
1257 | end | |
1258 | in | |
1259 | val realCompare = make real | |
1260 | val wordCompare = make word | |
1261 | end | |
1262 | val cint = word (WordSize.cint ()) | |
1263 | val compareRes = word WordSize.compareRes | |
1264 | val csize = word (WordSize.csize ()) | |
1265 | val cptrdiff = word (WordSize.cptrdiff ()) | |
1266 | val seqIndex = word (WordSize.seqIndex ()) | |
1267 | val shiftArg = word WordSize.shiftArg | |
1268 | val bigIntInfWord = word (WordSize.bigIntInfWord ()) | |
1269 | val smallIntInfWord = word (WordSize.smallIntInfWord ()) | |
1270 | ||
1271 | val word8 = word WordSize.word8 | |
1272 | val word32 = word WordSize.word32 | |
1273 | fun intInfBinary () = | |
1274 | noTargs (fn () => (threeArgs (intInf, intInf, csize), intInf)) | |
1275 | fun intInfShift () = | |
1276 | noTargs (fn () => (threeArgs (intInf, shiftArg, csize), intInf)) | |
1277 | fun intInfUnary () = | |
1278 | noTargs (fn () => (twoArgs (intInf, csize), intInf)) | |
1279 | fun realTernary s = | |
1280 | noTargs (fn () => (threeArgs (real s, real s, real s), real s)) | |
1281 | fun wordArray seqSize = array (word seqSize) | |
1282 | fun wordShift s = | |
1283 | noTargs (fn () => (twoArgs (word s, shiftArg), word s)) | |
1284 | val word8Vector = vector word8 | |
1285 | fun wordVector seqSize = vector (word seqSize) | |
1286 | val string = word8Vector | |
1287 | in | |
1288 | case prim of | |
1289 | Array_alloc _ => oneTarg (fn targ => (oneArg seqIndex, array targ)) | |
1290 | | Array_copyArray => oneTarg (fn t => (fiveArgs (array t, seqIndex, array t, seqIndex, seqIndex), unit)) | |
1291 | | Array_copyVector => oneTarg (fn t => (fiveArgs (array t, seqIndex, vector t, seqIndex, seqIndex), unit)) | |
1292 | | Array_length => oneTarg (fn t => (oneArg (array t), seqIndex)) | |
1293 | | Array_sub => oneTarg (fn t => (twoArgs (array t, seqIndex), t)) | |
1294 | | Array_toArray => oneTarg (fn t => (oneArg (array t), array t)) | |
1295 | | Array_toVector => oneTarg (fn t => (oneArg (array t), vector t)) | |
1296 | | Array_uninit => | |
1297 | oneTarg (fn t => (twoArgs (array t, seqIndex), unit)) | |
1298 | | Array_uninitIsNop => | |
1299 | oneTarg (fn t => (oneArg (array t), bool)) | |
1300 | | Array_update => | |
1301 | oneTarg (fn t => (threeArgs (array t, seqIndex, t), unit)) | |
1302 | | CPointer_add => | |
1303 | noTargs (fn () => (twoArgs (cpointer, cptrdiff), cpointer)) | |
1304 | | CPointer_diff => | |
1305 | noTargs (fn () => (twoArgs (cpointer, cpointer), cptrdiff)) | |
1306 | | CPointer_equal => | |
1307 | noTargs (fn () => (twoArgs (cpointer, cpointer), bool)) | |
1308 | | CPointer_fromWord => noTargs (fn () => (oneArg (csize), cpointer)) | |
1309 | | CPointer_getCPointer => | |
1310 | noTargs (fn () => (twoArgs (cpointer, cptrdiff), cpointer)) | |
1311 | | CPointer_getObjptr => | |
1312 | oneTarg (fn t => (twoArgs (cpointer, cptrdiff), t)) | |
1313 | | CPointer_getReal s => | |
1314 | noTargs (fn () => (twoArgs (cpointer, cptrdiff), real s)) | |
1315 | | CPointer_getWord s => | |
1316 | noTargs (fn () => (twoArgs (cpointer, cptrdiff), word s)) | |
1317 | | CPointer_lt => | |
1318 | noTargs (fn () => (twoArgs (cpointer, cpointer), bool)) | |
1319 | | CPointer_setCPointer => | |
1320 | noTargs (fn () => (threeArgs (cpointer, cptrdiff, cpointer), | |
1321 | unit)) | |
1322 | | CPointer_setObjptr => | |
1323 | oneTarg (fn t => (threeArgs (cpointer, cptrdiff, t), unit)) | |
1324 | | CPointer_setReal s => | |
1325 | noTargs (fn () => (threeArgs (cpointer, cptrdiff, real s), unit)) | |
1326 | | CPointer_setWord s => | |
1327 | noTargs (fn () => (threeArgs (cpointer, cptrdiff, word s), unit)) | |
1328 | | CPointer_sub => | |
1329 | noTargs (fn () => (twoArgs (cpointer, cptrdiff), cpointer)) | |
1330 | | CPointer_toWord => noTargs (fn () => (oneArg cpointer, csize)) | |
1331 | | Exn_extra => oneTarg (fn t => (oneArg exn, t)) | |
1332 | | Exn_name => noTargs (fn () => (oneArg exn, string)) | |
1333 | | Exn_setExtendExtra => oneTarg (fn t => (oneArg (arrow (t, t)), unit)) | |
1334 | | FFI f => | |
1335 | noTargs (fn () => (nArgs (CFunction.args f), CFunction.return f)) | |
1336 | | FFI_Symbol _ => noTargs (fn () => (noArgs, cpointer)) | |
1337 | | GC_collect => noTargs (fn () => (noArgs, unit)) | |
1338 | | IntInf_add => intInfBinary () | |
1339 | | IntInf_andb => intInfBinary () | |
1340 | | IntInf_arshift => intInfShift () | |
1341 | | IntInf_compare => | |
1342 | noTargs (fn () => (twoArgs (intInf, intInf), compareRes)) | |
1343 | | IntInf_gcd => intInfBinary () | |
1344 | | IntInf_lshift => intInfShift () | |
1345 | | IntInf_mul => intInfBinary () | |
1346 | | IntInf_neg => intInfUnary () | |
1347 | | IntInf_notb => intInfUnary () | |
1348 | | IntInf_orb => intInfBinary () | |
1349 | | IntInf_quot => intInfBinary () | |
1350 | | IntInf_rem => intInfBinary () | |
1351 | | IntInf_sub => intInfBinary () | |
1352 | | IntInf_toString => | |
1353 | noTargs (fn () => (threeArgs (intInf, word32, csize), string)) | |
1354 | | IntInf_toVector => | |
1355 | noTargs (fn () => (oneArg intInf, vector bigIntInfWord)) | |
1356 | | IntInf_toWord => noTargs (fn () => (oneArg intInf, smallIntInfWord)) | |
1357 | | IntInf_xorb => intInfBinary () | |
1358 | | MLton_bogus => oneTarg (fn t => (noArgs, t)) | |
1359 | | MLton_bug => noTargs (fn () => (oneArg string, unit)) | |
1360 | | MLton_deserialize => oneTarg (fn t => (oneArg word8Vector, t)) | |
1361 | | MLton_eq => oneTarg (fn t => (twoArgs (t, t), bool)) | |
1362 | | MLton_equal => oneTarg (fn t => (twoArgs (t, t), bool)) | |
1363 | | MLton_halt => noTargs (fn () => (oneArg cint, unit)) | |
1364 | | MLton_hash => oneTarg (fn t => (oneArg t, word32)) | |
1365 | | MLton_handlesSignals => noTargs (fn () => (noArgs, bool)) | |
1366 | | MLton_installSignalHandler => noTargs (fn () => (noArgs, unit)) | |
1367 | | MLton_serialize => oneTarg (fn t => (oneArg t, word8Vector)) | |
1368 | | MLton_share => oneTarg (fn t => (oneArg t, unit)) | |
1369 | | MLton_size => oneTarg (fn t => (oneArg t, csize)) | |
1370 | | MLton_touch => oneTarg (fn t => (oneArg t, unit)) | |
1371 | | Real_Math_acos s => realUnary s | |
1372 | | Real_Math_asin s => realUnary s | |
1373 | | Real_Math_atan s => realUnary s | |
1374 | | Real_Math_atan2 s => realBinary s | |
1375 | | Real_Math_cos s => realUnary s | |
1376 | | Real_Math_exp s => realUnary s | |
1377 | | Real_Math_ln s => realUnary s | |
1378 | | Real_Math_log10 s => realUnary s | |
1379 | | Real_Math_sin s => realUnary s | |
1380 | | Real_Math_sqrt s => realUnary s | |
1381 | | Real_Math_tan s => realUnary s | |
1382 | | Real_abs s => realUnary s | |
1383 | | Real_add s => realBinary s | |
1384 | | Real_castToWord (s, s') => | |
1385 | noTargs (fn () => (oneArg (real s), word s')) | |
1386 | | Real_div s => realBinary s | |
1387 | | Real_equal s => realCompare s | |
1388 | | Real_ldexp s => noTargs (fn () => (twoArgs (real s, cint), real s)) | |
1389 | | Real_le s => realCompare s | |
1390 | | Real_lt s => realCompare s | |
1391 | | Real_mul s => realBinary s | |
1392 | | Real_muladd s => realTernary s | |
1393 | | Real_mulsub s => realTernary s | |
1394 | | Real_neg s => realUnary s | |
1395 | | Real_qequal s => realCompare s | |
1396 | | Real_rndToReal (s, s') => | |
1397 | noTargs (fn () => (oneArg (real s), real s')) | |
1398 | | Real_rndToWord (s, s', _) => | |
1399 | noTargs (fn () => (oneArg (real s), word s')) | |
1400 | | Real_round s => realUnary s | |
1401 | | Real_sub s => realBinary s | |
1402 | | Ref_assign => oneTarg (fn t => (twoArgs (reff t, t), unit)) | |
1403 | | Ref_deref => oneTarg (fn t => (oneArg (reff t), t)) | |
1404 | | Ref_ref => oneTarg (fn t => (oneArg t, reff t)) | |
1405 | | Thread_atomicBegin => noTargs (fn () => (noArgs, unit)) | |
1406 | | Thread_atomicEnd => noTargs (fn () => (noArgs, unit)) | |
1407 | | Thread_atomicState => noTargs (fn () => (noArgs, word32)) | |
1408 | | Thread_copy => noTargs (fn () => (oneArg thread, thread)) | |
1409 | | Thread_copyCurrent => noTargs (fn () => (noArgs, unit)) | |
1410 | | Thread_returnToC => noTargs (fn () => (noArgs, unit)) | |
1411 | | Thread_switchTo => noTargs (fn () => (oneArg thread, unit)) | |
1412 | | TopLevel_getHandler => noTargs (fn () => (noArgs, arrow (exn, unit))) | |
1413 | | TopLevel_getSuffix => noTargs (fn () => (noArgs, arrow (unit, unit))) | |
1414 | | TopLevel_setHandler => | |
1415 | noTargs (fn () => (oneArg (arrow (exn, unit)), unit)) | |
1416 | | TopLevel_setSuffix => | |
1417 | noTargs (fn () => (oneArg (arrow (unit, unit)), unit)) | |
1418 | | String_toWord8Vector => | |
1419 | noTargs (fn () => (oneArg string, word8Vector)) | |
1420 | | Vector_length => oneTarg (fn t => (oneArg (vector t), seqIndex)) | |
1421 | | Vector_sub => oneTarg (fn t => (twoArgs (vector t, seqIndex), t)) | |
1422 | | Vector_vector => oneTarg (fn targ => (nArgs (Vector.map (args, fn _ => targ)), vector targ)) | |
1423 | | Weak_canGet => oneTarg (fn t => (oneArg (weak t), bool)) | |
1424 | | Weak_get => oneTarg (fn t => (oneArg (weak t), t)) | |
1425 | | Weak_new => oneTarg (fn t => (oneArg t, weak t)) | |
1426 | | WordArray_subWord {seqSize, eleSize} => | |
1427 | noTargs (fn () => (twoArgs (wordArray seqSize, seqIndex), word eleSize)) | |
1428 | | WordArray_updateWord {seqSize, eleSize} => | |
1429 | noTargs (fn () => (threeArgs (wordArray seqSize, seqIndex, word eleSize), unit)) | |
1430 | | WordVector_subWord {seqSize, eleSize} => | |
1431 | noTargs (fn () => (twoArgs (wordVector seqSize, seqIndex), word eleSize)) | |
1432 | | Word8Vector_toString => | |
1433 | noTargs (fn () => (oneArg (word8Vector), string)) | |
1434 | | WordVector_toIntInf => | |
1435 | noTargs (fn () => (oneArg (vector bigIntInfWord), intInf)) | |
1436 | | Word_add s => wordBinary s | |
1437 | | Word_addCheck (s, _) => wordBinary s | |
1438 | | Word_andb s => wordBinary s | |
1439 | | Word_castToReal (s, s') => | |
1440 | noTargs (fn () => (oneArg (word s), real s')) | |
1441 | | Word_equal s => wordCompare s | |
1442 | | Word_extdToWord (s, s', _) => | |
1443 | noTargs (fn () => (oneArg (word s), word s')) | |
1444 | | Word_lshift s => wordShift s | |
1445 | | Word_lt (s, _) => wordCompare s | |
1446 | | Word_mul (s, _) => wordBinary s | |
1447 | | Word_mulCheck (s, _) => wordBinary s | |
1448 | | Word_neg s => wordUnary s | |
1449 | | Word_negCheck s => wordUnary s | |
1450 | | Word_notb s => wordUnary s | |
1451 | | Word_orb s => wordBinary s | |
1452 | | Word_quot (s, _) => wordBinary s | |
1453 | | Word_rem (s, _) => wordBinary s | |
1454 | | Word_rndToReal (s, s', _) => | |
1455 | noTargs (fn () => (oneArg (word s), real s')) | |
1456 | | Word_rol s => wordShift s | |
1457 | | Word_ror s => wordShift s | |
1458 | | Word_rshift (s, _) => wordShift s | |
1459 | | Word_sub s => wordBinary s | |
1460 | | Word_subCheck (s, _) => wordBinary s | |
1461 | | Word_toIntInf => noTargs (fn () => (oneArg smallIntInfWord, intInf)) | |
1462 | | Word_xorb s => wordBinary s | |
1463 | | World_save => noTargs (fn () => (oneArg string, unit)) | |
1464 | end | |
1465 | ||
1466 | val checkApp = | |
1467 | fn z => | |
1468 | Trace.trace ("Prim.check", layout o #1, Layout.ignore) checkApp z | |
1469 | ||
1470 | fun ('a, 'b) extractTargs (prim: 'b t, | |
1471 | {args: 'a vector, | |
1472 | result: 'a, | |
1473 | typeOps = {deArray: 'a -> 'a, | |
1474 | deArrow: 'a -> 'a * 'a, | |
1475 | deRef: 'a -> 'a, | |
1476 | deVector: 'a -> 'a, | |
1477 | deWeak: 'a -> 'a}}) = | |
1478 | let | |
1479 | val one = Vector.new1 | |
1480 | fun arg i = Vector.sub (args, i) | |
1481 | datatype z = datatype t | |
1482 | in | |
1483 | case prim of | |
1484 | Array_alloc _ => one (deArray result) | |
1485 | | Array_copyArray => one (deArray (arg 0)) | |
1486 | | Array_copyVector => one (deArray (arg 0)) | |
1487 | | Array_length => one (deArray (arg 0)) | |
1488 | | Array_sub => one (deArray (arg 0)) | |
1489 | | Array_toArray => one (deArray (arg 0)) | |
1490 | | Array_toVector => one (deArray (arg 0)) | |
1491 | | Array_uninit => one (deArray (arg 0)) | |
1492 | | Array_uninitIsNop => one (deArray (arg 0)) | |
1493 | | Array_update => one (deArray (arg 0)) | |
1494 | | CPointer_getObjptr => one result | |
1495 | | CPointer_setObjptr => one (arg 2) | |
1496 | | Exn_extra => one result | |
1497 | | Exn_setExtendExtra => one (#2 (deArrow (arg 0))) | |
1498 | | MLton_bogus => one result | |
1499 | | MLton_deserialize => one result | |
1500 | | MLton_eq => one (arg 0) | |
1501 | | MLton_equal => one (arg 0) | |
1502 | | MLton_hash => one (arg 0) | |
1503 | | MLton_serialize => one (arg 0) | |
1504 | | MLton_share => one (arg 0) | |
1505 | | MLton_size => one (arg 0) | |
1506 | | MLton_touch => one (arg 0) | |
1507 | | Ref_assign => one (deRef (arg 0)) | |
1508 | | Ref_deref => one (deRef (arg 0)) | |
1509 | | Ref_ref => one (deRef result) | |
1510 | | Vector_length => one (deVector (arg 0)) | |
1511 | | Vector_sub => one (deVector (arg 0)) | |
1512 | | Vector_vector => one (deVector result) | |
1513 | | Weak_canGet => one (deWeak (arg 0)) | |
1514 | | Weak_get => one result | |
1515 | | Weak_new => one (arg 0) | |
1516 | | _ => Vector.new0 () | |
1517 | end | |
1518 | ||
1519 | val extractTargs = | |
1520 | fn z => | |
1521 | Trace.trace ("Prim.extractTargs", layout o #1, Layout.ignore) extractTargs z | |
1522 | ||
1523 | structure IntInfRep = Const.IntInfRep | |
1524 | ||
1525 | structure ApplyArg = | |
1526 | struct | |
1527 | datatype 'a t = | |
1528 | Con of {con: Con.t, hasArg: bool} | |
1529 | | Const of Const.t | |
1530 | | Var of 'a | |
1531 | ||
1532 | fun layout layoutX = | |
1533 | fn Con {con, hasArg} => | |
1534 | Layout.record [("con", Con.layout con), | |
1535 | ("hasArg", Bool.layout hasArg)] | |
1536 | | Const c => Const.layout c | |
1537 | | Var x => layoutX x | |
1538 | end | |
1539 | ||
1540 | structure ApplyResult = | |
1541 | struct | |
1542 | type 'a prim = 'a t | |
1543 | val layoutPrim = layout | |
1544 | ||
1545 | datatype ('a, 'b) t = | |
1546 | Apply of 'a prim * 'b list | |
1547 | | Bool of bool | |
1548 | | Const of Const.t | |
1549 | | Overflow | |
1550 | | Unknown | |
1551 | | Var of 'b | |
1552 | ||
1553 | fun layout layoutX ar = | |
1554 | let | |
1555 | open Layout | |
1556 | in | |
1557 | case ar of | |
1558 | Apply (p, args) => seq [layoutPrim p, List.layout layoutX args] | |
1559 | | Bool b => Bool.layout b | |
1560 | | Const c => Const.layout c | |
1561 | | Overflow => str "Overflow" | |
1562 | | Unknown => str "Unknown" | |
1563 | | Var x => layoutX x | |
1564 | end | |
1565 | end | |
1566 | ||
1567 | (* | |
1568 | * In addition to constant folding, here are the algebraic identities currently | |
1569 | * handled. | |
1570 | * | |
1571 | * x * 1 = 1 * x = x | |
1572 | * x * ~1 = ~1 * x = ~x | |
1573 | * x * 0 = 0 * x = 0 | |
1574 | * x + 0 = 0 + x = x | |
1575 | * x mod x = x rem x = 0 | |
1576 | * x mod 1 = x rem 1 = x mod ~1 = x rem ~1 = 0 | |
1577 | * x div x = x quot x = 1 | |
1578 | * x div 1 = x quot 1 = x | |
1579 | * andb (x, x) = orb (x, x) = x | |
1580 | * xorb (x, x) = 0 | |
1581 | * x - 0 = x | |
1582 | * 0 - x = ~x | |
1583 | * x - x = 0 | |
1584 | * x > x = x < x = false | |
1585 | * x >= x = x <= x = true | |
1586 | * x = x --> true | |
1587 | * | |
1588 | * Also, simple equality tests on constructors are handled. | |
1589 | * A = A --> true | |
1590 | * A = B --> false | |
1591 | * A x = B y --> false | |
1592 | *) | |
1593 | ||
1594 | fun ('a, 'b) apply (p: 'a t, | |
1595 | args: 'b ApplyArg.t list, | |
1596 | varEquals: 'b * 'b -> bool): ('a, 'b) ApplyResult.t = | |
1597 | let | |
1598 | datatype z = datatype t | |
1599 | datatype z = datatype Const.t | |
1600 | val bool = ApplyResult.Bool | |
1601 | val boolOpt = fn NONE => ApplyResult.Unknown | SOME b => bool b | |
1602 | val f = bool false | |
1603 | val t = bool true | |
1604 | fun seqIndexConst i = | |
1605 | ApplyResult.Const | |
1606 | (Const.word (WordX.fromIntInf (i, WordSize.seqIndex ()))) | |
1607 | local | |
1608 | val maxIntInf = IntInf.<< (1, 0w128) | |
1609 | val minIntInf = IntInf.~ maxIntInf | |
1610 | in | |
1611 | fun intInfTooBig ii = | |
1612 | IntInf.< (ii, minIntInf) | |
1613 | orelse IntInf.> (ii, maxIntInf) | |
1614 | end | |
1615 | val intInfTooBig = | |
1616 | Trace.trace | |
1617 | ("Prim.intInfTooBig", IntInf.layout, Bool.layout) | |
1618 | intInfTooBig | |
1619 | fun intInf (ii: IntInf.t): ('a, 'b) ApplyResult.t = | |
1620 | if intInfTooBig ii | |
1621 | then ApplyResult.Unknown | |
1622 | else ApplyResult.Const (Const.intInf ii) | |
1623 | val intInfConst = intInf o IntInf.fromInt | |
1624 | val null = ApplyResult.Const Const.null | |
1625 | fun real (r: RealX.t): ('a, 'b) ApplyResult.t = | |
1626 | ApplyResult.Const (Const.real r) | |
1627 | val realOpt = fn NONE => ApplyResult.Unknown | SOME r => real r | |
1628 | fun realNeg (s, x): ('a, 'b) ApplyResult.t = | |
1629 | ApplyResult.Apply (Real_neg s, [x]) | |
1630 | fun realAdd (s, x, y): ('a, 'b) ApplyResult.t = | |
1631 | ApplyResult.Apply (Real_add s, [x, y]) | |
1632 | fun word (w: WordX.t): ('a, 'b) ApplyResult.t = | |
1633 | ApplyResult.Const (Const.word w) | |
1634 | val wordOpt = fn NONE => ApplyResult.Unknown | SOME w => word w | |
1635 | fun wordVector (v: WordXVector.t): ('a, 'b) ApplyResult.t = | |
1636 | ApplyResult.Const (Const.wordVector v) | |
1637 | fun iio (f, c1, c2) = intInf (f (c1, c2)) | |
1638 | fun wordS (f: WordX.t * WordX.t * {signed: bool} -> WordX.t, | |
1639 | (_: WordSize.t, sg), | |
1640 | w: WordX.t, | |
1641 | w': WordX.t) = | |
1642 | word (f (w, w', sg)) | |
1643 | fun wordCmp (f: WordX.t * WordX.t * {signed: bool} -> bool, | |
1644 | (_: WordSize.t, sg), | |
1645 | w: WordX.t, | |
1646 | w': WordX.t) = | |
1647 | bool (f (w, w', sg)) | |
1648 | fun wordOrOverflow (s, sg, w) = | |
1649 | if WordSize.isInRange (s, w, sg) | |
1650 | then word (WordX.fromIntInf (w, s)) | |
1651 | else ApplyResult.Overflow | |
1652 | fun wcheck (f: IntInf.t * IntInf.t -> IntInf.t, | |
1653 | (s: WordSize.t, sg as {signed}), | |
1654 | w: WordX.t, | |
1655 | w': WordX.t) = | |
1656 | let | |
1657 | val conv = if signed then WordX.toIntInfX else WordX.toIntInf | |
1658 | in | |
1659 | wordOrOverflow (s, sg, f (conv w, conv w')) | |
1660 | end | |
1661 | val eq = | |
1662 | fn (Word w1, Word w2) => bool (WordX.equals (w1, w2)) | |
1663 | | _ => ApplyResult.Unknown | |
1664 | val equal = | |
1665 | fn (IntInf ii1, IntInf ii2) => bool (IntInf.equals (ii1, ii2)) | |
1666 | | (Word w1, Word w2) => bool (WordX.equals (w1, w2)) | |
1667 | | (WordVector v1, WordVector v2) => bool (WordXVector.equals (v1, v2)) | |
1668 | | _ => ApplyResult.Unknown | |
1669 | fun intInfBinary (i1, i2) = | |
1670 | if intInfTooBig i1 orelse intInfTooBig i2 | |
1671 | then ApplyResult.Unknown | |
1672 | else | |
1673 | case p of | |
1674 | IntInf_add => iio (IntInf.+, i1, i2) | |
1675 | | IntInf_andb => iio (IntInf.andb, i1, i2) | |
1676 | | IntInf_gcd => iio (IntInf.gcd, i1, i2) | |
1677 | | IntInf_mul => iio (IntInf.*, i1, i2) | |
1678 | | IntInf_orb => iio (IntInf.orb, i1, i2) | |
1679 | | IntInf_quot => iio (IntInf.quot, i1, i2) | |
1680 | | IntInf_rem => iio (IntInf.rem, i1, i2) | |
1681 | | IntInf_sub => iio (IntInf.-, i1, i2) | |
1682 | | IntInf_xorb => iio (IntInf.xorb, i1, i2) | |
1683 | | _ => ApplyResult.Unknown | |
1684 | fun intInfUnary (i1) = | |
1685 | if intInfTooBig i1 | |
1686 | then ApplyResult.Unknown | |
1687 | else | |
1688 | case p of | |
1689 | IntInf_neg => intInf (IntInf.~ i1) | |
1690 | | IntInf_notb => intInf (IntInf.notb i1) | |
1691 | | _ => ApplyResult.Unknown | |
1692 | fun intInfShiftOrToString (i1, w2) = | |
1693 | if intInfTooBig i1 | |
1694 | then ApplyResult.Unknown | |
1695 | else | |
1696 | case p of | |
1697 | IntInf_arshift => | |
1698 | intInf (IntInf.~>> (i1, Word.fromIntInf (WordX.toIntInf w2))) | |
1699 | | IntInf_lshift => | |
1700 | let | |
1701 | val maxShift = | |
1702 | WordX.fromIntInf (128, WordSize.shiftArg) | |
1703 | in | |
1704 | if WordX.lt (w2, maxShift, {signed = false}) | |
1705 | then intInf (IntInf.<< (i1, Word.fromIntInf (WordX.toIntInf w2))) | |
1706 | else ApplyResult.Unknown | |
1707 | end | |
1708 | | IntInf_toString => | |
1709 | let | |
1710 | val base = | |
1711 | case WordX.toInt w2 of | |
1712 | 2 => StringCvt.BIN | |
1713 | | 8 => StringCvt.OCT | |
1714 | | 10 => StringCvt.DEC | |
1715 | | 16 => StringCvt.HEX | |
1716 | | _ => Error.bug "Prim.apply: strange base for IntInf_toString" | |
1717 | in | |
1718 | ApplyResult.Const (Const.string (IntInf.format (i1, base))) | |
1719 | end | |
1720 | | _ => ApplyResult.Unknown | |
1721 | fun allConsts (cs: Const.t list) = | |
1722 | (case (p, cs) of | |
1723 | (MLton_eq, [c1, c2]) => eq (c1, c2) | |
1724 | | (MLton_equal, [c1, c2]) => equal (c1, c2) | |
1725 | | (CPointer_equal, [Null, Null]) => bool true | |
1726 | | (CPointer_fromWord, [Word w]) => | |
1727 | if WordX.isZero w | |
1728 | then null | |
1729 | else ApplyResult.Unknown | |
1730 | | (CPointer_toWord, [Null]) => word (WordX.zero (WordSize.cpointer ())) | |
1731 | | (IntInf_compare, [IntInf i1, IntInf i2]) => | |
1732 | let | |
1733 | val i = | |
1734 | case IntInf.compare (i1, i2) of | |
1735 | Relation.LESS => ~1 | |
1736 | | Relation.EQUAL => 0 | |
1737 | | Relation.GREATER => 1 | |
1738 | in | |
1739 | word (WordX.fromIntInf (i, WordSize.compareRes)) | |
1740 | end | |
1741 | | (IntInf_toWord, [IntInf i]) => | |
1742 | (case IntInfRep.fromIntInf i of | |
1743 | IntInfRep.Big _ => ApplyResult.Unknown | |
1744 | | IntInfRep.Small w => word w) | |
1745 | | (IntInf_toVector, [IntInf i]) => | |
1746 | (case IntInfRep.fromIntInf i of | |
1747 | IntInfRep.Big v => wordVector v | |
1748 | | IntInfRep.Small _ => ApplyResult.Unknown) | |
1749 | | (_, [IntInf i1, IntInf i2, _]) => intInfBinary (i1, i2) | |
1750 | | (_, [IntInf i1, Word w2, _]) => intInfShiftOrToString (i1, w2) | |
1751 | | (_, [IntInf i1, _]) => intInfUnary (i1) | |
1752 | | (Vector_length, [WordVector v]) => | |
1753 | seqIndexConst (IntInf.fromInt (WordXVector.length v)) | |
1754 | | (Vector_sub, [WordVector v, Word i]) => | |
1755 | word (WordXVector.sub (v, WordX.toInt i)) | |
1756 | | (Real_neg _, [Real r]) => realOpt (RealX.neg r) | |
1757 | | (Real_abs _, [Real r]) => realOpt (RealX.abs r) | |
1758 | | (Real_Math_acos _, [Real r]) => realOpt (RealX.acos r) | |
1759 | | (Real_Math_asin _, [Real r]) => realOpt (RealX.asin r) | |
1760 | | (Real_Math_atan _, [Real r]) => realOpt (RealX.atan r) | |
1761 | | (Real_Math_atan2 _, [Real r1, Real r2]) => | |
1762 | realOpt (RealX.atan2 (r1, r2)) | |
1763 | | (Real_Math_cos _, [Real r]) => realOpt (RealX.cos r) | |
1764 | | (Real_Math_exp _, [Real r]) => realOpt (RealX.exp r) | |
1765 | | (Real_Math_ln _, [Real r]) => realOpt (RealX.ln r) | |
1766 | | (Real_Math_log10 _, [Real r]) => realOpt (RealX.log10 r) | |
1767 | | (Real_Math_sin _, [Real r]) => realOpt (RealX.sin r) | |
1768 | | (Real_Math_sqrt _, [Real r]) => realOpt (RealX.sqrt r) | |
1769 | | (Real_Math_tan _, [Real r]) => realOpt (RealX.tan r) | |
1770 | | (Real_add _, [Real r1, Real r2]) => realOpt (RealX.add (r1, r2)) | |
1771 | | (Real_div _, [Real r1, Real r2]) => realOpt (RealX.div (r1, r2)) | |
1772 | | (Real_mul _, [Real r1, Real r2]) => realOpt (RealX.mul (r1, r2)) | |
1773 | | (Real_sub _, [Real r1, Real r2]) => realOpt (RealX.sub (r1, r2)) | |
1774 | | (Real_muladd _, [Real r1, Real r2, Real r3]) => | |
1775 | realOpt (RealX.muladd (r1, r2, r3)) | |
1776 | | (Real_mulsub _, [Real r1, Real r2, Real r3]) => | |
1777 | realOpt (RealX.mulsub (r1, r2, r3)) | |
1778 | | (Real_equal _, [Real r1, Real r2]) => boolOpt (RealX.equal (r1, r2)) | |
1779 | | (Real_le _, [Real r1, Real r2]) => boolOpt (RealX.le (r1, r2)) | |
1780 | | (Real_lt _, [Real r1, Real r2]) => boolOpt (RealX.lt (r1, r2)) | |
1781 | | (Real_qequal _, [Real r1, Real r2]) => boolOpt (RealX.qequal (r1, r2)) | |
1782 | | (Real_castToWord _, [Real r]) => wordOpt (RealX.castToWord r) | |
1783 | | (Vector_vector, (Word w)::_) => | |
1784 | (wordVector o WordXVector.fromList) | |
1785 | ({elementSize = WordX.size w}, | |
1786 | List.map (cs, Const.deWord)) | |
1787 | | (Word_castToReal _, [Word w]) => realOpt (RealX.castFromWord w) | |
1788 | | (Word_rndToReal (_, s, {signed}), [Word w]) => | |
1789 | realOpt | |
1790 | (RealX.fromIntInf | |
1791 | (if signed then WordX.toIntInfX w else WordX.toIntInf w, s)) | |
1792 | | (Word_add _, [Word w1, Word w2]) => word (WordX.add (w1, w2)) | |
1793 | | (Word_addCheck s, [Word w1, Word w2]) => wcheck (op +, s, w1, w2) | |
1794 | | (Word_andb _, [Word w1, Word w2]) => word (WordX.andb (w1, w2)) | |
1795 | | (Word_equal _, [Word w1, Word w2]) => bool (WordX.equals (w1, w2)) | |
1796 | | (Word_lshift _, [Word w1, Word w2]) => word (WordX.lshift (w1, w2)) | |
1797 | | (Word_lt s, [Word w1, Word w2]) => wordCmp (WordX.lt, s, w1, w2) | |
1798 | | (Word_mul s, [Word w1, Word w2]) => wordS (WordX.mul, s, w1, w2) | |
1799 | | (Word_mulCheck s, [Word w1, Word w2]) => wcheck (op *, s, w1, w2) | |
1800 | | (Word_neg _, [Word w]) => word (WordX.neg w) | |
1801 | | (Word_negCheck s, [Word w]) => | |
1802 | wordOrOverflow (s, {signed = true}, ~ (WordX.toIntInfX w)) | |
1803 | | (Word_notb _, [Word w]) => word (WordX.notb w) | |
1804 | | (Word_orb _, [Word w1, Word w2]) => word (WordX.orb (w1, w2)) | |
1805 | | (Word_quot s, [Word w1, Word w2]) => | |
1806 | if WordX.isZero w2 | |
1807 | then ApplyResult.Unknown | |
1808 | else wordS (WordX.quot, s, w1, w2) | |
1809 | | (Word_rem s, [Word w1, Word w2]) => | |
1810 | if WordX.isZero w2 | |
1811 | then ApplyResult.Unknown | |
1812 | else wordS (WordX.rem, s, w1, w2) | |
1813 | | (Word_rol _, [Word w1, Word w2]) => word (WordX.rol (w1, w2)) | |
1814 | | (Word_ror _, [Word w1, Word w2]) => word (WordX.ror (w1, w2)) | |
1815 | | (Word_rshift s, [Word w1, Word w2]) => | |
1816 | wordS (WordX.rshift, s, w1, w2) | |
1817 | | (Word_sub _, [Word w1, Word w2]) => word (WordX.sub (w1, w2)) | |
1818 | | (Word_subCheck s, [Word w1, Word w2]) => wcheck (op -, s, w1, w2) | |
1819 | | (Word_toIntInf, [Word w]) => | |
1820 | (case IntInfRep.smallToIntInf w of | |
1821 | NONE => ApplyResult.Unknown | |
1822 | | SOME i => intInf i) | |
1823 | | (Word_extdToWord (_, s, {signed}), [Word w]) => | |
1824 | word (if signed then WordX.resizeX (w, s) | |
1825 | else WordX.resize (w, s)) | |
1826 | | (Word_xorb _, [Word w1, Word w2]) => word (WordX.xorb (w1, w2)) | |
1827 | | (WordVector_toIntInf, [WordVector v]) => | |
1828 | (case IntInfRep.bigToIntInf v of | |
1829 | NONE => ApplyResult.Unknown | |
1830 | | SOME i => intInf i) | |
1831 | | _ => ApplyResult.Unknown) | |
1832 | handle Chr => ApplyResult.Unknown | |
1833 | | Div => ApplyResult.Unknown | |
1834 | | Exn.Overflow => ApplyResult.Overflow | |
1835 | | Subscript => ApplyResult.Unknown | |
1836 | fun someVars () = | |
1837 | let | |
1838 | datatype z = datatype ApplyResult.t | |
1839 | fun varIntInf (x, i: IntInf.t, space, inOrder) = | |
1840 | let | |
1841 | fun neg () = Apply (intInfNeg, [x, space]) | |
1842 | fun notb () = Apply (intInfNotb, [x, space]) | |
1843 | val i = IntInf.toInt i | |
1844 | in | |
1845 | case p of | |
1846 | IntInf_add => if i = 0 then Var x else Unknown | |
1847 | | IntInf_andb => if i = 0 | |
1848 | then intInfConst 0 | |
1849 | else if i = ~1 | |
1850 | then Var x | |
1851 | else Unknown | |
1852 | | IntInf_arshift => if i = 0 | |
1853 | then intInfConst 0 | |
1854 | else if i = ~1 | |
1855 | then intInfConst ~1 | |
1856 | else Unknown | |
1857 | | IntInf_gcd => if (i = ~1 orelse i = 1) | |
1858 | then intInfConst 1 | |
1859 | else Unknown | |
1860 | | IntInf_lshift => if i = 0 | |
1861 | then intInfConst 0 | |
1862 | else Unknown | |
1863 | | IntInf_mul => | |
1864 | (case i of | |
1865 | 0 => intInfConst 0 | |
1866 | | 1 => Var x | |
1867 | | ~1 => neg () | |
1868 | | _ => Unknown) | |
1869 | | IntInf_orb => if i = 0 | |
1870 | then Var x | |
1871 | else if i = ~1 | |
1872 | then intInfConst ~1 | |
1873 | else Unknown | |
1874 | | IntInf_quot => if inOrder | |
1875 | then (case i of | |
1876 | 1 => Var x | |
1877 | | ~1 => neg () | |
1878 | | _ => Unknown) | |
1879 | else Unknown | |
1880 | | IntInf_rem => if inOrder andalso (i = ~1 orelse i = 1) | |
1881 | then intInfConst 0 | |
1882 | else Unknown | |
1883 | | IntInf_sub => if i = 0 | |
1884 | then if inOrder | |
1885 | then Var x | |
1886 | else neg () | |
1887 | else Unknown | |
1888 | | IntInf_xorb => if i = 0 | |
1889 | then Var x | |
1890 | else if i = ~1 | |
1891 | then notb () | |
1892 | else Unknown | |
1893 | | _ => Unknown | |
1894 | end handle Exn.Overflow => Unknown | |
1895 | fun varReal (x, r, inOrder) = | |
1896 | let | |
1897 | datatype z = datatype RealX.decon | |
1898 | datatype z = datatype ApplyResult.t | |
1899 | fun negIf (s, signBit) = | |
1900 | if signBit then realNeg (s, x) else Var x | |
1901 | (* The SML Basis library does not distinguish between | |
1902 | different NaN values, so optimizations that may only | |
1903 | produce a different NaN value can be considered safe. | |
1904 | For example, SNaN*1.0 = SNaN/1.0 = QNaN, so it is | |
1905 | safe to optimize x*1.0 and x/1.0 to x. *) | |
1906 | in | |
1907 | case RealX.decon r of | |
1908 | NONE => Unknown | |
1909 | | SOME d => | |
1910 | case d of | |
1911 | ZERO _ => Unknown | |
1912 | | ONE {signBit} => | |
1913 | (case p of | |
1914 | Real_mul s => negIf (s, signBit) | |
1915 | | Real_div s => if inOrder | |
1916 | then negIf (s, signBit) | |
1917 | else Unknown | |
1918 | | _ => Unknown) | |
1919 | | NAN => | |
1920 | (case p of | |
1921 | Real_Math_atan2 _ => real r | |
1922 | | Real_add _ => real r | |
1923 | | Real_div _ => real r | |
1924 | | Real_mul _ => real r | |
1925 | | Real_sub _ => real r | |
1926 | | Real_equal _ => bool false | |
1927 | | Real_qequal _ => bool true | |
1928 | | Real_le _ => bool false | |
1929 | | Real_lt _ => bool false | |
1930 | | _ => Unknown) | |
1931 | | POW2 {signBit, exp} => | |
1932 | (case p of | |
1933 | Real_mul s => | |
1934 | if not signBit andalso exp = 2 | |
1935 | then realAdd (s, x, x) | |
1936 | else Unknown | |
1937 | | Real_div s => | |
1938 | if inOrder andalso not signBit andalso exp = 0 | |
1939 | then realAdd (s, x, x) | |
1940 | else Unknown | |
1941 | | _ => Unknown) | |
1942 | | INF _ => Unknown | |
1943 | | FIN _ => Unknown | |
1944 | end | |
1945 | fun varWord (x, w, inOrder) = | |
1946 | let | |
1947 | val zero = word o WordX.zero | |
1948 | fun add () = if WordX.isZero w then Var x else Unknown | |
1949 | fun mul ((s, {signed}), neg) = | |
1950 | if WordX.isZero w | |
1951 | then word w | |
1952 | else if WordX.isOne w | |
1953 | then Var x | |
1954 | else if signed andalso WordX.isNegOne w | |
1955 | then Apply (neg s, [x]) | |
1956 | else Unknown | |
1957 | fun sub (s, neg) = | |
1958 | if WordX.isZero w | |
1959 | then if inOrder | |
1960 | then Var x | |
1961 | else Apply (neg s, [x]) | |
1962 | else Unknown | |
1963 | fun ro s = | |
1964 | if inOrder | |
1965 | then | |
1966 | if WordX.isZero | |
1967 | (WordX.rem | |
1968 | (w, | |
1969 | WordX.fromIntInf | |
1970 | (IntInf.fromInt | |
1971 | (Bits.toInt (WordSize.bits s)), | |
1972 | WordX.size w), | |
1973 | {signed = false})) | |
1974 | then Var x | |
1975 | else Unknown | |
1976 | else | |
1977 | if WordX.isZero w orelse WordX.isAllOnes w | |
1978 | then word w | |
1979 | else Unknown | |
1980 | fun shift s = | |
1981 | if inOrder | |
1982 | then if WordX.isZero w | |
1983 | then Var x | |
1984 | else if (WordX.ge | |
1985 | (w, | |
1986 | WordX.fromIntInf (Bits.toIntInf | |
1987 | (WordSize.bits s), | |
1988 | WordSize.shiftArg), | |
1989 | {signed = false})) | |
1990 | then zero s | |
1991 | else Unknown | |
1992 | else if WordX.isZero w | |
1993 | then zero s | |
1994 | else Unknown | |
1995 | in | |
1996 | case p of | |
1997 | CPointer_add => | |
1998 | if WordX.isZero w | |
1999 | then Var x | |
2000 | else Unknown | |
2001 | | CPointer_sub => | |
2002 | if WordX.isZero w | |
2003 | andalso inOrder | |
2004 | then Var x | |
2005 | else Unknown | |
2006 | | Word_add _ => add () | |
2007 | | Word_addCheck _ => add () | |
2008 | | Word_andb s => | |
2009 | if WordX.isZero w | |
2010 | then zero s | |
2011 | else if WordX.isAllOnes w | |
2012 | then Var x | |
2013 | else Unknown | |
2014 | | Word_lshift s => shift s | |
2015 | | Word_lt (_, sg) => | |
2016 | if inOrder | |
2017 | then if WordX.isMin (w, sg) then f else Unknown | |
2018 | else if WordX.isMax (w, sg) then f else Unknown | |
2019 | | Word_mul s => mul (s, wordNeg) | |
2020 | | Word_mulCheck s => mul (s, wordNegCheck) | |
2021 | | Word_orb _ => | |
2022 | if WordX.isZero w | |
2023 | then Var x | |
2024 | else if WordX.isAllOnes w | |
2025 | then word w | |
2026 | else Unknown | |
2027 | | Word_quot (s, {signed}) => | |
2028 | if inOrder | |
2029 | then | |
2030 | if WordX.isOne w | |
2031 | then Var x | |
2032 | else if signed andalso WordX.isNegOne w | |
2033 | then Apply (wordNeg s, [x]) | |
2034 | else Unknown | |
2035 | else Unknown | |
2036 | | Word_rem (s, {signed}) => | |
2037 | if inOrder | |
2038 | andalso (WordX.isOne w | |
2039 | orelse signed andalso WordX.isNegOne w) | |
2040 | then zero s | |
2041 | else Unknown | |
2042 | | Word_rol s => ro s | |
2043 | | Word_ror s => ro s | |
2044 | | Word_rshift (s, {signed}) => | |
2045 | if signed | |
2046 | then | |
2047 | if WordX.isZero w | |
2048 | then if inOrder then Var x else zero s | |
2049 | else if WordX.isAllOnes w andalso not inOrder | |
2050 | then word w | |
2051 | else Unknown | |
2052 | else | |
2053 | shift s | |
2054 | | Word_sub s => sub (s, wordNeg) | |
2055 | | Word_subCheck s => sub (s, wordNegCheck o #1) | |
2056 | | Word_xorb s => | |
2057 | if WordX.isZero w | |
2058 | then Var x | |
2059 | else if WordX.isAllOnes w | |
2060 | then Apply (wordNotb s, [x]) | |
2061 | else Unknown | |
2062 | | _ => Unknown | |
2063 | end | |
2064 | datatype z = datatype ApplyArg.t | |
2065 | in | |
2066 | case (p, args) of | |
2067 | (_, [Con {con = c, hasArg = h}, Con {con = c', ...}]) => | |
2068 | if (case p of | |
2069 | MLton_eq => true | |
2070 | | MLton_equal => true | |
2071 | | _ => false) | |
2072 | then if Con.equals (c, c') | |
2073 | then if h | |
2074 | then Unknown | |
2075 | else t | |
2076 | else f | |
2077 | else Unknown | |
2078 | | (_, [Var x, Const (Real r)]) => varReal (x, r, true) | |
2079 | | (_, [Const (Real r), Var x]) => varReal (x, r, false) | |
2080 | | (_, [Var x, Const (Word i)]) => varWord (x, i, true) | |
2081 | | (_, [Const (Word i), Var x]) => varWord (x, i, false) | |
2082 | | (_, [Const (IntInf i1), Const (IntInf i2), _]) => | |
2083 | intInfBinary (i1, i2) | |
2084 | | (_, [Const (IntInf i1), Const (Word w2), _]) => | |
2085 | intInfShiftOrToString (i1, w2) | |
2086 | | (_, [Const (IntInf i1), _]) => intInfUnary (i1) | |
2087 | | (_, [Var x, Const (IntInf i), Var space]) => | |
2088 | varIntInf (x, i, space, true) | |
2089 | | (_, [Const (IntInf i), Var x, Var space]) => | |
2090 | varIntInf (x, i, space, false) | |
2091 | | (_, [Var x, Const (Word w), _]) => | |
2092 | if WordX.isZero w | |
2093 | then | |
2094 | let | |
2095 | datatype z = datatype ApplyResult.t | |
2096 | in | |
2097 | case p of | |
2098 | IntInf_arshift => Var x | |
2099 | | IntInf_lshift => Var x | |
2100 | | _ => Unknown | |
2101 | end | |
2102 | else Unknown | |
2103 | | (_, [Var x, Var y, _]) => | |
2104 | if varEquals (x, y) | |
2105 | then let datatype z = datatype ApplyResult.t | |
2106 | in | |
2107 | case p of | |
2108 | IntInf_andb => Var x | |
2109 | | IntInf_orb => Var x | |
2110 | | IntInf_quot => intInfConst 1 | |
2111 | | IntInf_rem => intInfConst 0 | |
2112 | | IntInf_sub => intInfConst 0 | |
2113 | | IntInf_xorb => intInfConst 0 | |
2114 | | _ => Unknown | |
2115 | end | |
2116 | else Unknown | |
2117 | | (_, [Var x, Var y]) => | |
2118 | if varEquals (x, y) | |
2119 | then let | |
2120 | datatype z = datatype ApplyResult.t | |
2121 | in | |
2122 | case p of | |
2123 | CPointer_diff => word (WordX.zero (WordSize.cptrdiff ())) | |
2124 | | CPointer_equal => t | |
2125 | | CPointer_lt => f | |
2126 | | IntInf_compare => | |
2127 | word (WordX.zero WordSize.compareRes) | |
2128 | | MLton_eq => t | |
2129 | | MLton_equal => t | |
2130 | | Real_lt _ => f | |
2131 | | Real_qequal _ => t | |
2132 | | Word_andb _ => Var x | |
2133 | | Word_equal _ => t | |
2134 | | Word_lt _ => f | |
2135 | | Word_orb _ => Var x | |
2136 | | Word_quot (s, _) => word (WordX.one s) | |
2137 | | Word_rem (s, _) => word (WordX.zero s) | |
2138 | | Word_sub s => word (WordX.zero s) | |
2139 | | Word_subCheck (s, _) => word (WordX.zero s) | |
2140 | | Word_xorb s => word (WordX.zero s) | |
2141 | | _ => Unknown | |
2142 | end | |
2143 | else Unknown | |
2144 | | _ => Unknown | |
2145 | end | |
2146 | in | |
2147 | if List.forall (args, fn ApplyArg.Const _ => true | _ => false) | |
2148 | then | |
2149 | allConsts | |
2150 | (List.map | |
2151 | (args, fn ApplyArg.Const c => c | _ => Error.bug "Prim.apply")) | |
2152 | else someVars () | |
2153 | end | |
2154 | ||
2155 | fun ('a, 'b) layoutApp (p: 'a t, | |
2156 | args: 'b vector, | |
2157 | layoutArg: 'b -> Layout.t): Layout.t = | |
2158 | let | |
2159 | fun arg i = layoutArg (Vector.sub (args, i)) | |
2160 | open Layout | |
2161 | fun one name = seq [str name, str " ", arg 0] | |
2162 | fun two name = seq [arg 0, str " ", str name, str " ", arg 1] | |
2163 | in | |
2164 | case p of | |
2165 | Array_length => one "length" | |
2166 | | Real_Math_acos _ => one "acos" | |
2167 | | Real_Math_asin _ => one "asin" | |
2168 | | Real_Math_atan _ => one "atan" | |
2169 | | Real_Math_cos _ => one "cos" | |
2170 | | Real_Math_exp _ => one "exp" | |
2171 | | Real_Math_ln _ => one "ln" | |
2172 | | Real_Math_log10 _ => one "log10" | |
2173 | | Real_Math_sin _ => one "sin" | |
2174 | | Real_Math_sqrt _ => one "sqrt" | |
2175 | | Real_Math_tan _ => one "tan" | |
2176 | | Real_add _ => two "+" | |
2177 | | Real_div _ => two "/" | |
2178 | | Real_equal _ => two "==" | |
2179 | | Real_le _ => two "<=" | |
2180 | | Real_lt _ => two "<" | |
2181 | | Real_mul _ => two "*" | |
2182 | | Real_neg _ => one "-" | |
2183 | | Real_qequal _ => two "?=" | |
2184 | | Real_sub _ => two "-" | |
2185 | | Ref_assign => two ":=" | |
2186 | | Ref_deref => one "!" | |
2187 | | Ref_ref => one "ref" | |
2188 | | Vector_length => one "length" | |
2189 | | Word_add _ => two "+" | |
2190 | | Word_addCheck _ => two "+" | |
2191 | | Word_andb _ => two "&" | |
2192 | | Word_equal _ => two "=" | |
2193 | | Word_lshift _ => two "<<" | |
2194 | | Word_lt _ => two "<" | |
2195 | | Word_mul _ => two "*" | |
2196 | | Word_mulCheck _ => two "*" | |
2197 | | Word_neg _ => one "-" | |
2198 | | Word_negCheck _ => one "-" | |
2199 | | Word_orb _ => two "|" | |
2200 | | Word_rol _ => two "rol" | |
2201 | | Word_ror _ => two "ror" | |
2202 | | Word_rshift (_, {signed}) => two (if signed then "~>>" else ">>") | |
2203 | | Word_sub _ => two "-" | |
2204 | | Word_subCheck _ => two "-" | |
2205 | | Word_xorb _ => two "^" | |
2206 | | _ => seq [layout p, str " ", Vector.layout layoutArg args] | |
2207 | end | |
2208 | ||
2209 | structure Name = | |
2210 | struct | |
2211 | datatype t = datatype t | |
2212 | val toString = toString | |
2213 | end | |
2214 | ||
2215 | end |