Eliminate allocation of dummy function (#1013)

* Runtime: improve internalMod.js

* Tests: new test for recursive functions

* Compiler: eliminate dummy function allocations

* Tests: tune tests

* Tests: tune tests

* Doc

.ocamlformat

@@ -12,4 +12,4 @@ break-infix-before-func
 break-separators=before
 dock-collection-brackets=false
 margin=90
-version=0.14.2
+version=0.14.3

compiler/lib/specialize.ml

@@ -46,7 +46,7 @@ let rec function_cardinality info x acc =
       | _ -> None)
     x
 
-let specialize_instr info (acc, free_pc, extra) i =
+let specialize_instr info dummy_funs (acc, free_pc, extra) i =
   match i with
   | Let (x, Apply (f, l, _)) when Config.Flag.optcall () -> (
       let n' = List.length l in
@@ -76,15 +76,52 @@ let specialize_instr info (acc, free_pc, extra) i =
           , free_pc + 1
           , (free_pc, block) :: extra )
       | _ -> i :: acc, free_pc, extra)
+  (* Some [caml_alloc_dummy_function + caml_update_dummy] can be eliminated *)
+  | Let (x, Prim (Extern "caml_alloc_dummy_function", [ _; _ ])) as i ->
+      let acc =
+        if Var.Map.exists (fun _ x' -> Var.equal x x') dummy_funs then acc else i :: acc
+      in
+      acc, free_pc, extra
+  | Let (_, Prim (Extern "caml_update_dummy", [ Pv _; Pv clo ])) as i ->
+      let acc = if Var.Map.mem clo dummy_funs then acc else i :: acc in
+      acc, free_pc, extra
+  | Let (x, e) when Var.Map.mem x dummy_funs ->
+      let acc =
+        let new_x = Var.Map.find x dummy_funs in
+        Let (new_x, e) :: acc
+      in
+      acc, free_pc, extra
   | _ -> i :: acc, free_pc, extra
 
+let buid_dummy_functions_map p =
+  let dummy_alloc, update =
+    Addr.Map.fold
+      (fun _ block acc ->
+        List.fold_left block.body ~init:acc ~f:(fun ((alloc, update) as acc) i ->
+            match i with
+            | Let (dummy, Prim (Extern "caml_alloc_dummy_function", [ _; _ ])) ->
+                (* [dummy] will be bound once only, it's an invariant *)
+                Var.Set.add dummy alloc, update
+            | Let (_, Prim (Extern "caml_update_dummy", [ Pv dummy; Pv clo_var ])) ->
+                assert (not (Var.Map.mem clo_var update));
+                alloc, Var.Map.add clo_var dummy update
+            | _ -> acc))
+      p
+      (Var.Set.empty, Var.Map.empty)
+  in
+  (* We only want to keep [caml_update_dummy] and correspond to
+     [caml_alloc_dummy_function]]. There are occurrences of [caml_update_dummy] that are
+     unrelated (e.g. [let rec unfinite_zeros = 0 :: unfinite_zeros]) *)
+  Var.Map.filter (fun _clo dummy -> Var.Set.mem dummy dummy_alloc) update
+
 let specialize_instrs info p =
