clean up

Author: bobzhang

jscomp/all.depend

@@ -578,8 +578,9 @@ core/lam_stats_export.cmx : ext/string_map.cmx core/lam_stats.cmx \
     common/ext_log.cmx ext/ext_list.cmx ext/ext_array.cmx \
     core/lam_stats_export.cmi
 core/lam_pass_alpha_conversion.cmx : core/lam_stats.cmx \
-    core/lam_eta_conversion.cmx core/lam_arity_analysis.cmx core/lam.cmx \
-    ext/ext_list.cmx core/lam_pass_alpha_conversion.cmi
+    core/lam_eta_conversion.cmx core/lam_arity_analysis.cmx \
+    core/lam_arity.cmx core/lam.cmx ext/ext_list.cmx \
+    core/lam_pass_alpha_conversion.cmi
 core/lam_pass_collect.cmx : core/lam_util.cmx core/lam_stats.cmx \
     core/lam_arity_analysis.cmx core/lam_arity.cmx core/lam.cmx \
     ext/ident_set.cmx ext/ident_hashtbl.cmx core/lam_pass_collect.cmi

jscomp/core/lam_arity.ml

@@ -90,9 +90,36 @@ let first_arity_na ( x : t ) =
   | Arity_info (_, [], _) -> true
   | _ -> false
 
-let extract_arity ( x : t) =   
+let get_first_arity (x : t) =   
   match x with 
-  | Arity_na  -> None
-  | Arity_info(_,xs,_) -> Some xs 
+  | Arity_na 
+  | Arity_info (_, [], _) -> None
+  | Arity_info (_, x::_, _) ->  Some x
 
-(* let update_arity (x : t) xs =    *)
+let extract_arity ( x : t) =   
+  match x with 
+  | Arity_na  -> []
+  | Arity_info(_,xs,_) ->  xs 
+
+(* let update_arity (x : t) xs =    *)
+
+let rec
+  merge_arities_aux 
+    (acc : int list) 
+    (unused_b : bool) 
+    (xs : int list) (ys : int list) (tail : bool) (tail2 : bool) = 
+  match xs,ys with
+  | [], [] -> 
+    info unused_b (List.rev acc) (tail && tail2) 
+  (* tail && tail2 *)
+  | [], y::ys when tail  -> 
+    merge_arities_aux (y::acc) unused_b  [] ys tail tail2
+  | x::xs, [] when tail2 -> 
+    merge_arities_aux (x::acc) unused_b  [] xs tail tail2
+  | x::xs, y::ys when x = y ->
+    merge_arities_aux (y :: acc) unused_b  xs ys tail tail2
+  | _, _  -> 
+  info false (List.rev acc) false
+
+let merge_arities b xs ys t t2 = 
+  merge_arities_aux [] b xs ys t t2

jscomp/core/lam_arity.mli

@@ -51,5 +51,15 @@ val na : t
 val info : bool -> int list -> bool -> t 
 
 val first_arity_na :  t -> bool
+val get_first_arity : t -> int option 
 
-val extract_arity : t -> int list option 
+(** when [NA] return  empty list*)
+val extract_arity : t -> int list 
+
+val merge_arities : 
+  bool -> 
+  int list -> 
+  int list -> 
+  bool -> 
+  bool -> 
+  t

jscomp/core/lam_arity_analysis.ml

@@ -24,45 +24,42 @@
 
 
 let arity_of_var (meta : Lam_stats.t) (v : Ident.t)  =
-    (** for functional parameter, if it is a high order function,
-        if it's not from function parameter, we should warn
-    *)
-      match Ident_hashtbl.find_opt meta.ident_tbl v with 
-      | Some (FunctionId {arity;_}) -> arity
-      | Some _
-      | None ->
-        Lam_arity.na 
+  (** for functional parameter, if it is a high order function,
+      if it's not from function parameter, we should warn
+  *)
+  match Ident_hashtbl.find_opt meta.ident_tbl v with 
+  | Some (FunctionId {arity;_}) -> arity
+  | Some _
+  | None ->
+    Lam_arity.na 
 
 
 (* we need record all aliases -- since not all aliases are eliminated, 
    mostly are toplevel bindings
    We will keep iterating such environment
    If not found, we will return [NA]
 *)
-let rec get_arity 
-    (meta : Lam_stats.t) 
-    (lam : Lam.t) : 
-  Lam_arity.t = 
+let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) :  Lam_arity.t = 
   match lam with 
-  | Lconst _ -> Lam_arity.non_function_arity_info
   | Lvar v -> arity_of_var meta v 
+  | Lconst _ -> Lam_arity.non_function_arity_info
   | Llet(_,_,_, l ) -> get_arity meta l 
   | Lprim {primitive = Pfield (n,_); 
            args =  [ Lglobal_module id  ]; _} ->
     begin match (Lam_compile_env.cached_find_ml_id_pos id n meta.env).arity with 
