source: Deliverables/D2.2/8051/src/languages.ml @ 1664

Last change on this file since 1664 was 1542, checked in by tranquil, 8 years ago

merge of indexed labels branch

File size: 9.6 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
38type transformation = name * (ast -> ast) 
39
40let language_of_ast = function
41  | AstClight _ -> Clight
42  | AstCminor _ -> Cminor
43  | AstRTLabs _ -> RTLabs
44  | AstRTL _    -> RTL
45  | AstERTL _   -> ERTL
46  | AstLTL _    -> LTL
47  | AstLIN _    -> LIN
48  | AstASM _    -> ASM
49
50let extension = function
51  | ASM      -> ["s" ; "hex"]
52  | Clight   -> ["c"]
53  | language -> [to_string language]
54
55let parse ?is_lustre_file ?remove_lustre_externals = function
56  | Clight -> 
57    fun filename ->
58      AstClight
59        (ClightParser.process ?is_lustre_file ?remove_lustre_externals filename)
60
61(*
62  | Cminor ->
63    fun filename ->
64      AstCminor
65        (SyntacticAnalysis.process
66           ~lexer_init: (fun filename -> Lexing.from_channel (open_in filename))
67           ~lexer_fun:  CminorLexer.token
68           ~parser_fun: CminorParser.program
69           ~input:      filename)
70*)
71
72  | _ ->
73    (* FIXME: Will be completed in the next commits. *)
74    assert false
75
76
77let labelize = function
78  | AstClight p -> 
79    AstClight (ClightLabelling.add_cost_labels p)
80
81(*
82  | AstCminor p ->
83    AstCminor (CminorLabelling.add_cost_labels p)
84*)
85
86  | x -> 
87    (* For the other languages, no labelling is defined. *)
88    x
89
90
91let clight_to_cminor = function
92  | AstClight p ->
93    AstCminor (ClightToCminor.translate p)
94  | _ -> assert false
95
96let cminor_to_rtlabs = function
97  | AstCminor p -> 
98    AstRTLabs (CminorToRTLabs.translate p)
99  | _ -> assert false
100
101let rtlabs_to_rtl = function
102  | AstRTLabs p -> 
103    AstRTL (RTLabsToRTL.translate p)
104  | _ -> assert false
105
106let rtl_to_ertl = function
107  | AstRTL p -> 
108    AstERTL (RTLToERTL.translate p)
109  | _ -> assert false
110
111let ertl_to_ltl = function
112  | AstERTL p -> 
113    AstLTL (ERTLToLTL.translate p)
114  | _ -> assert false
115
116let ltl_to_lin = function
117  | AstLTL p ->
118    AstLIN (LTLToLIN.translate p)
119  | _ -> assert false
120
121let lin_to_asm = function
122  | AstLIN p ->
123    AstASM (LINToASM.translate p)
124  | _ -> assert false
125
126(* We explicitly denote the compilation chain as a list of
127   passes that must be composed to translate a program
128   from a source language to a target language. *)
129let compilation_chain = [
130  (* Source language | Target language | Compilation function *) 
131  Clight,              Cminor,           clight_to_cminor;
132  Cminor,              RTLabs,           cminor_to_rtlabs;
133  RTLabs,              RTL,              rtlabs_to_rtl;
134  RTL,                 ERTL,             rtl_to_ertl;
135  ERTL,                LTL,              ertl_to_ltl;
136  LTL,                 LIN,              ltl_to_lin;
137  LIN,                 ASM,              lin_to_asm;
138]
139
140let insert_transformations ts chain =
141  (* turn transformation into elements of the compilation chain *)
142  let trans_to_comp (n, t) = (n, n, t) in
143  let ts = List.map trans_to_comp ts in
144  (* ts and chain are merged, and then sorted so that the resulting list is *)
145  (* still a well formed compilation chain. Stable sort preserves order *)
146  (* between transformations on the same language as appearing in ts *)
147  let compare (n1, n2, s) (m1, m2, t) = compare (n1, n2) (m1, m2) in
148  List.stable_sort compare (ts @ chain)
149
150let compile debug ts src tgt =
151  (* insert intermediate transformations *) 
152  let chain = insert_transformations ts compilation_chain in
153  (* erase transformations whose source is strictly before src *)
154  let chain = List.filter (function (l1, _, _) -> l1 >= src) chain in
155  (* erase transformations whose target is strictly after tgt *)
156  let chain = List.filter (function (_, l2, _) -> l2 <= tgt) chain in
157  (* Compose the atomic translations to build a compilation function
158     from [src] to [tgt]. Again, we assume that the compilation chain
159     is well-formed. Thus, if we cannot find [tgt] in the compilation
160     chain then the user must have made a mistake to ask for a
161     translation from [src] to [tgt]. *)
162  let rec compose iprogs src tgt chains ast = 
163    match chains with
164        | [] when src = tgt -> List.rev (ast :: iprogs)
165        | [] -> 
166          Error.global_error "During compilation configuration"
167            (Printf.sprintf "It is not possible to compile from `%s' to `%s'."
168               (to_string src)
169               (to_string tgt))
170           
171        | (l1, l2, src_to_l2) :: chain ->
172          assert (l1 = src);
173          let l2_to_tgt = compose iprogs l2 tgt chain in
174          let iprog = src_to_l2 ast in
175          ast :: l2_to_tgt iprog
176  in
177  compose [] src tgt chain
178
179
180(** [add_runtime ast] adds runtime functions for the operations not supported by
181    the target processor. *)
182let add_runtime = function
183  | AstClight p ->
184    AstClight (Runtime.replace_unsupported (ClightSwitch.simplify p))
185  | x -> 
186    (* For the other languages, no runtime functios are defined. *)
187    x
188
189
190let compute_costs = function
191  | AstClight p -> 
192  (* Computing costs on Clight programs cannot be done directly
193     because the control-flow is not explicit. Yet, for
194     incremental construction and test of the compiler, we
195     build a stupid mapping from labels to costs for a Clight
196     program that gives cost 1 to every label. *)
197    CostLabel.constant_map (ClightAnnotator.cost_labels p) 1
198
199  | AstCminor p -> 
200  (* Computing costs on Cminor programs cannot be done directly
201     because the control-flow is not explicit. Yet, for
202     incremental construction and test of the compiler, we
203     build a stupid mapping from labels to costs for a Cminor
204     program that gives cost 1 to every label. *)
205    CostLabel.constant_map (CminorAnnotator.cost_labels p) 1
206
207  | AstASM p ->
208    ASMCosts.compute p
209
210  | ast -> 
211    Error.global_error "during cost computing"
212      (Printf.sprintf
213         "Cost computing is not implemented for language `%s'\ 
214          Please compile to ASM if you want to annotate the input \
215          file or deactivate annotation using the '-no-annotation' flag."
216         (to_string (language_of_ast ast)))
217
218(* FIXME *)
219let instrument cost_tern costs_mapping = function
220  | AstClight p ->
221    let (p', cost_id, cost_incr, extern_cost_variables) =
222      ClightAnnotator.instrument cost_tern p costs_mapping in
223    (AstClight p', cost_id, cost_incr, extern_cost_variables)
224(*
225  | AstCminor p ->
226    let (p', cost_id, cost_incr) = CminorAnnotator.instrument p costs_mapping in
227    (AstCminor p', cost_id, cost_incr)
228*)
229  | p -> 
230    Error.warning "during instrumentation"
231      (Printf.sprintf
232         "Instrumentation is not implemented for source language `%s'."
233         (to_string (language_of_ast p)));
234    (p, "", "", StringTools.Map.empty)
235
236let annotate cost_tern input_ast final = 
237  let costs_mapping = compute_costs final in 
238  instrument cost_tern costs_mapping input_ast
239
240let string_output asm_pretty = function
241  | AstClight p -> 
242    [ClightPrinter.print_program p]
243  | AstCminor p ->
244    [CminorPrinter.print_program p]
245  | AstRTLabs p ->
246    [RTLabsPrinter.print_program p]
247  | AstRTL p ->
248    [RTLPrinter.print_program p]
249  | AstERTL p ->
250    [ERTLPrinter.print_program p]
251  | AstLTL p ->
252    [LTLPrinter.print_program p]
253  | AstLIN p ->
254    [LINPrinter.print_program p]
255  | AstASM p ->
256    (if asm_pretty then [Pretty.print_program p]
257     else ["Pretty print not requested"]) @
258    [ASMPrinter.print_program p]
259
260let save asm_pretty exact_output filename suffix ast =
261  let ext_chopped_filename =
262    if exact_output then filename
263    else
264      try Filename.chop_extension filename
265      with Invalid_argument ("Filename.chop_extension") -> filename in
266  let ext_chopped_filename = ext_chopped_filename ^ suffix in
267  let ext_filenames =
268    List.map (fun ext -> ext_chopped_filename ^ "." ^ ext)
269      (extension (language_of_ast ast)) in
270  let output_filenames =
271    if exact_output then ext_filenames
272    else List.map Misc.SysExt.alternative ext_filenames in
273  let output_strings = string_output asm_pretty ast in
274  let f filename s =
275    let cout = open_out filename in
276    output_string cout s;
277    flush cout;
278    close_out cout in
279  List.iter2 f output_filenames output_strings
280
281let save_cost exact_name filename cost_id cost_incr extern_cost_variables =
282  let filename =
283    if exact_name then filename
284    else
285      try Filename.chop_extension filename
286      with Invalid_argument ("Filename.chop_extension") -> filename in
287  let cout = open_out (filename ^ ".cerco") in
288  let f fun_name cost_var =
289    output_string cout (fun_name ^ " " ^ cost_var ^ "\n") in
290  output_string cout (cost_id ^ "\n");
291  output_string cout (cost_incr ^ "\n");
292  StringTools.Map.iter f extern_cost_variables;
293  flush cout;
294  close_out cout
295
296let interpret debug = function
297  | AstClight p ->
298    ClightInterpret.interpret debug p
299  | AstCminor p ->
300    CminorInterpret.interpret debug p 
301  | AstRTLabs p ->
302    RTLabsInterpret.interpret debug p
303  | AstRTL p ->
304    RTLInterpret.interpret debug p
305  | AstERTL p ->
306    ERTLInterpret.interpret debug p
307  | AstLTL p ->
308    LTLInterpret.interpret debug p
309  | AstLIN p ->
310    LINInterpret.interpret debug p
311  | AstASM p ->
312    ASMInterpret.interpret debug p
313
314let add_lustre_main
315    lustre_test lustre_test_cases lustre_test_cycles
316    lustre_test_min_int lustre_test_max_int = function
317  | AstClight p ->
318    AstClight
319      (ClightLustreMain.add lustre_test lustre_test_cases lustre_test_cycles
320         lustre_test_min_int lustre_test_max_int p)
321  | _ ->
322    Error.global_error "during main generation"
323      "Lustre testing is only available with C programs."
Note: See TracBrowser for help on using the repository browser.