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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
11 * If you add new polymorphic primitives, you must modify extractTargs.
14 functor Prim (S: PRIM_STRUCTS): PRIM =
22 structure RealX = RealX
23 structure WordX = WordX
24 structure WordXVector = WordXVector
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,
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.
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.
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
106 * MLton_handlesSignals is translated by closure conversion into
107 * a boolean, and is true iff MLton_installsSignalHandler is called.
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
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) *)
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.
204 fun toString (n: 'a t): string =
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]
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"
372 fun layout p = Layout.str (toString p)
373 fun layoutFull (p, layoutX) =
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 ",
379 [("name", Layout.str name),
380 ("cty", Option.layout CType.layout cty),
381 ("symbolScope", CFunction.SymbolScope.layout symbolScope)]]
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')
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')
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')
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
558 val map: 'a t * ('a -> 'b) -> 'b t =
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
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
703 val cast: 'a t -> 'b t = fn p => map (p, fn _ => Error.bug "Prim.cast")
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
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
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))
732 val cpointerLt = CPointer_lt
733 fun cpointerSet ctype =
734 let datatype z = datatype CType.t
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))
750 val cpointerSub = CPointer_sub
751 val cpointerToWord = CPointer_toWord
752 val deref = Ref_deref
754 val equal = MLton_equal
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
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
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
788 | MLton_equal => true
791 | Real_equal _ => true
792 | Real_qequal _ => true
794 | Word_addCheck _ => true
795 | Word_andb _ => true
796 | Word_equal _ => true
798 | Word_mulCheck _ => true
800 | Word_xorb _ => true
804 fn Word_addCheck _ => true
805 | Word_mulCheck _ => true
806 | Word_negCheck _ => true
807 | Word_subCheck _ => true
810 val kind: 'a t -> Kind.t =
813 datatype z = datatype Kind.t
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
961 fun isFunctional p = Kind.Functional = kind p
963 fun maySideEffect p = Kind.SideEffect = kind p
966 fun reals (s: RealSize.t) =
993 fun wordSigns (s: WordSize.t, signed: bool) =
995 val sg = {signed = signed}
997 List.map ([Word_addCheck,
1008 fun words (s: WordSize.t) =
1021 @ wordSigns (s, true)
1022 @ wordSigns (s, false)
1024 val all: unit t list =
1025 [Array_alloc {raw = false},
1026 Array_alloc {raw = true},
1040 CPointer_getCPointer,
1043 CPointer_setCPointer,
1075 MLton_handlesSignals,
1076 MLton_installSignalHandler,
1084 String_toWord8Vector,
1092 TopLevel_getHandler,
1094 TopLevel_setHandler,
1103 WordVector_toIntInf,
1104 Word8Vector_toString,
1106 @ List.concat [List.concatMap (RealSize.all, reals),
1107 List.concatMap (WordSize.prims, words)]
1109 val real = RealSize.all
1110 val word = WordSize.prims
1113 (WordSize.all, fn s => not (List.contains (word, s, WordSize.equals)))
1114 fun coerces (name, sizes, sizes', ac) =
1116 (sizes, ac, fn (s, ac) =>
1118 (sizes', ac, fn (s', ac) =>
1119 name (s, s') :: ac))
1120 fun coercesS (name, sizes, sizes', ac) =
1122 ([false, true], ac, fn (signed, ac) =>
1123 coerces (fn (s, s') => name (s, s', {signed = signed}),
1125 fun casts (name, sizes, ac) =
1126 List.fold (sizes, ac, fn (s, ac) => name s :: ac)
1127 fun castsS (name, sizes, ac) =
1129 ([false, true], ac, fn (signed, ac) =>
1130 casts (fn s => name (s, {signed = signed}),
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, []))))))))
1143 (WordSize.prims, fn seqSize =>
1145 (WordSize.prims, fn eleSize =>
1147 ([WordArray_subWord, WordArray_updateWord, WordVector_subWord], fn p =>
1148 p {seqSize = seqSize, eleSize = eleSize})))
1150 fun doit (all, get, set) =
1151 List.concatMap (all, fn s => [get s, set s])
1153 List.concat [doit (RealSize.all, CPointer_getReal, CPointer_setReal),
1154 doit (WordSize.prims, CPointer_getWord, CPointer_setWord)]
1159 val table: {hash: word,
1161 string: string} HashSet.t =
1162 HashSet.new {hash = #hash}
1164 List.foreach (all, fn prim =>
1166 val string = toString prim
1167 val hash = String.hash string
1169 HashSet.lookupOrInsert (table, hash,
1171 fn () => {hash = hash,
1178 val fromString: string -> 'a t option =
1182 (table, String.hash name, fn {string, ...} => name = string),
1183 fn {prim, ...} => cast prim)
1186 fun 'a checkApp (prim: 'a t,
1190 typeOps = {array: 'a -> 'a,
1191 arrow: 'a * 'a -> 'a,
1194 equals: 'a * 'a -> bool,
1197 real: RealSize.t -> 'a,
1203 word: WordSize.t -> 'a}}): bool =
1205 fun arg i = Vector.sub (args, i)
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)
1233 0 = Vector.length targs
1236 1 = Vector.length targs
1237 andalso done (f (targ 0))
1239 fun make f s = let val t = f s
1240 in noTargs (fn () => (oneArg t, t))
1243 val realUnary = make real
1244 val wordUnary = make word
1247 fun make f s = let val t = f s
1248 in noTargs (fn () => (twoArgs (t, t), t))
1251 val realBinary = make real
1252 val wordBinary = make word
1255 fun make f s = let val t = f s
1256 in noTargs (fn () => (twoArgs (t, t), bool))
1259 val realCompare = make real
1260 val wordCompare = make word
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 ())
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))
1280 noTargs (fn () => (threeArgs (real s, real s, real s), real s))
1281 fun wordArray seqSize = array (word seqSize)
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
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))
1297 oneTarg (fn t => (twoArgs (array t, seqIndex), unit))
1298 | Array_uninitIsNop =>
1299 oneTarg (fn t => (oneArg (array t), bool))
1301 oneTarg (fn t => (threeArgs (array t, seqIndex, t), unit))
1303 noTargs (fn () => (twoArgs (cpointer, cptrdiff), cpointer))
1305 noTargs (fn () => (twoArgs (cpointer, cpointer), cptrdiff))
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))
1318 noTargs (fn () => (twoArgs (cpointer, cpointer), bool))
1319 | CPointer_setCPointer =>
1320 noTargs (fn () => (threeArgs (cpointer, cptrdiff, cpointer),
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))
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))
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 ()
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))
1468 Trace.trace ("Prim.check", layout o #1, Layout.ignore) checkApp z
1470 fun ('a, 'b) extractTargs (prim: 'b t,
1473 typeOps = {deArray: 'a -> 'a,
1474 deArrow: 'a -> 'a * 'a,
1477 deWeak: 'a -> 'a}}) =
1479 val one = Vector.new1
1480 fun arg i = Vector.sub (args, i)
1481 datatype z = datatype t
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 ()
1521 Trace.trace ("Prim.extractTargs", layout o #1, Layout.ignore) extractTargs z
1523 structure IntInfRep = Const.IntInfRep
1525 structure ApplyArg =
1528 Con of {con: Con.t, hasArg: bool}
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
1540 structure ApplyResult =
1543 val layoutPrim = layout
1545 datatype ('a, 'b) t =
1546 Apply of 'a prim * 'b list
1553 fun layout layoutX ar =
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
1568 * In addition to constant folding, here are the algebraic identities currently
1572 * x * ~1 = ~1 * 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
1584 * x > x = x < x = false
1585 * x >= x = x <= x = true
1588 * Also, simple equality tests on constructors are handled.
1591 * A x = B y --> false
1594 fun ('a, 'b) apply (p: 'a t,
1595 args: 'b ApplyArg.t list,
1596 varEquals: 'b * 'b -> bool): ('a, 'b) ApplyResult.t =
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
1604 fun seqIndexConst i =
1606 (Const.word (WordX.fromIntInf (i, WordSize.seqIndex ())))
1608 val maxIntInf = IntInf.<< (1, 0w128)
1609 val minIntInf = IntInf.~ maxIntInf
1611 fun intInfTooBig ii =
1612 IntInf.< (ii, minIntInf)
1613 orelse IntInf.> (ii, maxIntInf)
1617 ("Prim.intInfTooBig", IntInf.layout, Bool.layout)
1619 fun intInf (ii: IntInf.t): ('a, 'b) ApplyResult.t =
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),
1642 word (f (w, w', sg))
1643 fun wordCmp (f: WordX.t * WordX.t * {signed: bool} -> bool,
1644 (_: WordSize.t, sg),
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}),
1657 val conv = if signed then WordX.toIntInfX else WordX.toIntInf
1659 wordOrOverflow (s, sg, f (conv w, conv w'))
1662 fn (Word w1, Word w2) => bool (WordX.equals (w1, w2))
1663 | _ => ApplyResult.Unknown
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
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) =
1686 then ApplyResult.Unknown
1689 IntInf_neg => intInf (IntInf.~ i1)
1690 | IntInf_notb => intInf (IntInf.notb i1)
1691 | _ => ApplyResult.Unknown
1692 fun intInfShiftOrToString (i1, w2) =
1694 then ApplyResult.Unknown
1698 intInf (IntInf.~>> (i1, Word.fromIntInf (WordX.toIntInf w2)))
1702 WordX.fromIntInf (128, WordSize.shiftArg)
1704 if WordX.lt (w2, maxShift, {signed = false})
1705 then intInf (IntInf.<< (i1, Word.fromIntInf (WordX.toIntInf w2)))
1706 else ApplyResult.Unknown
1708 | IntInf_toString =>
1711 case WordX.toInt w2 of
1713 | 8 => StringCvt.OCT
1714 | 10 => StringCvt.DEC
1715 | 16 => StringCvt.HEX
1716 | _ => Error.bug "Prim.apply: strange base for IntInf_toString"
1718 ApplyResult.Const (Const.string (IntInf.format (i1, base)))
1720 | _ => ApplyResult.Unknown
1721 fun allConsts (cs: Const.t list) =
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]) =>
1729 else ApplyResult.Unknown
1730 | (CPointer_toWord, [Null]) => word (WordX.zero (WordSize.cpointer ()))
1731 | (IntInf_compare, [IntInf i1, IntInf i2]) =>
1734 case IntInf.compare (i1, i2) of
1736 | Relation.EQUAL => 0
1737 | Relation.GREATER => 1
1739 word (WordX.fromIntInf (i, WordSize.compareRes))
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]) =>
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]) =>
1807 then ApplyResult.Unknown
1808 else wordS (WordX.quot, s, w1, w2)
1809 | (Word_rem s, [Word w1, Word 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
1838 datatype z = datatype ApplyResult.t
1839 fun varIntInf (x, i: IntInf.t, space, inOrder) =
1841 fun neg () = Apply (intInfNeg, [x, space])
1842 fun notb () = Apply (intInfNotb, [x, space])
1843 val i = IntInf.toInt i
1846 IntInf_add => if i = 0 then Var x else Unknown
1847 | IntInf_andb => if i = 0
1852 | IntInf_arshift => if i = 0
1857 | IntInf_gcd => if (i = ~1 orelse i = 1)
1860 | IntInf_lshift => if i = 0
1869 | IntInf_orb => if i = 0
1874 | IntInf_quot => if inOrder
1880 | IntInf_rem => if inOrder andalso (i = ~1 orelse i = 1)
1883 | IntInf_sub => if i = 0
1888 | IntInf_xorb => if i = 0
1894 end handle Exn.Overflow => Unknown
1895 fun varReal (x, r, inOrder) =
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. *)
1907 case RealX.decon r of
1914 Real_mul s => negIf (s, signBit)
1915 | Real_div s => if inOrder
1916 then negIf (s, signBit)
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
1931 | POW2 {signBit, exp} =>
1934 if not signBit andalso exp = 2
1935 then realAdd (s, x, x)
1938 if inOrder andalso not signBit andalso exp = 0
1939 then realAdd (s, x, x)
1945 fun varWord (x, w, inOrder) =
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) =
1952 else if WordX.isOne w
1954 else if signed andalso WordX.isNegOne w
1955 then Apply (neg s, [x])
1961 else Apply (neg s, [x])
1971 (Bits.toInt (WordSize.bits s)),
1977 if WordX.isZero w orelse WordX.isAllOnes w
1982 then if WordX.isZero w
1986 WordX.fromIntInf (Bits.toIntInf
1992 else if WordX.isZero w
2006 | Word_add _ => add ()
2007 | Word_addCheck _ => add ()
2011 else if WordX.isAllOnes w
2014 | Word_lshift s => shift s
2015 | Word_lt (_, sg) =>
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)
2024 else if WordX.isAllOnes w
2027 | Word_quot (s, {signed}) =>
2032 else if signed andalso WordX.isNegOne w
2033 then Apply (wordNeg s, [x])
2036 | Word_rem (s, {signed}) =>
2038 andalso (WordX.isOne w
2039 orelse signed andalso WordX.isNegOne w)
2042 | Word_rol s => ro s
2043 | Word_ror s => ro s
2044 | Word_rshift (s, {signed}) =>
2048 then if inOrder then Var x else zero s
2049 else if WordX.isAllOnes w andalso not inOrder
2054 | Word_sub s => sub (s, wordNeg)
2055 | Word_subCheck s => sub (s, wordNegCheck o #1)
2059 else if WordX.isAllOnes w
2060 then Apply (wordNotb s, [x])
2064 datatype z = datatype ApplyArg.t
2067 (_, [Con {con = c, hasArg = h}, Con {con = c', ...}]) =>
2070 | MLton_equal => true
2072 then if Con.equals (c, c')
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), _]) =>
2095 datatype z = datatype ApplyResult.t
2098 IntInf_arshift => Var x
2099 | IntInf_lshift => Var x
2103 | (_, [Var x, Var y, _]) =>
2105 then let datatype z = datatype ApplyResult.t
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
2117 | (_, [Var x, Var y]) =>
2120 datatype z = datatype ApplyResult.t
2123 CPointer_diff => word (WordX.zero (WordSize.cptrdiff ()))
2124 | CPointer_equal => t
2127 word (WordX.zero WordSize.compareRes)
2131 | Real_qequal _ => t
2132 | Word_andb _ => Var x
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)
2147 if List.forall (args, fn ApplyArg.Const _ => true | _ => false)
2151 (args, fn ApplyArg.Const c => c | _ => Error.bug "Prim.apply"))
2155 fun ('a, 'b) layoutApp (p: 'a t,
2157 layoutArg: 'b -> Layout.t): Layout.t =
2159 fun arg i = layoutArg (Vector.sub (args, i))
2161 fun one name = seq [str name, str " ", arg 0]
2162 fun two name = seq [arg 0, str " ", str name, str " ", arg 1]
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]
2211 datatype t = datatype t
2212 val toString = toString