]> matita.cs.unibo.it Git - pkg-cerco/acc.git/blob - src/languages.ml
Imported Upstream version 0.2
[pkg-cerco/acc.git] / src / languages.ml
1 type name = 
2   | Clight
3   | Cminor
4   | RTLabs
5   | RTL
6   | ERTL
7   | LTL
8   | LIN
9   | ASM
10
11 let 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
22 let from_string s = 
23   List.assoc s strings
24
25 let to_string l = 
26   List.assoc l (Misc.ListExt.inv_assoc strings)
27
28 type 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
38 let 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
48 let extension = function
49   | ASM      -> ["s" ; "hex"]
50   | Clight   -> ["c"]
51   | language -> [to_string language]
52
53 type source = [
54     `Filename of string
55   | `Source of string * string
56 ]
57
58 let parse ?is_lustre_file ?remove_lustre_externals = function
59   | Clight -> 
60     fun source ->
61       AstClight
62         (ClightParser.process ?is_lustre_file ?remove_lustre_externals source)
63
64 (*
65   | Cminor -> 
66     fun filename -> 
67       AstCminor 
68         (SyntacticAnalysis.process
69            ~lexer_init: (fun filename -> Lexing.from_channel (open_in filename))
70            ~lexer_fun:  CminorLexer.token
71            ~parser_fun: CminorParser.program
72            ~input:      filename)
73 *)
74
75   | _ ->
76     (* FIXME: Will be completed in the next commits. *)
77     assert false
78
79 let print = function
80   | AstClight a -> ClightPrinter.print_program a
81   | AstCminor a -> CminorPrinter.print_program a
82   | AstRTLabs a -> RTLabsPrinter.print_program a
83   | AstRTL a    -> RTLPrinter.print_program a
84   | AstERTL a   -> ERTLPrinter.print_program a
85   | AstLTL a    -> LTLPrinter.print_program a
86   | AstLIN a    -> LINPrinter.print_program a
87   | AstASM a    -> ASMPrinter.print_program a
88
89 let labelize = function
90   | AstClight p -> 
91     AstClight (ClightLabelling.add_cost_labels p)
92
93 (*
94   | AstCminor p -> 
95     AstCminor (CminorLabelling.add_cost_labels p)
96 *)
97
98   | x -> 
99     (* For the other languages, no labelling is defined. *)
100     x 
101
102
103 let clight_to_cminor = function
104   | AstClight p ->
105     AstCminor (ClightToCminor.translate p)
106   | _ -> assert false
107
108 let cminor_to_rtlabs = function
109   | AstCminor p -> 
110     AstRTLabs (CminorToRTLabs.translate p)
111   | _ -> assert false
112
113 let rtlabs_to_rtl = function
114   | AstRTLabs p -> 
115     AstRTL (RTLabsToRTL.translate p)
116   | _ -> assert false
117
118 let rtl_to_ertl = function
119   | AstRTL p -> 
120     AstERTL (RTLToERTL.translate p)
121   | _ -> assert false
122
123 let ertl_to_ltl = function
124   | AstERTL p -> 
125     AstLTL (ERTLToLTL.translate p)
126   | _ -> assert false
127
128 let ltl_to_lin = function
129   | AstLTL p ->
130     AstLIN (LTLToLIN.translate p)
131   | _ -> assert false
132
133 let lin_to_asm = function
134   | AstLIN p ->
135     AstASM (LINToASM.translate p)
136   | _ -> assert false
137
138 (* We explicitly denote the compilation chain as a list of 
139    passes that must be composed to translate a program 
140    from a source language to a target language. *)
141 let compilation_chain = [
142   (* Source language | Target language | Compilation function *) 
143   Clight,              Cminor,           clight_to_cminor;
144   Cminor,              RTLabs,           cminor_to_rtlabs;
145   RTLabs,              RTL,              rtlabs_to_rtl;
146   RTL,                 ERTL,             rtl_to_ertl;
147   ERTL,                LTL,              ertl_to_ltl;
148   LTL,                 LIN,              ltl_to_lin;
149   LIN,                 ASM,              lin_to_asm;
150 ]
151
152 let compile debug src tgt = 
153   (* Find the maximal suffix of the chain that starts with the
154      language [src]. *)
155   let rec subchain = function
156     | [] -> 
157       (* The chain is assumed to be well-formed: such a suffix 
158          exists. *)
159       assert false 
160     | ((l, _, _) :: _) as chain when l = src -> chain
161     | _ :: chain -> subchain chain
162   in
163   (* Compose the atomic translations to build a compilation function
164      from [src] to [tgt]. Again, we assume that the compilation chain
165      is well-formed. Thus, if we cannot find [tgt] in the compilation
166      chain then the user must have made a mistake to ask for a
167      translation from [src] to [tgt]. *)
168   let rec compose iprogs src tgt chains ast = 
169     if src = tgt then List.rev (ast :: iprogs)
170     else 
171       match chains with
172         | [] -> 
173           Error.global_error "During compilation configuration"
174             (Printf.sprintf "It is not possible to compile from `%s' to `%s'."
175                (to_string src)
176                (to_string tgt))
177             
178         | (l1, l2, src_to_l2) :: chain ->
179           assert (l1 = src);
180           let l2_to_tgt = compose iprogs l2 tgt chain in
181           let iprog = 
182             Misc.Timed.profile 
183               (Printf.sprintf "%s -> %s" 
184                  (to_string l1)
185                  (to_string l2))
186             src_to_l2 ast 
187           in
188           ast :: l2_to_tgt iprog
189   in
190   compose [] src tgt (subchain compilation_chain)
191
192
193 (** [add_runtime ast] adds runtime functions for the operations not supported by
194     the target processor. *)
195 let add_runtime = function
196   | AstClight p ->
197     AstClight (Runtime.replace_unsupported (ClightSwitch.simplify p))
198   | x -> 
199     (* For the other languages, no runtime functios are defined. *)
200     x 
201
202
203 let compute_costs = function
204   | AstClight p -> 
205     (* Computing costs on Clight programs cannot be done directly
206        because the control-flow is not explicit. Yet, for
207        incremental construction and test of the compiler, we 
208        build a stupid mapping from labels to costs for a Clight
209        program that gives cost 1 to every label. *)
210     CostLabel.constant_map (ClightAnnotator.cost_labels p) 1
211
212   | AstCminor p -> 
213     (* Computing costs on Cminor programs cannot be done directly
214        because the control-flow is not explicit. Yet, for
215        incremental construction and test of the compiler, we 
216        build a stupid mapping from labels to costs for a Cminor
217        program that gives cost 1 to every label. *)
218     CostLabel.constant_map (CminorAnnotator.cost_labels p) 1
219
220   | AstASM p ->
221     ASMCosts.compute p
222
223   | ast -> 
224     Error.warning "during cost computing"
225       (Printf.sprintf 
226          "Cost computing is not implemented for language `%s'. Please compile to ASM if you want to annotate the input."
227          (to_string (language_of_ast ast))) ;
228     CostLabel.Map.empty
229
230
231 (* FIXME *)
232 let instrument costs_mapping = function
233   | AstClight p ->
234     let (p', cost_id, cost_incr, extern_cost_variables) =
235       ClightAnnotator.instrument p costs_mapping in
236     (AstClight p', cost_id, cost_incr, extern_cost_variables)
237 (*
238   | AstCminor p ->
239     let (p', cost_id, cost_incr) = CminorAnnotator.instrument p costs_mapping in
240     (AstCminor p', cost_id, cost_incr)
241 *)
242   | p -> 
243     Error.warning "during instrumentation"
244       (Printf.sprintf 
245          "Instrumentation is not implemented for source language `%s'."
246          (to_string (language_of_ast p)));
247     (p, "", "", StringTools.Map.empty)
248
249 let annotate input_ast final =
250   let costs_mapping = Misc.Timed.profile "Compute costs" compute_costs final in 
251   Misc.Timed.profile "Instrument" (instrument costs_mapping) input_ast
252
253 let string_output asm_pretty = function
254   | AstClight p -> 
255     [ClightPrinter.print_program p]
256   | AstCminor p ->
257     [CminorPrinter.print_program p]
258   | AstRTLabs p ->
259     [RTLabsPrinter.print_program p]
260   | AstRTL p ->
261     [RTLPrinter.print_program p]
262   | AstERTL p ->
263     [ERTLPrinter.print_program p]
264   | AstLTL p ->
265     [LTLPrinter.print_program p]
266   | AstLIN p ->
267     [LINPrinter.print_program p]
268   | AstASM p ->
269     (if asm_pretty then [Pretty.print_program p]
270      else ["Pretty print not requested"]) @
271     [ASMPrinter.print_program p]
272
273 let save asm_pretty exact_output filename suffix ast =
274   let ext_chopped_filename =
275     if exact_output then filename 
276     else
277       try Filename.chop_extension filename
278       with Invalid_argument ("Filename.chop_extension") -> filename in
279   let ext_chopped_filename = ext_chopped_filename ^ suffix in
280   let ext_filenames =
281     List.map (fun ext -> ext_chopped_filename ^ "." ^ ext)
282       (extension (language_of_ast ast)) in
283   let output_filenames =
284     if exact_output then ext_filenames
285     else List.map Misc.SysExt.alternative ext_filenames in
286   let output_strings = string_output asm_pretty ast in
287   let f filename s =
288     let cout = open_out filename in
289     output_string cout s;
290     flush cout;
291     close_out cout in
292   List.iter2 f output_filenames output_strings
293
294 let save_cost exact_name filename cost_id cost_incr extern_cost_variables =
295   let filename =
296     if exact_name then filename
297     else
298       try Filename.chop_extension filename
299       with Invalid_argument ("Filename.chop_extension") -> filename in
300   let cout = open_out (filename ^ ".cerco") in
301   let f fun_name cost_var =
302     output_string cout (fun_name ^ " " ^ cost_var ^ "\n") in
303   output_string cout (cost_id ^ "\n");
304   output_string cout (cost_incr ^ "\n");
305   StringTools.Map.iter f extern_cost_variables;
306   flush cout;
307   close_out cout
308
309 let save_stack exact_name filename stack_id
310     stack_max_id stack_incr extern_stack_variables =
311   let filename =
312     if exact_name then filename
313     else
314       try Filename.chop_extension filename
315       with Invalid_argument ("Filename.chop_extension") -> filename in
316   let cout = open_out (filename ^ ".stack_cerco") in
317   let f fun_name stack_var =
318     output_string cout (fun_name ^ " " ^ stack_var ^ "\n") in
319   output_string cout (stack_id ^ "\n");
320   output_string cout (stack_max_id ^ "\n");
321   output_string cout (stack_incr ^ "\n");
322   StringTools.Map.iter f extern_stack_variables;
323   flush cout;
324   close_out cout
325
326
327 let interpret debug = function
328   | AstClight p ->
329     ClightInterpret.interpret debug p
330   | AstCminor p ->
331     CminorInterpret.interpret debug p  
332   | AstRTLabs p ->
333     RTLabsInterpret.interpret debug p
334   | AstRTL p ->
335     RTLInterpret.interpret debug p
336   | AstERTL p ->
337     ERTLInterpret.interpret debug p
338   | AstLTL p ->
339     LTLInterpret.interpret debug p
340   | AstLIN p ->
341     LINInterpret.interpret debug p
342   | AstASM p ->
343     ASMInterpret.interpret debug p
344
345 let add_lustre_main
346     lustre_test lustre_test_cases lustre_test_cycles
347     lustre_test_min_int lustre_test_max_int = function
348   | AstClight p ->
349     AstClight
350       (ClightLustreMain.add lustre_test lustre_test_cases lustre_test_cycles
351          lustre_test_min_int lustre_test_max_int p)
352   | _ ->
353     Error.global_error "during main generation"
354       "Lustre testing is only available with C programs."
355
356
357
358
359 (* FIXME *)
360 let annotate_stack_size cost_incr = function
361   | AstClight p ->
362     let (p', stack_id, stack_max_id, stack_incr, extern_stack_variables) =
363       AnnotStackSize.instrument cost_incr p in
364     (AstClight p', stack_id, stack_max_id, stack_incr, extern_stack_variables)
365 (*
366   | AstCminor p ->
367     let (p', stack_id, stack_incr) = CminorAnnotator.instrument p costs_mapping in
368     (AstCminor p', stack_id, stack_incr)
369 *)
370   | p -> 
371     Error.warning "during instrumentation"
372       (Printf.sprintf 
373          "Instrumentation is not implemented for source language `%s'."
374          (to_string (language_of_ast p)));
375     (p, "", "", "", StringTools.Map.empty)