fir/util/fir_util.ml

   1 (*
   2  * Some common unitilites.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * @begin[license]
   7  * Copyright (C) 2001 Jason Hickey, Caltech
   8  *
   9  * This program is free software; you can redistribute it and/or
  10  * modify it under the terms of the GNU General Public License
  11  * as published by the Free Software Foundation; either version 2
  12  * of the License, or (at your option) any later version.
  13  *
  14  * This program is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17  * GNU General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU General Public License
  20  * along with this program; if not, write to the Free Software
  21  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22  *
  23  * Author: Jason Hickey
  24  * @email{jyh@cs.caltech.edu}
  25  * @end[license]
  26  *)
  27 open Symbol
  28
  29 open Fir
  30 open Fir_ds
  31
  32 (*
  33  * Field tables.
  34  *)
  35 (*
  36  * Frame label tables.
  37  *)
  38 module FrameLabelCompare =
  39 struct
  40    type t = frame_label
  41
  42    let compare (x1, x2, x3) (y1, y2, y3) =
  43       let cmp1 = Symbol.compare x1 y1 in
  44          if cmp1 = 0 then
  45             let cmp2 = Symbol.compare x2 y2 in
  46                if cmp2 = 0 then
  47                   Symbol.compare x3 y3
  48                else
  49                   cmp2
  50          else
  51             cmp1
  52 end
  53
  54 module FrameLabelTable = Mc_map.McMake (FrameLabelCompare)
  55
  56 (*
  57  * Map a function over all the types in the unop.
  58  *)
  59 let map_type_unop f op =
  60    match op with
  61       NotEnumOp _
  62
  63       (* Negation (arithmetic and bitwise) for NAML ints *)
  64     | UMinusIntOp
  65     | NotIntOp
  66     | AbsIntOp
  67
  68       (* Negation (arithmetic and bitwise) for native ints *)
  69     | UMinusRawIntOp _
  70     | NotRawIntOp _
  71
  72       (*
  73        * RawBitFieldOp (pre, signed, offset, length):
  74        *    Extracts the bitfield in an integer value, which starts at bit
  75        *    <offset> (counting from LSB) and containing <length> bits. The
  76        *    bit shift and length are constant values.  To access a variable
  77        *    bitfield you must do a manual shift/mask; this optimization is
  78        *    only good for constant values.  (pre, signed) refer to the
  79        *    rawint precision of the result; the input should be int32.
  80        *)
  81     | RawBitFieldOp     _
  82
  83       (* Unary floating-point operations *)
  84     | UMinusFloatOp     _
  85     | AbsFloatOp        _
  86     | SinFloatOp        _
  87     | CosFloatOp        _
  88     | TanFloatOp        _
  89     | ASinFloatOp       _
  90     | ACosFloatOp       _
  91     | ATanFloatOp       _
  92     | SinHFloatOp       _
  93     | CosHFloatOp       _
  94     | TanHFloatOp       _
  95     | ExpFloatOp        _
  96     | LogFloatOp        _
  97     | Log10FloatOp      _
  98     | SqrtFloatOp       _
  99     | CeilFloatOp       _
 100     | FloorFloatOp      _
 101
 102       (*
 103        * Coercions:
 104        *    Int refers to an ML-style integer
 105        *    Float refers to floating-point value
 106        *    RawInt refers to native int, any precision
 107        *
 108        * In operators where both terms have precision qualifiers, the
 109        * destination precision is always specified before the source
 110        * precision.
 111        *)
 112
 113       (* Coercions to int *)
 114     | IntOfFloatOp      _
 115     | IntOfRawIntOp     _
 116
 117       (* Coerce to float *)
 118     | FloatOfIntOp      _
 119     | FloatOfFloatOp    _
 120     | FloatOfRawIntOp   _
 121
 122       (* Coerce to rawint *)
 123     | RawIntOfIntOp     _
 124     | RawIntOfEnumOp    _
 125     | RawIntOfFloatOp   _
 126
 127       (*
 128        * Coerce a rawint _
 129        * First pair is destination precision, second pair is source.
 130        *)
 131     | RawIntOfRawIntOp  _
 132
 133       (*
 134        * Integer<->pointer coercions (only for C, not inherently safe)
 135        * These operators are specifically related to infix pointers...
 136        *)
 137     | RawIntOfPointerOp _
 138     | PointerOfRawIntOp _
 139
 140       (*
 141        * Create an infix pointer from a block pointer.  The infix pointer
 142        * so that both the base and _
 143        * to the beginning _
 144        *)
 145     | PointerOfBlockOp _ ->
 146          op
 147
 148       (*
 149        * Get the block length.
 150        *)
 151     | LengthOfBlockOp (subop, ty) ->
 152          LengthOfBlockOp (subop, f ty)
 153
 154       (*
 155        * Type coercions.
 156        *)
 157     | DTupleOfDTupleOp (ty_var, ty_fields) ->
 158          DTupleOfDTupleOp (ty_var, List.map (fun (ty, b) -> f ty, b) ty_fields)
 159     | UnionOfUnionOp (ty_var, tyl, s1, s2) ->
 160          UnionOfUnionOp (ty_var, List.map f tyl, s1, s2)
 161     | RawDataOfFrameOp (ty_var, tyl) ->
 162          RawDataOfFrameOp (ty_var, List.map f tyl)
 163
 164 (*
 165  * Map a function over all the types in the binop.
 166  *)
 167 let map_type_binop f op =
 168    match op with
 169       (* Bitwise operations on enumerations. *)
 170       AndEnumOp _
 171     | OrEnumOp _
 172     | XorEnumOp _
 173
 174       (* Standard binary operations on NAML ints *)
 175     | PlusIntOp
 176     | MinusIntOp
 177     | MulIntOp
 178     | DivIntOp
 179     | RemIntOp
 180     | LslIntOp
 181     | LsrIntOp
 182     | AsrIntOp
 183     | AndIntOp
 184     | OrIntOp
 185     | XorIntOp
 186     | MaxIntOp
 187     | MinIntOp
 188
 189       (* Comparisons on NAML ints *)
 190     | EqIntOp
 191     | NeqIntOp
 192     | LtIntOp
 193     | LeIntOp
 194     | GtIntOp
 195     | GeIntOp
 196     | CmpIntOp                (* Similar to ML's ``compare'' function. *)
 197
 198       (*
 199        * Standard binary operations on native ints.  The precision is
 200        * the result precision; the inputs should match this precision.
 201        *)
 202     | PlusRawIntOp   _
 203     | MinusRawIntOp  _
 204     | MulRawIntOp    _
 205     | DivRawIntOp    _
 206     | RemRawIntOp    _
 207     | SlRawIntOp     _
 208     | SrRawIntOp     _
 209     | AndRawIntOp    _
 210     | OrRawIntOp     _
 211     | XorRawIntOp    _
 212     | MaxRawIntOp    _
 213     | MinRawIntOp    _
 214
 215       (*
 216        * RawSetBitFieldOp (pre, signed, _
 217        *    See comments for RawBitFieldOp. This modifies the bitfield starting
 218        *    at bit <_
 219        *       First atom is the integer containing the field.
 220        *       Second atom is the value to be set in the field.
 221        *    The resulting integer contains the revised field, with type
 222        *    ACRawInt (pre, signed)
 223        *)
 224     | RawSetBitFieldOp _
 225
 226       (* Comparisons on native ints *)
 227     | EqRawIntOp     _
 228     | NeqRawIntOp    _
 229     | LtRawIntOp     _
 230     | LeRawIntOp     _
 231     | GtRawIntOp     _
 232     | GeRawIntOp     _
 233     | CmpRawIntOp    _
 234
 235       (* Standard binary operations on floats *)
 236     | PlusFloatOp  _
 237     | MinusFloatOp _
 238     | MulFloatOp   _
 239     | DivFloatOp   _
 240     | RemFloatOp   _
 241     | MaxFloatOp   _
 242     | MinFloatOp   _
 243
 244       (* Comparisons on floats *)
 245     | EqFloatOp    _
 246     | NeqFloatOp   _
 247     | LtFloatOp    _
 248     | LeFloatOp    _
 249     | GtFloatOp    _
 250     | GeFloatOp    _
 251     | CmpFloatOp   _
 252
 253       (*
 254        * Arctangent.  This computes arctan(y/x), where y is the first atom
 255        * and x is the second atom given.  Handles case when x = 0 correctly.
 256        *)
 257     | ATan2FloatOp _
 258
 259       (*
 260        * Power.  This computes x^y.
 261        *)
 262     | PowerFloatOp _
 263
 264       (*
 265        * Float hacking.
 266        * This sets the exponent field _
 267        *)
 268     | LdExpFloatIntOp _
 269
 270       (*
 271        * Pointer arithmetic. The pointer in the first argument, and the
 272        * returned pointer should be infix pointers (which keep the base
 273        * pointer as well as a pointer to anywhere within the block).
 274        *)
 275     | PlusPointerOp _ ->
 276          op
 277
 278
 279       (* Pointer (in)equality.  Arguments must have the given type *)
 280     | EqEqOp ty ->
 281          EqEqOp (f ty)
 282     | NeqEqOp ty ->
 283          NeqEqOp (f ty)
 284
 285 (*
 286  * Map a function over all types in the atom.
 287  *)
 288 let rec map_type_atom f a =
 289    match a with
 290       AtomInt _
 291     | AtomEnum _
 292     | AtomRawInt _
 293     | AtomFloat _
 294     | AtomVar _
 295     | AtomFun _
 296     | AtomLabel _
 297     | AtomSizeof _
 298     | AtomTyUnpack _ ->
 299          a
 300     | AtomNil ty ->
 301          AtomNil (f ty)
 302     | AtomConst (ty, ty_v, i) ->
 303          AtomConst (f ty, ty_v, i)
 304     | AtomTyApply (v, ty, tyl) ->
 305          AtomTyApply (v, f ty, List.map f tyl)
 306     | AtomTyPack (v, ty, tyl) ->
 307          AtomTyPack (v, f ty, List.map f tyl)
 308     | AtomUnop (op, a) ->
 309          AtomUnop (map_type_unop f op, map_type_atom f a)
 310     | AtomBinop (op, a1, a2) ->
 311          AtomBinop (map_type_binop f op, map_type_atom f a1, map_type_atom f a2)
 312
 313 let map_type_atom_opt f a =
 314    match a with
 315       Some a ->
 316          Some (map_type_atom f a)
 317     | None ->
 318          None
 319
 320 let map_type_atoms f args =
 321    List.map (map_type_atom f) args
 322
 323 let map_type_atom_opt_list f args =
 324    List.map (map_type_atom_opt f) args
 325
 326 (*
 327  * Map a type over all the types in the alloc_op.
 328  *)
 329 let map_type_alloc_op f op =
 330    match op with
 331       AllocTuple (tclass, ty_vars, ty, args) ->
 332          AllocTuple (tclass, ty_vars, f ty, map_type_atoms f args)
 333     | AllocUnion (ty_vars, ty, ty_v, i, args) ->
 334          AllocUnion (ty_vars, f ty, ty_v, i, map_type_atoms f args)
 335     | AllocArray (ty, args) ->
 336          AllocArray (f ty, map_type_atoms f args)
 337     | AllocVArray (ty, sub_index, a1, a2) ->
 338          AllocVArray (f ty, sub_index, map_type_atom f a1, map_type_atom f a2)
 339     | AllocMalloc (ty, a) ->
 340          AllocMalloc (f ty, map_type_atom f a)
 341     | AllocFrame (v, tyl) ->
 342          AllocFrame (v, List.map f tyl)
 343     | AllocDTuple (ty, ty_var, a, args) ->
 344          AllocDTuple (f ty, ty_var, map_type_atom f a, map_type_atoms f args)
 345
 346 (*
 347  * Map a type over the types in the debug_info.
 348  *)
 349 let map_type_debug_var f (v1, ty, v2) =
 350    v1, f ty, v2
 351
 352 let map_type_debug_vars f vars =
 353    List.map (map_type_debug_var f) vars
 354
 355 let map_type_debug_info f info =
 356    match info with
 357       DebugString _ ->
 358          info
 359     | DebugContext (line, vars) ->
 360          DebugContext (line, map_type_debug_vars f vars)
 361
 362 (*
 363  * Map a function over the types in the pred.
 364  *)
 365 let map_type_pred f pred =
 366    match pred with
 367       IsMutable a ->
 368          IsMutable (map_type_atom f a)
 369     | Reserve (a1, a2) ->
 370          Reserve (map_type_atom f a1, map_type_atom f a2)
 371     | BoundsCheck (op, a1, a2, a3) ->
 372          BoundsCheck (op, map_type_atom f a1, map_type_atom f a2, map_type_atom f a3)
 373     | ElementCheck (ty, op, a1, a2) ->
 374          ElementCheck (f ty, op, map_type_atom f a1, map_type_atom f a2)
 375
 376 (*
 377  * Map a function over all types.
 378  *)
 379 let rec map_type_exp f e =
 380    let loc = loc_of_exp e in
 381    let e = map_type_exp_core f (dest_exp_core e) in
 382       make_exp loc e
 383
 384 and map_type_exp_core f e =
 385    match e with
 386       LetAtom (v, ty, a, e) ->
 387          let ty = f ty in
 388          let a = map_type_atom f a in
 389          let e = map_type_exp f e in
 390             LetAtom (v, ty, a, e)
 391     | LetExt (v, ty, s, b, ty2, ty_args, al, e) ->
 392          let ty = f ty in
 393          let ty2 = f ty2 in
 394          let ty_args = List.map f ty_args in
 395          let al = map_type_atoms f al in
 396          let e = map_type_exp f e in
 397             LetExt (v, ty, s, b, ty2, ty_args, al, e)
 398     | TailCall (label, v, args) ->
 399          let v = map_type_atom f v in
 400          let args = map_type_atoms f args in
 401             TailCall (label, v, args)
 402     | SpecialCall (label, TailSysMigrate (id, loc_ptr, loc_off, fn, args)) ->
 403          let loc_ptr = map_type_atom f loc_ptr in
 404          let loc_off = map_type_atom f loc_off in
 405          let fn = map_type_atom f fn in
 406          let args = map_type_atoms f args in
 407             SpecialCall (label, TailSysMigrate (id, loc_ptr, loc_off, fn, args))
 408     | SpecialCall (label, TailAtomic (fn, c, args)) ->
 409          let c = map_type_atom f c in
 410          let fn = map_type_atom f fn in
 411          let args = map_type_atoms f args in
 412             SpecialCall (label, TailAtomic (fn, c, args))
 413     | SpecialCall (label, TailAtomicRollback (level, c)) ->
 414          let level = map_type_atom f level in
 415          let c = map_type_atom f c in
 416             SpecialCall (label, TailAtomicRollback (level, c))
 417     | SpecialCall (label, TailAtomicCommit (level, fn, args)) ->
 418          let level = map_type_atom f level in
 419          let fn = map_type_atom f fn in
 420          let args = map_type_atoms f args in
 421             SpecialCall (label, TailAtomicCommit (level, fn, args))
 422     | Match (a, cases) ->
 423          let a = map_type_atom f a in
 424          let cases =
 425             List.map (fun (label, set, e) -> label, set, map_type_exp f e) cases
 426          in
 427             Match (a, cases)
 428     | MatchDTuple (a, cases) ->
 429          let a = map_type_atom f a in
 430          let cases =
 431             List.map (fun (label, a_opt, e) ->
 432                   label, map_type_atom_opt f a_opt, map_type_exp f e) cases
 433          in
 434             MatchDTuple (a, cases)
 435     | TypeCase (a1, a2, name, v, e1, e2) ->
 436          let a1 = map_type_atom f a1 in
 437          let a2 = map_type_atom f a2 in
 438          let e1 = map_type_exp f e1 in
 439          let e2 = map_type_exp f e2 in
 440             TypeCase (a1, a2, name, v, e1, e2)
 441     | LetAlloc (v, op, e) ->
 442          let op = map_type_alloc_op f op in
 443          let e = map_type_exp f e in
 444             LetAlloc (v, op, e)
 445     | LetSubscript (op, v1, ty, a2, a3, e) ->
 446          let ty = f ty in
 447          let a2 = map_type_atom f a2 in
 448          let a3 = map_type_atom f a3 in
 449          let e = map_type_exp f e in
 450             LetSubscript (op, v1, ty, a2, a3, e)
 451     | SetSubscript (op, label, a1, a2, ty, a3, e) ->
 452          let ty = f ty in
 453          let a1 = map_type_atom f a1 in
 454          let a2 = map_type_atom f a2 in
 455          let a3 = map_type_atom f a3 in
 456          let e = map_type_exp f e in
 457             SetSubscript (op, label, a1, a2, ty, a3, e)
 458     | LetGlobal (op, v, ty, l, e) ->
 459          let ty = f ty in
 460          let e = map_type_exp f e in
 461             LetGlobal (op, v, ty, l, e)
 462     | SetGlobal (op, label, v, ty, a, e) ->
 463          let ty = f ty in
 464          let a = map_type_atom f a in
 465          let e = map_type_exp f e in
 466             SetGlobal (op, label, v, ty, a, e)
 467     | Memcpy (op, label, a1, a2, a3, a4, a5, e) ->
 468          let a1 = map_type_atom f a1 in
 469          let a2 = map_type_atom f a2 in
 470          let a3 = map_type_atom f a3 in
 471          let a4 = map_type_atom f a4 in
 472          let a5 = map_type_atom f a5 in
 473          let e = map_type_exp f e in
 474             Memcpy (op, label, a1, a2, a3, a4, a5, e)
 475     | Assert (label, pred, e) ->
 476          Assert (label, map_type_pred f pred, map_type_exp f e)
 477     | Call (label, v, args, e) ->
 478          Call (label, v, map_type_atom_opt_list f args, map_type_exp f e)
 479     | Debug (info, e) ->
 480          let info = map_type_debug_info f info in
 481          let e = map_type_exp f e in
 482             Debug (info, e)
 483
 484 (*
 485  * Map a function over a type definition.
 486  *)
 487 let map_type_tydef f tydef =
 488    match tydef with
 489       TyDefUnion (ty_vars, fields) ->
 490          let fields =
 491             List.map (List.map (fun (ty, b) -> f ty, b)) fields
 492          in
 493             TyDefUnion (ty_vars, fields)
 494     | TyDefLambda (ty_vars, ty) ->
 495          TyDefLambda (ty_vars, f ty)
 496     | TyDefDTuple _ ->
 497          tydef
 498
 499 (*
 500  * Map a function over a global initializer.
 501  *)
 502 let map_type_init f init =
 503    match init with
 504       InitAtom a ->
 505          InitAtom (map_type_atom f a)
 506     | InitAlloc op ->
 507          InitAlloc (map_type_alloc_op f op)
 508     | InitTag (ty_var, tyl) ->
 509          InitTag (ty_var, List.map (fun (ty, b) -> f ty, b) tyl)
 510     | InitRawData _
 511     | InitNames _ ->
 512          init
 513
 514 let map_type_globals f globals =
 515    SymbolTable.map (fun (ty, init) ->
 516          f ty, map_type_init f init) globals
 517
 518 let map_type_import f import =
 519    SymbolTable.map (fun import ->
 520          { import with import_type = f import.import_type }) import
 521
 522 let map_type_export f export =
 523    SymbolTable.map (fun export ->
 524          { export with export_type = f export.export_type }) export
 525
 526 (*
 527  * Map a function over a function definition.
 528  *)
 529 let map_type_fundef f (line, ty_vars, ty, vars, e) =
 530    line, ty_vars, f ty, vars, map_type_exp f e
 531
 532 let map_type_funs f funs =
 533    SymbolTable.map (map_type_fundef f) funs
 534
 535 (*
 536  * Map a function over the type definitions.
 537  *)
 538 let map_type_types f types =
 539    SymbolTable.map f types
 540
 541 let map_type_tydefs f types =
 542    SymbolTable.map (map_type_tydef f) types
 543
 544 (*
 545  * Map a function over the type definitions in the frame.
 546  *)
 547 let map_type_frames f frames =
 548    SymbolTable.map (fun (vars, frame) ->
 549          let frame =
 550             SymbolTable.map (fun vars ->
 551                   List.map (fun (v, ty, i) -> v, f ty, i) vars) frame
 552          in
 553             vars, frame) frames
 554
 555 (*
 556  * Map a function over all types in the program.
 557  *)
 558 let map_type_prog f
 559     { prog_file = file;
 560       prog_import = import;
 561       prog_export = export;
 562       prog_types = types;
 563       prog_frames = frames;
 564       prog_names = names;
 565       prog_globals = globals;
 566       prog_funs = funs
 567     } =
 568    { prog_file = file;
 569      prog_import = map_type_import f import;
 570      prog_export = map_type_export f export;
 571      prog_types = map_type_tydefs f types;
 572      prog_frames = map_type_frames f frames;
 573      prog_names = map_type_types f names;
 574      prog_globals = map_type_globals f globals;
 575      prog_funs = map_type_funs f funs
 576    }
 577
 578 (*!
 579  * @docoff
 580  *
 581  * -*-
 582  * Local Variables:
 583  * Caml-master: "compile"
 584  * End:
 585  * -*-
 586  *)