source: Deliverables/D2.2/8051-indexed-labels-branch/src/languages.ml @ 1433

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