Ignore:
Timestamp:
Dec 1, 2011, 2:50:27 PM (9 years ago)
Author:
tranquil
Message:

implemented constant propagation in LTL
cleaned up translations in optimizations, a new module for translations is available

File:
1 moved

Legend:

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

    r1572 r1580  
    11(** this module provides some utilities relative to RTLabs graphs *)
     2
     3type node = Label.t
     4type statement = RTLabs.statement
     5
     6module NodeMap = Label.Map
     7module NodeSet = Label.Set
     8
     9type t = RTLabs.graph
    210
    311open RTLabs
    412
    5 type node = Label.t
    6 
    713(** Successors of a statement *)
    8 let statement_successors (stmt : statement) =
     14let successors (stmt : statement) =
    915  match stmt with
    10   | St_return _ 
     16  | St_return _
    1117  | St_tailcall_id _
    1218  | St_tailcall_ptr _ ->
     
    2834  | St_jumptable (_, ls) -> ls
    2935
    30 let count_statement_successors (stmt : statement) =
    31   match stmt with
    32   | St_return _
    33   | St_tailcall_id _
    34   | St_tailcall_ptr _ -> 0
    35   | St_skip _
    36   | St_cost _
    37   | St_ind_0 _
    38   | St_ind_inc _
    39   | St_cst _
    40   | St_op1 _
    41   | St_op2 _
    42   | St_load _
    43   | St_store _
    44   | St_call_ptr _
    45   | St_call_id _ -> 1
    46   | St_cond _ -> 2
    47   | St_jumptable (_, ls) -> List.length ls
     36let skip lbl = St_skip lbl
    4837
    49 (** computes a map binding the set of predecessors to each node. The domain
    50     is guaranteed to be equal to the domain of graph *)
    51 let compute_predecessors graph =
    52   let add_to_preds pred map lbl =
    53     let preds =
    54         try
    55           Label.Set.add pred (Label.Map.find lbl map)
    56     with
    57           | Not_found -> Label.Set.singleton pred in
    58     Label.Map.add lbl preds map in
    59   let add_predecessor lbl stmt map =
    60         (* make sure the domain of the map will be equal to dom graph, adding *)
    61         (* empty sets if need be *)
    62     let map = if Label.Map.mem lbl map then map else
    63             Label.Map.add lbl Label.Set.empty map in
    64         List.fold_left (add_to_preds lbl) map (statement_successors stmt) in
    65   Label.Map.fold add_predecessor graph Label.Map.empty
     38let fill_succs stmt succs = match stmt, succs with
     39  | (St_return _
     40        | St_tailcall_id _
     41        | St_tailcall_ptr _) as inst, [] -> inst
     42  | St_skip _, [lbl] -> St_skip lbl
     43  | St_cost (cost_lbl, _), [lbl] -> St_cost (cost_lbl, lbl)
     44  | St_ind_0 (i, _), [lbl] -> St_ind_0 (i, lbl)
     45  | St_ind_inc (i, _), [lbl] -> St_ind_inc (i, lbl)
     46  | St_cst (r, k, _), [lbl] -> St_cst (r, k, lbl)
     47  | St_op1 (o, r, s, _), [lbl] -> St_op1 (o, r, s, lbl)
     48  | St_op2 (o, r, a, b, _), [lbl] -> St_op2 (o, r, a, b, lbl)
     49  | St_load (r, a, b, _), [lbl] -> St_load (r, a, b, lbl)
     50  | St_store (a, b, c, _), [lbl] -> St_store (a, b, c, lbl)
     51  | St_call_ptr (f, args, ret, s, _), [lbl] -> St_call_ptr (f, args, ret, s, lbl)
     52  | St_call_id (f, args, ret, s, _), [lbl] -> St_call_id (f, args, ret, s, lbl)
     53  | St_cond (r, _, _), [lbl1; lbl2] -> St_cond (r, lbl1, lbl2)
     54  | St_jumptable (r, _), ls -> St_jumptable (r, ls)
     55  | _ -> invalid_arg "fill_succs: provided successors do not match statement"
    6656
    67 let compute_predecessor_lists graph =
    68   let add_to_preds pred map lbl =
    69     let preds =
    70       try
    71         pred :: Label.Map.find lbl map
    72       with
    73         | Not_found -> [pred] in
    74     Label.Map.add lbl preds map in
    75   let add_predecessors lbl stmt map =
    76         (* make sure the domain of the map will be equal to dom graph, adding *)
    77         (* empty sets if need be *)
    78     let map = if Label.Map.mem lbl map then map else
    79             Label.Map.add lbl [] map in
    80         List.fold_left (add_to_preds lbl) map (statement_successors stmt) in
    81   Label.Map.fold add_predecessors graph Label.Map.empty
    82 
    83 let fill_labels stmt lbls = match stmt, lbls with
    84   | St_return _, _
    85   | St_tailcall_id _, _
    86   | St_tailcall_ptr _, _ -> stmt
    87   | St_skip _, lbl :: _ -> St_skip lbl
    88   | St_cost (cost_lbl, _), lbl :: _ -> St_cost (cost_lbl, lbl)
    89   | St_ind_0 (i, _), lbl :: _ -> St_ind_0 (i, lbl)
    90   | St_ind_inc (i, _), lbl :: _ -> St_ind_inc (i, lbl)
    91   | St_cst (r, c, _), lbl :: _ -> St_cst (r, c, lbl)
    92   | St_op1 (op, r, s, _), lbl :: _ -> St_op1 (op, r, s, lbl)
    93   | St_op2 (op, r, s, t, _), lbl :: _ -> St_op2 (op, r, s, t, lbl)
    94   | St_load (q, r, s, _), lbl :: _ -> St_load (q, r, s, lbl)
    95   | St_store (q, r, s, _), lbl :: _ -> St_store (q, r, s, lbl)
    96   | St_call_ptr (r, args, ret, sg, _), lbl :: _ ->
    97     St_call_ptr (r, args, ret, sg, lbl)
    98   | St_call_id (i, args, ret, sg, _), lbl :: _ ->
    99     St_call_id (i, args, ret, sg, lbl)
    100   | St_cond (r, _, _), lbl1 :: lbl2 :: _ -> St_cond (r, lbl1, lbl2)
    101   | St_jumptable (r, _), lbls -> St_jumptable (r, lbls)
    102   | _ -> invalid_arg "fill_labels: not enough successors to fill"
    103 
    104 (** [insert_in_between u g src tgt s] inserts [s] between [src] and [tgt].
    105     [tgt] should be a successor of [src], and the provided [s] should already be
    106     linked to [tgt]. This function just generates a new node containing [s]
    107     and updates [src]'s links to [tgt] to be pointing to this new node.
    108     If [src] is linked to [tgt] multiple times, all such links are updated. *)
    109 let insert_in_between
    110     (fresh : unit -> node)
    111     (g : graph)
    112     (src : node)
    113     (tgt : node)
    114     (s : statement)
    115     : Label.t * graph =
    116   let new_lbl = fresh () in
    117   let src_stmt = Label.Map.find src g in
    118   let succs = statement_successors src_stmt in
    119   let repl lbl = if lbl = tgt then new_lbl else lbl in
    120   let new_succs = List.map repl succs in
    121   let new_src_stmt = fill_labels src_stmt new_succs in
    122   (new_lbl, Label.Map.add new_lbl s (Label.Map.add src new_src_stmt g))
    123 
    124 let dfs_fold
    125     (f : node -> statement -> 'a -> 'a)
    126     (g : graph)
    127     (entry : node)
    128     (init : 'a)
    129     : 'a =
    130   assert (Label.Map.mem entry g);
    131   let rec process done_set = function
    132     | [] -> init
    133     | next :: worklist when Label.Set.mem next done_set ->
    134       process done_set worklist
    135     | next :: worklist ->
    136       let stmt = Label.Map.find next g in
    137       let succs = statement_successors stmt in
    138       f next stmt (process (Label.Set.add next done_set) (succs @ worklist)) in
    139   process Label.Set.empty [entry]
    140    
    141 let dead_code_elim
    142     (g     : graph)
    143     (entry : node)
    144     : graph =
    145   let add lbl _ = Label.Set.add lbl in
    146   let reachable = dfs_fold add g entry Label.Set.empty in
    147   let is_reachable x _ = Label.Set.mem x reachable in
    148   Label.Map.filter is_reachable g
    149 
    150 let dfs_iter
    151     (f : node -> statement -> unit)
    152     (g : graph)
    153     (entry : node)
    154     : unit =
    155   assert (Label.Map.mem entry g);
    156   let rec process done_set = function
    157     | [] -> ();
    158     | next :: worklist when Label.Set.mem next done_set ->
    159       process done_set worklist
    160     | next :: worklist ->
    161       let stmt = Label.Map.find next g in
    162       let succs = statement_successors stmt in
    163       f next stmt;
    164       process (Label.Set.add next done_set) (succs @ worklist) in
    165   process Label.Set.empty [entry]
    166 
    167 let computes_type_map
     57(** Exported helper functions *)
     58let compute_type_map
    16859    (f_def : internal_function)
    16960    : AST.sig_type Register.Map.t =
    170   let types = Register.Map.empty in 
     61  let types = Register.Map.empty in
    17162  let add map (r, typ)  = Register.Map.add r typ map in
    17263  let types = List.fold_left add types f_def.f_params in
     
    17667    | Some x -> add types x
    17768
    178 (* the register modified by a node *)
     69(* the register directly modified by a node *)
    17970let modified_at_stmt stmt =
    18071  match stmt with
     
    18980let modified_at (g : graph) (n : Label.t) : Register.t option =
    19081  modified_at_stmt (Label.Map.find n g)
    191 
Note: See TracChangeset for help on using the changeset viewer.