Improved global deadcode elimination

CHANGES.md

@@ -16,6 +16,7 @@
   requested at compile time (--enable with-js-error) or at startup (OCAMLRUNPARAM=b=1)
 * Runtime: allow dynlink of precompiled js with separate compilation (#1676)
 * Lib: Modify Typed_array API for compatibility with WebAssembly
+* Compiler: improved global dead code elimination (#2206)
 
 
 ## Bug fixes

compiler/lib/code.ml

@@ -95,6 +95,8 @@ module Var : sig
 
   module Map : Map.S with type key = t
 
+  module Hashtbl : Hashtbl.S with type key = t
+
   module Tbl : sig
     type key = t
 
@@ -108,14 +110,6 @@ module Var : sig
       val fold : ('a -> 'acc -> 'acc) -> 'a t -> 'acc -> 'acc
     end
 
-    module DataMap : sig
-      type ('a, 'b) t
-
-      val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
-
-      val fold : ('a -> 'b -> 'acc -> 'acc) -> ('a, 'b) t -> 'acc -> 'acc
-    end
-
     type size = unit
 
     val get : 'a t -> key -> 'a
@@ -124,12 +118,8 @@ module Var : sig
 
     val make : size -> 'a -> 'a t
 
-    val make_map : size -> ('a, 'b) DataMap.t t
-
     val make_set : size -> 'a DataSet.t t
 
-    val add_map : ('a, 'b) DataMap.t t -> key -> 'a -> 'b -> unit
-
     val add_set : 'a DataSet.t t -> key -> 'a -> unit
 
     val iter : (key -> 'a -> unit) -> 'a t -> unit
@@ -159,6 +149,8 @@ end = struct
     let compare : t -> t -> int = compare
 
     let equal (a : t) (b : t) = a = b
+
+    let hash x = x
   end
 
   include T
@@ -246,24 +238,6 @@ end = struct
         | Many t -> Hashtbl.fold (fun k () acc -> f k acc) t acc
     end
 
-    module DataMap = struct
-      type ('a, 'b) t =
-        | Empty
-        | One of 'a * 'b
-        | Many of ('a, 'b) Hashtbl.t
-
-      let iter f = function
-        | Empty -> ()
-        | One (a, b) -> f a b
-        | Many t -> Hashtbl.iter f t
-
-      let fold f t acc =
-        match t with
-        | Empty -> acc
-        | One (a, b) -> f a b acc
-        | Many t -> Hashtbl.fold f t acc
-    end
-
     type key = T.t
 
     type size = unit
@@ -276,18 +250,6 @@ end = struct
 
     let make_set () = Array.make (count ()) DataSet.Empty
 
-    let make_map () = Array.make (count ()) DataMap.Empty
-
-    let add_map t x k v =
-      match t.(x) with
-      | DataMap.Empty -> t.(x) <- One (k, v)
-      | One (k', v') ->
-          let tbl = Hashtbl.create 0 in
-          Hashtbl.replace tbl k' v';
-          Hashtbl.replace tbl k v;
-          t.(x) <- Many tbl
-      | Many tbl -> Hashtbl.replace tbl k v
-
     let add_set t x k =
       match t.(x) with
       | DataSet.Empty -> t.(x) <- One k
@@ -304,6 +266,8 @@ end = struct
       done
   end
 
+  module Hashtbl = Hashtbl.Make (T)
+
   module ISet = struct
     type t = BitSet.t
 
@@ -452,9 +416,7 @@ type prim_arg =
   | Pv of Var.t
   | Pc of constant
 
-type special =
-  | Undefined
-  | Alias_prim of string
+type special = Alias_prim of string
 
 type mutability =
   | Immutable
@@ -603,7 +565,6 @@ module Print = struct
 
   let special f s =
     match s with
-    | Undefined -> Format.fprintf f "undefined"
     | Alias_prim s -> Format.fprintf f "alias %s" s
 
   let expr f e =

compiler/lib/code.mli

@@ -88,6 +88,8 @@ module Var : sig
 
   module Map : Map.S with type key = t
 
+  module Hashtbl : Hashtbl.S with type key = t
+
   module Tbl : sig
     type key = t
 
@@ -99,14 +101,6 @@ module Var : sig
       val fold : ('a -> 'acc -> 'acc) -> 'a t -> 'acc -> 'acc
     end
 
-    module DataMap : sig
-      type ('a, 'b) t
-
-      val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
-
-      val fold : ('a -> 'b -> 'acc -> 'acc) -> ('a, 'b) t -> 'acc -> 'acc
-    end
-
     type 'a t
 
     type size = unit
@@ -117,12 +111,8 @@ module Var : sig
 
     val make : size -> 'a -> 'a t
 
-    val make_map : size -> ('a, 'b) DataMap.t t
-
     val make_set : size -> 'a DataSet.t t
 
-    val add_map : ('a, 'b) DataMap.t t -> key -> 'a -> 'b -> unit
-
     val add_set : 'a DataSet.t t -> key -> 'a -> unit
 
     val iter : (key -> 'a -> unit) -> 'a t -> unit
@@ -210,9 +200,7 @@ type prim_arg =
   | Pv of Var.t
   | Pc of constant
 
-type special =
-  | Undefined
-  | Alias_prim of string
+type special = Alias_prim of string
 
 type mutability =
   | Immutable

compiler/lib/dgraph.ml

@@ -288,3 +288,90 @@ let t3 = Timer.get t3 in
     let f size g f = f' size g (fun ~update:_ v x -> f v x)
   end
 end
+
+module type ACTION = sig
+  type t
+end
+
+module type DOMAIN = sig
+  type t
+
+  val equal : t -> t -> bool
+
+  val bot : t
+
+  val top : t
+
+  val join : t -> t -> t
+end
+
+module Solver
+    (N : sig
+      type t
+    end)
+    (NSet : ISet with type elt = N.t)
+    (NTbl : Tbl with type key = N.t)
+    (A : ACTION)
+    (D : DOMAIN) =
+struct
+  type t =
+    { domain : NSet.t
+    ; iter_children : (N.t -> A.t -> unit) -> N.t -> unit
+    }
+
+  type queue =
+    { queue : N.t Queue.t
+    ; set : NSet.t
+    }
+
+  let is_empty st = Queue.is_empty st.queue
+
+  let pop st =
+    let x = Queue.pop st.queue in
+    NSet.add st.set x;
+    x
+
+  let push x st =
+    if NSet.mem st.set x
+    then (
+      Queue.push x st.queue;
+      NSet.remove st.set x)
+
+  let rec iterate g f ~state w =
+    if not (is_empty w)
+    then (
+      let dep = pop w in
+      if not (D.equal (NTbl.get state dep) D.bot)
+      then
+        g.iter_children
+          (fun target action ->
+            let a = NTbl.get state target in
+            if not (D.equal a D.top)
+            then
+              let b = D.join a (f ~state ~dep ~target ~action) in
+              if not (D.equal a b)
+              then (
+                NTbl.set state target b;
+                push target w))
+          dep;
+      iterate g f ~state w)
+
+  let rec traverse g to_visit lst x =
+    if NSet.mem to_visit x
+    then (
+      NSet.remove to_visit x;
+      g.iter_children (fun y _ -> traverse g to_visit lst y) x;
+      lst := x :: !lst)
+
+  let traverse_all g =
+    let lst = ref [] in
+    let to_visit = NSet.copy g.domain in
+    NSet.iter (fun x -> traverse g to_visit lst x) g.domain;
+    let queue = Queue.create () in
+    List.iter ~f:(fun x -> Queue.push x queue) !lst;
+    { queue; set = to_visit }
+
+  let f ~state g f =
+    let w = traverse_all g in
+    iterate g f ~state w
+end

compiler/lib/dgraph.mli

@@ -104,3 +104,39 @@ module Make_Imperative
       -> D.t NTbl.t
   end
 end
+
+module type ACTION = sig
+  type t
+end
+
+module type DOMAIN = sig
+  type t
+
+  val equal : t -> t -> bool
+
+  val bot : t
+
+  val top : t
+
+  val join : t -> t -> t
+end
+
+module Solver
+    (N : sig
+      type t
+    end)
+    (NSet : ISet with type elt = N.t)
+    (NTbl : Tbl with type key = N.t)
+    (A : ACTION)
+    (D : DOMAIN) : sig
+  type t =
+    { domain : NSet.t
+    ; iter_children : (N.t -> A.t -> unit) -> N.t -> unit
+    }
+
+  val f :
+       state:D.t NTbl.t
+    -> t
+    -> (state:D.t NTbl.t -> dep:N.t -> target:N.t -> action:A.t -> D.t)
+    -> unit
+end

compiler/lib/driver.ml

@@ -667,7 +667,7 @@ let full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p =
   in
   let deadcode_sentinal =
     (* If deadcode is disabled, this field is just fresh variable *)
-    Code.Var.fresh_n "undef"
+    Code.Var.fresh_n "dummy"
   in
   let opt =
     specialize_js_once

compiler/lib/generate.ml

@@ -1031,10 +1031,32 @@ let throw_statement ctx cx k loc =
         , loc )
       ]
 
+let remove_unused_tail_args ctx exact trampolined args =
+  if exact && not trampolined
+  then
+    let has_unused_tail_args =
+      List.fold_left
+        ~f:(fun _ x -> Var.equal x ctx.Ctx.deadcode_sentinal)
+        ~init:false
+        args
+    in
+    if has_unused_tail_args
+    then
+      List.fold_right
+        ~f:(fun x args ->
+          match args with
+          | [] when Var.equal x ctx.Ctx.deadcode_sentinal -> []
+          | _ -> x :: args)
+        ~init:[]
+        args
+    else args
+  else args
+
 let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
   match e with
   | Apply { f; args; exact } ->
       let trampolined = Var.Set.mem x ctx.Ctx.trampolined_calls in
+      let args = remove_unused_tail_args ctx exact trampolined args in
       let args, prop, queue =
         List.fold_right
           ~f:(fun x (args, prop, queue) ->
@@ -1090,16 +1112,18 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
             (st, loc) :: rem
         | _ -> clo
       in
-      let clo = J.EFun (None, J.fun_ (List.map args ~f:(fun v -> J.V v)) clo loc) in
+      let clo =
+        J.EFun
+          ( None
+          , J.fun_ (List.map args ~f:(fun v -> J.V v)) (Js_simpl.function_body clo) loc )
+      in
       (clo, (fst const_p, fv), queue), []
   | Constant c ->
       let js, instrs = constant ~ctx c level in
       (js, const_p, queue), instrs
   | Special (Alias_prim name) ->
       let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
       (prim, const_p, queue), []
-  | Special Undefined ->
-      (J.(EVar (ident (Utf8_string.of_string_exn "undefined"))), const_p, queue), []
   | Prim (Extern "debugger", _) ->
       let ins =
         if Config.Flag.debugger () then J.Debugger_statement else J.Empty_statement