arch/mir/opt/mir_cond.ml

   1 (*
   2    Perform IfThenElse optimization on the MIR code
   3    Copyright (C) 2002,2001 Justin David Smith, Caltech
   4
   5    This program is free software; you can redistribute it and/or
   6    modify it under the terms of the GNU General Public License
   7    as published by the Free Software Foundation; either version 2
   8    of the License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  *)
  19 open Format
  20
  21 open Debug
  22 open Symbol
  23 open Flags
  24
  25 open Frame_type
  26
  27 open Mir
  28 open Mir_ds
  29 open Mir_pos
  30 open Mir_exn
  31 open Mir_print
  32 open Mir_valias
  33 open Mir_standardize
  34
  35 open Fir_set
  36 open Fir_state
  37
  38 module Pos = MakePos (struct let name = "Mir_cond" end)
  39 open Pos
  40
  41
  42 module type MirCondSig =
  43 sig
  44    val rewrite_matches : prog -> prog
  45 end
  46
  47
  48 module MirCond (Frame : BackendSig) : MirCondSig =
  49 struct
  50    module MirUtil = Mir_util.MirUtil (Frame)
  51    open MirUtil
  52
  53
  54    (*
  55       Rewrite match statements immediately following a relative
  56       operator to use our IfThenElse primitive instead.  This
  57       optimization is fairly sensitive to the way code is emitted
  58       in the FIR->MIR conversion, so check it when major changes
  59       are made to make sure the pattern match is still working.
  60     *)
  61
  62
  63    (***  Utilities  ***)
  64
  65
  66    (* Position utility *)
  67    let exp_pos pos = string_pos "Mir_cond" (exp_pos pos)
  68
  69
  70    (* venv utilities *)
  71    let venv_empty = SymbolTable.empty
  72    let venv_add = SymbolTable.add
  73    let venv_mem = SymbolTable.mem
  74    let venv_lookup venv pos v =
  75       try SymbolTable.find venv v with
  76          Not_found -> raise (MirException (pos, UnboundVar v))
  77
  78
  79    (* rewrite_var
  80       Rewrites a variable, substituting variable names as necessary.  *)
  81    let rewrite_var env v =
  82       try SymbolTable.find env v with
  83          Not_found -> v
  84
  85
  86    (* rewrite_vars
  87       Plural version of above.  *)
  88    let rewrite_vars env vars = List.map (rewrite_var env) vars
  89
  90
  91    (* remove_var
  92       Removes a variable from the rewrite environment.  *)
  93    let remove_var env v =
  94       SymbolTable.remove env v
  95
  96
  97    (* rewrite_atom
  98       Rewrites an atom, substituting variable names as necessary.  *)
  99    let rec rewrite_atom env a =
 100       match a with
 101          AtomVar (ac, v) ->
 102             AtomVar (ac, rewrite_var env v)
 103        | AtomFunVar (ac, v) ->
 104             AtomFunVar (ac, rewrite_var env v)
 105        | AtomUnop (op, a) ->
 106             AtomUnop (op, rewrite_atom env a)
 107        | AtomBinop (op, a1, a2) ->
 108             AtomBinop (op, rewrite_atom env a1, rewrite_atom env a2)
 109        | AtomInt _
 110        | AtomRawInt _
 111        | AtomFloat _ ->
 112             a
 113
 114
 115    (* rewrite_atoms
 116       Plural version of above.  *)
 117    let rewrite_atoms env atoms = List.map (rewrite_atom env) atoms
 118
 119
 120    (* rewrite_alloc_op
 121       Rewrites an allocation operator.  *)
 122    let rewrite_alloc_op env op =
 123       match op with
 124          AllocTuple atoms ->
 125             AllocTuple (rewrite_atoms env atoms)
 126        | AllocArray atoms ->
 127             AllocArray (rewrite_atoms env atoms)
 128        | AllocMArray (atoms, a) ->
 129             AllocMArray (rewrite_atoms env atoms, rewrite_atom env a)
 130        | AllocUnion (tag, atoms) ->
 131             AllocUnion (tag, rewrite_atoms env atoms)
 132        | AllocMalloc a ->
 133             AllocMalloc (rewrite_atom env a)
 134
 135
 136    (* rewrite_reserve_info
 137       Rewrites the reserve information (only need vars) *)
 138    let rewrite_reserve_info env rinfo =
 139       let label, vars, mem, ptr = rinfo in
 140       let vars = rewrite_vars env vars in
 141       let mem = rewrite_atom env mem in
 142       let ptr = rewrite_atom env ptr in
 143          (label, vars, mem, ptr)
 144
 145
 146    (* translate_relop
 147       Try to rewrite the operation specified as a relative operator
 148       that can be used in an if/then/else expression.  If the operator
 149       given is NOT a relative operator, then None is returned.  Other-
 150       wise, we will return Some of the corresponding if/then/else
 151       operator.  *)
 152    let translate_relop = function
 153       EqOp(ac) ->  Some (REqOp ac)
 154     | NeqOp(ac) -> Some (RNeqOp ac)
 155     | LtOp(ac) ->  Some (RLtOp ac)
 156     | LeOp(ac) ->  Some (RLeOp ac)
 157     | GtOp(ac) ->  Some (RGtOp ac)
 158     | GeOp(ac) ->  Some (RGeOp ac)
 159     | AndOp(ac) -> Some (RAndOp ac)
 160     | _           ->  None
 161
 162
 163    (***  Conditional Rewrite - Transform Match to IfThenElse  ***)
 164
 165
 166    (* rewrite_match_rawint
 167       Attempt to rewrite the match given.  The parametres are as given
 168       in the pattern that matches the LetAtom/Match form we see in the
 169       expression stream.  *)
 170    let rec rewrite_match_rawint env loc v op ac a1 a2 s1 e1 s2 e2 =
 171       let is_true_set s =
 172          RawIntSet.equal s native_true_set
 173          || RawIntSet.equal s native_true_set_alt
 174          || RawIntSet.equal s unsigned_true_set
 175       in
 176       let is_false_set s =
 177          RawIntSet.equal s native_false_set
 178          || RawIntSet.equal s unsigned_false_set
 179       in
 180
 181       (* Rewrite the basic atoms *)
 182       let a1 = rewrite_atom env a1 in
 183       let a2 = rewrite_atom env a2 in
 184       let env = remove_var env v in
 185
 186          (* Find out if we can rewrite this match *)
 187          match translate_relop op with
 188             Some op when is_true_set s1 && is_false_set s2 ->
 189                let env1 = SymbolTable.add env v (new_symbol v) in
 190                let env2 = SymbolTable.add env v (new_symbol v) in
 191                let e1 = make_exp loc (LetAtom (v, ac, native_true_value, rewrite_matches env1 e1)) in
 192                let e2 = make_exp loc (LetAtom (v, ac, native_false_value, rewrite_matches env2 e2)) in
 193                   make_exp loc (IfThenElse (op, a1, a2, e1, e2))
 194           | Some op when is_false_set s1 && is_true_set s2 ->
 195                let env1 = SymbolTable.add env v (new_symbol v) in
 196                let env2 = SymbolTable.add env v (new_symbol v) in
 197                let e1 = make_exp loc (LetAtom (v, ac, native_false_value, rewrite_matches env1 e1)) in
 198                let e2 = make_exp loc (LetAtom (v, ac, native_true_value, rewrite_matches env2 e2)) in
 199                   make_exp loc (IfThenElse (op, a1, a2, e2, e1))
 200           | _ ->
 201                let e1 = rewrite_matches env e1 in
 202                let e2 = rewrite_matches env e2 in
 203                   make_exp loc (LetAtom (v, ac, AtomBinop(op, a1, a2),
 204                   make_exp loc (Match (AtomVar (ac, v), ac,
 205                                        [RawIntSet s1, e1; RawIntSet s2, e2]))))
 206
 207
 208    (* rewrite_matches
 209       Rewrite all matches that can be converted to if/then/else
 210       within an entire expression.  *)
 211    and is_match_exp v e =
 212       match dest_exp_core e with
 213          CommentFIR (_, e) ->
 214             is_match_exp v e
 215        | Match (AtomVar (_, v'), ACRawInt _, [RawIntSet _, _; RawIntSet _, _]) ->
 216             Symbol.eq v v'
 217        | _ ->
 218             false
 219
 220    and dest_match e =
 221       match dest_exp_core e with
 222          CommentFIR (_, e) ->
 223             dest_match e
 224        | Match (_, ACRawInt _, [RawIntSet s1, e1; RawIntSet s2, e2]) ->
 225             s1, e1, s2, e2
 226        | _ ->
 227             raise (Invalid_argument "Mir_cond.dest_match")
 228
 229    and rewrite_matches env e =
 230       let loc = loc_of_exp e in
 231          match dest_exp_core e with
 232             LetAtom (v, ac, AtomBinop (op, a1, a2), e)
 233             when is_match_exp v e ->
 234                let s1, e1, s2, e2 = dest_match e in
 235                   rewrite_match_rawint env loc v op ac a1 a2 s1 e1 s2 e2
 236
 237           | LetAtom (v, ac, a, e) ->
 238                let a = rewrite_atom env a in
 239                let env = remove_var env v in
 240                let e = rewrite_matches env e in
 241                   make_exp loc (LetAtom (v, ac, a, e))
 242           | LetAlloc (v, op, e) ->
 243                let op = rewrite_alloc_op env op in
 244                let env = remove_var env v in
 245                let e = rewrite_matches env e in
 246                   make_exp loc (LetAlloc (v, op, e))
 247           | LetExternal (v, ac, f, atoms, e) ->
 248                let atoms = rewrite_atoms env atoms in
 249                let env = remove_var env v in
 250                let e = rewrite_matches env e in
 251                   make_exp loc (LetExternal (v, ac, f, atoms, e))
 252           | LetExternalReserve (rinfo, v, ac, f, atoms, e) ->
 253                let rinfo = rewrite_reserve_info env rinfo in
 254                let atoms = rewrite_atoms env atoms in
 255                let env = remove_var env v in
 256                let e = rewrite_matches env e in
 257                   make_exp loc (LetExternalReserve (rinfo, v, ac, f, atoms, e))
 258           | TailCall (op, f, atoms) ->
 259                let f = rewrite_var env f in
 260                let atoms = rewrite_atoms env atoms in
 261                   make_exp loc (TailCall (op, f, atoms))
 262           | Match (a, ac, cases) ->
 263                let a = rewrite_atom env a in
 264                let cases = List.map (fun (set, e) -> set, rewrite_matches env e) cases in
 265                   make_exp loc (Match (a, ac, cases))
 266           | IfThenElse (op, a1, a2, e1, e2) ->
 267                let a1 = rewrite_atom env a1 in
 268                let a2 = rewrite_atom env a2 in
 269                let e1 = rewrite_matches env e1 in
 270                let e2 = rewrite_matches env e2 in
 271                   make_exp loc (IfThenElse (op, a1, a2, e1, e2))
 272           | IfType (obj, names, name, v, e1, e2) ->
 273                let obj   = rewrite_atom env obj in
 274                let names = rewrite_atom env names in
 275                let name  = rewrite_atom env name in
 276                let env'  = remove_var env v in
 277                let e1    = rewrite_matches env' e1 in
 278                let e2    = rewrite_matches env  e2 in
 279                   make_exp loc (IfType (obj, names, name, v, e1, e2))
 280           | SetMem (ac, ptrty, a1, a2, a3, e) ->
 281                let a1 = rewrite_atom env a1 in
 282                let a2 = rewrite_atom env a2 in
 283                let a3 = rewrite_atom env a3 in
 284                let e = rewrite_matches env e in
 285                   make_exp loc (SetMem (ac, ptrty, a1, a2, a3, e))
 286           | SetGlobal (ac, v, a, e) ->
 287                let v = rewrite_var env v in
 288                let a = rewrite_atom env a in
 289                let e = rewrite_matches env e in
 290                   make_exp loc (SetGlobal (ac, v, a, e))
 291           | BoundsCheck (label, ptrty, ptr, start, stop, e) ->
 292                let ptr = rewrite_atom env ptr in
 293                let start = rewrite_atom env start in
 294                let stop = rewrite_atom env stop in
 295                let e = rewrite_matches env e in
 296                   make_exp loc (BoundsCheck (label, ptrty, ptr, start, stop, e))
 297           | LowerBoundsCheck (label, ptrty, ptr, start, e) ->
 298                let ptr = rewrite_atom env ptr in
 299                let start = rewrite_atom env start in
 300                let e = rewrite_matches env e in
 301                   make_exp loc (LowerBoundsCheck (label, ptrty, ptr, start, e))
 302           | UpperBoundsCheck (label, ptrty, ptr, stop, e) ->
 303                let ptr = rewrite_atom env ptr in
 304                let stop = rewrite_atom env stop in
 305                let e = rewrite_matches env e in
 306                   make_exp loc (UpperBoundsCheck (label, ptrty, ptr, stop, e))
 307           | PointerIndexCheck (label, ptrty, v, ac, index, e) ->
 308                let index = rewrite_atom env index in
 309                let env = remove_var env v in
 310                   make_exp loc (PointerIndexCheck (label, ptrty, v, ac, index, e))
 311           | FunctionIndexCheck (label, funty, v, ac, index, e) ->
 312                let index = rewrite_atom env index in
 313                let env = remove_var env v in
 314                   make_exp loc (FunctionIndexCheck (label, funty, v, ac, index, e))
 315           | Memcpy (ptrty, a1, a2, a3, a4, a5, e) ->
 316                let a1 = rewrite_atom env a1 in
 317                let a2 = rewrite_atom env a2 in
 318                let a3 = rewrite_atom env a3 in
 319                let a4 = rewrite_atom env a4 in
 320                let a5 = rewrite_atom env a5 in
 321                let e = rewrite_matches env e in
 322                   make_exp loc (Memcpy (ptrty, a1, a2, a3, a4, a5, e))
 323           | Debug (info, e) ->
 324                make_exp loc (Debug (info, rewrite_matches env e))
 325           | PrintDebug (v1, v2, a, e) ->
 326                make_exp loc (PrintDebug (v1, v2, a, rewrite_matches env e))
 327           | CommentFIR (fir, e) ->
 328                make_exp loc (CommentFIR (fir, rewrite_matches env e))
 329           | SpecialCall (TailSysMigrate (label, loc_base, loc_off, f, args)) ->
 330                let loc_base = rewrite_atom env loc_base in
 331                let loc_off  = rewrite_atom env loc_off in
 332                let args     = rewrite_atoms env args in
 333                   make_exp loc (SpecialCall (TailSysMigrate (label, loc_base, loc_off, f, args)))
 334           | SpecialCall (TailAtomic (f, i, args)) ->
 335                let i    = rewrite_atom env i in
 336                let args = rewrite_atoms env args in
 337                   make_exp loc (SpecialCall (TailAtomic (f, i, args)))
 338           | SpecialCall (TailAtomicRollback (level, i)) ->
 339                let level = rewrite_atom env level in
 340                let i = rewrite_atom env i in
 341                   make_exp loc (SpecialCall (TailAtomicRollback (level, i)))
 342           | SpecialCall (TailAtomicCommit (level, f, args)) ->
 343                let level = rewrite_atom env level in
 344                let args = rewrite_atoms env args in
 345                   make_exp loc (SpecialCall (TailAtomicCommit (level, f, args)))
 346           | SysMigrate (label, dptr, doff, f, e) ->
 347                let f = rewrite_var env f in
 348                let dptr = rewrite_atom env dptr in
 349                let doff = rewrite_atom env doff in
 350                let e = rewrite_atom env e in
 351                   make_exp loc (SysMigrate (label, dptr, doff, f, e))
 352           | Atomic (f, i, e) ->
 353                let f = rewrite_var env f in
 354                let i = rewrite_atom env i in
 355                let e = rewrite_atom env e in
 356                   make_exp loc (Atomic (f, i, e))
 357           | AtomicRollback (level, i) ->
 358                let level = rewrite_atom env level in
 359                let i = rewrite_atom env i in
 360                   make_exp loc (AtomicRollback (level, i))
 361           | AtomicCommit (level, e) ->
 362                let level = rewrite_atom env level in
 363                let e = rewrite_matches env e in
 364                   make_exp loc (AtomicCommit (level, e))
 365           | CopyOnWrite (rinfo, ptr, e) ->
 366                let rinfo = rewrite_reserve_info env rinfo in
 367                let ptr = rewrite_atom env ptr in
 368                let e = rewrite_matches env e in
 369                   make_exp loc (CopyOnWrite (rinfo, ptr, e))
 370           | Reserve (rinfo, e) ->
 371                let rinfo = rewrite_reserve_info env rinfo in
 372                let e = rewrite_matches env e in
 373                   make_exp loc (Reserve (rinfo, e))
 374
 375
 376    (***  Remove - Remove Unconditional IfThenElse Statements  ***)
 377
 378
 379    (* remove_unconditional_cond
 380       This occurs once we've realized we can write an IfThenElse expr.
 381       In many cases, these ``conditional'' expressions turn out to be
 382       unconditional, usually because we compare against a lower range
 383       bound.  Let's see if we can simplify the expression further by
 384       removing this conditional.  Note: this is primarily intended to
 385       clean up code emitted by MIR, not to clean up source programs
 386       that use unconditional conds -- therefore it is not thorough!  *)
 387    let remove_unconditional_cond loc op a1 a2 e1 e2 =
 388       let default_expr = make_exp loc (IfThenElse (op, a1, a2, e1, e2)) in
 389          match op, a1, a2 with
 390             _, AtomRawInt v1, AtomRawInt v2 ->
 391                begin
 392                (* Computation is known in advance because both atoms
 393                   are constant integers.  This happens mostly in the
 394                   conditional checks after constant simplification. *)
 395                let build_expr op pre signed =
 396                   let v1 = Rawint.of_rawint pre signed v1 in
 397                   let v2 = Rawint.of_rawint pre signed v2 in
 398                      if op (Rawint.compare v1 v2) 0 then
 399                         e1
 400                      else
 401                         e2
 402                in (* end of build_expr *)
 403                   match op with
 404                      REqOp  (ACRawInt (pre, signed)) -> build_expr (=)  pre signed
 405                    | RNeqOp (ACRawInt (pre, signed)) -> build_expr (<>) pre signed
 406                    | RLeOp  (ACRawInt (pre, signed)) -> build_expr (<=) pre signed
 407                    | RLtOp  (ACRawInt (pre, signed)) -> build_expr (<)  pre signed
 408                    | RGeOp  (ACRawInt (pre, signed)) -> build_expr (>=) pre signed
 409                    | RGtOp  (ACRawInt (pre, signed)) -> build_expr (>)  pre signed
 410                    | _ ->
 411                         (* Shouldn't have happened, but we don't have pos info.
 412                            Oh well... we'll just emit default for now. *)
 413                         default_expr
 414                end (* atoms are constant int *)
 415
 416           | RLeOp (ACRawInt (Rawint.Int32, false)), AtomRawInt v1, _ ->
 417                (* Seen once in awhile in bounds checks *)
 418                let v1 = Rawint.of_rawint Rawint.Int32 false v1 in
 419                   if Rawint.compare (Rawint.of_int Rawint.Int32 false 0) v1 == 0 then
 420                      e1
 421                   else
 422                      default_expr
 423
 424           | RGeOp (ACRawInt (Rawint.Int32, false)), _, AtomRawInt v2 ->
 425                (* Seen once in awhile in bounds checks *)
 426                let v2 = Rawint.of_rawint Rawint.Int32 false v2 in
 427                   if Rawint.compare (Rawint.of_int Rawint.Int32 false 0) v2 == 0 then
 428                      e1
 429                   else
 430                      default_expr
 431           | _ ->
 432                default_expr
 433
 434
 435    (* remove_unconditional_dual_cond
 436       This function eliminates unconditional comparisons that are
 437       unconditional BECAUSE they were preceded by another check that
 438       was more ``complete''.  This happens usually because of the
 439       BoundsCheck function, which is fond of emitting statements like
 440          if 24 <= size then
 441             if 20 < size then
 442                ...
 443       This function cleans such expressions out.  The form for the
 444       arguments is
 445          if a11 op1 a12 then
 446             if a21 op2 a22 then
 447                e1
 448             else
 449                e2
 450          else
 451             e3
 452       Again, this function is not thorough -- it is only intended to
 453       clean up backend MIR code.  *)
 454    let remove_unconditional_dual_cond loc op1 a11 a12 op2 a21 a22 e1 e2 e3 =
 455       let default_nested_cond = remove_unconditional_cond loc op2 a21 a22 e1 e2 in
 456       let default_expr = remove_unconditional_cond loc op1 a11 a12 default_nested_cond e3 in
 457       let removed_expr = remove_unconditional_cond loc op1 a11 a12 e1 e3 in
 458          match op1, op2 with
 459             RLeOp (ACRawInt (_, false)), RLtOp (ACRawInt (_, false)) ->
 460                begin
 461                match a11, a21 with
 462                   AtomRawInt i11, AtomRawInt i21 when Rawint.compare i11 i21 >= 0 ->
 463                      (* Second conditional is redundant *)
 464                      removed_expr
 465                 | _ ->
 466                      (* Second conditional not redundant *)
 467                      default_expr
 468                end (* <=, < unsigned *)
 469           | _ ->
 470                (* Unknown pair of operators *)
 471                default_expr
 472
 473
 474    (* remove_cond
 475       Interface for above functions. *)
 476    let remove_cond loc op a1 a2 e1 e2 =
 477       match dest_exp_core e1 with
 478          IfThenElse (op', a1', a2', e1', e2') ->
 479             remove_unconditional_dual_cond loc op a1 a2 op' a1' a2' e1' e2' e2
 480        | _ ->
 481             remove_unconditional_cond loc op a1 a2 e1 e2
 482
 483
 484    (* remove_expr
 485       Removes unconditional conditionals from the expression.  This should be
 486       called AFTER rewrite_matches because this function only considers the
 487       IfThenElse expressions - not Match statements. *)
 488    let rec remove_expr e =
 489       let loc = loc_of_exp e in
 490          match dest_exp_core e with
 491             IfThenElse (op, a1, a2, e1, e2) ->
 492                remove_cond loc op a1 a2 (remove_expr e1) (remove_expr e2)
 493           | LetAtom (v, ac, a, e) ->
 494                make_exp loc (LetAtom (v, ac, a, remove_expr e))
 495           | LetAlloc (v, op, e) ->
 496                make_exp loc (LetAlloc (v, op, remove_expr e))
 497           | LetExternal (v, ac, f, atoms, e) ->
 498                make_exp loc (LetExternal (v, ac, f, atoms, remove_expr e))
 499           | LetExternalReserve (rinfo, v, ac, f, atoms, e) ->
 500                make_exp loc (LetExternalReserve (rinfo, v, ac, f, atoms, remove_expr e))
 501           | Match (a, ac, cases) ->
 502                let process_case (s, e) = (s, remove_expr e) in
 503                   make_exp loc (Match (a, ac, List.map process_case cases))
 504           | IfType (obj, names, name, v, e1, e2) ->
 505                make_exp loc (IfType (obj, names, name, v, remove_expr e1, remove_expr e2))
 506           | SetMem (ac, ptrty, a1, a2, a3, e) ->
 507                make_exp loc (SetMem (ac, ptrty, a1, a2, a3, remove_expr e))
 508           | SetGlobal (ac, v, a, e) ->
 509                make_exp loc (SetGlobal (ac, v, a, remove_expr e))
 510           | BoundsCheck (label, ptrty, ptr, start, stop, e) ->
 511                make_exp loc (BoundsCheck (label, ptrty, ptr, start, stop, remove_expr e))
 512           | LowerBoundsCheck (label, ptrty, ptr, start, e) ->
 513                make_exp loc (LowerBoundsCheck (label, ptrty, ptr, start, remove_expr e))
 514           | UpperBoundsCheck (label, ptrty, ptr, stop, e) ->
 515                make_exp loc (UpperBoundsCheck (label, ptrty, ptr, stop, remove_expr e))
 516           | PointerIndexCheck (label, ptrty, v, ac, index, e) ->
 517                make_exp loc (PointerIndexCheck (label, ptrty, v, ac, index, remove_expr e))
 518           | FunctionIndexCheck (label, funty, v, ac, index, e) ->
 519                make_exp loc (FunctionIndexCheck (label, funty, v, ac, index, remove_expr e))
 520           | Memcpy (ptrty, a1, a2, a3, a4, a5, e) ->
 521                make_exp loc (Memcpy (ptrty, a1, a2, a3, a4, a5, remove_expr e))
 522           | Debug (info, e) ->
 523                make_exp loc (Debug (info, remove_expr e))
 524           | PrintDebug (v1, v2, a, e) ->
 525                make_exp loc (PrintDebug (v1, v2, a, remove_expr e))
 526           | CommentFIR (fir, e) ->
 527                make_exp loc (CommentFIR (fir, remove_expr e))
 528           | AtomicCommit (level, e) ->
 529                make_exp loc (AtomicCommit (level, remove_expr e))
 530           | CopyOnWrite (rinfo, ptr, e) ->
 531                make_exp loc (CopyOnWrite (rinfo, ptr, remove_expr e))
 532           | Reserve (rinfo, e) ->
 533                make_exp loc (Reserve (rinfo, remove_expr e))
 534           | TailCall _
 535           | SpecialCall _
 536           | SysMigrate _
 537           | Atomic _
 538           | AtomicRollback _ ->
 539                e
 540
 541
 542    (***  Conditional Rewrites -- Fold Relops into IfThenElse Code  ***)
 543
 544
 545    (* elim_relop
 546       Attempt to eliminate relops that can be merged into an existing
 547       IfThenElse statement.  All too often we see code like:
 548          let v = (a == b) in
 549          if v == 0 then
 550             ...
 551          else
 552             ...
 553       This is inefficient, and while the backend can USUALLY identify
 554       and simplify these cases, the backend doesn't always catch it.
 555       These relops are expensive for us, so it's in our interests to
 556       try to remove these cases now...
 557
 558       The venv is an environment of all variables which are bound to
 559       a simple relop expression.  *)
 560    let rec elim_relop venv e =
 561       let pos = string_pos "elim_relop" (exp_pos e) in
 562       let loc = loc_of_exp e in
 563          match dest_exp_core e with
 564             IfThenElse (op, a1, a2, e1, e2) ->
 565                elim_relop_if_then_else venv pos loc op a1 a2 e1 e2
 566           | LetAtom (v, ac, a, e) ->
 567                elim_relop_let_atom venv pos loc v ac a e
 568           | LetAlloc (v, op, e) ->
 569                make_exp loc (LetAlloc (v, op, elim_relop venv e))
 570           | LetExternal (v, ac, f, atoms, e) ->
 571                make_exp loc (LetExternal (v, ac, f, atoms, elim_relop venv e))
 572           | LetExternalReserve (rinfo, v, ac, f, atoms, e) ->
 573                make_exp loc (LetExternalReserve (rinfo, v, ac, f, atoms, elim_relop venv e))
 574           | Match (a, ac, cases) ->
 575                let process_case (s, e) = (s, elim_relop venv e) in
 576                   make_exp loc (Match (a, ac, List.map process_case cases))
 577           | IfType (obj, names, name, v, e1, e2) ->
 578                (* v is bound here, but not as a relop *)
 579                make_exp loc (IfType (obj, names, name, v, elim_relop venv e1, elim_relop venv e2))
 580           | SetMem (ac, ptrty, a1, a2, a3, e) ->
 581                make_exp loc (SetMem (ac, ptrty, a1, a2, a3, elim_relop venv e))
 582           | SetGlobal (ac, v, a, e) ->
 583                make_exp loc (SetGlobal (ac, v, a, elim_relop venv e))
 584           | BoundsCheck (label, ptrty, ptr, start, stop, e) ->
 585                make_exp loc (BoundsCheck (label, ptrty, ptr, start, stop, elim_relop venv e))
 586           | LowerBoundsCheck (label, ptrty, ptr, start, e) ->
 587                make_exp loc (LowerBoundsCheck (label, ptrty, ptr, start, elim_relop venv e))
 588           | UpperBoundsCheck (label, ptrty, ptr, stop, e) ->
 589                make_exp loc (UpperBoundsCheck (label, ptrty, ptr, stop, elim_relop venv e))
 590           | PointerIndexCheck (label, ptrty, v, ac, index, e) ->
 591                (* v is bound here, but not as a relop *)
 592                make_exp loc (PointerIndexCheck (label, ptrty, v, ac, index, elim_relop venv e))
 593           | FunctionIndexCheck (label, funty, v, ac, index, e) ->
 594                (* v is bound here, but not as a relop *)
 595                make_exp loc (FunctionIndexCheck (label, funty, v, ac, index, elim_relop venv e))
 596           | Memcpy (ptrty, a1, a2, a3, a4, a5, e) ->
 597                make_exp loc (Memcpy (ptrty, a1, a2, a3, a4, a5, elim_relop venv e))
 598           | Debug (info, e) ->
 599                make_exp loc (Debug (info, elim_relop venv e))
 600           | PrintDebug (v1, v2, a, e) ->
 601                make_exp loc (PrintDebug (v1, v2, a, elim_relop venv e))
 602           | CommentFIR (fir, e) ->
 603                make_exp loc (CommentFIR (fir, elim_relop venv e))
 604           | AtomicCommit (level, e) ->
 605                make_exp loc (AtomicCommit (level, elim_relop venv e))
 606           | CopyOnWrite (rinfo, ptr, e) ->
 607                make_exp loc (CopyOnWrite (rinfo, ptr, elim_relop venv e))
 608           | Reserve (rinfo, e) ->
 609                make_exp loc (Reserve (rinfo, elim_relop venv e))
 610           | TailCall _
 611           | SpecialCall _
 612           | SysMigrate _
 613           | Atomic _
 614           | AtomicRollback _ ->
 615                e
 616
 617
 618    (* elim_relop_let_atom
 619       If this is a binding occurence of a variable to a simple relop
 620       expression, then add it to the venv.  Note that we do not attempt
 621       to remove the binding occurrence here; if we are successful in
 622       eliminating v, then mir_dead_code.ml will remove it later. *)
 623    and elim_relop_let_atom venv pos loc v ac a e =
 624       let pos = string_pos "elim_relop_let_atom" pos in
 625       let venv =
 626          match a with
 627             AtomBinop (EqOp  ac, a1, a2) ->
 628                venv_add venv v (REqOp  ac, a1, a2)
 629           | AtomBinop (NeqOp ac, a1, a2) ->
 630                venv_add venv v (RNeqOp ac, a1, a2)
 631           | AtomBinop (LtOp  ac, a1, a2) ->
 632                venv_add venv v (RLtOp  ac, a1, a2)
 633           | AtomBinop (LeOp  ac, a1, a2) ->
 634                venv_add venv v (RLeOp  ac, a1, a2)
 635           | AtomBinop (GtOp  ac, a1, a2) ->
 636                venv_add venv v (RGtOp  ac, a1, a2)
 637           | AtomBinop (GeOp  ac, a1, a2) ->
 638                venv_add venv v (RGeOp  ac, a1, a2)
 639           | _ ->
 640                venv
 641       in
 642          make_exp loc (LetAtom (v, ac, a, elim_relop venv e))
 643
 644
 645    (* elim_relop_if_then_else
 646       Attempt to merge a relop into this conditional. *)
 647    and elim_relop_if_then_else venv pos loc op a1 a2 e1 e2 =
 648       let pos = string_pos "elim_relop_if_then_else" pos in
 649
 650       (* Process the subexpressions *)
 651       let e1 = elim_relop venv e1 in
 652       let e2 = elim_relop venv e2 in
 653
 654       (* We need to be able to negate relops in a few cases... *)
 655       let negate_relop = function
 656          REqOp  ac -> RNeqOp ac
 657        | RNeqOp ac -> REqOp  ac
 658        | RLtOp  ac -> RGeOp  ac
 659        | RLeOp  ac -> RGtOp  ac
 660        | RGtOp  ac -> RLeOp  ac
 661        | RGeOp  ac -> RLtOp  ac
 662        | RAndOp _ ->
 663             raise (MirException (pos, InternalError "RAndOp not allowed here"))
 664       in
 665       let e =
 666          (* Find out what operation is performed in the IfThenElse *)
 667          match op, a1, a2 with
 668             REqOp  (ACRawInt (pre, signed)), AtomRawInt i, AtomVar (_, v)
 669           | REqOp  (ACRawInt (pre, signed)), AtomVar (_, v), AtomRawInt i
 670             when Rawint.compare i (Rawint.of_int pre signed 0) = 0 ->
 671                (* Any prior relop must be FALSE *)
 672                if venv_mem venv v then
 673                   (* We can fold a previous relop into this expression! *)
 674                   let op, a1, a2 = venv_lookup venv pos v in
 675                   let op = negate_relop op in
 676                      IfThenElse (op, a1, a2, e1, e2)
 677                else
 678                   (* Unknown case *)
 679                   IfThenElse (op, a1, a2, e1, e2)
 680           | RNeqOp (ACRawInt (pre, signed)), AtomRawInt i, AtomVar (_, v)
 681           | RNeqOp (ACRawInt (pre, signed)), AtomVar (_, v), AtomRawInt i
 682             when Rawint.compare i (Rawint.of_int pre signed 0) = 0 ->
 683                (* Any prior relop must be TRUE *)
 684                if venv_mem venv v then
 685                   (* We can fold a previous relop into this expression! *)
 686                   let op, a1, a2 = venv_lookup venv pos v in
 687                      IfThenElse (op, a1, a2, e1, e2)
 688                else
 689                   (* Unknown case *)
 690                   IfThenElse (op, a1, a2, e1, e2)
 691           | _ ->
 692                (* Default is just construct the cond the way it was... *)
 693                IfThenElse (op, a1, a2, e1, e2)
 694       in
 695          make_exp loc e
 696
 697
 698    (***  Interface  ***)
 699
 700
 701    let rewrite_matches e = rewrite_matches (SymbolTable.empty) e
 702
 703    let rewrite_matches prog =
 704       (* Do standard conditional rewrites. *)
 705       let funs = SymbolTable.mapi (fun name (line, args, e) ->
 706          line, args, remove_expr (rewrite_matches e)) prog.prog_funs
 707       in
 708       let prog = { prog with prog_funs = funs } in
 709
 710       (* Note: we let valiasing get a chance here, because elim_relop
 711          will alter the landscape of the IfThenElse expressions, and
 712          we want to make sure we get to exploit aliases in subexpr's
 713          FIRST.  If we don't valias, odds are good we'll remove real
 714          aliases for the relop vars we're trying to eliminate! *)
 715       let prog = valias_prog prog in
 716       let funs = SymbolTable.mapi (fun name (line, args, e) ->
 717          line, args, elim_relop venv_empty e) prog.prog_funs
 718       in
 719       let prog = { prog with prog_funs = funs } in
 720       let prog = valias_prog prog in
 721       let prog = standardize_prog prog in
 722          if debug Mir_state.debug_print_mir then
 723             debug_prog "Cond" prog;
 724          prog
 725
 726    let rewrite_matches prog = Fir_state.profile "Mir_cond.rewrite_matches" rewrite_matches prog
 727
 728    let rewrite_matches prog =
 729       if optimize_mir_level "opt.mir.cond" 2 then
 730          rewrite_matches prog
 731       else
 732          prog
 733
 734
 735 end (* struct *)
 736
 737 let () = std_flags_register_list_help "opt.mir"
 738   ["opt.mir.cond",   FlagBool true,
 739                      "Enable MIR conditional optimizations.  The MIR attempts to revise" ^
 740                      " certain match constructs to use the simpler IfThenElse construct" ^
 741                      " which can be handled more efficiently by many backends.  Some branch" ^
 742                      " prediction may also be performed here."]