Experiment with some static evalution

compiler/lib-wasm/generate.ml

@@ -2474,6 +2474,16 @@ module Generate (Target : Target_sig.S) = struct
     Typing.reset ();
     Primitive.register "caml_make_array" `Mutable None None;
     Primitive.register "caml_array_of_uniform_array" `Mutable None None;
+    Primitive.register "caml_array_unsafe_get" `Mutable None None;
+    Primitive.register "caml_alloc_dummy" `Pure None None;
+    Primitive.register "caml_alloc_dummy_float" `Pure None None;
+    Primitive.register "caml_alloc_dummy_mixed" `Pure None None;
+    Primitive.register "caml_js_to_int32" `Pure None None;
+    Primitive.register "caml_js_to_nativeint" `Pure None None;
+    Primitive.register "caml_js_from_bool" `Pure None None;
+    Primitive.register "caml_js_to_bool" `Pure None None;
+    Primitive.register "caml_js_equals" `Mutable None None;
+    Primitive.register "caml_js_strict_equals" `Mutable None None;
     (* These primitives are rewritten by [Specialize_js] before code
        generation, but need to be registered so that
        [Primitive.get_external] reports them as available for the

compiler/lib/eval.ml

@@ -17,6 +17,23 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
+(*
+Static evaluation
+=================
+- Limited amount of fuel
+- Cannot return a static boxed constant
+  (`return x` where x is a constant global variable (not in env),
+   or a parameter from the initial call)
+- Deal with constant tuples (see one_ulp / lower_bound_for_int)
+
+We need to keep track of whether we have a global constant,
+a small constant, a tuple built during evaluation.
+==> beware of sharing when building a tuple (maybe do not allow tuple of anything but small constants and global constants? at least after evaluation)
+==> should keep referring to global constants and not duplicate them
+
+Add tests
+*)
+
 open! Stdlib
 open Code
 open Flow
@@ -27,6 +44,8 @@ let stats = Debug.find "stats"
 
 let debug_stats = Debug.find "stats-debug"
 
+let debug_static_eval = Debug.find "static-eval"
+
 let static_env = String.Hashtbl.create 17
 
 let clear_static_env () = String.Hashtbl.clear static_env
@@ -138,6 +157,16 @@ let nativeint_shiftop (l : constant list) (f : int32 -> int -> int32) : constant
   | [ NativeInt i; Int j ] -> Some (NativeInt (f i (Targetint.to_int_exn j)))
   | _ -> None
 
+let eval_comparison op args =
+  match args with
+  | [ Int i; Int j ] -> bool (op (Targetint.compare i j) 0)
+  | [ Int32 i; Int32 j ] -> bool (op (Int32.compare i j) 0)
+  | [ Int64 i; Int64 j ] -> bool (op (Int64.compare i j) 0)
+  | [ NativeInt i; NativeInt j ] -> bool (op (Int32.compare i j) 0)
+  | [ Float f; Float g ] ->
+      bool (op (Float.compare (Int64.float_of_bits f) (Int64.float_of_bits g)) 0)
+  | _ -> None
+
 let quiet_nan n = Int64.logor n 0x00_08_00_00_00_00_00_00L
 
 let eval_prim ~target x =
@@ -362,6 +391,22 @@ let eval_prim ~target x =
           Some (Int (Targetint.of_int_exn (Targetint.num_bits ())))
       | "caml_sys_const_big_endian", [ _ ] -> Some (Int Targetint.zero)
       | "caml_sys_const_naked_pointers_checked", [ _ ] -> Some (Int Targetint.zero)
+      | "caml_sys_const_runtime5", [ _ ] -> Some (Int Targetint.one)
+      | "caml_obj_dup", [ x ] -> (
+          match x with
+          | NativeString _
+          | Float _
+          | Float32 _
+          | Int _
+          | Int32 _
+          | Int64 _
+          | NativeInt _
+          | Null_ -> Some x
+          | String _ | Float_array _ | Tuple _ -> None)
+      | "caml_greaterthan", args -> eval_comparison ( > ) args
+      | "caml_greaterequal", args -> eval_comparison ( >= ) args
+      | "caml_lessthan", args -> eval_comparison ( < ) args
+      | "caml_lessequal", args -> eval_comparison ( <= ) args
       | _ -> None)
   | _ -> None
 
@@ -530,7 +575,214 @@ let constant_equal a b =
   | (String _ | NativeString _), _ -> false
   | (Float_array _ | Tuple _), _ -> false
 
