Ignore:
Timestamp:
Nov 28, 2011, 3:13:14 PM (9 years ago)
Author:
tranquil
Message:
  • corrected previous bug
  • finished propagating immediates
File:
1 edited

Legend:

Unmodified
Added
Removed
  • Deliverables/D2.2/8051/src/RTLabs/redundancyElimination.ml

    r1569 r1572  
    33    This is a reformulation of material found in Muchnick, Advanced compiler
    44    design and implementation.
    5                 Along the way we also perform a first rough liveness analysis. *)
    6                
     5    Along the way we also perform a first rough liveness analysis. *)
     6
    77
    88open RTLabs
     
    2424(* an example where this transformation really applies. *)
    2525
    26 let count_predecessors 
     26let count_predecessors
    2727    (g : graph)
    2828    : int Label.Map.t =
    2929  let f lbl s m =
    3030    let succs = RTLabsUtilities.statement_successors s in
    31       let f' m succ =
     31    let f' m succ =
    3232      try
    3333        Label.Map.add succ (1 + Label.Map.find succ m) m
    3434      with
    3535        | Not_found -> Label.Map.add succ 1 m in
    36       let m = List.fold_left f' m succs in
    37       if Label.Map.mem lbl m then m else Label.Map.add lbl 0 m in
     36    let m = List.fold_left f' m succs in
     37    if Label.Map.mem lbl m then m else Label.Map.add lbl 0 m in
    3838  Label.Map.fold f g Label.Map.empty
    3939
     
    4747  let add_if_2_preds l1 s l2 =
    4848    if Label.Map.find l2 pred_count < 2 then s else
    49     LabelPairSet.add (l1, l2) s in
     49      LabelPairSet.add (l1, l2) s in
    5050  let f l stmt s = match stmt with
    5151    | St_cond(_, l1, l2) ->
    52       add_if_2_preds l (add_if_2_preds l s l1) l2 
     52      add_if_2_preds l (add_if_2_preds l s l1) l2
    5353    | St_jumptable (_, ls) when List.length ls > 1 ->
    5454      List.fold_left (add_if_2_preds l) s ls
    5555    | _ -> s in
    5656  Label.Map.fold f g LabelPairSet.empty
    57      
     57
    5858(* note to self: there is a degenrate case that is not eliminated by the *)
    5959(* following, namely (top to bottom) *)
     
    7676    (f_def : internal_function)
    7777    : internal_function =
    78         let g = f_def.f_graph in
    79         let fresh () = Label.Gen.fresh f_def.f_luniverse in
     78  let g = f_def.f_graph in
     79  let fresh () = Label.Gen.fresh f_def.f_luniverse in
    8080  let critical_edges = find_critical_edges g in
    8181  let rem (src, tgt) g =
    8282    snd (RTLabsUtilities.insert_in_between fresh g src tgt (St_skip tgt)) in
    8383  { f_def with f_graph = LabelPairSet.fold rem critical_edges g }
    84          
     84
    8585(* Expressions, expression sets, and operations thereof *)
    8686
    8787(* Load and store ops are not taken into account, maybe later *)
    8888type expr =
    89 (*      | Cst of cst (* do we need to consider constants? maybe only big ones? *)*)
     89  (*        | Cst of cst (* do we need to consider constants? maybe only big ones? *)*)
    9090  | UnOp of op1 * Register.t
    9191  | BinOp of op2 * argument * argument
    9292
    9393let expr_of_stmt (s : statement) : expr option = match s with
    94 (*      | St_cst (_, c, _) -> Some (Cst c)*)
    95         | St_op1 (op, _, s, _) when op <> Op_id -> Some (UnOp (op, s))
    96         | St_op2 (op, _, s, t, _) -> Some (BinOp (op, s, t))
    97         | _ -> None
     94        (*        | St_cst (_, c, _) -> Some (Cst c)*)
     95  | St_op1 (op, _, s, _) when op <> Op_id -> Some (UnOp (op, s))
     96  | St_op2 (op, _, s, t, _) -> Some (BinOp (op, s, t))
     97  | _ -> None
    9898
    9999let expr_of (g : graph) (n : Label.t) : expr option =
    100         expr_of_stmt (Label.Map.find n g)
     100  expr_of_stmt (Label.Map.find n g)
    101101
    102102(* the register modified by a node *)
     
    111111let vars_of_stmt = function
    112112  | St_op2 (_, _, Reg s, Reg t, _) ->
    113                 Register.Set.add s (Register.Set.singleton t)
     113    Register.Set.add s (Register.Set.singleton t)
    114114  | St_load (_, Reg s, _, _)
    115115  | St_op1 (_, _, s, _)
    116         | St_op2 (_, _, Reg s, _, _)
    117         | St_op2 (_, _, _, Reg s, _) -> Register.Set.singleton s
    118         | _ -> Register.Set.empty
     116  | St_op2 (_, _, Reg s, _, _)
     117  | St_op2 (_, _, _, Reg s, _) -> Register.Set.singleton s
     118  | _ -> Register.Set.empty
    119119
    120120let vars_of (g : graph) (n : Label.t) : Register.Set.t =
    121         vars_of_stmt (Label.Map.find n g)
    122        
     121  vars_of_stmt (Label.Map.find n g)
     122
    123123(* used in possibly non side-effect-free statements *)
    124 let used_at_stmt = function
    125         | St_call_id (_, rs, _, _, _)
    126         | St_call_ptr (_, rs, _, _, _)
    127         | St_tailcall_id (_, rs, _)
    128         | St_tailcall_ptr (_, rs, _) ->
    129             let f s r = Register.Set.add r s in
    130             List.fold_left f Register.Set.empty rs
    131   | St_store (_, Reg s, Reg t, _) ->
    132                 Register.Set.add s (Register.Set.singleton t)
    133         | St_return (Some r)
    134         | St_cond (r, _, _)
    135         | St_store (_, Reg r, _, _)
    136         | St_store (_, _, Reg r, _)  -> Register.Set.singleton r
    137         | _ -> Register.Set.empty
     124let used_at_stmt stmt =
     125  let add_arg s = function
     126    | Reg r -> Register.Set.add r s
     127    | Imm _ -> s in
     128  match stmt with
     129    | St_call_id (_, rs, _, _, _)
     130    | St_call_ptr (_, rs, _, _, _)
     131    | St_tailcall_id (_, rs, _)
     132    | St_tailcall_ptr (_, rs, _) ->
     133      List.fold_left add_arg Register.Set.empty rs
     134    | St_store (_, a, b, _) ->
     135      add_arg (add_arg Register.Set.empty a) b
     136    | St_return (Some (Reg r))
     137    | St_cond (r, _, _) -> Register.Set.singleton r
     138    | _ -> Register.Set.empty
    138139
    139140let used_at g n = used_at_stmt (Label.Map.find n g)
    140141
    141142module ExprOrdered = struct
    142         type t = expr
    143         let compare = compare
     143  type t = expr
     144  let compare = compare
    144145end
    145146
     
    164165
    165166let big_inter (f : Label.t -> ExprSet.t) (ls : Label.t list) : ExprSet.t =
    166         (* generalized intersection, but in case of empty list it is empty *)
    167         match ls with
    168                 | [] -> ExprSet.empty
     167        (* generalized intersection, but in case of empty list it is empty *)
     168  match ls with
     169    | [] -> ExprSet.empty
    169170    (* these two cases are singled out for speed, as they will be common *)
    170171    | [l] -> f l
     
    176177let big_union (f : Label.t -> Register.Set.t) (ls : Label.t list)
    177178    : Register.Set.t =
    178     (* generalized union *)
     179  (* generalized union *)
    179180  let union s l' = Register.Set.union s (f l') in
    180     List.fold_left union Register.Set.empty ls
     181  List.fold_left union Register.Set.empty ls
    181182
    182183let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set =
    183         match r with
    184                 | None -> s
    185                 | Some r ->
    186                         let filter = function
    187                                 | UnOp (_, s) when r = s -> false
    188                                 | BinOp (_, s, t) when s = Reg r || t = Reg r -> false
    189                                 | _ -> true in
    190                         ExprSet.filter filter s
    191                        
     184  match r with
     185    | None -> s
     186    | Some r ->
     187      let filter = function
     188        | UnOp (_, s) when r = s -> false
     189        | BinOp (_, s, t) when s = Reg r || t = Reg r -> false
     190        | _ -> true in
     191      ExprSet.filter filter s
     192
    192193module Lpair = struct
    193        
    194         (* A property is a pair of sets of expressions. *)
    195         type property = expr_set * expr_set
    196        
    197         let bottom = (ExprSet.empty, ExprSet.empty)
    198        
     194
     195        (* A property is a pair of sets of expressions. *)
     196  type property = expr_set * expr_set
     197
     198  let bottom = (ExprSet.empty, ExprSet.empty)
     199
    199200  let equal (ant1, nea1) (ant2, nea2) =
    200                 ExprSet.equal ant1 ant2 && ExprSet.equal nea1 nea2
     201    ExprSet.equal ant1 ant2 && ExprSet.equal nea1 nea2
    201202
    202203  let is_maximal _ = false
    203        
     204
    204205end
    205206
    206207module Lsing = struct
    207    
     208
    208209  (* A property is a set of expressions. *)
    209210  type property = expr_set
    210    
     211
    211212  let bottom = ExprSet.empty
    212    
     213
    213214  let equal = ExprSet.equal
    214215
    215216  let is_maximal _ = false
    216    
     217
    217218end
    218219
    219220module Lexprid = struct
    220    
     221
    221222  (* A property is a set of expressions and a set of registers. *)
    222223  type property = expr_set * Register.Set.t
    223    
     224
    224225  let bottom = (ExprSet.empty, Register.Set.empty)
    225    
     226
    226227  let equal (a, b) (c, d) = ExprSet.equal a c && Register.Set.equal b d
    227228
    228229  let is_maximal _ = false
    229    
     230
    230231end
    231232
     
    239240
    240241let print_expr = function
    241 (*    | Cst c ->
    242       (RTLabsPrinter.print_cst c)*)
    243     | UnOp (op, r) ->
    244       (RTLabsPrinter.print_op1 op r)
    245     | BinOp (op, r, s) ->
    246       (RTLabsPrinter.print_op2 op r s)
    247                        
     242    (*    | Cst c ->
     243          (RTLabsPrinter.print_cst c)*)
     244  | UnOp (op, r) ->
     245    (RTLabsPrinter.print_op1 op r)
     246  | BinOp (op, r, s) ->
     247    (RTLabsPrinter.print_op2 op r s)
     248
    248249let print_prop_pair (p : Fpair.property) = let (ant, nea) = p in
    249   let f e = Printf.printf "%s, " (print_expr e) in
    250         Printf.printf "{ ";
    251         ExprSet.iter f ant;
    252   Printf.printf "}; { ";
    253   ExprSet.iter f nea;
    254   Printf.printf "}\n"
     250                                           let f e = Printf.printf "%s, " (print_expr e) in
     251                                           Printf.printf "{ ";
     252                                           ExprSet.iter f ant;
     253                                           Printf.printf "}; { ";
     254                                           ExprSet.iter f nea;
     255                                           Printf.printf "}\n"
    255256
    256257let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) =
    257     let f lbl _ =
    258         Printf.printf "%s: " lbl;
    259         print_prop_pair (valu lbl) in
    260      RTLabsUtilities.dfs_iter f g entry
    261 
    262 let print_prop_sing (p : Fsing.property) = 
     258  let f lbl _ =
     259    Printf.printf "%s: " lbl;
     260    print_prop_pair (valu lbl) in
     261  RTLabsUtilities.dfs_iter f g entry
     262
     263let print_prop_sing (p : Fsing.property) =
    263264  let f e = Printf.printf "%s, " (print_expr e) in
    264265  Printf.printf "{ ";
     
    267268
    268269let print_valu_sing (valu : Fsing.valuation) (g : graph) (entry : Label.t) =
    269     let f lbl _ =
    270         Printf.printf "%s: " lbl;
    271         print_prop_sing (valu lbl) in
    272      RTLabsUtilities.dfs_iter f g entry
    273    
    274    
     270  let f lbl _ =
     271    Printf.printf "%s: " lbl;
     272    print_prop_sing (valu lbl) in
     273  RTLabsUtilities.dfs_iter f g entry
     274
     275
    275276(* ----- PHASE 1 : Anticipatability and erliestness ------ *)
    276277(* An expression e is anticipatable at point p if every path from p contains  *)
     
    280281(* preceding p giving the same value. *)
    281282(* We will compute anticipatable expressions and *non*-earliest ones for every*)
    282 (* point with a single invocation to a fixpoint calculation. *) 
     283(* point with a single invocation to a fixpoint calculation. *)
    283284
    284285
    285286let semantics_ant_nea
    286287    (g : graph)
    287                 (pred_table : Label.t list Label.Map.t)
     288    (pred_table : Label.t list Label.Map.t)
    288289    (lbl : Label.t)
    289290    (valu : Fpair.valuation)
    290291    : Fpair.property =
    291         let succs = RTLabsUtilities.statement_successors (Label.Map.find lbl g) in
    292         let preds = Label.Map.find lbl pred_table in
    293        
    294   (* anticipatable expressions at entry *)
    295         (* take anticipatable expressions of successors... *)
    296         let ant l = fst (valu l) in
    297         let nea l = snd (valu l) in
    298         let ant_in = big_inter ant succs in
    299         (* ... filter out those that contain the register being changed ...*)
    300         let ant_in = filter_unchanged (modified_at g lbl) ant_in in
    301         (* ... and add the expression being calculated ... *)
    302         let ant_in = ant_in ++* expr_of g lbl in
    303        
    304         (* non-earliest expressions at entry *)
    305         (* take non-earliest or anticipatable expressions of predecessors, *)
    306         (* filtered so that just unchanged expressions leak *)
    307         let ant_or_nea l =
    308                 filter_unchanged (modified_at g l) (ant l ++ nea l) in
    309         let nea_in = big_inter ant_or_nea preds in
    310                        
    311         (ant_in, nea_in)
    312        
     292  let succs = RTLabsUtilities.statement_successors (Label.Map.find lbl g) in
     293  let preds = Label.Map.find lbl pred_table in
     294
     295        (* anticipatable expressions at entry *)
     296        (* take anticipatable expressions of successors... *)
     297  let ant l = fst (valu l) in
     298  let nea l = snd (valu l) in
     299  let ant_in = big_inter ant succs in
     300        (* ... filter out those that contain the register being changed ...*)
     301  let ant_in = filter_unchanged (modified_at g lbl) ant_in in
     302        (* ... and add the expression being calculated ... *)
     303  let ant_in = ant_in ++* expr_of g lbl in
     304
     305        (* non-earliest expressions at entry *)
     306        (* take non-earliest or anticipatable expressions of predecessors, *)
     307        (* filtered so that just unchanged expressions leak *)
     308  let ant_or_nea l =
     309    filter_unchanged (modified_at g l) (ant l ++ nea l) in
     310  let nea_in = big_inter ant_or_nea preds in
     311
     312  (ant_in, nea_in)
     313
    313314let compute_anticipatable_and_non_earliest
    314315    (f_def : internal_function)
    315316    (pred_table : Label.t list Label.Map.t)
    316317    : Fpair.valuation =
    317    
    318     Fpair.lfp (semantics_ant_nea f_def.f_graph pred_table)
    319    
     318
     319  Fpair.lfp (semantics_ant_nea f_def.f_graph pred_table)
     320
    320321(* ------------ PHASE 2 : delayedness and lateness ----------- *)
    321322(* An expression e is delayable at position p there is a point p' preceding it*)
     
    331332    (valu : Fsing.valuation)
    332333    : Fsing.property =
    333     let preds = Label.Map.find lbl pred_table in
    334    
    335     (* delayed expressions at entry *)
    336     (* take delayed expressions of predecessors which are not the expressions *)
    337                 (* of such predecessors... *)
    338                 let rem_pred lbl' = valu lbl' --* expr_of g lbl' in
    339     let delay_in = big_inter rem_pred preds in
    340                 (* ... and add in anticipatable and earliest expressions *)
    341                 let (ant, nea) = ant_nea lbl in
    342     delay_in ++ (ant -- nea)
    343    
     334  let preds = Label.Map.find lbl pred_table in
     335
     336                (* delayed expressions at entry *)
     337                (* take delayed expressions of predecessors which are not the expressions *)
     338                (* of such predecessors... *)
     339  let rem_pred lbl' = valu lbl' --* expr_of g lbl' in
     340  let delay_in = big_inter rem_pred preds in
     341                (* ... and add in anticipatable and earliest expressions *)
     342  let (ant, nea) = ant_nea lbl in
     343  delay_in ++ (ant -- nea)
     344
    344345let compute_delayed
    345346    (f_def : internal_function)
    346                 (pred_table : Label.t list Label.Map.t)
    347                 (ant_nea : Fpair.valuation)
     347    (pred_table : Label.t list Label.Map.t)
     348    (ant_nea : Fpair.valuation)
    348349    : Fsing.valuation =
    349    
    350     Fsing.lfp (semantics_delay f_def.f_graph pred_table ant_nea)
     350
     351  Fsing.lfp (semantics_delay f_def.f_graph pred_table ant_nea)
    351352
    352353(* An expression is latest at p if it cannot be delayed further *)
    353354let late (g : graph) (delay : Fsing.valuation)
    354   : Fsing.valuation = fun lbl ->
    355         let stmt = Label.Map.find lbl g in
    356         let succs = RTLabsUtilities.statement_successors stmt in
    357        
    358         let eo = match expr_of g lbl with
    359                 | Some e when ExprSet.mem e (delay lbl) -> Some e
    360                 | _ -> None in
    361 
    362   (delay lbl -- big_inter delay succs) ++* eo   
    363        
     355    : Fsing.valuation = fun lbl ->
     356      let stmt = Label.Map.find lbl g in
     357      let succs = RTLabsUtilities.statement_successors stmt in
     358
     359      let eo = match expr_of g lbl with
     360        | Some e when ExprSet.mem e (delay lbl) -> Some e
     361        | _ -> None in
     362
     363      (delay lbl -- big_inter delay succs) ++* eo
     364
    364365
    365366(* --------------- PHASE 3 : isolatedness, optimality and redudancy --------*)
     
    372373let semantics_isolated_used
    373374    (g : graph)
    374                 (late : Fsing.valuation)
     375    (late : Fsing.valuation)
    375376    (lbl : Label.t)
    376377    (valu : Fexprid.valuation)
    377                 : Fexprid.property =
    378        
    379         let stmt = Label.Map.find lbl g in
    380         let succs = RTLabsUtilities.statement_successors stmt in
    381         let f l = late l ++ (fst (valu l) --* expr_of g l) in
    382         let isol = big_inter f succs in
    383        
    384         let f l =
    385                 let used_out = snd (valu l) in
    386                 let used_out = match modified_at g l with
    387                 | Some r when Register.Set.mem r used_out ->
    388                         Register.Set.union (Register.Set.remove r used_out) (vars_of g l)
    389                 | _ -> used_out in
    390                 Register.Set.union used_out (used_at g l) in
    391         let used = big_union f succs in
    392        
    393         (isol, used)
    394        
     378    : Fexprid.property =
     379
     380  let stmt = Label.Map.find lbl g in
     381  let succs = RTLabsUtilities.statement_successors stmt in
     382  let f l = late l ++ (fst (valu l) --* expr_of g l) in
     383  let isol = big_inter f succs in
     384
     385  let f l =
     386    let used_out = snd (valu l) in
     387    let used_out = match modified_at g l with
     388      | Some r when Register.Set.mem r used_out ->
     389        Register.Set.union (Register.Set.remove r used_out) (vars_of g l)
     390      | _ -> used_out in
     391    Register.Set.union used_out (used_at g l) in
     392  let used = big_union f succs in
     393
     394  (isol, used)
     395
    395396let compute_isolated_used
    396397    (f_def : internal_function)
     
    398399    : Fexprid.valuation =
    399400
    400     let graph = f_def.f_graph in
    401                
    402     Fexprid.lfp (semantics_isolated_used graph (late graph delayed))
     401  let graph = f_def.f_graph in
     402
     403  Fexprid.lfp (semantics_isolated_used graph (late graph delayed))
    403404
    404405(* expressions that are optimally placed at point p, without being isolated *)
    405406let optimal (late : Fsing.valuation) (isol : Fsing.valuation)
    406407    : Fsing.valuation = fun lbl ->
    407         late lbl -- isol lbl
     408      late lbl -- isol lbl
    408409
    409410(* mark instructions that are redundant and can be removed *)
    410411let redundant g late isol lbl =
    411         match expr_of g lbl with
    412                 | Some e when ExprSet.mem e (isol lbl) ->
    413                         false
    414                 | Some _ -> true
    415                 | _ -> false
     412  match expr_of g lbl with
     413    | Some e when ExprSet.mem e (isol lbl) ->
     414      false
     415    | Some _ -> true
     416    | _ -> false
    416417
    417418(* mark instructions that modify an unused register *)
    418419let unused g used lbl =
    419     match modified_at g lbl with
    420         | Some r when Register.Set.mem r (used lbl) ->
    421             false
    422         | Some r -> true
    423                                 | _ -> false
     420  match modified_at g lbl with
     421    | Some r when Register.Set.mem r (used lbl) ->
     422      false
     423    | Some r -> true
     424    | _ -> false
    424425
    425426(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)
    426427
    427428let remove_redundant def is_redundant is_unused =
    428         let g = def.f_graph in
    429         let types = RTLabsUtilities.computes_type_map def in
    430         let f lbl stmt (g', s) =
    431                 if is_unused lbl then
     429  let g = def.f_graph in
     430  let types = RTLabsUtilities.computes_type_map def in
     431  let f lbl stmt (g', s) =
     432    if is_unused lbl then
    432433      let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
    433                         (Label.Map.add lbl (St_skip succ) g', s) else
    434                 if is_redundant lbl then
    435                         match modified_at_stmt stmt, expr_of_stmt stmt with
    436                                 | Some r, Some e ->
    437                                         let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
    438                             let (s, (tmp, _)) =
    439                                                 try
    440                                                         (s, ExprMap.find e s)
    441                                                 with
    442                                                         | Not_found ->
    443                                                                 let tmp =       Register.fresh def.f_runiverse in
    444                                                                 let typ = Register.Map.find r types in
    445                                                                 let s = ExprMap.add e (tmp, typ) s in
    446                                                                 (s, (tmp, typ)) in
    447                                         let new_stmt = St_op1 (Op_id, r, tmp, succ) in
    448           (Label.Map.add lbl new_stmt g', s)
    449         | _ -> assert false
    450                 else (g', s) in
    451         let (g, s) = Label.Map.fold f g (g, ExprMap.empty) in
    452         ({ def with f_graph = g }, s)
     434      (Label.Map.add lbl (St_skip succ) g', s) else
     435      if is_redundant lbl then
     436        match modified_at_stmt stmt, expr_of_stmt stmt with
     437          | Some r, Some e ->
     438            let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
     439            let (s, (tmp, _)) =
     440              try
     441                (s, ExprMap.find e s)
     442              with
     443                | Not_found ->
     444                  let tmp =        Register.fresh def.f_runiverse in
     445                  let typ = Register.Map.find r types in
     446                  let s = ExprMap.add e (tmp, typ) s in
     447                  (s, (tmp, typ)) in
     448            let new_stmt = St_op1 (Op_id, r, tmp, succ) in
     449            (Label.Map.add lbl new_stmt g', s)
     450          | _ -> assert false
     451      else (g', s) in
     452  let (g, s) = Label.Map.fold f g (g, ExprMap.empty) in
     453  ({ def with f_graph = g }, s)
    453454
    454455let stmt_of_expr
    455456    (r : Register.t)
    456                 (e : expr)
    457                 (l : Label.t)
    458                 : statement =
    459         match e with
    460 (*              | Cst c -> St_cst (r, c, l)*)
    461                 | UnOp (op, s) -> St_op1 (op, r, s, l)
    462                 | BinOp (op, s, t) -> St_op2 (op, r, s, t, l)
     457    (e : expr)
     458    (l : Label.t)
     459    : statement =
     460  match e with
     461                (*                | Cst c -> St_cst (r, c, l)*)
     462    | UnOp (op, s) -> St_op1 (op, r, s, l)
     463    | BinOp (op, s, t) -> St_op2 (op, r, s, t, l)
    463464
    464465let insert_after exprs redundants g freshl lbl next =
    465466  let f e (next', g') =
    466     try 
     467    try
    467468      let (tmp, _) = ExprMap.find e redundants in
    468469      let opt_calc = stmt_of_expr tmp e next' in
    469470      RTLabsUtilities.insert_in_between freshl g' lbl next' opt_calc
    470                 with
    471                         | Not_found -> (next', g') in
     471    with
     472      | Not_found -> (next', g') in
    472473  snd (ExprSet.fold f exprs (next, g))
    473        
     474
    474475let insert_before exprs redundants g freshl lbl stmt =
    475         let f e (stmt', g') =
    476     try 
     476  let f e (stmt', g') =
     477    try
    477478      let (tmp, _) = ExprMap.find e redundants in
    478                         let n_lbl = freshl () in
     479      let n_lbl = freshl () in
    479480      let opt_calc = stmt_of_expr tmp e n_lbl in
    480                         let g' = Label.Map.add n_lbl stmt' g' in
    481                         let g' = Label.Map.add lbl opt_calc g' in
    482                         (opt_calc, g')
    483      with
    484                         | Not_found -> (stmt', g') in
     481      let g' = Label.Map.add n_lbl stmt' g' in
     482      let g' = Label.Map.add lbl opt_calc g' in
     483      (opt_calc, g')
     484    with
     485      | Not_found -> (stmt', g') in
    485486  snd (ExprSet.fold f exprs (stmt, g))
    486                
     487
    487488let store_optimal_computation (def, redundants) optimal =
    488         (* first add the temporaries' declarations *)
    489         let f _ (r, typ) vars = (r, typ) :: vars in
    490         let f_locals = ExprMap.fold f redundants def.f_locals in
    491        
    492         (* now the actual replacement *)
    493         let g = def.f_graph in
     489        (* first add the temporaries' declarations *)
     490  let f _ (r, typ) vars = (r, typ) :: vars in
     491  let f_locals = ExprMap.fold f redundants def.f_locals in
     492
     493        (* now the actual replacement *)
     494  let g = def.f_graph in
    494495  let freshl () = Label.Gen.fresh def.f_luniverse in
    495         let f lbl stmt g' =
    496                 match stmt with
    497                         (* in case of cost emittance the optimal calculations are inserted *)
    498                         (* after, to preserve preciness *)
    499 (*                      | St_cost (_, next) ->
    500                                 insert_after (optimal lbl) redundants g' freshl lbl next *)
    501                         | _ ->
    502                                 insert_before (optimal lbl) redundants g' freshl lbl stmt in
    503         { def with f_locals = f_locals; f_graph = Label.Map.fold f g g }
    504 
    505                
    506 (* piecing it all together *)           
    507 let transform_internal f_def = 
     496  let f lbl stmt g' =
     497    match stmt with
     498      (* in case of cost emittance the optimal calculations are inserted *)
     499      (* after, to preserve preciness *)
     500      | St_cost (_, next) ->
     501         insert_after (optimal lbl) redundants g' freshl lbl next
     502      | _ ->
     503        insert_before (optimal lbl) redundants g' freshl lbl stmt in
     504  { def with f_locals = f_locals; f_graph = Label.Map.fold f g g }
     505
     506
     507(* piecing it all together *)
     508let transform_internal f_def =
    508509  let pred_table = RTLabsUtilities.compute_predecessor_lists f_def.f_graph in
    509510  let ant_nea = compute_anticipatable_and_non_earliest f_def pred_table in
    510   (*Printf.printf "Ant + Nearl:\n";
    511   print_valu_pair ant_nea f_def.f_graph f_def.f_entry;*)
    512511  let delay = compute_delayed f_def pred_table ant_nea in
    513   (*Printf.printf "Delayed:\n";
    514   print_valu_sing delay f_def.f_graph f_def.f_entry;*)
    515512  let late = late f_def.f_graph delay in
    516   (*Printf.printf "Late:\n";
    517   print_valu_sing late f_def.f_graph f_def.f_entry;*)
    518513  let isol_used = compute_isolated_used f_def delay in
    519         let isol = fun lbl -> fst (isol_used lbl) in
     514  let isol = fun lbl -> fst (isol_used lbl) in
    520515  let used = fun lbl -> snd (isol_used lbl) in
    521   (*Printf.printf "isolated:\n";
    522   print_valu_sing isol f_def.f_graph f_def.f_entry;*)
    523         let opt = optimal late isol in
    524         let redn = redundant f_def.f_graph late isol in
    525         let unusd = unused f_def.f_graph used in
    526   (*Printf.printf "optimal:\n";
    527   print_valu_sing opt f_def.f_graph f_def.f_entry;
    528   Printf.printf "redundant:\n";
    529     let f lbl _ =
    530       Printf.printf "%s : %s\n" lbl (if redn lbl then "yes" else "no") in
    531     RTLabsUtilities.dfs_iter f f_def.f_graph f_def.f_entry;*)
    532         let f lbl _ s = Register.Set.union (used lbl) s in
    533         let regs_used =
    534                 RTLabsUtilities.dfs_fold f f_def.f_graph f_def.f_entry Register.Set.empty in
    535         let filter (r, _) = Register.Set.mem r regs_used in
    536         let f_def = { f_def with f_locals = List.filter filter f_def.f_locals } in
    537         store_optimal_computation (remove_redundant f_def redn unusd) opt
    538        
    539        
     516  let opt = optimal late isol in
     517  let redn = redundant f_def.f_graph late isol in
     518  let unusd = unused f_def.f_graph used in
     519  let f lbl _ s = Register.Set.union (used lbl) s in
     520  let regs_used =
     521    RTLabsUtilities.dfs_fold f f_def.f_graph f_def.f_entry Register.Set.empty in
     522  let filter (r, _) = Register.Set.mem r regs_used in
     523  let f_def = { f_def with f_locals = List.filter filter f_def.f_locals } in
     524  store_optimal_computation (remove_redundant f_def redn unusd) opt
     525
     526
    540527let transform_funct = function
    541         | (f, F_int f_def) -> (f, F_int (transform_internal f_def))
    542         | f -> f
     528  | (f, F_int f_def) -> (f, F_int (transform_internal f_def))
     529  | f -> f
    543530
    544531let trans = Languages.RTLabs, function
    545         | Languages.AstRTLabs p ->
    546                 Languages.AstRTLabs { p with functs = List.map transform_funct p.functs }
    547         | _ -> assert false (* wrong language *)
     532  | Languages.AstRTLabs p ->
     533    Languages.AstRTLabs { p with functs = List.map transform_funct p.functs }
     534  | _ -> assert false (* wrong language *)
Note: See TracChangeset for help on using the changeset viewer.