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)