source: Deliverables/D2.2/8051/src/languages.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: 8.0 KB
Line 
1type name = 
2  | Clight
3  | Cminor
4  | RTLabs
5  | RTL
6  | ERTL
7  | LTL
8  | LIN
9  | ASM
10
11let strings = [
12  "Clight", Clight;
13  "Cminor", Cminor;
14  "RTLabs", RTLabs;
15  "RTL"   , RTL;
16  "ERTL"  , ERTL;
17  "LTL"   , LTL;
18  "LIN"   , LIN;
19  "ASM"   , ASM;
20]
21
22let from_string s = 
23  List.assoc s strings
24
25let to_string l = 
26  List.assoc l (Misc.ListExt.inv_assoc strings)
27
28type ast = 
29  | AstClight of Clight.program
30  | AstCminor of Cminor.program
31  | AstRTLabs of RTLabs.program
32  | AstRTL    of RTL.program
33  | AstERTL   of ERTL.program
34  | AstLTL    of LTL.program
35  | AstLIN    of LIN.program
36  | AstASM    of ASM.program
37
38let language_of_ast = function
39  | AstClight _ -> Clight
40  | AstCminor _ -> Cminor
41  | AstRTLabs _ -> RTLabs
42  | AstRTL _    -> RTL
43  | AstERTL _   -> ERTL
44  | AstLTL _    -> LTL
45  | AstLIN _    -> LIN
46  | AstASM _    -> ASM
47
48let extension = function
49  | ASM      -> ["s" ; "hex"]
50  | Clight   -> ["c"]
51  | language -> [to_string language]
52
53let parse = function
54  | Clight -> 
55    fun filename -> AstClight (ClightParser.process filename)
56
57(*
58  | Cminor ->
59    fun filename ->
60      AstCminor
61        (SyntacticAnalysis.process
62           ~lexer_init: (fun filename -> Lexing.from_channel (open_in filename))
63           ~lexer_fun:  CminorLexer.token
64           ~parser_fun: CminorParser.program
65           ~input:      filename)
66*)
67
68  | _ ->
69    (* FIXME: Will be completed in the next commits. *)
70    assert false
71
72
73let labelize = function
74  | AstClight p -> 
75    AstClight (ClightLabelling.add_cost_labels p)
76
77(*
78  | AstCminor p ->
79    AstCminor (CminorLabelling.add_cost_labels p)
80*)
81
82  | x -> 
83    (* For the other languages, no labelling is defined. *)
84    x
85
86
87let clight_to_cminor = function
88  | AstClight p ->
89    AstCminor (ClightToCminor.translate p)
90  | _ -> assert false
91
92let cminor_to_rtlabs = function
93  | AstCminor p -> 
94    AstRTLabs (CminorToRTLabs.translate p)
95  | _ -> assert false
96
97let rtlabs_to_rtl = function
98  | AstRTLabs p -> 
99    AstRTL (RTLabsToRTL.translate p)
100  | _ -> assert false
101
102let rtl_to_ertl = function
103  | AstRTL p -> 
104    AstERTL (RTLToERTL.translate p)
105  | _ -> assert false
106
107let ertl_to_ltl = function
108  | AstERTL p -> 
109    AstLTL (ERTLToLTL.translate p)
110  | _ -> assert false
111
112let ltl_to_lin = function
113  | AstLTL p -> 
114    AstLIN (LTLToLIN.translate p)
115  | _ -> assert false
116
117let lin_to_asm = function
118  | AstLIN p -> 
119    AstASM (LINToASM.translate p)
120  | _ -> assert false
121
122(* We explicitly denote the compilation chain as a list of
123   passes that must be composed to translate a program
124   from a source language to a target language. *)
125let compilation_chain = [
126  (* Source language | Target language | Compilation function *) 
127  Clight,              Cminor,           clight_to_cminor;
128  Cminor,              RTLabs,           cminor_to_rtlabs;
129  RTLabs,              RTL,              rtlabs_to_rtl;
130  RTL,                 ERTL,             rtl_to_ertl;
131  ERTL,                LTL,              ertl_to_ltl;
132  LTL,                 LIN,              ltl_to_lin;
133  LIN,                 ASM,              lin_to_asm;
134]
135
136let compile debug src tgt = 
137  (* Find the maximal suffix of the chain that starts with the
138     language [src]. *)
139  let rec subchain = function
140    | [] -> 
141      (* The chain is assumed to be well-formed: such a suffix
142         exists. *)
143      assert false 
144    | ((l, _, _) :: _) as chain when l = src -> chain
145    | _ :: chain -> subchain chain
146  in
147  (* Compose the atomic translations to build a compilation function
148     from [src] to [tgt]. Again, we assume that the compilation chain
149     is well-formed. Thus, if we cannot find [tgt] in the compilation
150     chain then the user must have made a mistake to ask for a
151     translation from [src] to [tgt]. *)
152  let rec compose iprogs src tgt chains ast = 
153    if src = tgt then List.rev (ast :: iprogs)
154    else 
155      match chains with
156        | [] -> 
157          Error.global_error "During compilation configuration"
158            (Printf.sprintf "It is not possible to compile from `%s' to `%s'."
159               (to_string src)
160               (to_string tgt))
161           
162        | (l1, l2, src_to_l2) :: chain ->
163          assert (l1 = src);
164          let l2_to_tgt = compose iprogs l2 tgt chain in
165          let iprog = src_to_l2 ast in
166          ast :: l2_to_tgt iprog
167  in
168  compose [] src tgt (subchain compilation_chain)
169
170
171(** [add_runtime ast] adds runtime functions for the operations not supported by
172    the target processor. *)
173let add_runtime = function
174  | AstClight p ->
175    AstClight (Runtime.replace_unsupported (ClightSwitch.simplify p))
176  | x -> 
177    (* For the other languages, no runtime functios are defined. *)
178    x
179
180
181let compute_costs = function
182  | AstClight p -> 
183  (* Computing costs on Clight programs cannot be done directly
184     because the control-flow is not explicit. Yet, for
185     incremental construction and test of the compiler, we
186     build a stupid mapping from labels to costs for a Clight
187     program that gives cost 1 to every label. *)
188    CostLabel.constant_map (ClightAnnotator.cost_labels p) 1
189
190  | AstCminor p -> 
191  (* Computing costs on Cminor programs cannot be done directly
192     because the control-flow is not explicit. Yet, for
193     incremental construction and test of the compiler, we
194     build a stupid mapping from labels to costs for a Cminor
195     program that gives cost 1 to every label. *)
196    CostLabel.constant_map (CminorAnnotator.cost_labels p) 1
197
198  | AstASM p ->
199    ASMCosts.compute p
200
201  | ast -> 
202    Error.global_error "during cost computing"
203      (Printf.sprintf
204         "Cost computing is not implemented for language `%s'\ 
205          Please compile to ASM if you want to annotate the input \
206          file or deactivate annotation using the '-no-annotation' flag."
207         (to_string (language_of_ast ast)))
208
209(* FIXME *)
210let instrument costs_mapping = function
211  | AstClight p ->
212    let (p', cost_id, cost_incr) = ClightAnnotator.instrument p costs_mapping in
213    (AstClight p', cost_id, cost_incr)
214(*
215  | AstCminor p ->
216    let (p', cost_id, cost_incr) = CminorAnnotator.instrument p costs_mapping in
217    (AstCminor p', cost_id, cost_incr)
218*)
219  | p -> 
220    Error.warning "during instrumentation"
221      (Printf.sprintf
222         "Instrumentation is not implemented for source language `%s'."
223         (to_string (language_of_ast p)));
224    (p, "", "")
225
226let annotate input_ast final = 
227  let costs_mapping = compute_costs final in 
228  instrument costs_mapping input_ast
229
230let string_output = function
231  | AstClight p -> 
232    [ClightPrinter.print_program p]
233  | AstCminor p ->
234    [CminorPrinter.print_program p]
235  | AstRTLabs p ->
236    [RTLabsPrinter.print_program p]
237  | AstRTL p ->
238    [RTLPrinter.print_program p]
239  | AstERTL p ->
240    [ERTLPrinter.print_program p]
241  | AstLTL p ->
242    [LTLPrinter.print_program p]
243  | AstLIN p ->
244    [LINPrinter.print_program p]
245  | AstASM p ->
246    [Pretty.print_program p ; ASMPrinter.print_program p]
247
248let save exact_output filename suffix ast =
249  let ext_chopped_filename =
250    if exact_output then filename
251    else
252      try Filename.chop_extension filename
253      with Invalid_argument ("Filename.chop_extension") -> filename in
254  let ext_chopped_filename = ext_chopped_filename ^ suffix in
255  let ext_filenames =
256    List.map (fun ext -> ext_chopped_filename ^ "." ^ ext)
257      (extension (language_of_ast ast)) in
258  let output_filenames =
259    if exact_output then ext_filenames
260    else List.map Misc.SysExt.alternative ext_filenames in
261  let output_strings = string_output ast in
262  let f filename s =
263    let cout = open_out filename in
264    output_string cout s;
265    flush cout;
266    close_out cout in
267  List.iter2 f output_filenames output_strings
268
269let save_cost filename cost_id cost_incr =
270  let cout = open_out (filename ^ ".cerco") in
271  output_string cout (cost_id ^ "\n");
272  output_string cout (cost_incr ^ "\n");
273  flush cout;
274  close_out cout
275
276let interpret debug = function
277  | AstClight p ->
278    ClightInterpret.interpret debug p
279  | AstCminor p ->
280    CminorInterpret.interpret debug p 
281  | AstRTLabs p ->
282    RTLabsInterpret.interpret debug p
283  | AstRTL p ->
284    RTLInterpret.interpret debug p
285  | AstERTL p ->
286    ERTLInterpret.interpret debug p
287  | AstLTL p ->
288    LTLInterpret.interpret debug p
289  | AstLIN p ->
290    LINInterpret.interpret debug p
291  | AstASM p ->
292    ASMInterpret.interpret debug p
Note: See TracBrowser for help on using the repository browser.