-    | Single x -> x 
-    | Submodule _ -> Lam_arity.na
+      | Single x -> x 
+      | Submodule _ -> Lam_arity.na
     end
   | Lprim {primitive = Pfield (m,_); 
            args =  [ Lprim{primitive = Pfield(n,_); 
-            args = [ Lglobal_module id]}  ]
-           ; _} ->
+                           args = [ Lglobal_module id]}  ]
+          ; _} ->
     begin match (Lam_compile_env.cached_find_ml_id_pos id n meta.env).arity with 
       | Submodule subs -> subs.(m)
       | Single _ -> Lam_arity.na
-  end
+    end
   (* TODO: all information except Pccall is complete, we could 
-    get more arity information
+     get more arity information
   *)
   | Lprim {primitive = Praise ;  _} -> Lam_arity.raise_arity_info
   | Lglobal_module _ (* TODO: fix me never going to happen assert false  *)
@@ -86,15 +83,15 @@ let rec get_arity
     begin match fn with 
       | Arity_na -> Lam_arity.na
       | Arity_info (b, xs, tail ) -> 
-        let rec take (xs : _ list) arg_length = 
-          match xs with 
+        let rec take (arities : _ list) arg_length = 
+          match arities with 
           | x :: yys ->
             if arg_length = x then Lam_arity.info b yys tail
             else if arg_length > x then
               take yys (arg_length - x)
             else Lam_arity.info b 
-                           ((x -  arg_length ) :: yys)
-                           tail
+                ((x -  arg_length ) :: yys)
+                tail
           | [] -> 
             if tail then Lam_arity.info b [] tail            
             else Lam_arity.na
@@ -115,7 +112,7 @@ let rec get_arity
     all_lambdas meta (
       let rest = 
         Ext_list.map_append snd sw_consts
-        (Ext_list.map snd sw_blocks) in
+          (Ext_list.map snd sw_blocks) in
       match sw_failaction with None -> rest | Some x -> x::rest )
   | Lstringswitch(l, sw, d) -> 
     begin match d with 
@@ -139,43 +136,20 @@ and all_lambdas meta (xs : Lam.t list) =
   match xs with 
   | y :: ys -> 
     let arity =  get_arity meta y in 
-    List.fold_left (fun exist (v : Lam.t) -> 
-        match (exist : Lam_arity.t) with 
+    let rec aux (acc : Lam_arity.t) xs = 
+      match acc, xs  with 
+      | Arity_na, _ -> acc 
+      | _, [] -> acc 
+      | Arity_info(bbb, xxxs, tail), y::ys ->
+        match get_arity meta y with 
         | Arity_na -> Lam_arity.na
-        | Arity_info (bbb, xxxs, tail) -> 
-          begin 
-            match get_arity meta v with 
-            | Arity_na -> Lam_arity.na 
-            | Arity_info (u,ys,tail2) -> 
-              let rec aux (b,acc) xs ys = 
-                match xs,ys with
-                | [], [] -> (b, List.rev acc, tail && tail2) 
-                | [], y::ys when tail  -> 
-                  aux (b,y::acc) [] ys 
-                | x::xs, [] when tail2 -> 
-                  aux (b,x::acc) [] xs
-                | x::xs, y::ys when x = y -> aux (b, (y :: acc)) xs ys 
-                | _, _  -> (false, List.rev acc, false) in 
-              let (b,acc, tail3)  = aux ( u &&bbb, []) xxxs ys in 
-              Lam_arity.info b acc tail3
-          end
-      ) arity ys 
-  | _ -> assert false 
+        | Arity_info (u,yyys,tail2) -> 
+          aux 
+            (Lam_arity.merge_arities ( u && bbb )  xxxs yyys tail tail2)
+            ys
+    in  aux arity ys     
+
+  | [] -> Lam_arity.na
+
 
-(*
-let dump_exports_arities (meta : Lam_stats.t ) = 
-  let fmt = 
-    if meta.filename <> "" then 
-      let cmj_file = Ext_path.chop_extension meta.filename ^ Literals.suffix_cmj in
-      let out = open_out cmj_file in   
-      Format.formatter_of_out_channel out
-    else 
-      Format.err_formatter in 
-  begin 
-    List.iter (fun (i : Ident.t) ->  
-      pp fmt "@[%s: %s -> %a@]@." meta.filename i.name 
-        pp_arities  (get_arity meta (Lvar i))
-              ) meta.exports
-  end
-*)
 

jscomp/core/lam_compile.ml

@@ -177,11 +177,11 @@ and compile_external_field_apply
            params body args_lambda)
     | _ ->
       let rec aux (acc : J.expression)
