source: Deliverables/D2.2/8051/src/utilities/graphUtilities.ml @ 1580

Last change on this file since 1580 was 1580, checked in by tranquil, 8 years ago

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

File size: 6.6 KB
Line 
1module type GraphType = sig
2
3  type node
4  type statement
5
6  module NodeMap : Map.S with type key = node
7  module NodeSet : Set.S with type elt = node
8
9  type t = statement NodeMap.t
10
11  val successors : statement -> node list
12  val skip : node -> statement
13  val fill_succs : statement -> node list -> statement
14
15end
16
17module Util (G : GraphType) = struct
18
19  open G
20
21  let compute_predecessor_lists (graph : G.t) : G.node list G.NodeMap.t =
22    let add_to_preds pred map lbl =
23      let preds =
24        try
25          pred :: NodeMap.find lbl map
26        with
27          | Not_found -> [pred] in
28      NodeMap.add lbl preds map in
29    let add_predecessors lbl stmt map =
30    (* make sure the domain of the map will be equal to dom graph, adding *)
31    (* empty sets if need be *)
32      let map = if NodeMap.mem lbl map then map else
33          NodeMap.add lbl [] map in
34      List.fold_left (add_to_preds lbl) map (successors stmt) in
35    NodeMap.fold add_predecessors graph NodeMap.empty
36
37  let dfs_fold
38      (f : node -> statement -> 'a -> 'a)
39      (g : t)
40      (entry : node)
41      (init : 'a)
42      : 'a =
43  if not (NodeMap.mem entry g) then
44    invalid_arg "dfs_fold: entry is not in graph"
45  else
46    let rec process done_set = function
47      | [] -> init
48      | next :: worklist when NodeSet.mem next done_set ->
49        process done_set worklist
50      | next :: worklist ->
51        let stmt = NodeMap.find next g in
52        let succs = successors stmt in
53        f next stmt (process (NodeSet.add next done_set) (succs @ worklist)) in
54    process NodeSet.empty [entry]
55
56  let dfs_iter
57    (f : node -> statement -> unit)
58    (g : t)
59    (entry : node)
60    : unit =
61  if not (NodeMap.mem entry g) then
62    invalid_arg "dfs_iter: entry is not in graph"
63  else
64  let rec process done_set = function
65    | [] -> ();
66    | next :: worklist when NodeSet.mem next done_set ->
67      process done_set worklist
68    | next :: worklist ->
69      let stmt = NodeMap.find next g in
70      let succs = successors stmt in
71      f next stmt;
72      process (NodeSet.add next done_set) (succs @ worklist) in
73  process NodeSet.empty [entry]
74
75  let dead_code_elim
76      (g : t)
77      (entry : node)
78      : t =
79    let add lbl _ = NodeSet.add lbl in
80    let reachable = dfs_fold add g entry NodeSet.empty in
81    let is_reachable x _ = NodeSet.mem x reachable in
82    NodeMap.filter is_reachable g
83
84end
85
86module Trans (Src : GraphType) (Trg : GraphType with type node = Src.node) =
87struct
88  type node = Src.node
89
90  (* keeping this general branching translation just in case *)
91  let translate_general
92      (fresh : unit -> Trg.node)
93      (f : 'a -> node -> Src.statement ->
94       'a * Trg.statement list * Trg.statement list list * node list option)
95      (info : 'a)
96      (g : Src.t) : 'a * Trg.t =
97
98    let rec put_rev stmts src dests graph =
99      match stmts, dests with
100        | [], [next] -> Trg.NodeMap.add src (Trg.skip next) graph
101        | [last], _ -> Trg.NodeMap.add src (Trg.fill_succs last dests) graph
102        | last :: stmts, _ ->
103          let new_l = fresh () in
104          let graph = Trg.NodeMap.add new_l (Trg.fill_succs last dests) graph in
105          put_rev stmts src [new_l] graph
106        | _ ->
107          invalid_arg "successors of statement and translation do not match" in
108
109    let rec put_block stmts blocks src dests graph =
110      match stmts, blocks, dests with
111        | [], [b], ds ->
112          let rev_b = List.rev b in
113          put_rev rev_b src ds graph
114        | [], _, _ ->
115          invalid_arg "translation: empty preamble with several destinations"
116        | _ ->
117          let f (lbls, g) blck dst =
118            let lbl = fresh () in
119            (lbl :: lbls, put_block [] [blck] lbl [dst] g) in
120          let (lbls, graph) = List.fold_left2 f ([], graph) blocks dests in
121          put_rev (List.rev stmts) src lbls graph in
122
123    let trans lbl stmt (x, graph) =
124      let (y, stmts, blocks, redirects) = f x lbl stmt in
125      let succs = match redirects with
126        | Some x -> x
127        | None -> Src.successors stmt in
128      (y, put_block stmts blocks lbl succs graph) in
129
130    Src.NodeMap.fold trans g (info, Trg.NodeMap.empty)
131
132  let translate fresh f =
133    let f' x lbl stmt =
134      let (y, stmts) = f x lbl stmt in
135      (y, [], [stmts], None) in
136    translate_general fresh f'
137
138  let translate_with_redirects fresh f =
139    let f' x lbl stmt =
140      let (y, stmts, redirects) = f x lbl stmt in
141      (y, [], [stmts], redirects) in
142    translate_general fresh f'
143
144  let translate_pure fresh f g =
145    let f' () l s = ((), [], [f l s], None) in
146    snd (translate_general fresh f' () g)
147
148  let translate_pure_with_redirects fresh f g =
149    let f' () l s =
150      let (res, redirects) = f l s in
151      ((), [], [res], redirects) in
152    snd (translate_general fresh f' () g)
153
154  open BList
155
156  let translate_with_redirects' freshl freshr f def g =
157
158    let rec put_rev stmts src dests def graph =
159      match stmts, dests with
160        | BNil, [next] -> (def, Trg.NodeMap.add src (Trg.skip next) graph)
161        | BCons (last, BNil), _ ->
162          (def, Trg.NodeMap.add src (Trg.fill_succs last dests) graph)
163        | BCons (last, stmts), _ ->
164          let new_l = freshl () in
165          let graph = Trg.NodeMap.add new_l (Trg.fill_succs last dests) graph in
166          put_rev stmts src [new_l] def graph
167        | BNew f_stmts, _ ->
168          let (def, new_r) = freshr def in
169          let stmts = f_stmts new_r in
170          put_rev stmts src dests def graph
171        | _ ->
172          invalid_arg "successors of statement and translation do not match" in
173
174    let trans lbl stmt (def, graph) =
175      let (stmts, redirects) = f lbl stmt in
176      let succs = match redirects with
177        | Some x -> x
178        | None -> Src.successors stmt in
179      put_rev (b_rev stmts) lbl succs def graph in
180
181    Src.NodeMap.fold trans g (def, Trg.NodeMap.empty)
182
183  let translate' freshl freshr f =
184    let f' lbl stmt = (f lbl stmt, None) in
185    translate_with_redirects' freshl freshr f'
186
187
188  (* let translate f = *)
189  (*   let f' x _ stmt = *)
190  (*     let (y, stmts) = f x stmt in *)
191  (*     (y, stmts, [], [Src.successors stmt]) in *)
192  (*   translate_general f' *)
193
194  (* let translate_with_redirects f = *)
195  (*   let f' x _ stmt = *)
196  (*     let (y, stmts, redirects) = f x stmt in *)
197  (*     (y, stmts, [], [redirects]) in *)
198  (*   translate_general f' *)
199
200  (* let translate_pure f fresh g = *)
201  (*   let f' () _ stmt = *)
202  (*     ((), f stmt, [], [Src.successors stmt]) in *)
203  (*   snd (translate_general f' fresh () g) *)
204
205  (* let translate_pure_with_redirects f fresh g = *)
206  (*   let f' () _ stmt = *)
207  (*     let (res, redirects) = f stmt in *)
208  (*     ((), res, [], [redirects]) in *)
209  (*   snd (translate_general f' fresh () g) *)
210
211end
Note: See TracBrowser for help on using the repository browser.