From eee0bfa70571a753faf9d34ee65eee13dc078d5d Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Tue, 8 Oct 2024 16:32:04 +0200 Subject: [PATCH] Benchmarks: use Ppxlib to generate code instead of compiler-libs --- src/lib_benchmark/ast.ml | 10 ++--- src/lib_benchmark/ast.mli | 2 +- src/lib_benchmark/codegen.ml | 74 ++++++++++++++++++++---------------- 3 files changed, 47 insertions(+), 39 deletions(-) diff --git a/src/lib_benchmark/ast.ml b/src/lib_benchmark/ast.ml index 8c3194376464..02d02caa2b9e 100644 --- a/src/lib_benchmark/ast.ml +++ b/src/lib_benchmark/ast.ml @@ -59,7 +59,7 @@ module type S = sig val pp : Format.formatter -> _ t -> unit (** To OCaml parsetree *) - val to_expression : _ t -> Parsetree.expression + val to_expression : _ t -> Ppxlib.expression (** Existentials *) @@ -147,7 +147,7 @@ struct | Variable _ -> 1 module Parsetree = struct - open Ast_helper + open Ppxlib.Ast_helper let loc txt = {Asttypes.txt; loc = Location.none} @@ -163,12 +163,12 @@ struct let call f args = let f = WithExceptions.Option.get ~loc:__LOC__ @@ Longident.unflatten f in - let args = List.map (fun x -> (Asttypes.Nolabel, x)) args in + let args = List.map (fun x -> (Ppxlib.Nolabel, x)) args in Exp.(apply (ident (loc f)) args) let string_of_fv fv = Format.asprintf "%a" Free_variable.pp fv - let rec to_expression : type a. a t -> Parsetree.expression = function + let rec to_expression : type a. a t -> Ppxlib.expression = function | Bool true -> Exp.construct (loc_ident "true") None | Bool false -> Exp.construct (loc_ident "false") None | Size (Int i) -> call (saturated "safe_int") [Exp.constant (Const.int i)] @@ -222,7 +222,7 @@ struct let to_expression = Parsetree.to_expression - let pp ppf t = Pprintast.expression ppf @@ Parsetree.to_expression t + let pp ppf t = Ppxlib.Pprintast.expression ppf @@ Parsetree.to_expression t (* Existential *) diff --git a/src/lib_benchmark/ast.mli b/src/lib_benchmark/ast.mli index 4737815ad62d..c8ecbf19b2e1 100644 --- a/src/lib_benchmark/ast.mli +++ b/src/lib_benchmark/ast.mli @@ -59,7 +59,7 @@ module type S = sig val pp : Format.formatter -> _ t -> unit (** To OCaml parsetree *) - val to_expression : _ t -> Parsetree.expression + val to_expression : _ t -> Ppxlib.expression (** Existentials *) diff --git a/src/lib_benchmark/codegen.ml b/src/lib_benchmark/codegen.ml index 0da8bceaaa46..1c66df426688 100644 --- a/src/lib_benchmark/codegen.ml +++ b/src/lib_benchmark/codegen.ml @@ -46,7 +46,7 @@ let () = | _ -> None) module Codegen_helpers = struct - open Ast_helper + open Ppxlib.Ast_helper let loc txt = {Asttypes.txt; loc = Location.none} @@ -68,14 +68,15 @@ module Codegen_helpers = struct let string_of_fv fv = Format.asprintf "%a" Free_variable.pp fv end -module Codegen : Costlang.S with type 'a repr = Parsetree.expression = struct - type 'a repr = Parsetree.expression +module Codegen : Costlang.S with type 'a repr = Ppxlib.expression = struct + type 'a repr = Ppxlib.expression type size = int let size_ty = Costlang.Ty.int open Codegen_helpers + open Ppxlib open Ast_helper let true_ = Exp.construct (loc_ident "true") None @@ -133,8 +134,9 @@ module Codegen : Costlang.S with type 'a repr = Parsetree.expression = struct end (* Very similar to Codegen but for human eyes *) -module Comment : Costlang.S with type 'a repr = Parsetree.expression = struct +module Comment : Costlang.S with type 'a repr = Ppxlib.expression = struct include Codegen + open Ppxlib open Ast_helper open Codegen_helpers @@ -150,20 +152,19 @@ module Comment : Costlang.S with type 'a repr = Parsetree.expression = struct end let detach_funcs = - let open Parsetree in let rec aux acc expr = - match expr with - | { - pexp_desc = Pexp_fun (_, _, {ppat_desc = Ppat_var {txt = arg; _}; _}, expr'); - _; - } -> - aux (arg :: acc) expr' - | _ -> (acc, expr) + let pattern = Ppxlib.Ast_pattern.(pexp_fun drop drop (ppat_var __) __) in + Ppxlib.Ast_pattern.parse + pattern + Location.none + ~on_error:(fun () -> (acc, expr)) + expr + @@ fun label body -> aux (label :: acc) body in aux [] let rec restore_funcs ~used_vars (acc, expr) = - let open Ast_helper in + let open Ppxlib.Ast_helper in match acc with | arg :: acc -> let arg = @@ -174,7 +175,7 @@ let rec restore_funcs ~used_vars (acc, expr) = | [] -> expr let open_m = - let open Ast_helper in + let open Ppxlib.Ast_helper in let open Codegen_helpers in Str.open_ (Opn.mk (Mod.ident (loc_ident "S.Syntax"))) @@ -189,20 +190,27 @@ let open_m = If [takes_saturation_reprs=true], skips [let sizeN = S.safe_int sizeN in] *) let generate_let_binding = - let open Ast_helper in + let open Ppxlib.Ast_helper in let open Codegen_helpers in fun ~takes_saturation_reprs name expr -> let args, expr = detach_funcs expr in let used_vars = let vs = ref [] in - let super = Ast_iterator.default_iterator in - let f_expr (i : Ast_iterator.iterator) e = - match e.Parsetree.pexp_desc with - | Pexp_ident {txt = Longident.Lident v; _} -> vs := v :: !vs - | _ -> super.expr i e + let i = + object + inherit Ppxlib.Ast_traverse.iter as super + + method! expression e = + Ppxlib.Ast_pattern.( + parse + (pexp_ident (lident __)) + Location.none + ~on_error:(fun () -> super#expression e) + e + @@ fun v -> vs := v :: !vs) + end in - let i = {super with expr = f_expr} in - i.expr i expr ; + i#expression expr ; !vs in let expr = @@ -222,7 +230,7 @@ let generate_let_binding = args in let expr = restore_funcs ~used_vars (args, expr) in - Str.value Asttypes.Nonrecursive [Vb.mk (pvar name) expr] + Str.value Ppxlib.Asttypes.Nonrecursive [Vb.mk (pvar name) expr] (* ------------------------------------------------------------------------- *) type solution = { @@ -321,7 +329,7 @@ type code = | Item of { comments : string list; name : string option; - code : Parsetree.structure_item; + code : Ppxlib.structure_item; } type module_ = code list @@ -341,7 +349,7 @@ let pp_code fmtr = lines | Item {comments; name = _; code} -> List.iter (fprintf fmtr "(* %s *)@;") comments ; - Pprintast.structure_item fmtr code + Ppxlib.Pprintast.structure_item fmtr code let pp_module fmtr items = let open Format in @@ -361,7 +369,7 @@ let pp_module fmtr items = Format.pp_print_string fmtr s let make_toplevel_module structure_items = - let open Ast_helper in + let open Ppxlib.Ast_helper in let open Codegen_helpers in let this_file_was_autogenerated = Comment @@ -433,7 +441,7 @@ let codegen (Model.Model model) (sol : solution) let module M = M.Def (X) in let expr = X.prj M.model in (* Need to think the indentation by the comment head *) - let expr = Format.asprintf "(* @[%a@]" Pprintast.expression expr in + let expr = Format.asprintf "(* @[%a@]" Ppxlib.Pprintast.expression expr in let expr = Stdlib.Option.get @@ String.remove_prefix ~prefix:"(* " expr in ["model " ^ Namespace.to_string model_name; expr] in @@ -495,7 +503,7 @@ let%expect_test "basic_printing" = let_ ~name:"tmp2" (int 43) @@ fun tmp2 -> x + y + tmp1 + tmp2 in let item = generate_let_binding ~takes_saturation_reprs:false "name" term in - Format.printf "%a" Pprintast.structure_item item ; + Format.printf "%a" Ppxlib.Pprintast.structure_item item ; [%expect {| let name x y = @@ -511,7 +519,7 @@ let%expect_test "anonymous_int_literals" = lam ~name:"y" @@ fun y -> x + y + int 42 + int 43 in let item = generate_let_binding ~takes_saturation_reprs:false "name" term in - Format.printf "%a" Pprintast.structure_item item ; + Format.printf "%a" Ppxlib.Pprintast.structure_item item ; [%expect {| let name x y = @@ -527,7 +535,7 @@ let%expect_test "let_bound_lambda" = app incr x + app incr y in let item = generate_let_binding ~takes_saturation_reprs:false "name" term in - Format.printf "%a" Pprintast.structure_item item ; + Format.printf "%a" Ppxlib.Pprintast.structure_item item ; [%expect {| let name x y = @@ -543,7 +551,7 @@ let%expect_test "ill_typed_higher_order" = lam ~name:"y" @@ fun y -> app incr x + app incr y in let item = generate_let_binding ~takes_saturation_reprs:false "name" term in - Format.printf "%a" Pprintast.structure_item item ; + Format.printf "%a" Ppxlib.Pprintast.structure_item item ; [%expect {| let name incr x y = @@ -557,7 +565,7 @@ let%expect_test "if_conditional_operator" = lam ~name:"y" @@ fun y -> if_ (lt x y) y x in let item = generate_let_binding ~takes_saturation_reprs:false "name" term in - Format.printf "%a" Pprintast.structure_item item ; + Format.printf "%a" Ppxlib.Pprintast.structure_item item ; [%expect {| let name x y = @@ -611,7 +619,7 @@ let%expect_test "takes_saturation_reprs" = let_ ~name:"tmp2" (int 43) @@ fun tmp2 -> x + y + tmp1 + tmp2 in let item = generate_let_binding ~takes_saturation_reprs:true "name" term in - Format.printf "%a" Pprintast.structure_item item ; + Format.printf "%a" Ppxlib.Pprintast.structure_item item ; [%expect {| let name x y = -- GitLab