+  let dummy_funs = buid_dummy_functions_map p.blocks in
   let blocks, free_pc =
     Addr.Map.fold
       (fun pc block (blocks, free_pc) ->
         let body, free_pc, extra =
           List.fold_right block.body ~init:([], free_pc, []) ~f:(fun i acc ->
-              specialize_instr info acc i)
+              specialize_instr info dummy_funs acc i)
         in
         let blocks =
           List.fold_left extra ~init:blocks ~f:(fun blocks (pc, b) ->

compiler/tests-compiler/recfun.ml

@@ -0,0 +1,114 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2020 Hugo Heuzard
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+
+open Util
+
+module M = struct
+  type state = int
+
+  type hash_value = int
+
+  let get_hash_value x = x
+
+  let create () = 42
+
+  let fold_int state i = state + i
+
+  let hash_fold_string state s = state + String.length s
+
+  let hash_fold_list fold state l = List.fold_left fold state l
+
+  type t =
+    | Atom of string
+    | List of t list
+
+  let rec (hash_fold_t : state -> t -> state) =
+    (fun hsv arg ->
+       match arg with
+       | Atom _a0 ->
+           let hsv = fold_int hsv 0 in
+           let hsv = hsv in
+           hash_fold_string hsv _a0
+       | List _a0 ->
+           let hsv = fold_int hsv 1 in
+           let hsv = hsv in
+           hash_fold_list hash_fold_t hsv _a0
+      : state -> t -> state)
+
+  and (hash : t -> hash_value) =
+    let func arg =
+      get_hash_value
+        (let hsv = create () in
+         hash_fold_t hsv arg)
+    in
+    fun x -> func x
+end
+
+let%expect_test _ =
+  let program =
+    compile_and_parse
+      {|
+type state = int
+type hash_value = int
+let get_hash_value x = x
+let create () = 42
+let fold_int state i = state + i
+let hash_fold_string state s = state + String.length s
+let hash_fold_list fold state l = List.fold_left fold state l
+
+let myfun x =
+  let module M = struct
+    type t =
+      | Atom of string
+      | List of t list
+
+    let rec (hash_fold_t : state -> t -> state) =
+      (fun hsv ->
+         fun arg ->
+           match arg with
+           | Atom _a0 ->
+             let hsv = fold_int hsv 0 in
+             let hsv = hsv in hash_fold_string hsv _a0
+           | List _a0 ->
+             let hsv = fold_int hsv 1 in
+             let hsv = hsv in hash_fold_list hash_fold_t hsv _a0 : state -> t -> state)
+    and (hash : t -> hash_value) =
+      let func arg = get_hash_value
+          (let hsv = create () in hash_fold_t hsv arg) in
+      fun x -> func x
+  end
+  in
+  M.hash_fold_t (create ()) (List [ Atom "asd"]),
+  M.hash (List [ Atom "asd"]),
+  M.hash (List [ ])
+
+  |}
+  in
+  print_fun_decl program (Some "myfun");
+  [%expect
+    {|
+    function myfun(x)
+     {function hash_fold_t(hsv,arg)
+       {if(0 === arg[0])
+         {var a0=arg[1],hsv$0=hsv | 0;return hash_fold_string(hsv$0,a0)}
+        var a0$0=arg[1],hsv$1=hsv + 1 | 0;
+        return hash_fold_list(hash_fold_t,hsv$1,a0$0)}
+      function hash(x){return hash_fold_t(42,x)}
+      var _d_=hash(_a_),_e_=hash(_b_);
+      return [0,hash_fold_t(42,_c_),_e_,_d_]} |}]

runtime/internalMod.js

@@ -27,7 +27,7 @@ function caml_CamlinternalMod_init_mod(loc,shape) {
     if(typeof shape === "number")
       switch(shape){
       case 0://function
-        struct[idx]={fun:undef_module};
+        struct[idx]=undef_module;
         break;
       case 1://lazy
         struct[idx]=[246, undef_module];
@@ -53,22 +53,27 @@ function caml_CamlinternalMod_init_mod(loc,shape) {
 //Provides: caml_CamlinternalMod_update_mod
 //Requires: caml_update_dummy
 function caml_CamlinternalMod_update_mod(shape,real,x) {
-  if(typeof shape === "number")
-    switch(shape){
-    case 0://function
-    case 1://lazy
-    case 2://class
-    default:
-      caml_update_dummy(real,x);
-    }
-  else
-    switch(shape[0]){
-    case 0://module
-      for(var i=1;i<shape[1].length;i++)
-        caml_CamlinternalMod_update_mod(shape[1][i],real[i],x[i]);
-      break;
-      //case 1://Value
-    default:
-    };
-  return 0
+  function loop (shape,real,x,parent,i) {
+    if(typeof shape === "number")
+      switch(shape){
+      case 0://function
+        parent[i]=x;
+        break
+      case 1://lazy
+      case 2://class
+      default:
+        caml_update_dummy(real,x);
+      }
+    else
+      switch(shape[0]){
+      case 0://module
+        for(var i=1;i<shape[1].length;i++)
+          loop(shape[1][i],real[i],x[i],real,i);
+        break;
+        //case 1://Value
+      default:
+      };
+  }
+  loop(shape,real,x,undefined,undefined);
+  return 0;
 }