source: Deliverables/D2.2/8051/src/cminor/cminorPointers.ml @ 486

Last change on this file since 486 was 486, checked in by ayache, 9 years ago

Deliverable D2.2

File size: 5.6 KB
Line 
1
2let union_list =
3  List.fold_left StringTools.Set.union StringTools.Set.empty
4
5
6(** [is_pointer ptrs e] returns true iff the expression [e] represents an
7    address when considering that the variables in the set [ptrs] are
8    pointers. *)
9
10let rec is_pointer ptrs = function
11  | Cminor.Id x -> StringTools.Set.mem x ptrs
12  | Cminor.Cst (AST.Cst_stackoffset _) | Cminor.Cst (AST.Cst_addrsymbol _) ->
13    true
14  | Cminor.Op1 (AST.Op_id, e) -> is_pointer ptrs e
15  | Cminor.Op1 (AST.Op_ptrofint, _) -> true
16  | Cminor.Op2 (AST.Op_addp, _, _) | Cminor.Op2 (AST.Op_subp, _, _) -> true
17  | Cminor.Mem (Memory.MQ_pointer, _) -> true
18  | Cminor.Cond (_, e2, e3) -> (is_pointer ptrs e2) || (is_pointer ptrs e3)
19  | Cminor.Exp_cost (_, e) -> is_pointer ptrs e
20  | _ -> false
21
22(** [is_op1_pointer op1] returns true iff [op1] returns a pointer. *)
23
24let is_op1_pointer = function
25  | AST.Op_intofptr -> true
26  | _ -> false
27
28(** When [op2_ptr_args op2 = (b1, b2)] [b1] (resp. [b2]) is true iff the first
29    (resp. second) argument of [op2] must be a pointer. *)
30
31let op2_ptr_args = function
32  | AST.Op_cmpp _ -> (true, true)
33  | AST.Op_addp | AST.Op_subp -> (true, false)
34  | _ -> (false, false)
35
36(** [expression_pointer is_pointer e] returns the set of variables that
37    represent an address in the expression [e]. The [is_pointer] function is a
38    predicate telling whether or not a given variable is a pointer. *)
39
40let rec expression_pointers is_pointer = function
41  | Cminor.Id x when is_pointer -> StringTools.Set.singleton x
42  | Cminor.Id x -> StringTools.Set.empty
43  | Cminor.Cst _ -> StringTools.Set.empty
44  | Cminor.Exp_cost (_, e)
45  | Cminor.Op1 (AST.Op_id, e) -> expression_pointers is_pointer e
46  | Cminor.Op1 (op1, e) -> expression_pointers (is_op1_pointer op1) e
47  | Cminor.Op2 (op2, e1, e2) ->
48    let (b1, b2) = op2_ptr_args op2 in
49    let res1 = expression_pointers b1 e1 in
50    let res2 = expression_pointers b2 e2 in
51    union_list [res1 ; res2]
52  | Cminor.Mem (_, e) -> expression_pointers true e
53  | Cminor.Cond (e1, e2, e3) ->
54    let res1 = expression_pointers false e1 in
55    let res2 = expression_pointers is_pointer e2 in
56    let res3 = expression_pointers is_pointer e3 in
57    union_list [res1 ; res2 ; res3]
58
59
60(** [f_statement_pointers ret_type ptrs stmt subexp_res substmt_res] returns the
61    set of variables that are pointers in [stmt]. [ret_type] is the type of the
62    returned expression of the statement, if any. [ptrs] is a set of already
63    known pointer variables. [subexp_res] is not used. [substmt_res] is the
64    result of the application of the function on the sub-statements of
65    [stmt]. *)
66
67let f_statement_pointers ret_type ptrs stmt _ substmt_res =
68  let ptrs = union_list (ptrs :: substmt_res) in
69  let stmt_ptrs = match stmt with
70    | Cminor.St_assign (x, e) ->
71      let res1 =
72        if is_pointer ptrs e then StringTools.Set.singleton x
73        else StringTools.Set.empty in
74      let res2 = expression_pointers (StringTools.Set.mem x ptrs) e in
75      union_list [res1 ; res2]
76    | Cminor.St_store (_, e1, e2) ->
77      let res1 =
78        expression_pointers
79          true (* when storing, [e1] must be an address *) e1 in
80      let res2 = expression_pointers false e2 in
81      union_list [res1 ; res2]
82    | Cminor.St_call (None, f, args, sg)
83    | Cminor.St_tailcall (f, args, sg) ->
84      let res1 =
85        expression_pointers
86          true (* when calling, [f] must be an address *) f in
87      (* Fetch the results on the arguments of the function. *)
88      let f typ e = expression_pointers (typ = AST.Sig_ptr) e in
89      let res2 = union_list (List.map2 f sg.AST.args args) in
90      union_list [res1 ; res2]
91    | Cminor.St_call (Some x, f, args, sg) ->
92      let res1 =
93        if sg.AST.res = AST.Type_ret AST.Sig_ptr then
94          StringTools.Set.singleton x
95        else StringTools.Set.empty in
96      let res2 = expression_pointers true f in
97      let f typ e = expression_pointers (typ = AST.Sig_ptr) e in
98      let res3 = union_list (List.map2 f sg.AST.args args) in
99      union_list [res1 ; res2 ; res3]
100    | Cminor.St_ifthenelse (e, _, _) -> expression_pointers false e
101    | Cminor.St_return (Some e) ->
102      expression_pointers (ret_type = AST.Type_ret AST.Sig_ptr) e
103    | _ -> StringTools.Set.empty
104  in
105  union_list [ptrs ; stmt_ptrs]
106
107(** [statement_pointers type_ret stmt ptrs] is one iteration that collects the
108    pointers of [stmt]. [type_ret] is the type of the returned expression of the
109    statement, if any. [ptrs] is a set of already known pointer variables.  *)
110
111let statement_pointers type_ret stmt ptrs =
112  CminorFold.statement_left (fun _ _ -> StringTools.Set.empty)
113    (f_statement_pointers type_ret ptrs) stmt
114
115
116(* A function that iterates another function until a fixpoint is reached. The
117   result is a set of strings. *)
118
119let rec fixpoint f s =
120  let s' = f s in
121  if StringTools.Set.equal s s' then s
122  else fixpoint f s'
123
124
125let internal_pointers def =
126  (* The pointers of a function are found by iterating one step of collecting
127     the pointers until a fixpoint is reached. *)
128  let ptrs =
129    fixpoint
130      (statement_pointers def.Cminor.f_sig.AST.res def.Cminor.f_body)
131      StringTools.Set.empty in
132  let ptrs = StringTools.Set.fold (fun x l -> x :: l) ptrs [] in
133  { def with Cminor.f_ptrs = ptrs }
134
135let fun_def_pointers (id, def) =
136  let def' = match def with
137    | Cminor.F_int def -> Cminor.F_int (internal_pointers def)
138    | _ -> def
139  in
140  (id, def')
141
142(** [fill p] sets the pointer variables field of each function of the program
143    [p]. The algorithm works as a fixpoint: initially, there are no pointers,
144    then we collect the pointers found in one pass and repeat the operation
145    considering the new result. *)
146
147let fill p =
148  { p with Cminor.functs = List.map fun_def_pointers p.Cminor.functs }
Note: See TracBrowser for help on using the repository browser.