source: Deliverables/D2.2/8051/src/clight/clightFold.ml @ 818

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

32 and 16 bits operations support in D2.2/8051

File size: 7.4 KB
Line 
1
2(** This module provides folding functions over the constructors of the
3    [Clight]'s AST. *)
4
5
6let ctype_subs = function
7  | Clight.Tvoid | Clight.Tint _ | Clight.Tfloat _ | Clight.Tcomp_ptr _ -> []
8  | Clight.Tpointer ctype | Clight.Tarray (ctype, _) -> [ctype]
9  | Clight.Tfunction (args, res) -> args @ [res]
10  | Clight.Tstruct (_, fields) | Clight.Tunion (_, fields) ->
11    List.map snd fields
12
13let ctype_fill_subs ctype sub_ctypes = match ctype, sub_ctypes with
14  | Clight.Tvoid, _ | Clight.Tint _, _ | Clight.Tfloat _, _
15  | Clight.Tcomp_ptr _, _ -> ctype
16  | Clight.Tpointer _, ctype :: _ -> Clight.Tpointer ctype
17  | Clight.Tarray (_, size), ctype :: _ -> Clight.Tarray (ctype, size)
18  | Clight.Tfunction _, _ ->
19    let (args, res) = MiscPottier.split_last sub_ctypes in
20    Clight.Tfunction (args, res)
21  | Clight.Tstruct (name, fields), _ ->
22    let fields = List.map2 (fun (x, _) ctype -> (x, ctype)) fields sub_ctypes in
23    Clight.Tstruct (name, fields)
24  | Clight.Tunion (name, fields), _ ->
25    let fields = List.map2 (fun (x, _) ctype -> (x, ctype)) fields sub_ctypes in
26    Clight.Tunion (name, fields)
27  | _ -> assert false (* wrong arguments, do not use on these values *)
28
29let rec ctype f t =
30  let sub_ctypes_res = List.map (ctype f) (ctype_subs t) in
31  f t sub_ctypes_res
32
33
34let expr_subs = function
35  | Clight.Expr (expr_descr, ctype) -> ([ctype], [expr_descr])
36
37let expr_descr_subs = function
38  | Clight.Econst_int _ | Clight.Econst_float _ | Clight.Evar _ -> ([], [])
39  | Clight.Ederef e | Clight.Eaddrof e | Clight.Eunop (_, e)
40  | Clight.Efield (e, _) -> ([], [e])
41  | Clight.Ebinop (_, e1, e2) | Clight.Eandbool (e1, e2)
42  | Clight.Eorbool (e1, e2) -> ([], [e1 ; e2])
43  | Clight.Ecast (ctype, e) -> ([ctype], [e])
44  | Clight.Econdition (e1, e2, e3) -> ([], [e1 ; e2 ; e3])
45  | Clight.Esizeof ctype -> ([ctype], [])
46  | Clight.Ecost (_, e) -> ([], [e])
47  | Clight.Ecall (_, e1, e2) -> ([], [e1 ; e2])
48
49let expr_fill_subs e sub_ctypes sub_expr_descrs =
50  match e, sub_ctypes, sub_expr_descrs with
51  | Clight.Expr _, ctype :: _, expr_descr :: _ ->
52    Clight.Expr (expr_descr, ctype)
53  | _ -> assert false (* wrong arguments, do not use on these values *)
54
55let expr_descr_fill_subs e sub_ctypes sub_exprs = 
56  match e, sub_ctypes, sub_exprs with
57  | Clight.Econst_int _, _, _ | Clight.Econst_float _, _, _
58  | Clight.Evar _, _, _ -> e
59  | Clight.Ederef _, _, e :: _ -> Clight.Ederef e
60  | Clight.Eaddrof _, _, e :: _ -> Clight.Eaddrof e
61  | Clight.Eunop (unop, _), _, e :: _ -> Clight.Eunop (unop, e)
62  | Clight.Ebinop (binop, _, _), _, e1 :: e2 :: _ ->
63    Clight.Ebinop (binop, e1, e2)
64  | Clight.Ecast _, ctype :: _, e :: _ -> Clight.Ecast (ctype, e)
65  | Clight.Econdition _, _, e1 :: e2 :: e3 :: _ ->
66    Clight.Econdition (e1, e2, e3)
67  | Clight.Eandbool (_, _), _, e1 :: e2 :: _ ->
68    Clight.Eandbool (e1, e2)
69  | Clight.Eorbool (_, _), _, e1 :: e2 :: _ ->
70    Clight.Eorbool (e1, e2)
71  | Clight.Esizeof _, ctype :: _, _ -> Clight.Esizeof ctype
72  | Clight.Efield (_, field_name), _, e :: _ -> Clight.Efield (e, field_name)
73  | Clight.Ecost (lbl, _), _, e :: _ -> Clight.Ecost (lbl, e)
74  | Clight.Ecall (id, _, _), _, e1 :: e2 :: _ -> Clight.Ecall (id, e1, e2)
75  | _ -> assert false (* wrong arguments, do not use on these values *)
76
77let expr_fill_exprs (Clight.Expr (ed, t)) exprs =
78  let (sub_ctypes, _) = expr_descr_subs ed in
79  let ed = expr_descr_fill_subs ed sub_ctypes exprs in
80  Clight.Expr (ed, t)
81
82let rec expr f_ctype f_expr f_expr_descr e =
83  let (sub_ctypes, sub_expr_descrs) = expr_subs e in
84  let sub_expr_descrs_res =
85    List.map (expr_descr f_ctype f_expr f_expr_descr) sub_expr_descrs in
86  let sub_ctypes_res = List.map (ctype f_ctype) sub_ctypes in
87  f_expr e sub_ctypes_res sub_expr_descrs_res
88
89and expr_descr f_ctype f_expr f_expr_descr e =
90  let (sub_ctypes, sub_exprs) = expr_descr_subs e in
91  let sub_exprs_res =
92    List.map (expr f_ctype f_expr f_expr_descr) sub_exprs in
93  let sub_ctypes_res = List.map (ctype f_ctype) sub_ctypes in
94  f_expr_descr e sub_ctypes_res sub_exprs_res
95
96
97let expr_subs2 e =
98  let (_, expr_descrs) = expr_subs e in
99  let l = List.map expr_descr_subs expr_descrs in
100  List.flatten (List.map snd l)
101
102let rec expr2 f e = f e (List.map (expr2 f) (expr_subs2 e))
103
104
105let rec labeled_statements_subs = function
106  | Clight.LSdefault stmt -> [stmt]
107  | Clight.LScase (_, stmt, lbl_stmts) ->
108    stmt :: (labeled_statements_subs lbl_stmts)
109
110let statement_subs = function
111  | Clight.Sskip | Clight.Sbreak | Clight.Scontinue | Clight.Sreturn None
112  | Clight.Sgoto _ -> ([], [])
113  | Clight.Sassign (e1, e2) -> ([e1 ; e2], [])
114  | Clight.Scall (None, e, args) -> (e :: args, [])
115  | Clight.Scall (Some e1, e2, args) -> (e1 :: e2 :: args, [])
116  | Clight.Ssequence (stmt1, stmt2) -> ([], [stmt1 ; stmt2])
117  | Clight.Sifthenelse (e, stmt1, stmt2) -> ([e], [stmt1 ; stmt2])
118  | Clight.Swhile (e, stmt) | Clight.Sdowhile (e, stmt) -> ([e], [stmt])
119  | Clight.Sfor (stmt1, e, stmt2, stmt3) -> ([e], [stmt1 ; stmt2 ; stmt3])
120  | Clight.Sreturn (Some e) -> ([e], [])
121  | Clight.Sswitch (e, lbl_stmts) -> ([e], labeled_statements_subs lbl_stmts)
122  | Clight.Slabel (_, stmt) | Clight.Scost (_, stmt) -> ([], [stmt])
123
124let statement_sub_exprs stmt = fst (statement_subs stmt)
125
126let rec labeled_statements_fill_subs lbl_stmts sub_statements =
127  match lbl_stmts, sub_statements with
128    | Clight.LSdefault _, stmt :: _ -> Clight.LSdefault stmt
129    | Clight.LScase (i, _, lbl_stmts), stmt :: sub_statements ->
130      Clight.LScase (i, stmt,
131                     labeled_statements_fill_subs lbl_stmts sub_statements)
132    | _ -> assert false (* wrong arguments, do not use on these values *)
133
134let statement_fill_subs statement sub_exprs sub_statements =
135  match statement, sub_exprs, sub_statements with
136    | Clight.Sskip, _, _ | Clight.Sbreak, _, _ | Clight.Scontinue, _, _
137    | Clight.Sreturn None, _, _ | Clight.Sgoto _, _, _ -> statement
138    | Clight.Sassign _, e1 :: e2 :: _, _ -> Clight.Sassign (e1, e2)
139    | Clight.Scall (None, _, _), e :: args, _ ->
140      Clight.Scall (None, e, args)
141    | Clight.Scall (Some _, _, _), e1 :: e2 :: args, _ ->
142      Clight.Scall (Some e1, e2, args)
143    | Clight.Ssequence _, _, stmt1 :: stmt2 :: _ ->
144      Clight.Ssequence (stmt1, stmt2)
145    | Clight.Sifthenelse _, e :: _, stmt1 :: stmt2 :: _ ->
146      Clight.Sifthenelse (e, stmt1, stmt2)
147    | Clight.Swhile _, e :: _, stmt :: _ ->
148      Clight.Swhile (e, stmt)
149    | Clight.Sdowhile _, e :: _, stmt :: _ ->
150      Clight.Sdowhile (e, stmt)
151    | Clight.Sfor _, e :: _, stmt1 :: stmt2 :: stmt3 :: _ ->
152      Clight.Sfor (stmt1, e, stmt2, stmt3)
153    | Clight.Sreturn (Some _), e :: _, _ -> Clight.Sreturn (Some e)
154    | Clight.Sswitch (_, lbl_stmts), e :: _, _ ->
155      Clight.Sswitch (e, labeled_statements_fill_subs lbl_stmts sub_statements)
156    | Clight.Slabel (lbl, _), _, stmt :: _ -> Clight.Slabel (lbl, stmt)
157    | Clight.Scost (lbl, _), _, stmt :: _ -> Clight.Scost (lbl, stmt)
158    | _ -> assert false (* wrong arguments, do not use on these values *)
159
160let rec statement f_ctype f_expr f_expr_descr f_statement stmt =
161  let (sub_exprs, sub_stmts) = statement_subs stmt in
162  let sub_exprs_res = List.map (expr f_ctype f_expr f_expr_descr) sub_exprs in
163  let sub_stmts_res =
164    List.map (statement f_ctype f_expr f_expr_descr f_statement) sub_stmts in
165  f_statement stmt sub_exprs_res sub_stmts_res
166
167let rec statement2 f_expr f_statement stmt =
168  let (sub_exprs, sub_stmts) = statement_subs stmt in
169  let sub_exprs_res = List.map (expr2 f_expr) sub_exprs in
170  let sub_stmts_res = List.map (statement2 f_expr f_statement) sub_stmts in
171  f_statement stmt sub_exprs_res sub_stmts_res
Note: See TracBrowser for help on using the repository browser.