WIP: experiment with a faster analysis

Author: vouillon

compiler/lib/global_flow.ml

@@ -100,6 +100,7 @@ type state =
   ; applied_functions : (Var.t * Var.t, unit) Hashtbl.t
         (* Functions that have been already considered at a call site.
            This is to avoid repeated computations *)
+  ; fast : bool
   }
 
 let add_var st x = Var.ISet.add st.vars x
@@ -126,7 +127,8 @@ let add_assign_def st x y =
 let add_param_def st x =
   add_var st x;
   let idx = Var.idx x in
-  assert (is_undefined st.defs.(idx))
+  assert (is_undefined st.defs.(idx));
+  if st.fast then st.defs.(idx) <- Phi { known = Var.Set.empty; others = true }
 
 let rec arg_deps st ?ignore params args =
   match params, args with
@@ -155,6 +157,12 @@ let expr_deps blocks st x e =
       (* The analysis knowns about these primitives, and will compute
          an approximation of the value they return based on an
          approximation of their arguments *)
+      (if st.fast
+      then
+        match l with
+        | Pv x :: _ -> do_escape st Escape x
+        | Pc _ :: _ -> ()
+        | [] -> assert false);
       List.iter
         ~f:(fun a ->
           match a with
@@ -207,7 +215,7 @@ let expr_deps blocks st x e =
       match st.defs.(Var.idx f) with
       | Expr (Closure (params, _)) when List.length args = List.length params ->
           Hashtbl.add st.applied_functions (x, f) ();
-          List.iter2 ~f:(fun p a -> add_assign_def st p a) params args;
+          if not st.fast then List.iter2 ~f:(fun p a -> add_assign_def st p a) params args;
           Var.Set.iter (fun y -> add_dep st x y) (Var.Map.find f st.return_values)
       | _ -> ())
   | Closure (l, cont) ->
@@ -243,17 +251,19 @@ let program_deps st { blocks; _ } =
             ~f:(fun i (pc, _) ->
               Hashtbl.replace h pc (i :: (try Hashtbl.find h pc with Not_found -> [])))
             a2;
