1 | (** this module provides some utilities relative to RTLabs graphs *) |
---|
2 | |
---|
3 | type node = Label.t |
---|
4 | type statement = RTLabs.statement |
---|
5 | |
---|
6 | module NodeMap = Label.Map |
---|
7 | module NodeSet = Label.Set |
---|
8 | |
---|
9 | type t = RTLabs.graph |
---|
10 | |
---|
11 | open RTLabs |
---|
12 | |
---|
13 | (** Successors of a statement *) |
---|
14 | let 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 | |
---|
36 | let skip lbl = St_skip lbl |
---|
37 | |
---|
38 | let 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 *) |
---|
58 | let 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 *) |
---|
70 | let 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 | |
---|
80 | let modified_at (g : graph) (n : Label.t) : Register.t option = |
---|
81 | modified_at_stmt (Label.Map.find n g) |
---|