tools/mgen/main.ml

   1 open Cgen
   2 open Match
   3
   4 let mgen ~verbose ~fuzz path lofs input oc =
   5   let info ?(level = 1) fmt =
   6     if level <= verbose then
   7       Printf.eprintf fmt
   8     else
   9       Printf.ifprintf stdout fmt
  10   in
  11
  12   let rules =
  13     match Sexp.(run_parser ppats) input with
  14     | `Error (ps, err, loc) ->
  15         Printf.eprintf "%s:%d:%d %s\n"
  16           path (lofs + ps.Sexp.line) ps.Sexp.coln err;
  17         Printf.eprintf "%s" loc;
  18         exit 1
  19     | `Ok rules -> rules
  20   in
  21
  22   info "adding ac variants...%!";
  23   let nparsed =
  24     List.fold_left
  25       (fun npats (_, _, ps) ->
  26          npats + List.length ps)
  27       0 rules
  28   in
  29   let varsmap = Hashtbl.create 10 in
  30   let rules =
  31     List.concat_map (fun (name, vars, patterns) ->
  32         (try assert (Hashtbl.find varsmap name = vars)
  33          with Not_found -> ());
  34         Hashtbl.replace varsmap name vars;
  35         List.map
  36           (fun pattern -> {name; vars; pattern})
  37           (List.concat_map ac_equiv patterns)
  38       ) rules
  39   in
  40   info " %d -> %d patterns\n"
  41     nparsed (List.length rules);
  42
  43   let rnames =
  44     setify (List.map (fun r -> r.name) rules) in
  45
  46   info "generating match tables...%!";
  47   let sa, am, sm = generate_table rules in
  48   let numbr = make_numberer sa am sm in
  49   info " %d states, %d rules\n"
  50     (Array.length sa) (StateMap.cardinal sm);
  51   if verbose >= 2 then begin
  52     info "-------------\nstates:\n";
  53     Array.iteri (fun i s ->
  54         info "  state %d: %s\n"
  55           i (show_pattern s.seen)) sa;
  56     info "-------------\nstatemap:\n";
  57     Test.print_sm stderr sm;
  58     info "-------------\n";
  59   end;
  60
  61   info "generating matchers...\n";
  62   let matchers =
  63     List.map (fun rname ->
  64         info "+ %s...%!" rname;
  65         let m = lr_matcher sm sa rules rname in
  66         let vars = Hashtbl.find varsmap rname in
  67         info " %d nodes\n" (Action.size m);
  68         info ~level:2 "  -------------\n";
  69         info ~level:2 "  automaton:\n";
  70         info ~level:2 "%s\n"
  71           (Format.asprintf "    @[%a@]" Action.pp m);
  72         info ~level:2 "  ----------\n";
  73         (vars, rname, m)
  74       ) rnames
  75   in
  76
  77   if fuzz then begin
  78     info ~level:0 "fuzzing statemap...\n";
  79     let tp = Fuzz.fuzz_numberer rules numbr in
  80     info ~level:0 "testing %d patterns...\n"
  81       (List.length rules);
  82     Fuzz.test_matchers tp numbr rules
  83   end;
  84
  85   info "emitting C...\n";
  86   flush stderr;
  87
  88   let cgopts =
  89     { pfx = ""; static = true; oc = oc } in
  90   emit_c cgopts numbr;
  91   emit_matchers cgopts matchers;
  92
  93   ()
  94
  95 let read_all ic =
  96   let bufsz = 4096 in
  97   let buf = Bytes.create bufsz in
  98   let data = Buffer.create bufsz in
  99   let read = ref 0 in
 100   while
 101     read := input ic buf 0 bufsz;
 102     !read <> 0
 103   do
 104     Buffer.add_subbytes data buf 0 !read
 105   done;
 106   Buffer.contents data
 107
 108 let split_c src =
 109   let begin_re, eoc_re, end_re =
 110     let re = Str.regexp in
 111     ( re "mgen generated code"
 112     , re "\\*/"
 113     , re "end of generated code" )
 114   in
 115   let str_match regexp str =
 116     try
 117       let _: int =
 118         Str.search_forward regexp str 0
 119       in true
 120     with Not_found -> false
 121   in
 122
 123   let rec go st lofs pfx rules lines =
 124     let line, lines =
 125       match lines with
 126       | [] ->
 127           failwith (
 128             match st with
 129             | `Prefix -> "could not find mgen section"
 130             | `Rules -> "mgen rules not terminated"
 131             | `Skip -> "mgen section not terminated"
 132           )
 133       | l :: ls -> (l, ls)
 134     in
 135     match st with
 136     | `Prefix ->
 137         let pfx = line :: pfx in
 138         if str_match begin_re line
 139         then
 140           let lofs = List.length pfx in
 141           go `Rules lofs pfx rules lines
 142         else go `Prefix 0 pfx rules lines
 143     | `Rules ->
 144         let pfx = line :: pfx in
 145         if str_match eoc_re line
 146         then go `Skip lofs pfx rules lines
 147         else go `Rules lofs pfx (line :: rules) lines
 148     | `Skip ->
 149         if str_match end_re line then
 150           let join = String.concat "\n" in
 151           let pfx = join (List.rev pfx) ^ "\n\n"
 152           and rules = join (List.rev rules)
 153           and sfx = join (line :: lines)
 154           in (lofs, pfx, rules, sfx)
 155         else go `Skip lofs pfx rules lines
 156   in
 157
 158   let lines = String.split_on_char '\n' src in
 159   go `Prefix 0 [] [] lines
 160
 161 let () =
 162   let usage_msg =
 163     "mgen [--fuzz] [--verbose <N>] <file>" in
 164
 165   let fuzz_arg = ref false in
 166   let verbose_arg = ref 0 in
 167   let input_paths = ref [] in
 168
 169   let anon_fun filename =
 170     input_paths := filename :: !input_paths in
 171
 172   let speclist =
 173     [ ( "--fuzz", Arg.Set fuzz_arg
 174       , "  Fuzz tables and matchers" )
 175     ; ( "--verbose", Arg.Set_int verbose_arg
 176       , "<N>  Set verbosity level" )
 177     ; ( "--", Arg.Rest_all (List.iter anon_fun)
 178       , "  Stop argument parsing" ) ]
 179   in
 180   Arg.parse speclist anon_fun usage_msg;
 181
 182   let input_paths = !input_paths in
 183   let verbose = !verbose_arg in
 184   let fuzz = !fuzz_arg in
 185   let input_path, input =
 186     match input_paths with
 187     | ["-"] -> ("-", read_all stdin)
 188     | [path] -> (path, read_all (open_in path))
 189     | _ ->
 190         Printf.eprintf
 191           "%s: single input file expected\n"
 192           Sys.argv.(0);
 193         Arg.usage speclist usage_msg; exit 1
 194   in
 195   let mgen = mgen ~verbose ~fuzz in
 196
 197   if Str.last_chars input_path 2 <> ".c"
 198   then mgen input_path 0 input stdout
 199   else
 200     let tmp_path = input_path ^ ".tmp" in
 201     Fun.protect
 202       ~finally:(fun () ->
 203           try Sys.remove tmp_path with _ -> ())
 204       (fun () ->
 205          let lofs, pfx, rules, sfx = split_c input in
 206          let oc = open_out tmp_path in
 207          output_string oc pfx;
 208          mgen input_path lofs rules oc;
 209          output_string oc sfx;
 210          close_out oc;
 211          Sys.rename tmp_path input_path;
 212          ());
 213
 214   ()