From 1be8b7ef6489dc6b4f18bd7d0206819b75922b82 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sat, 20 Apr 2024 09:52:38 +0200 Subject: [PATCH] WIP --- compiler/lib/driver.ml | 3 ++- compiler/lib/flow.ml | 24 ++++++++++++++++++++---- compiler/lib/flow.mli | 2 +- compiler/lib/pure_fun.ml | 3 ++- compiler/lib/shape.ml | 9 ++++++++- compiler/lib/shape.mli | 2 ++ compiler/lib/specialize.ml | 2 +- toplevel/examples/lwt_toplevel/dune | 2 ++ 8 files changed, 38 insertions(+), 9 deletions(-) diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index fb629ae4e1..45db7ac298 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -650,6 +650,7 @@ if (typeof module === 'object' && module.exports) { let collects_shapes p = let _, info = Flow.f p in + let pure = Pure_fun.f p in let l = ref StringMap.empty in Code.Addr.Map.iter (fun _ block -> @@ -660,7 +661,7 @@ let collects_shapes p = , Prim ( Extern "caml_register_global" , [ _code; Pv block; Pc (NativeString name) ] ) ) -> - let shape = Flow.the_shape_of info block in + let shape = Flow.the_shape_of ~pure info block in let name = match name with | Byte s -> s diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 72d08f1889..51a185dd49 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -397,7 +397,7 @@ let direct_approx (info : Info.t) x = y | _ -> None -let rec the_shape_of info x = +let rec the_shape_of ~pure info x = let rec loop info x acc : Shape.t = get_approx info @@ -407,9 +407,10 @@ let rec the_shape_of info x = | None -> ( match info.info_defs.(Var.idx x) with | Expr (Block (_, a, _, Immutable)) -> - Shape.Block (List.map ~f:(the_shape_of info) (Array.to_list a)) + Shape.Block (List.map ~f:(the_shape_of ~pure info) (Array.to_list a)) | Expr (Closure (l, _)) -> - Shape.Function { arity = List.length l; pure = false; res = Top "unk" } + let pure = Code.Var.Set.mem x pure in + Shape.Function { arity = List.length l; pure; res = Top "unk" } | Expr (Special (Alias_prim name)) -> ( try let arity = Primitive.arity name in @@ -429,7 +430,22 @@ let rec the_shape_of info x = | Shape.Block _ | Shape.Top _ -> Shape.Top "apply2") | _ -> Shape.Top "other")) (Top "init") - (fun _u _v -> Shape.Top "merge") + (fun u v -> + let rec merge (u : Shape.t) (v : Shape.t) = + match u, v with + | ( Function { arity = a1; pure = p1; res = r1 } + , Function { arity = a2; pure = p2; res = r2 } ) -> + if a1 = a2 + then Shape.Function { arity = a1; pure = p1 && p2; res = merge r1 r2 } + else Shape.Top "merge" + | Block b1, Block b2 -> + if List.length b1 = List.length b2 + then Block (List.map2 b1 b2 ~f:merge) + else Top "merge block" + | (Top _ as a), _ | _, (Top _ as a) -> a + | Function _, Block _ | Block _, Function _ -> Shape.Top "merge block/fun" + in + merge u v) x in loop info x [] diff --git a/compiler/lib/flow.mli b/compiler/lib/flow.mli index c4e6ecfdab..75748625d8 100644 --- a/compiler/lib/flow.mli +++ b/compiler/lib/flow.mli @@ -60,6 +60,6 @@ val the_native_string_of : Info.t -> Code.prim_arg -> Code.Native_string.t optio val the_int : Info.t -> Code.prim_arg -> int32 option -val the_shape_of : Info.t -> Code.Var.t -> Shape.t +val the_shape_of : pure:Code.Var.Set.t -> Info.t -> Code.Var.t -> Shape.t val f : ?skip_param:bool -> Code.program -> Code.program * Info.t diff --git a/compiler/lib/pure_fun.ml b/compiler/lib/pure_fun.ml index 8e566fd135..f055e49028 100644 --- a/compiler/lib/pure_fun.ml +++ b/compiler/lib/pure_fun.ml @@ -26,7 +26,8 @@ let pure_expr pure_funs e = match e with | Block _ | Field _ | Closure _ | Constant _ -> true | Special (Alias_prim _ | Undefined) -> true - | Apply { f; exact; _ } -> exact && Var.Set.mem f pure_funs + | Apply { f; exact; _ } -> + exact && (Var.Set.mem f pure_funs || Shape.State.is_pure_fun f) | Prim (p, _l) -> ( match p with | Extern f -> Primitive.is_pure f diff --git a/compiler/lib/shape.ml b/compiler/lib/shape.ml index 9bd70dfc44..7ab609f3b8 100644 --- a/compiler/lib/shape.ml +++ b/compiler/lib/shape.ml @@ -46,7 +46,8 @@ let rec to_string (shape : t) = match shape with | Top s -> if true then "N" else Printf.sprintf "N(%s)" s | Block l -> "[" ^ String.concat ~sep:"," (List.map ~f:to_string l) ^ "]" - | Function { arity; _ } -> Printf.sprintf "F(%d)" arity + | Function { arity; pure; _ } -> + Printf.sprintf "F(%d)%s" arity (if pure then "" else "") module Store = struct module T = Hashtbl.Make (struct @@ -153,5 +154,11 @@ module State = struct let get x = T.find_opt t x + let is_pure_fun x = + match T.find_opt t x with + | None -> false + | Some (Top _ | Block _) -> false + | Some (Function { pure; _ }) -> pure + let reset () = T.clear t end diff --git a/compiler/lib/shape.mli b/compiler/lib/shape.mli index b5dc788032..85bacfa547 100644 --- a/compiler/lib/shape.mli +++ b/compiler/lib/shape.mli @@ -53,5 +53,7 @@ module State : sig val get : Code.Var.t -> t option + val is_pure_fun : Code.Var.t -> bool + val reset : unit -> unit end diff --git a/compiler/lib/specialize.ml b/compiler/lib/specialize.ml index 35afaa9d36..93afd24724 100644 --- a/compiler/lib/specialize.ml +++ b/compiler/lib/specialize.ml @@ -21,7 +21,7 @@ open! Stdlib open Code let function_arity info x = - match Flow.the_shape_of info x with + match Flow.the_shape_of ~pure:Code.Var.Set.empty info x with | Top _ | Block _ -> None | Function { arity; _ } -> Some arity diff --git a/toplevel/examples/lwt_toplevel/dune b/toplevel/examples/lwt_toplevel/dune index 7d17aa55a5..e27af569e1 100644 --- a/toplevel/examples/lwt_toplevel/dune +++ b/toplevel/examples/lwt_toplevel/dune @@ -69,6 +69,7 @@ (action (run %{bin:js_of_ocaml} + --no-runtime --pretty --toplevel %{read-strings:effects_flags.txt} @@ -79,6 +80,7 @@ (action (run %{bin:js_of_ocaml} + --no-runtime --pretty --toplevel --include-runtime