-          (arity : Lam_arity.t) args (len : int)  : E.t =
+          arity args (len : int)  : E.t =
           if len = 0 then         
           acc (** All arguments consumed so far *)
           else match arity with 
-          | Arity_info (aaaaa, x :: rest, bbbbb)   ->
+          |  x :: rest   ->
           let x =
             if x = 0
             then 1
@@ -191,7 +191,7 @@ and compile_external_field_apply
             let first_part, continue =  Ext_list.split_at x args in
             aux
               (E.call ~info:{arity=Full; call_info = Call_ml} acc first_part)
-              (Lam_arity.info aaaaa rest bbbbb)
+              rest
               continue (len - x)
           else (* GPR #1423 *)
           if List.for_all Js_analyzer.is_okay_to_duplicate args then
@@ -204,19 +204,17 @@ and compile_external_field_apply
         (* alpha conversion now? --
            Since we did an alpha conversion before so it is not here
         *)
-        | Arity_info (_, [], _ ) ->
+        | [] ->
           (* can not happen, unless it's an exception ? *)
           E.call ~info:Js_call_info.dummy acc args
-        | Arity_na ->
-          E.call ~info:Js_call_info.dummy acc args
       in
       let fn = E.ml_var_dot id name in 
       let initial_args_len = List.length args in 
       let expression = 
         match arity with 
         | Submodule _ -> E.call ~info:Js_call_info.dummy fn args 
         | Single x -> 
-          aux fn x  args initial_args_len
+          aux fn (Lam_arity.extract_arity x) args initial_args_len
       in   
       Js_output.output_of_block_and_expression
         cxt.st

jscomp/core/lam_pass_alpha_conversion.ml

@@ -37,13 +37,10 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
     | Lapply {fn = l1; args =  ll;  loc ; status} 
       -> (* detect functor application *)
       begin 
-        match Lam_arity_analysis.get_arity meta l1 with 
-        | Arity_na -> 
-          Lam.apply (simpl  l1) (Ext_list.map simpl  ll) loc status
-        | Arity_info (_, args, _) -> 
-          let len = List.length ll in 
-          let rec take args = 
-            match args with 
+        let args_arity =  Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta l1) in
+        let len = List.length ll in 
+        let take args_arity = 
+            match args_arity with 
             | x :: xs -> 
               if x = len 
               then 
@@ -63,8 +60,8 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
                          loc App_ml_full
                 )
                   (Ext_list.map simpl rest) loc status (* TODO refien *)
-            | _ -> Lam.apply (simpl l1) (Ext_list.map simpl ll)  loc status
-          in take args
+            | [] -> Lam.apply (simpl l1) (Ext_list.map simpl ll)  loc status
+          in take args_arity
       end
 
     | Llet (str, v, l1, l2) ->
@@ -76,16 +73,17 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
     | Lprim {primitive = (Lam.Pjs_fn_make len) as primitive ; args = [arg] 
       ; loc } -> 
 
-      begin match Lam_arity_analysis.get_arity meta arg with       
-      | Arity_info (_, x::_, _)
+      begin match 
+      Lam_arity.get_first_arity 
+      (Lam_arity_analysis.get_arity meta arg) with       
+      | Some x 
         -> 
         let arg = simpl arg in
           Lam_eta_conversion.unsafe_adjust_to_arity loc 
             ~to_:len 
             ~from:x
             arg 
-      | Arity_info(_,[],_)
-      | Arity_na   -> Lam.prim ~primitive ~args:[simpl arg] loc
+      | None ->  Lam.prim ~primitive ~args:[simpl arg] loc
       end
     | Lprim {primitive; args ; loc} -> 
       Lam.prim ~primitive ~args:(Ext_list.map simpl  args) loc

jscomp/test/.depend

@@ -61,6 +61,7 @@ arith_parser.cmj : ../stdlib/parsing.cmj ../stdlib/obj.cmj \
     ../stdlib/lexing.cmj arith_syntax.cmj
 arith_syntax.cmj :
 arity_deopt.cmj : mt.cmj
+arity_infer.cmj :
 array_data_util.cmj : ../others/belt.cmj
 array_safe_get.cmj : ../stdlib/array.cmj
 array_subtle_test.cmj : mt.cmj ../runtime/js.cmj ../stdlib/array.cmj

jscomp/test/Makefile

@@ -251,6 +251,7 @@ OTHERS := test_literals a test_ari test_export2 test_internalOO test_obj_simple_
 	gpr_2614_test\
 	gpr_2700_test\
 	gpr_2731_test\
+	arity_infer\
 # bs_uncurry_test
 # needs Lam to get rid of Uncurry arity first
 # simple_derive_test