From 62d1aa73166716821230352dd86006fec9647f25 Mon Sep 17 00:00:00 2001
From: Kakadu <Kakadu@pm.me>
Date: Sat, 3 Oct 2020 11:38:29 +0300
Subject: [PATCH] Adding benchmarking executable

Signed-off-by: Kakadu <Kakadu@pm.me>
---
 bench/Makefile      |  34 ++++++++++
 bench/README.md     |   8 +++
 bench/bench_main.ml |  49 ++++++++++++++
 bench/p.ml          | 159 ++++++++++++++++++++++++++++++++++++++++++++
 bench/pp_default.m4 |  25 +++++++
 bench/pp_gt.m4      |  40 +++++++++++
 src/Pprinter.ml     |  13 ++--
 7 files changed, 321 insertions(+), 7 deletions(-)
 create mode 100644 bench/Makefile
 create mode 100644 bench/README.md
 create mode 100644 bench/bench_main.ml
 create mode 100644 bench/p.ml
 create mode 100644 bench/pp_default.m4
 create mode 100644 bench/pp_gt.m4

diff --git a/bench/Makefile b/bench/Makefile
new file mode 100644
index 000000000..cad3a08a6
--- /dev/null
+++ b/bench/Makefile
@@ -0,0 +1,34 @@
+.PHONY: clean 
+
+OUT = bench.exe
+LAMA_CMXES = ../src/Language.cmx 
+OCAMLC = ocamlfind c
+OCAMLOPT = ocamlfind opt
+BFLAGS += -package GT,ostap,re,benchmark -I ../src -rectypes -g
+GENERATED = Pprint_gt.ml Pprint_default.ml
+
+all: $(OUT)
+
+bench_main.cmx: Pprint_gt.cmx Pprint_default.cmx
+
+$(OUT): Pprint_gt.cmx Pprint_default.cmx bench_main.cmx 
+	$(OCAMLOPT) $(BFLAGS) $(LAMA_CMXES) -linkpkg $^ -o $@
+  
+clean:
+	$(RM) *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend $(OUT) $(GENERATED)
+
+%.cmi: %.ml
+	$(OCAMLC) -c $(BFLAGS)  $<
+    
+%.cmx: %.ml
+	$(OCAMLOPT) -c $(BFLAGS) $<
+
+
+###############
+Pprint_gt.ml: pp_gt.m4 p.ml
+	m4 $< p.ml > $@
+
+###############
+Pprint_default.ml: pp_default.m4 p.ml
+	m4 $< p.ml > $@
+
diff --git a/bench/README.md b/bench/README.md
new file mode 100644
index 000000000..53c7c6f9a
--- /dev/null
+++ b/bench/README.md
@@ -0,0 +1,8 @@
+##### Benchmark suite for pretty printing
+
+Files:
+
+- `bench_main.ml` -- runner of benhcmark
+- `p.ml` -- an implementation of pretty-printer
+- `pp_default.m4` -- macro that converts `p.ml` into strightforward pretty printer
+- `pp_gt.m4` -- a macro that converts `p.ml` into GT-based pretty printer
diff --git a/bench/bench_main.ml b/bench/bench_main.ml
new file mode 100644
index 000000000..5d7c1bc9a
--- /dev/null
+++ b/bench/bench_main.ml
@@ -0,0 +1,49 @@
+open Benchmark
+
+let () =
+  let options = object
+    method is_workaround = false
+    method get_infile = "stdlib/List.lama"
+    method get_include_paths = ["./stdlib"; "runtime"]
+  end in
+  let ast =
+    try match Language.run_parser options with
+      | `Ok  r -> r
+      | `Fail s ->
+          Printf.eprintf "Error: %s\n" s;
+          exit 1
+    with Language.Semantic_error s ->
+      Printf.eprintf "Error: %s\n" s;
+      exit 1
+  in
+
+  let () =
+    let s1 = Format.asprintf "%a" Pprint_gt.pp (snd ast) in
+    let s2 = Format.asprintf "%a" Pprint_default.pp (snd ast) in
+    if s1<>s2
+    then begin
+      let wrap name cnt =
+        let ch = open_out name in
+        output_string ch cnt;
+        close_out ch
+      in
+      wrap "/tmp/gt.ml" s1;
+      wrap "/tmp/default.ml" s2;
+      failwith "Two printers doesn't behave the same"
+    end
+  in
+  let run_gt () =
+    let _:string = Format.asprintf "%a" Pprint_gt.pp (snd ast) in
+    ()
+  in
+  let run_default () =
+    let _:string = Format.asprintf "%a" Pprint_default.pp (snd ast) in
+    ()
+  in
+
+  let res = throughputN ~repeat:1 1
+    [ ("GT", run_gt, ())
+    ; ("Default", run_default, ())
+    ]
+  in
+  tabulate res
diff --git a/bench/p.ml b/bench/p.ml
new file mode 100644
index 000000000..c0f0b26df
--- /dev/null
+++ b/bench/p.ml
@@ -0,0 +1,159 @@
+open Language
+
+class pp_pattern fself = object
+  inherit [Pattern.t] Pattern.fmt_t_t fself
+
+  method! c_Wildcard ppf _ = Format.fprintf ppf "_"
+  method! c_Const ppf _ = Format.fprintf ppf "%d"
+  method! c_Named ppf _ name _ =
+    (* TODO: should I ignore another argument? *)
+    Format.fprintf ppf "%s" name
+  method! c_Sexp ppf _ name xs =
+    match name,xs with
+    | "cons", [l; r] ->
+        Format.fprintf ppf "%a@ :@ %a" fself l fself r
+    | _ ->
+        Format.fprintf ppf "@[%s@ (" name;
+        xs |> List.iter (Format.fprintf ppf "%a@ " fself);
+        Format.fprintf ppf ")@] "
+
+  method! c_Array ppf _ xs =
+    Format.fprintf ppf "@[{ ";
+    Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
+      fself ppf xs;
+    Format.fprintf ppf " }@]"
+
+  method! c_ArrayTag ppf _ = Format.fprintf ppf "#array"
+  method! c_SexpTag ppf _ = Format.fprintf ppf "#sexp"
+  method! c_ClosureTag ppf _ = Format.fprintf ppf "#fun"
+end
+
+let pp_pattern fmt p =
+  GT.transform Pattern.t (new pp_pattern) fmt p
+
+HEADER_EXPR
+METH(Const, ppf, n, Const n, Format.fprintf ppf "%d" n)
+METH(Var, ppf, s, Var s, Format.fprintf ppf "%s" s)
+METH(Ref, ppf, s, Ref s, Format.fprintf ppf "%s" s)
+METH(String, ppf, s, String s, Format.fprintf ppf "\"%s\"" s)
+METH(Array, ppf, xs, Array xs, [[Format.fprintf ppf "@[{@ ";
+xs |> List.iteri (fun i ->
+  if i<>0 then Format.fprintf ppf ",@ ";
+  fself ppf);
+Format.fprintf ppf " }@]"]]
+)
+METH(Sexp, ppf, name xs, [[Sexp (name,xs)]], [[(match name,xs with
+| "cons", [l;r] -> Format.fprintf ppf "@[%a : %a@]" fself l fself r
+| _ ->
+    Format.fprintf ppf "@[%s@ (" name;
+    xs |> List.iteri (fun i x ->
+      if i<>0 then Format.fprintf ppf ", ";
+      fself ppf x
+    );
+    Format.fprintf ppf ")@]")
+]])
+METH(Binop, ppf, op l r, Binop (op, l, r), [[Format.fprintf ppf "@[%a@ %s@ %a@]" fself l op fself r]])
+METH(Elem, ppf, l idx, Elem (l,idx), [[Format.fprintf ppf "%a[%a]" fself l fself idx]])
+METH(ElemRef, ppf, l idx, ElemRef (l,idx), [[Format.fprintf ppf "%a[%a]" fself l fself idx]])
+METH(Length, ppf, e, Length e, [[Format.fprintf ppf "@[(%a).length@]" fself e]])
+
+METH(StringVal, ppf, _x__519_, StringVal _x__519_, [[Format.fprintf ppf "StringVal @[(@,%a@,)@]" fself _x__519_]])
+
+
+
+METH(Call, ppf, f args, Call (f,args), [[Format.fprintf ppf "@[%a @[(" fself f;
+args |> List.iteri (fun i arg ->
+  Format.fprintf ppf "%s%a" (if i<>0 then ", " else "") fself arg
+);
+Format.fprintf ppf ")@]@]"]])
+
+METH(Assign, ppf, l r, Assign (l,r), [[Format.fprintf ppf "@[%a@ :=@ %a@]" fself l fself r]])
+METH(Seq, ppf, l r, Seq (l,r), [[Format.fprintf ppf "@[<v>%a;@ %a@]" fself l fself r]])
+
+
+METH(Skip, ppf, , Skip, [[ Format.fprintf ppf "skip" ]])
+
+METH(If, ppf, c th el, If (c,th,el), [[
+Format.fprintf ppf "@[if %a then @[<v 2>{@,%a@]@ @[<v 2>} else {@,%a@]@ } fi@]"
+  fself c fself th fself el]])
+
+METH(While, ppf, cond body, While(cond,body), [[
+Format.fprintf ppf "@[<v 2>";
+Format.fprintf ppf "while %a do@," fself cond;
+fself ppf body;
+Format.fprintf ppf "@]@ ";
+Format.fprintf ppf "od"]])
+
+METH(Repeat, ppf, cond body, Repeat(cond,body), [[
+Format.fprintf ppf "@[<v 2>";
+Format.fprintf ppf "repeat@,%a" fself body;
+Format.fprintf ppf "until %a@]" fself cond]])
+
+METH(Case, ppf, scru cases _ _, Case(scru, cases, _,_), [[
+Format.fprintf ppf "@[<v>";
+Format.fprintf ppf "@[case %a of@ @]@," fself scru;
+Format.fprintf ppf "@[<v 0>";
+cases |> List.iteri (fun i (p,e) ->
+  Format.fprintf ppf "@[%s %a@ ->@ %a@]@ " (if i=0 then " " else "|") pp_pattern p fself e
+);
+Format.fprintf ppf "@]";
+Format.fprintf ppf "@[esac@]";
+Format.fprintf ppf "@]"]])
+
+METH(Return, ppf, e, Return e, [[(match e with
+| None -> Format.fprintf ppf "return"
+| Some e -> Format.fprintf ppf "@[return@ %a@]" fself e)]])
+
+METH(Ignore, ppf, e, Ignore e, Format.fprintf ppf "@[%a@]" fself e)
+METH(Unit, ppf, , Unit, Format.fprintf ppf "Unit ")
+METH(Scope, ppf, xs body, Scope(xs,body), [[Format.fprintf ppf "@[<v>";
+Format.pp_print_list ~pp_sep:(fun fmt () -> ())
+  (fun ppf (name, d) ->
+    Format.fprintf ppf "@[%a@]@," (fun ppf -> pp_decl (name,ppf)) d)
+  ppf xs;
+fself ppf body;
+Format.fprintf ppf "@]"]])
+
+METH(Lambda, ppf, args body, Lambda(args, body), [[
+Format.fprintf ppf "@[fun (%a) { %a }@]"
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_text)
+    args
+    fself
+    body
+]])
+
+METH(Leave, ppf, , Leave, Format.fprintf ppf "Leave ")
+
+METH(Intrinsic, ppf, _x__584_, Intrinsic _, Format.fprintf ppf "Intrinsic ")
+METH(Control, ppf, _x__584_, Control _, Format.fprintf ppf "Control ")
+
+FOOTER_EXPR
+
+let args ppf =
+  Format.fprintf ppf "%a" @@
+  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",")
+    (Format.pp_print_text)
+
+let pp_qualifier ppf : Expr.qualifier -> _ = function
+  | `Local -> ()
+  | `Extern -> Format.fprintf ppf "extern@ "
+  | `Public -> Format.fprintf ppf "public@ "
+  | `PublicExtern -> Format.fprintf ppf "not implemented %d" __LINE__
+
+HEADER_DECL
+METH0(DECL, (name,ppf), (qual,item), [[
+  let _: [`Fun of string list * Expr.t | `Variable of Expr.t GT.option] = item in
+  match item with
+  | `Variable(None) -> Format.fprintf ppf "local %s;" name
+  | `Variable(Some e) ->
+      Format.fprintf ppf "local %s = %a;" name pp_expr e
+  | `Fun (ss,e) ->
+      Format.fprintf ppf "@[<v>";
+      Format.fprintf ppf "@[%afun %s (%a) @]@," pp_qualifier qual name args ss;
+      Format.fprintf ppf "@[<v 2>{@,@[%a@]@]@ " pp_expr e;
+      Format.fprintf ppf "}";
+      Format.fprintf ppf "@]"]]
+)
+FOOTER_DECL
+
+FIX
diff --git a/bench/pp_default.m4 b/bench/pp_default.m4
new file mode 100644
index 000000000..2d5320823
--- /dev/null
+++ b/bench/pp_default.m4
@@ -0,0 +1,25 @@
+changequote([[,]])
+define(HEADER_EXPR, [[
+let rec pp_e pp_decl fself ppf root =
+  let open Expr in
+  match root with]])
+
+define(METH, [[
+  | $4 ->
+      $5]])
+define(METH0, [[
+  | $3 ->
+      $4]])
+define(FOOTER_EXPR, [[]])
+define(HEADER_DECL, [[
+let rec pp_d fself pp_expr (name,ppf) root =
+  let open Expr in
+  match root with]])
+
+
+define(FOOTER_DECL, [[]])
+
+define(FIX, [[
+let rec pp_decl ppf = pp_d pp_decl pp ppf
+and pp ppf = pp_e pp_decl pp ppf
+]])
diff --git a/bench/pp_gt.m4 b/bench/pp_gt.m4
new file mode 100644
index 000000000..40a01c542
--- /dev/null
+++ b/bench/pp_gt.m4
@@ -0,0 +1,40 @@
+changequote([[,]])
+define(HEADER_EXPR, [[
+class pp_e pp_decl fself  = object
+  inherit [Format.formatter, Expr.t, unit] Expr.t_t
+  ]])
+
+define(METH, [[
+  method c_$1 $2 _ $3 =
+    $5
+]])
+define(METH0, [[
+  method c_$1 $2 $3 =
+    $4]])
+define(FOOTER_EXPR, [[
+end (* class *)
+]])
+define(HEADER_DECL, [[
+class pp_d fself pp_expr  =
+let (_: (string*Format.formatter) -> Expr.decl -> unit) = fself in
+let (_: Format.formatter -> Expr.t -> unit) = pp_expr  in
+object
+  inherit [(string*Format.formatter), _, unit] Expr.decl_t]])
+
+
+define(FOOTER_DECL, [[
+end (* class *)
+]])
+define(FIX, [[
+
+let fix_decl decl0 t0 =
+  let rec traitdecl inh subj =
+    Expr.gcata_decl (decl0 traitdecl traitt) inh subj
+  and traitt inh subj =
+    Expr.gcata_t (t0 traitdecl traitt) inh subj
+  in
+  (traitdecl, traitt)
+
+let pp fmt s =
+  snd (fix_decl (new pp_d) (new pp_e)) fmt s
+]])
diff --git a/src/Pprinter.ml b/src/Pprinter.ml
index b4e0aac95..c54a0bc0c 100644
--- a/src/Pprinter.ml
+++ b/src/Pprinter.ml
@@ -79,22 +79,21 @@ object
     Format.fprintf ppf ")@]@]"
 
 
-  method c_Assign ppf _ _x__526_ _x__527_ =
-    Format.fprintf ppf "@[%a@ :=@ %a@]" fself _x__526_ fself _x__527_
+  method c_Assign ppf _ l r =
+    Format.fprintf ppf "@[%a@ :=@ %a@]" fself l fself r
   method c_Seq ppf _ l r =
     Format.fprintf ppf "@[<v>%a;@ %a@]" fself l fself r
   method c_Skip ppf _ = Format.fprintf ppf "skip"
-  method c_If ppf _ _x__533_ _x__534_ _x__535_ =
+  method c_If ppf _ c th el =
     Format.fprintf ppf "@[if %a then @[<v 2>{@,%a@]@ @[<v 2>} else {@,%a@]@ } fi@]"
-      fself _x__533_ fself _x__534_ fself _x__535_
+      fself c fself th fself el
   method c_While ppf _ cond body =
     Format.fprintf ppf "@[<v 2>";
     Format.fprintf ppf "while %a do@," fself cond;
     fself ppf body;
     Format.fprintf ppf "@]@ ";
-    Format.fprintf ppf "od";
-    (*Format.fprintf inh___536_ "While @[(@,%a,@,@ %a@,)@]" fself
-      cond fself body*)
+    Format.fprintf ppf "od"
+
   method c_Repeat ppf _ cond body =
     Format.fprintf ppf "@[<v 2>";
     Format.fprintf ppf "repeat@,%a" fself body;