-          Hashtbl.iter
-            (fun pc tags ->
-              let block = Addr.Map.find pc blocks in
-              List.iter
-                ~f:(fun i ->
-                  match i with
-                  | Let (y, Field (x', _)) when Var.equal x x' ->
-                      Hashtbl.add st.known_cases y tags
-                  | _ -> ())
-                block.body)
-            h
+          if not st.fast
+          then
+            Hashtbl.iter
+              (fun pc tags ->
+                let block = Addr.Map.find pc blocks in
+                List.iter
+                  ~f:(fun i ->
+                    match i with
+                    | Let (y, Field (x', _)) when Var.equal x x' ->
+                        Hashtbl.add st.known_cases y tags
+                    | _ -> ())
+                  block.body)
+              h
       | Pushtrap (cont, x, cont_h, _) ->
           add_var st x;
           st.defs.(Var.idx x) <- Phi { known = Var.Set.empty; others = true };
@@ -406,31 +416,34 @@ let propagate st ~update approx x =
           | Top -> Top)
       | Prim (Extern "caml_check_bound", [ Pv y; _ ]) -> Var.Tbl.get approx y
       | Prim ((Array_get | Extern "caml_array_unsafe_get"), [ Pv y; _ ]) -> (
-          match Var.Tbl.get approx y with
-          | Values { known; others } ->
-              Domain.join_set
-                ~update
-                ~st
-                ~approx
-                ~others
-                (fun z ->
-                  match st.defs.(Var.idx z) with
-                  | Expr (Block (_, lst, _)) ->
-                      Array.iter ~f:(fun t -> add_dep st x t) lst;
-                      let a =
-                        Array.fold_left
-                          ~f:(fun acc t ->
-                            Domain.join ~update ~st ~approx (Var.Tbl.get approx t) acc)
-                          ~init:Domain.bot
-                          lst
-                      in
-                      if st.possibly_mutable.(Var.idx z)
-                      then Domain.join ~update ~st ~approx Domain.others a
-                      else a
-                  | Expr (Closure _) -> Domain.bot
-                  | Phi _ | Expr _ -> assert false)
-                known
-          | Top -> Top)
+          if st.fast
+          then Domain.others
+          else
+            match Var.Tbl.get approx y with
+            | Values { known; others } ->
+                Domain.join_set
+                  ~update
+                  ~st
+                  ~approx
+                  ~others
+                  (fun z ->
+                    match st.defs.(Var.idx z) with
+                    | Expr (Block (_, lst, _)) ->
+                        Array.iter ~f:(fun t -> add_dep st x t) lst;
+                        let a =
+                          Array.fold_left
+                            ~f:(fun acc t ->
+                              Domain.join ~update ~st ~approx (Var.Tbl.get approx t) acc)
+                            ~init:Domain.bot
+                            lst
+                        in
+                        if st.possibly_mutable.(Var.idx z)
+                        then Domain.join ~update ~st ~approx Domain.others a
+                        else a
+                    | Expr (Closure _) -> Domain.bot
+                    | Phi _ | Expr _ -> assert false)
+                  known
+            | Top -> Top)
       | Prim (Array_get, _) -> assert false
       | Prim ((Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) ->
           (* The result of these primitive is neither a function nor a
@@ -457,12 +470,14 @@ let propagate st ~update approx x =
                       if not (Hashtbl.mem st.applied_functions (x, g))
                       then (
                         Hashtbl.add st.applied_functions (x, g) ();
-                        List.iter2
-                          ~f:(fun p a ->
-                            add_assign_def st p a;
-                            update ~children:false p)
-                          params
-                          args;
+                        if not st.fast
+                        then
+                          List.iter2
+                            ~f:(fun p a ->
+                              add_assign_def st p a;
+                              update ~children:false p)
+                            params
+                            args;
                         Var.Set.iter
                           (fun y -> add_dep st x y)
                           (Var.Map.find g st.return_values));
@@ -550,6 +565,7 @@ let f p =
     ; possibly_mutable
     ; known_cases = Hashtbl.create 16
     ; applied_functions = Hashtbl.create 16
+    ; fast = not (Config.Flag.effects ())
     }
   in
   program_deps st p;

compiler/lib/specialize.ml

@@ -49,13 +49,16 @@ let function_arity info x =
   in
   arity info x []
 
+let count = ref 0
+
 let specialize_instr function_arity (acc, free_pc, extra) i =
   match i with
   | Let (x, Apply { f; args; exact }) when (not exact) && Config.Flag.optcall () -> (
       let n' = List.length args in
       match function_arity f with
       | None -> i :: acc, free_pc, extra
       | Some n when n = n' ->
+          incr count;
           Let (x, Apply { f; args; exact = true }) :: acc, free_pc, extra
       | Some n when n < n' ->
           let v = Code.Var.fresh () in
@@ -84,6 +87,7 @@ let specialize_instr function_arity (acc, free_pc, extra) i =
   | _ -> i :: acc, free_pc, extra
 
 let specialize_instrs ~function_arity p =
+  count := 0;
   let blocks, free_pc =
     Addr.Map.fold
       (fun pc block (blocks, free_pc) ->
@@ -99,6 +103,12 @@ let specialize_instrs ~function_arity p =
       p.blocks
       (Addr.Map.empty, p.free_pc)
   in
+  (*
+  Format.eprintf "EXACT: %d@." !count;*)
   { p with blocks; free_pc }
 
-let f = specialize_instrs
+let f ~function_arity p =
+  let t = Timer.make () in
+  let p = specialize_instrs ~function_arity p in
+  if Debug.find "times" () then Format.eprintf "  specialize: %a@." Timer.print t;
+  p

compiler/tests-compiler/direct_calls.ml

@@ -57,15 +57,15 @@ let%expect_test "direct calls without --enable effects" =
   [%expect
     {|
     function test1(param)
-     {function f(g,x){return g(x)}
+     {function f(g,x){return caml_call1(g,x)}
       var _d_=7;
       f(function(x){return x + 1 | 0},_d_);
       var _e_=4.;
       f(function(x){return x * 2.},_e_);
       return 0}
     //end
     function test2(param)
-     {function f(g,x){return g(x)}
+     {function f(g,x){return caml_call1(g,x)}
       var _c_=7;
       f(function(x){return x + 1 | 0},_c_);
       f(function(x){return caml_call2(Stdlib[28],x,cst_a$0)},cst_a);