-let eval_instr update_count inline_constant ~target info i =
+let static_eval_fuel = 1000
+
+let rec eval_block ~fuel ~info ~blocks ~target ~env pc args =
+  if !fuel <= 0
+  then None
+  else (
+    decr fuel;
+    let block = Addr.Map.find pc blocks in
+    let env =
+      List.fold_left2
+        ~f:(fun env x x' ->
+          match resolve ~info ~env (Pv x') with
+          | None -> Var.Map.remove x env
+          | Some c -> Var.Map.add x c env)
+        block.params
+        args
+        ~init:env
+    in
+    match eval_block_body ~fuel ~info ~blocks ~target ~env block.body with
+    | None -> None
+    | Some env -> (
+        if debug_static_eval ()
+        then Format.eprintf "instr %a@." Code.Print.last block.branch;
+        match block.branch with
+        | Return x -> resolve ~info ~env (Pv x)
+        | Branch (pc', args') -> eval_block ~fuel ~info ~blocks ~target ~env pc' args'
+        | Cond (x, (pc1, args1), (pc2, args2)) -> (
+            match resolve ~info ~env (Pv x) with
+            | Some (Int i) when Targetint.is_zero i ->
+                eval_block ~fuel ~info ~blocks ~target ~env pc2 args2
+            | Some (Int _ | Tuple _) ->
+                eval_block ~fuel ~info ~blocks ~target ~env pc1 args1
+            | _ -> None)
+        | Switch (x, conts) -> (
+            match resolve ~info ~env (Pv x) with
+            | Some (Int i) ->
+                let pc', args' = conts.(Targetint.to_int_exn i) in
+                eval_block ~fuel ~info ~blocks ~target ~env pc' args'
+            | _ -> None)
+        | Raise _ | Stop | Pushtrap _ | Poptrap _ -> None))
+
+and resolve ~info ~env ?(eq = constant_equal) a =
+  match
+    match a with
+    | Pv x -> Var.Map.find_opt x env
+    | _ -> None
+  with
+  | Some _ as c -> c
+  | None -> the_const_of ~eq info a
+
+and eval_block_body ~fuel ~info ~blocks ~target ~env instrs =
+  (if debug_static_eval ()
+   then
+     match instrs with
+     | i :: _ -> Format.eprintf "instr %a@." Code.Print.instr i
+     | [] -> ());
+  match instrs with
+  | [] -> Some env
+  | Event _ :: rem -> eval_block_body ~fuel ~info ~blocks ~target ~env rem
+  | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) :: rem
+    -> (
+      let eq e1 e2 =
+        match Code.Constant.ocaml_equal e1 e2 with
+        | None -> false
+        | Some e -> e
+      in
+      match resolve ~info ~env ~eq y, resolve ~info ~env ~eq z with
+      | Some e1, Some e2 -> (
+          match Code.Constant.ocaml_equal e1 e2 with
+          | None -> None
+          | Some c ->
+              let c =
+                match prim with
+                | "caml_equal" -> c
+                | "caml_notequal" -> not c
+                | _ -> assert false
+              in
+              eval_block_body
+                ~fuel
+                ~info
+                ~blocks
+                ~target
+                ~env:(Var.Map.add x (bool' c) env)
+                rem)
+      | _ -> None)
+  | Let (x, Prim (IsInt, [ y ])) :: rem -> (
+      let res =
+        match is_int info y with
+        | Y -> Some true
+        | N -> Some false
+        | Unknown -> (
+            match resolve ~info ~env y with
+            | Some (Int _) -> Some true
+            | Some _ -> Some false
+            | None -> None)
+      in
+      match res with
+      | None -> None
+      | Some b ->
+          eval_block_body
+            ~fuel
+            ~info
+            ~blocks
+            ~target
+            ~env:(Var.Map.add x (bool' b) env)
+            rem)
+  | Let (x, Prim (Extern "caml_obj_tag", [ y ])) :: rem -> (
+      match resolve ~info ~env y with
+      | Some (Tuple (tag, _, _)) ->
+          eval_block_body
+            ~fuel
+            ~info
+            ~blocks
+            ~target
+            ~env:(Var.Map.add x (Int (Targetint.of_int_exn tag)) env)
+            rem
+      | _ -> None)
+  | (Let (x, Prim (prim, prim_args)) as i) :: rem -> (
+      let prim_args' = List.map prim_args ~f:(fun a -> resolve ~info ~env a) in
+      if List.exists prim_args' ~f:Option.is_none
+      then (
+        if debug_static_eval ()
+        then (
+          List.iter prim_args' ~f:(fun a ->
+              Format.eprintf "%s" (if Option.is_some a then "x" else "?"));
+          Format.eprintf "@.");
+        None)
+      else
+        let res =
+          eval_prim
+            ~target
+            ( prim
+            , List.map prim_args' ~f:(function
+                | Some c -> c
+                | None -> assert false) )
+        in
+        match res with
+        | None ->
+            if debug_static_eval () then Format.eprintf "INSTR %a@." Code.Print.instr i;
+            None
+        | Some c ->
+            eval_block_body ~fuel ~info ~blocks ~target ~env:(Var.Map.add x c env) rem)
+  | Let (x, Constant c) :: rem -> (
+      match c with
+      | Float _
+      | Float32 _
+      | Int _
+      | Int32 _
+      | Int64 _
+      | NativeInt _
+      | NativeString _
+      | Float_array _
+      | Null_ ->
+          eval_block_body ~fuel ~info ~blocks ~target ~env:(Var.Map.add x c env) rem
+      | String _ | Tuple _ -> None)
+  | Let (x, Apply { f; args; _ }) :: rem -> (
+      match get_approx info (fun g -> Flow.Info.def info g) None (fun _ _ -> None) f with
+      | Some (Closure (params, (pc, args'), _)) when List.compare_lengths args params = 0
+        ->
+          let args = List.map args ~f:(fun x -> resolve ~info ~env (Pv x)) in
+          if List.for_all args ~f:Option.is_some
+          then
+            let callee_env =
+              List.fold_left2
+                ~f:(fun s x v -> Var.Map.add x (Option.get v) s)
+                params
+                args
+                ~init:Var.Map.empty
+            in
+            match eval_block ~fuel ~info ~blocks ~target ~env:callee_env pc args' with
+            | Some c ->
+                eval_block_body ~fuel ~info ~blocks ~target ~env:(Var.Map.add x c env) rem
+            | None -> None
+          else None
+      | _ -> None)
+  | Let (x, Block (tag, fields, _, _)) :: rem ->
+      let fields = Array.map fields ~f:(fun x -> resolve ~info ~env (Pv x)) in
+      if Array.exists fields ~f:Option.is_none
+      then None
+      else
+        let fields =
+          Array.map fields ~f:(function
+            | Some c -> c
+            | None -> assert false)
+        in
+        eval_block_body
+          ~fuel
+          ~info
+          ~blocks
+          ~target
+          ~env:(Var.Map.add x (Tuple (tag, fields, Unknown)) env)
+          rem
+  | Let (x, Field (y, i, _)) :: rem -> (
+      match resolve ~info ~env (Pv y) with
+      | Some (Tuple (_, fields, _)) when i < Array.length fields ->
+          eval_block_body
+            ~fuel
+            ~info
+            ~blocks
+            ~target
+            ~env:(Var.Map.add x fields.(i) env)
+            rem
+      | _ -> None)
+  | ( Let (_, (Closure _ | Special _))
+    | Assign _ | Set_field _ | Offset_ref _ | Array_set _ )
+    :: _ -> None
+
+let eval_instr update_count inline_constant ~target info ~blocks i =
   match i with
   | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> (
       let eq e1 e2 =
@@ -721,6 +973,39 @@ let eval_instr update_count inline_constant ~target info i =
                             they're not represented with constant in javascript. *)
                             | None, _ -> arg)) ) )
           ])
