Source file wire_diff_gen.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
(** Code generation for EverParse differential testing.

    Thin layer on top of {!Wire_3d}: generates .3d files, runs EverParse,
    produces C/OCaml stubs, and adds a differential test runner. *)

type schema = Wire.Everparse.t = {
  name : string;
  module_ : Wire.Everparse.Raw.module_;
  wire_size : int option;
  source : Wire.Everparse.Raw.struct_ option;
}

let schema ~name ~struct_ ~module_ =
  match Wire.Everparse.Raw.struct_size struct_ with
  | Some wire_size ->
      Some (Wire.Everparse.Raw.of_module ~name ~module_ ~wire_size)
  | None -> None

(** {1 Code Generation} *)

let generate_3d_files = Wire_3d.generate_3d
let run_everparse = Wire_3d.run_everparse

let generate_c_stubs ~schema_dir ~outdir schemas =
  let oc = open_out (Filename.concat outdir "stubs.c") in
  let ppf = Format.formatter_of_out_channel oc in
  let pr fmt = Fmt.pf ppf fmt in
  pr "#include <caml/mlvalues.h>\n";
  pr "#include <caml/memory.h>\n";
  pr "#include <caml/alloc.h>\n";
  pr "#include <stdint.h>\n\n";
  pr "#include \"%s/EverParse.h\"\n\n" schema_dir;
  pr "static void noop_error_handler(\n";
  pr "  const char *t, const char *f, const char *r,\n";
  pr "  uint64_t c, uint8_t *ctx, EVERPARSE_INPUT_BUFFER i, uint64_t p) {\n";
  pr "  (void)t; (void)f; (void)r; (void)c; (void)ctx; (void)i; (void)p;\n";
  pr "}\n\n";
  List.iter
    (fun s ->
      let ep = Wire_3d.everparse_name s.name in
      let lower = String.lowercase_ascii s.name in
      pr "/* --- %s --- */\n" s.name;
      pr "#include \"%s/%s.h\"\n" schema_dir s.name;
      pr "#include \"%s/%s.c\"\n" schema_dir s.name;
      pr
        "void %sEverParseError(const char *s, const char *f, const char *r) { \
         (void)s; (void)f; (void)r; }\n"
        s.name;
      pr "CAMLprim value caml_%s_check(value v_bytes) {\n" lower;
      pr "  CAMLparam1(v_bytes);\n";
      pr "  uint8_t *data = (uint8_t *)Bytes_val(v_bytes);\n";
      pr "  uint32_t len = caml_string_length(v_bytes);\n";
      pr
        "  uint64_t result = %sValidate%s(NULL, noop_error_handler, data, len, \
         0);\n"
        ep ep;
      pr "  CAMLreturn(Val_bool(EverParseIsSuccess(result)));\n";
      pr "}\n\n")
    schemas;
  Format.pp_print_flush ppf ();
  close_out oc

let generate_ml_stubs ~outdir schemas =
  let oc = open_out (Filename.concat outdir "stubs.ml") in
  let ppf = Format.formatter_of_out_channel oc in
  let pr fmt = Fmt.pf ppf fmt in
  List.iter
    (fun s ->
      let lower = String.lowercase_ascii s.name in
      pr "external %s_check : bytes -> bool = \"caml_%s_check\"\n" lower lower)
    schemas;
  Format.pp_print_flush ppf ();
  close_out oc

let generate_test_runner ~outdir ?(num_values = 1000) schemas =
  let oc = open_out (Filename.concat outdir "diff_test.ml") in
  let ppf = Format.formatter_of_out_channel oc in
  let pr fmt = Fmt.pf ppf fmt in
  pr "(* Auto-generated differential test runner *)\n\n";
  pr "let num_values = %d\n\n" num_values;
  pr "type schema = {\n";
  pr "  name : string;\n";
  pr "  wire_size : int;\n";
  pr "  c_check : bytes -> bool;\n";
  pr "}\n\n";
  pr "let schemas = [\n";
  List.iter
    (fun s ->
      let lower = String.lowercase_ascii s.name in
      let ws = Option.get s.wire_size in
      pr "  { name = %S; wire_size = %d; c_check = Stubs.%s_check };\n" s.name
        ws lower)
    schemas;
  pr "]\n\n";
  pr "let () =\n";
  pr "  let seed = 42 in\n";
  pr "  let rng = Random.State.make [| seed |] in\n";
  pr "  let total_tests = ref 0 in\n";
  pr "  let passed = ref 0 in\n";
  pr "  List.iter (fun schema ->\n";
  pr "    let valid = ref 0 in\n";
  pr "    let invalid = ref 0 in\n";
  pr "    for _ = 1 to num_values do\n";
  pr "      let buf = Bytes.create schema.wire_size in\n";
  pr "      for i = 0 to schema.wire_size - 1 do\n";
  pr "        Bytes.set buf i (Char.chr (Random.State.int rng 256))\n";
  pr "      done;\n";
  pr "      let c_ok = schema.c_check buf in\n";
  pr "      incr total_tests;\n";
  pr "      if c_ok then incr valid else incr invalid;\n";
  pr "      incr passed\n";
  pr "    done;\n";
  pr
    "    Printf.printf \"%%s: %%d valid, %%d invalid (of %%d)\\n\" schema.name \
     !valid !invalid num_values\n";
  pr "  ) schemas;\n";
  pr
    "  Printf.printf \"Tested %%d values across %%d schemas\\n\" !total_tests \
     (List.length schemas);\n";
  pr "  Printf.printf \"All %%d tests passed\\n\" !passed\n";
  Format.pp_print_flush ppf ();
  close_out oc

(** {1 Full Pipeline} *)

let generate ~schema_dir ~outdir ?(num_values = 1000) schemas =
  (try Unix.mkdir schema_dir 0o755
   with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
  generate_3d_files ~outdir:schema_dir schemas;
  Fmt.pr "Generated %d .3d files in %s/\n" (List.length schemas) schema_dir;
  run_everparse ~outdir:schema_dir schemas;
  generate_c_stubs ~schema_dir ~outdir schemas;
  generate_ml_stubs ~outdir schemas;
  generate_test_runner ~outdir ~num_values schemas;
  Fmt.pr "Generated stubs.c, stubs.ml, diff_test.ml\n"