src/acc.ml

   1 open Options
   2 open Misc.Timed
   3
   4 (** Parse the command line. *)
   5 let input_files =
   6   if not (Options.is_web_mode ()) then
   7     OptionsParsing.results ()
   8   else
   9     []
  10
  11 (** For each input file of the source language:
  12
  13     1. Parse.
  14
  15     2. Add runtime functions.
  16
  17     3. Labelize.
  18
  19     4. Compile to the target language.
  20        (And keep track of annotations if required).
  21
  22     5. Annotate the input program with collected costs.
  23
  24     6. Save the annotated input program.
  25
  26     Optionnally, we can interpret the intermediate programs
  27     if {!Options.interpretation_requested}.
  28 *)
  29 let process ?(step=fun step over -> ()) source =
  30   (** Set source and target languages. *)
  31   let src_language = Options.get_source_language () in
  32   let tgt_language = Options.get_target_language () in
  33
  34   let next_step =
  35     let nb_step = 10 in
  36     let c = ref 0 in
  37     fun () -> incr c; step !c nb_step
  38   in
  39
  40   (** These variables are related to the lustre mode of the compiler. *)
  41   let is_lustre_file = Options.is_lustre_file () in
  42   let remove_lustre_externals = Options.is_remove_lustre_externals () in
  43
  44   (** Parse. *)
  45   let input_ast =
  46     profile "Parsing"
  47       (Languages.parse ~is_lustre_file ~remove_lustre_externals src_language)
  48       source
  49   in
  50
  51   next_step ();
  52
  53   (** Embed the runtime functions in the abstract syntax tree. *)
  54   let input_ast = Languages.add_runtime input_ast in
  55
  56   (** Labelling pass. *)
  57   let input_ast =
  58     profile "Labelling"
  59     Languages.labelize input_ast
  60   in
  61
  62   next_step ();
  63
  64   (** Compilation. *)
  65   let target_asts =
  66     (** If debugging is enabled, the compilation function returns all
  67         the intermediate programs. *)
  68     profile "Compilation"
  69       (Languages.compile
  70          (Options.is_debug_enabled ())
  71          src_language tgt_language)
  72       input_ast
  73   in
  74
  75   next_step ();
  76
  77   let final_ast, intermediate_asts = Misc.ListExt.cut_last target_asts in
  78
  79   (** Instrument the source file with cost annotations. *)
  80   let (annotated_input_ast, cost_id, cost_incr, extern_cost_variables) =
  81     profile "Annotation"
  82       (Languages.annotate input_ast)
  83       final_ast
  84   in
  85
  86   (** Instrument the source file with cost annotations. *)
  87   let (annotated_input_ast, stack_id, stack_max_id,
  88        stack_incr, extern_stack_variables) =
  89     profile "Annotation Stack"
  90       Languages.annotate_stack_size cost_incr annotated_input_ast
  91   in
  92
  93   next_step ();
  94
  95   (** Combine the output asts. *)
  96   let output = (target_asts, annotated_input_ast) in
  97
  98   (** Finally save these output if we are not in a web mode. *)
  99   let _ =
 100     if not (Options.is_web_mode ()) then
 101       let filename = match source with `Filename f -> f | _ -> assert false in
 102       let (exact_output, output_filename) = match Options.get_output_files () with
 103         | None -> (false, filename)
 104         | Some filename' -> (true, filename') in
 105       let save ?(suffix="") ast =
 106         Languages.save
 107           (Options.is_asm_pretty ()) exact_output output_filename suffix ast
 108       in
 109       begin
 110         save final_ast;
 111         save ~suffix:"-instrumented" annotated_input_ast;
 112         Languages.save_cost exact_output output_filename cost_id cost_incr
 113           extern_cost_variables;
 114         Languages.save_stack
 115           exact_output output_filename
 116           stack_id stack_max_id stack_incr extern_stack_variables;
 117         if Options.is_debug_enabled () then
 118           List.iter save intermediate_asts;
 119       end;
 120
 121       (** Interpret all the intermediate ASTs if requested. *)
 122       if Options.interpretations_requested () then
 123         begin
 124           Printf.printf "Interpret\n%!" ;
 125           let asts = target_asts in
 126           let debug = Options.is_debug_enabled () in
 127           let label_traces = List.map (Languages.interpret debug) asts in
 128           Misc.IOExt.eprintf "Checking execution traces...%!";
 129           Checker.same_traces (List.combine asts label_traces);
 130           Misc.IOExt.eprintf "OK.\n%!";
 131         end;
 132
 133       (** Interpret the final AST if requested. *)
 134       if Options.interpretation_requested () then
 135         ignore (Languages.interpret (Options.is_debug_enabled ()) final_ast)
 136   in
 137   (** Return the output ASTs. *)
 138   output
 139
 140 let lustre_test (filename : string) =
 141   let lustre_test       = match Options.get_lustre_test () with
 142     | None -> assert false (* do not use on this argument *)
 143     | Some lustre_test -> lustre_test in
 144   let lustre_test_cases = Options.get_lustre_test_cases () in
 145   let lustre_test_cycles = Options.get_lustre_test_cycles () in
 146   let lustre_test_min_int = Options.get_lustre_test_min_int () in
 147   let lustre_test_max_int = Options.get_lustre_test_max_int () in
 148   let src_language      = Languages.Clight in
 149   let tgt_language      = Languages.Clight in
 150   let input_ast         = Languages.parse src_language (`Filename filename) in
 151   let input_ast         =
 152     Languages.add_lustre_main lustre_test lustre_test_cases lustre_test_cycles
 153       lustre_test_min_int lustre_test_max_int input_ast in
 154   let (exact_output, output_filename) = match Options.get_output_files () with
 155     | None -> (false, filename)
 156     | Some filename' -> (true, filename')
 157   in
 158   let save ast =
 159     Languages.save
 160       (Options.is_asm_pretty ()) exact_output output_filename "" ast in
 161   let target_asts =
 162     Languages.compile false src_language tgt_language input_ast
 163   in
 164   let final_ast, _ = Misc.ListExt.cut_last target_asts in
 165   save input_ast ;
 166   save final_ast
 167
 168 let _ =
 169   Misc.Timed.set_profiling_flag (Options.is_debug_enabled () || Options.is_web_mode ());
 170   if not (Options.is_web_mode ()) then
 171     begin
 172       set_now (fun () -> 0.); (* Unix.gettimeofday () *. 1000.); *)
 173       if Options.is_dev_test_enabled () then
 174         Dev_test.do_dev_test input_files
 175       else
 176         if Options.get_lustre_test () <> None then
 177           List.iter lustre_test input_files
 178         else
 179           ignore (List.map process (List.map (fun f -> `Filename f) input_files))
 180     end