+  | Let (x, Apply { f; args; _ }) -> (
+      match get_approx info (fun g -> Flow.Info.def info g) None (fun _ _ -> None) f with
+      | Some (Closure (params, (pc, args'), _)) when List.compare_lengths args params = 0
+        ->
+          let args =
+            List.map args ~f:(fun x -> the_const_of ~eq:constant_equal info (Pv x))
+          in
+          if List.for_all args ~f:Option.is_some
+          then (
+            if debug_static_eval () then Format.eprintf "ZZZ %a@." Code.Var.print f;
+            let env =
+              List.fold_left2
+                ~f:(fun s x v -> Var.Map.add x (Option.get v) s)
+                params
+                args
+                ~init:Var.Map.empty
+            in
+            let fuel = ref static_eval_fuel in
+            match eval_block ~fuel ~info ~blocks ~target ~env pc args' with
+            | Some (Tuple _ | Float_array _) ->
+                (* The outcome is not supposed to be a block; emitting one as
+                   a constant loses the array_or_not / field-type information
+                   the back-end needs (e.g. for float records). *)
+                [ i ]
+            | Some c ->
+                if debug_static_eval () then Format.eprintf "===> STATIC@.";
+                let c = Constant c in
+                Flow.Info.update_def info x c;
+                incr update_count;
+                [ Let (x, c) ]
+            | None -> [ i ])
+          else [ i ]
+      | _ -> [ i ])
   | _ -> [ i ]
 
 type cond_of =
@@ -853,7 +1138,7 @@ let eval update_count update_branch inline_constant ~target info blocks =
       let body =
         List.concat_map
           block.body
-          ~f:(eval_instr update_count inline_constant ~target info)
+          ~f:(eval_instr update_count inline_constant ~blocks ~target info)
       in
       let branch = eval_branch update_branch info block.branch in
       { block with Code.body; Code.branch })

runtime/js/obj.js

@@ -30,7 +30,7 @@ function caml_update_dummy(x, y) {
   return 0;
 }
 
-//Provides: caml_alloc_dummy_infix
+//Provides: caml_alloc_dummy_infix pure
 //Requires: caml_call_gen
 //Version: < 5.4
 function caml_alloc_dummy_infix() {
@@ -39,7 +39,7 @@ function caml_alloc_dummy_infix() {
   };
 }
 
-//Provides: caml_alloc_dummy_lazy
+//Provides: caml_alloc_dummy_lazy pure
 //Version: >= 5.4
 function caml_alloc_dummy_lazy(_unit) {
   return [0, 0];

runtime/js/sys.js

@@ -161,7 +161,7 @@ function caml_sys_unsafe_getenv(name) {
   return caml_sys_getenv(name);
 }
 
-//Provides: caml_argv
+//Provides: caml_argv mutable
 //Requires: caml_string_of_jsstring
 var caml_argv = (function () {
   var process = globalThis.process;