source: Deliverables/D2.2/8051/src/RTLabs/RTLabsGraph.ml @ 1580

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

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

File size: 2.5 KB
Line 
1(** 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
10
11open RTLabs
12
13(** Successors of a statement *)
14let successors (stmt : statement) =
15  match stmt with
16  | St_return _
17  | St_tailcall_id _
18  | St_tailcall_ptr _ ->
19    []
20  | St_skip l
21  | St_cost (_, l)
22  | St_ind_0 (_, l)
23  | St_ind_inc (_, l)
24  | St_cst (_, _, l)
25  | St_op1 (_, _, _, l)
26  | St_op2 (_, _, _, _, l)
27  | St_load (_, _, _, l)
28  | St_store (_, _, _, l)
29  | St_call_ptr (_, _, _, _, l)
30  | St_call_id (_, _, _, _, l) ->
31    [l]
32  | St_cond (_, l1, l2) ->
33    [l1 ; l2]
34  | St_jumptable (_, ls) -> ls
35
36let skip lbl = St_skip lbl
37
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"
56
57(** Exported helper functions *)
58let compute_type_map
59    (f_def : internal_function)
60    : AST.sig_type Register.Map.t =
61  let types = Register.Map.empty in
62  let add map (r, typ)  = Register.Map.add r typ map in
63  let types = List.fold_left add types f_def.f_params in
64  let types = List.fold_left add types f_def.f_locals in
65  match f_def.f_result with
66    | None -> types
67    | Some x -> add types x
68
69(* the register directly modified by a node *)
70let modified_at_stmt stmt =
71  match stmt with
72    | St_op1 (_, r, _, _)
73    | St_op2 (_, r, _, _, _)
74    | St_cst (r, _, _)
75    | St_load (_, _, r, _)
76    | St_call_id (_, _, Some r, _, _)
77    | St_call_ptr (_, _, Some r, _, _) -> Some r
78    | _ -> None
79
80let modified_at (g : graph) (n : Label.t) : Register.t option =
81  modified_at_stmt (Label.Map.find n g)
Note: See TracBrowser for help on using the repository browser.