arch/mir/util/mir_standardize.ml

   1 (*
   2  * MIR standardizer.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * @begin[license]
   7  * Copyright (C) 2002 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 Mir
  30 open Mir_ds
  31
  32 (************************************************************************
  33  * ENVIRONMENT
  34  ************************************************************************)
  35
  36 (*
  37  * Variable environment for variable renamining.
  38  *)
  39 let genv_empty = SymbolSet.empty
  40
  41 let venv_empty = SymbolTable.empty
  42
  43 let venv_lookup venv v =
  44    try SymbolTable.find venv v with
  45       Not_found ->
  46          v
  47
  48 (************************************************************************
  49  * RENAMING
  50  ************************************************************************)
  51
  52 (*
  53  * Bind a var.
  54  *)
  55 let standardize_bind genv venv v =
  56    if SymbolSet.mem genv v then
  57       (* Variable already bound elsewhere *)
  58       let v' = new_symbol v in
  59          genv, SymbolTable.add venv v v', v'
  60    else
  61       SymbolSet.add genv v, venv, v
  62
  63 (*
  64  * Rename a var.
  65  *)
  66 let standardize_var venv v =
  67    venv_lookup venv v
  68
  69 let standardize_vars venv vars =
  70    List.map (standardize_var venv) vars
  71
  72 (*
  73  * Rename an atom.
  74  *)
  75 let rec standardize_atom venv a =
  76    match a with
  77       AtomInt _
  78     | AtomRawInt _
  79     | AtomFloat _ ->
  80          a
  81     | AtomVar (ac, v) ->
  82          AtomVar (ac, standardize_var venv v)
  83     | AtomFunVar (ac, v) ->
  84          AtomFunVar (ac, standardize_var venv v)
  85     | AtomUnop (op, a) ->
  86          AtomUnop (op, standardize_atom venv a)
  87     | AtomBinop (op, a1, a2) ->
  88          AtomBinop (op, standardize_atom venv a1, standardize_atom venv a2)
  89
  90 let standardize_atoms venv args =
  91    List.map (standardize_atom venv) args
  92
  93 (*
  94  * Rename an allocation.
  95  *)
  96 let standardize_alloc_op venv op =
  97    match op with
  98       AllocTuple args ->
  99          AllocTuple (standardize_atoms venv args)
 100     | AllocArray args ->
 101          AllocArray (standardize_atoms venv args)
 102     | AllocMArray (args, a) ->
 103          AllocMArray (standardize_atoms venv args, standardize_atom venv a)
 104     | AllocUnion (i, args) ->
 105          AllocUnion (i, standardize_atoms venv args)
 106     | AllocMalloc a ->
 107          AllocMalloc (standardize_atom venv a)
 108
 109 (*
 110  * Rename an initializer.
 111  *)
 112 let standardize_init venv init =
 113    match init with
 114       InitAtom a ->
 115          InitAtom (standardize_atom venv a)
 116     | InitAlloc op ->
 117          InitAlloc (standardize_alloc_op venv op)
 118     | InitRawData _ ->
 119          init
 120
 121 (*
 122  * Rename a tailcall.
 123  *)
 124 let standardize_tailop venv op =
 125    match op with
 126       TailSysMigrate (i, a1, a2, f, args) ->
 127          TailSysMigrate (i,
 128                          standardize_atom venv a1,
 129                          standardize_atom venv a2,
 130                          standardize_var venv f,
 131                          standardize_atoms venv args)
 132     | TailAtomic (v, a, args) ->
 133          TailAtomic (standardize_var venv v,
 134                      standardize_atom venv a,
 135                      standardize_atoms venv args)
 136     | TailAtomicRollback (level, a) ->
 137          TailAtomicRollback (standardize_atom venv level, standardize_atom venv a)
 138     | TailAtomicCommit (level, f, args) ->
 139          TailAtomicCommit (standardize_atom venv level, standardize_var venv f, standardize_atoms venv args)
 140
 141 (*
 142  * Rename a reservation.
 143  *)
 144 let standardize_reserve venv (v, vars, a1, a2) =
 145    standardize_var venv v,
 146    standardize_vars venv vars,
 147    standardize_atom venv a1,
 148    standardize_atom venv a2
 149
 150 (*
 151  * Rename debugging info.
 152  *)
 153 let standardize_debug venv (line, vars) =
 154    let vars =
 155       List.map (fun (v1, ty, v2) ->
 156             v1, ty, standardize_var venv v2) vars
 157    in
 158       line, vars
 159
 160 (*
 161  * Rename an expression.
 162  *)
 163 let rec standardize_exp genv venv e =
 164    let loc = loc_of_exp e in
 165    let genv, e = standardize_exp_core genv venv (dest_exp_core e) in
 166       genv, make_exp loc e
 167
 168 and standardize_exp_core genv venv e =
 169    match e with
 170       LetAtom (v, ac, a, e) ->
 171          standardize_atom_exp genv venv v ac a e
 172     | TailCall (op, f, args) ->
 173          genv, TailCall (op, standardize_var venv f, standardize_atoms venv args)
 174     | LetExternal (v, ac, s, args, e) ->
 175          standardize_external_exp genv venv v ac s args e
 176     | LetExternalReserve (rinfo, v, ac, s, args, e) ->
 177          standardize_external_reserve_exp genv venv rinfo v ac s args e
 178     | IfThenElse (op, a1, a2, e1, e2) ->
 179          standardize_if_exp genv venv op a1 a2 e1 e2
 180     | Match (a, ac, cases) ->
 181          standardize_match_exp genv venv a ac cases
 182     | IfType (a1, a2, a3, v, e1, e2) ->
 183          standardize_iftype_exp genv venv a1 a2 a3 v e1 e2
 184     | Reserve (info, e) ->
 185          let genv, e = standardize_exp genv venv e in
 186             genv, Reserve (standardize_reserve venv info, e)
 187     | LetAlloc (v, op, e) ->
 188          standardize_alloc_exp genv venv v op e
 189     | SetMem (ac, op, a1, a2, a3, e) ->
 190          standardize_set_mem_exp genv venv ac op a1 a2 a3 e
 191     | SetGlobal (ac, v, a, e) ->
 192          standardize_set_global_exp genv venv ac v a e
 193     | BoundsCheck (v, ty, ptr, start, stop, e) ->
 194          standardize_bounds_check_exp genv venv v ty ptr start stop e
 195     | LowerBoundsCheck (v, ty, ptr, start, e) ->
 196          standardize_lower_bounds_check_exp genv venv v ty ptr start e
 197     | UpperBoundsCheck (v, ty, ptr, stop, e) ->
 198          standardize_upper_bounds_check_exp genv venv v ty ptr stop e
 199     | PointerIndexCheck (label, ptrty, v, ac, index, e) ->
 200          standardize_pointer_index_check_exp genv venv label ptrty v ac index e
 201     | FunctionIndexCheck (label, funty, v, ac, index, e) ->
 202          standardize_function_index_check_exp genv venv label funty v ac index e
 203     | Memcpy (op, a1, a2, a3, a4, a5, e) ->
 204          standardize_memcpy_exp genv venv op a1 a2 a3 a4 a5 e
 205     | Debug (info, e) ->
 206          let genv, e = standardize_exp genv venv e in
 207             genv, Debug (standardize_debug venv info, e)
 208     | PrintDebug (v1, v2, args, e) ->
 209          standardize_print_debug_exp genv venv v1 v2 args e
 210     | CommentFIR (e1, e2) ->
 211          let genv, e2 = standardize_exp genv venv e2 in
 212             genv, CommentFIR (e1, e2)
 213     | SpecialCall op ->
 214          genv, SpecialCall (standardize_tailop venv op)
 215     | SysMigrate (id, dptr, doff, f, env) ->
 216          standardize_sys_migrate_exp genv venv id dptr doff f env
 217     | Atomic (v, a1, a2) ->
 218          standardize_atomic_exp genv venv v a1 a2
 219     | AtomicRollback (level, a) ->
 220          genv, AtomicRollback (standardize_atom venv level, standardize_atom venv a)
 221     | AtomicCommit (level, e) ->
 222          let genv, e = standardize_exp genv venv e in
 223             genv, AtomicCommit (standardize_atom venv level, e)
 224     | CopyOnWrite (info, a, e) ->
 225          standardize_cow_exp genv venv info a e
 226
 227 (*
 228  * Atom.
 229  *)
 230 and standardize_atom_exp genv venv v ac a e =
 231    let a = standardize_atom venv a in
 232    let genv, venv, v' = standardize_bind genv venv v in
 233    let genv, e = standardize_exp genv venv e in
 234       genv, LetAtom (v', ac, a, e)
 235
 236 (*
 237  * External call.
 238  *)
 239 and standardize_external_exp genv venv v ac s args e =
 240    let args = standardize_atoms venv args in
 241    let genv, venv, v' = standardize_bind genv venv v in
 242    let genv, e = standardize_exp genv venv e in
 243       genv, LetExternal (v', ac, s, args, e)
 244
 245 and standardize_external_reserve_exp genv venv rinfo v ac s args e =
 246    let args = standardize_atoms venv args in
 247    let genv, venv, v' = standardize_bind genv venv v in
 248    let genv, e = standardize_exp genv venv e in
 249    let rinfo = standardize_reserve venv rinfo in
 250       genv, LetExternalReserve (rinfo, v', ac, s, args, e)
 251
 252 (*
 253  * Conditional.
 254  *)
 255 and standardize_if_exp genv venv op a1 a2 e1 e2 =
 256    let a1 = standardize_atom venv a1 in
 257    let a2 = standardize_atom venv a2 in
 258    let genv, e1 = standardize_exp genv venv e1 in
 259    let genv, e2 = standardize_exp genv venv e2 in
 260       genv, IfThenElse (op, a1, a2, e1, e2)
 261
 262 (*
 263  * Arbitrary match.
 264  *)
 265 and standardize_match_exp genv venv a ac cases =
 266    let a = standardize_atom venv a in
 267    let genv, cases = List.fold_left (fun (genv, cases) (s, e) ->
 268       let genv, e = standardize_exp genv venv e in
 269       let cases = (s, e) :: cases in
 270          genv, cases) (genv, []) cases
 271    in
 272    let cases = List.rev cases in
 273       genv, Match (a, ac, cases)
 274
 275 (*
 276  * Iftype.
 277  *)
 278 and standardize_iftype_exp genv venv a1 a2 a3 v e1 e2 =
 279    let a1 = standardize_atom venv a1 in
 280    let a2 = standardize_atom venv a2 in
 281    let a3 = standardize_atom venv a3 in
 282    let genv, e2 = standardize_exp genv venv e2 in
 283    let genv, venv, v' = standardize_bind genv venv v in
 284    let genv, e1 = standardize_exp genv venv e1 in
 285       genv, IfType (a1, a2, a3, v', e1, e2)
 286
 287 (*
 288  * Allocation.
 289  *)
 290 and standardize_alloc_exp genv venv v op e =
 291    let op = standardize_alloc_op venv op in
 292    let genv, venv, v' = standardize_bind genv venv v in
 293    let genv, e = standardize_exp genv venv e in
 294       genv, LetAlloc (v', op, e)
 295
 296 (*
 297  * SetMem.
 298  *)
 299 and standardize_set_mem_exp genv venv ac op a1 a2 a3 e =
 300    let a1 = standardize_atom venv a1 in
 301    let a2 = standardize_atom venv a2 in
 302    let a3 = standardize_atom venv a3 in
 303    let genv, e = standardize_exp genv venv e in
 304       genv, SetMem (ac, op, a1, a2, a3, e)
 305
 306 and standardize_set_global_exp genv venv ac v a e =
 307    let v = standardize_var venv v in
 308    let a = standardize_atom venv a in
 309    let genv, e = standardize_exp genv venv e in
 310       genv, SetGlobal (ac, v, a, e)
 311
 312 and standardize_memcpy_exp genv venv op a1 a2 a3 a4 a5 e =
 313    let a1 = standardize_atom venv a1 in
 314    let a2 = standardize_atom venv a2 in
 315    let a3 = standardize_atom venv a3 in
 316    let a4 = standardize_atom venv a4 in
 317    let a5 = standardize_atom venv a5 in
 318    let genv, e = standardize_exp genv venv e in
 319       genv, Memcpy (op, a1, a2, a3, a4, a5, e)
 320
 321 (*
 322  * Safety checks.
 323  *)
 324 and standardize_bounds_check_exp genv venv v ty ptr start stop e =
 325    let ptr   = standardize_atom venv ptr in
 326    let start = standardize_atom venv start in
 327    let stop  = standardize_atom venv stop in
 328    let genv, venv, v' = standardize_bind genv venv v in
 329    let genv, e = standardize_exp genv venv e in
 330       genv, BoundsCheck (v', ty, ptr, start, stop, e)
 331
 332 and standardize_lower_bounds_check_exp genv venv v ty ptr start e =
 333    let ptr   = standardize_atom venv ptr in
 334    let start = standardize_atom venv start in
 335    let genv, venv, v' = standardize_bind genv venv v in
 336    let genv, e = standardize_exp genv venv e in
 337       genv, LowerBoundsCheck (v', ty, ptr, start, e)
 338
 339 and standardize_upper_bounds_check_exp genv venv v ty ptr stop e =
 340    let ptr   = standardize_atom venv ptr in
 341    let stop = standardize_atom venv stop in
 342    let genv, venv, v' = standardize_bind genv venv v in
 343    let genv, e = standardize_exp genv venv e in
 344       genv, UpperBoundsCheck (v', ty, ptr, stop, e)
 345
 346 and standardize_pointer_index_check_exp genv venv label ptrty v ac index e =
 347    let index = standardize_atom venv index in
 348    let genv, venv, label' = standardize_bind genv venv label in
 349    let genv, venv, v' = standardize_bind genv venv v in
 350    let genv, e = standardize_exp genv venv e in
 351       genv, PointerIndexCheck (label', ptrty, v', ac, index, e)
 352
 353 and standardize_function_index_check_exp genv venv label funty v ac index e =
 354    let index = standardize_atom venv index in
 355    let genv, venv, label' = standardize_bind genv venv label in
 356    let genv, venv, v' = standardize_bind genv venv v in
 357    let genv, e = standardize_exp genv venv e in
 358       genv, FunctionIndexCheck (label', funty, v', ac, index, e)
 359
 360 (*
 361  * Debugging.
 362  *)
 363 and standardize_print_debug_exp genv venv v1 v2 args e =
 364    let v1 = standardize_var venv v1 in
 365    let v2 = standardize_var venv v2 in
 366    let args = standardize_atoms venv args in
 367    let genv, e = standardize_exp genv venv e in
 368       genv, PrintDebug (v1, v2, args, e)
 369
 370 (*
 371  * Migrate.
 372  *)
 373 and standardize_sys_migrate_exp genv venv id dptr doff f env =
 374    let dptr = standardize_atom venv dptr in
 375    let doff = standardize_atom venv doff in
 376    let f    = standardize_var  venv f in
 377    let env  = standardize_atom venv env in
 378       genv, SysMigrate (id, dptr, doff, f, env)
 379
 380 (*
 381  * Atomic.
 382  *)
 383 and standardize_atomic_exp genv venv f a1 a2 =
 384    let f  = standardize_var  venv f in
 385    let a1 = standardize_atom venv a1 in
 386    let a2 = standardize_atom venv a2 in
 387       genv, Atomic (f, a1, a2)
 388
 389 (*
 390  * Copy-on-write.
 391  *)
 392 and standardize_cow_exp genv venv info a e =
 393    let info = standardize_reserve venv info in
 394    let a = standardize_atom venv a in
 395    let genv, e = standardize_exp genv venv e in
 396       genv, CopyOnWrite (info, a, e)
 397
 398 (*
 399  * Rename the vars in a program.
 400  *)
 401 let standardize_prog prog =
 402    let { prog_file         = file;
 403          prog_import       = import;
 404          prog_export       = export;
 405          prog_globals      = globals;
 406          prog_funs         = funs;
 407          prog_mprog        = mprog;
 408          prog_global_order = global_order;
 409          prog_fun_order    = fun_order;
 410          prog_arity_tags   = arity_tags;
 411        } = prog
 412    in
 413
 414    (* Make new names for the program parts *)
 415    let genv = genv_empty in
 416    let venv = venv_empty in
 417    let genv, venv =
 418       SymbolTable.fold (fun (genv, venv) v _ ->
 419          let genv, venv, _ = standardize_bind genv venv v in
 420             genv, venv) (genv, venv) import
 421    in
 422    let genv, venv =
 423       SymbolTable.fold (fun (genv, venv) v _ ->
 424          let genv, venv, _ = standardize_bind genv venv v in
 425             genv, venv) (genv, venv) globals
 426    in
 427
 428    (* WARNING:  We _can't_ rename the funs because of the program ordering *)
 429
 430    (* Rename the imports *)
 431    let import =
 432       SymbolTable.fold (fun import v info ->
 433          let v = venv_lookup venv v in
 434             SymbolTable.add import v info) SymbolTable.empty import
 435    in
 436
 437    (* Rename the exports *)
 438    let export =
 439       SymbolTable.fold (fun export v info ->
 440          let v = venv_lookup venv v in
 441             SymbolTable.add export v info) SymbolTable.empty export
 442    in
 443
 444    (* Rename the globals *)
 445    let globals =
 446       SymbolTable.fold (fun globals v init ->
 447          let v = venv_lookup venv v in
 448          let init = standardize_init venv init in
 449             SymbolTable.add globals v init) SymbolTable.empty globals
 450    in
 451
 452    (* Rename the funs *)
 453    let genv, funs =
 454       SymbolTable.fold (fun (genv, funs) f (line, vars, e) ->
 455          let f = venv_lookup venv f in
 456          let genv, venv, vars =
 457             List.fold_left (fun (genv, venv, vars) (v, ac) ->
 458                let genv, venv, v' = standardize_bind genv venv v in
 459                let vars = (v', ac) :: vars in
 460                   genv, venv, vars) (genv, venv, []) vars
 461          in
 462          let genv, e = standardize_exp genv venv e in
 463             genv, SymbolTable.add funs f (line, List.rev vars, e)) (genv, SymbolTable.empty) funs
 464    in
 465       (* Rebuild the prog *)
 466       { prog_file          = file;
 467         prog_import        = import;
 468         prog_export        = export;
 469         prog_globals       = globals;
 470         prog_funs          = funs;
 471         prog_mprog         = mprog;
 472         prog_global_order  = global_order;
 473         prog_fun_order     = fun_order;
 474         prog_arity_tags    = arity_tags;
 475       }
 476
 477 (*!
 478  * @docoff
 479  *
 480  * -*-
 481  * Local Variables:
 482  * Caml-master: "compile"
 483  * End:
 484  * -*-
 485  *)