mlton/atoms/prim.fun

   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