Eliminate Pjs_fn_make, Pjs_fn_make_unit, and unsafe_adjust_to_arity

CHANGELOG.md

@@ -48,6 +48,7 @@
 
 - Sync the platform npm package's compiler binaries (`packages/@rescript/<platform>/bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560
 - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555
+- Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570
 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569
 
 - Make the typed layers n-ary as well: `Types.Tarrow` carries a parameter list, `Texp_function` carries typed parameters (label, ident, pattern, per-parameter exhaustiveness) and a body, and `Ttyp_arrow`/`Otyp_arrow` follow. The `arity` annotation and its `int option` phantom state are gone from the compiler entirely; `push_defaults` in translcore and the hand-rolled gather-until-arity walks in gentype, reanalyze, and the outcome printer are deleted. The cmi and cmt magic numbers are bumped (`Caml1999I023`/`Caml1999T023`). Generated JavaScript is byte-identical across the test suite (optional-parameter internals are named `*opt_<label>*` instead of `*opt*`, visible only in the rare unprettified case); reanalyze no longer emits spurious empty optional-argument references, and genType recovers real parameter names after defaulted parameters. https://github.com/rescript-lang/rescript/pull/8568

compiler/core/design.md

@@ -173,20 +173,6 @@ We can simply do inlining, it may have side efffect in `b0`, `b1`, our optimizer
 
 Maybe in the future, we should lift the restriction about `variadic` (delegate to `slow` mode when we can not resolve it statically, my personal expereince is that people will complain about why it fails to compile more than why it is slow in some corner cases)
 
-Note this also interacts with `[@uncurry]`
-
-for example
-
-```ocaml
-external filter : 'a array -> ('a -> bool [@uncurry]) -> 'a array = "filter"
-[@@send]
-
-let f xs =
-    xs |. filter (fun x -> x > 2)
-```
-
-Here whether the callback gets inlined to the call of `filter` will have an effect on how `Pjs_fn_make` gets cancelled.
-
 Note when we pattern match over the original lamba,`Levent` needs to be removed as early as possible. Due to the existence of `Levent`, we can not pattern match over nested original raw lambda.
 
 We turned off event generation temporarily
@@ -474,4 +460,3 @@ we do the optimizer, e.g, `Js_exp_make.int_comp`, we need make sure the peepwhol
 
 
 
-

compiler/core/lam.ml

@@ -140,13 +140,6 @@ let rec is_eta_conversion_exn params inner_args outer_args : t list =
   match (params, inner_args, outer_args) with
   | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y ->
     r :: is_eta_conversion_exn xs ys rest
-  | ( x :: xs,
-      Lprim
-        ({primitive = Pjs_fn_make _ | Pjs_fn_make_unit; args = [Lvar y]} as p)
-      :: ys,
-      r :: rest )
-    when Ident.same x y ->
-    Lprim {p with args = [r]} :: is_eta_conversion_exn xs ys rest
   | [], [], [] -> []
   | _, _, _ -> raise_notrace Not_simple_form
 

compiler/core/lam_analysis.ml

@@ -46,8 +46,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
       | _ -> false)
     | Pcreate_extension _ | Ptypeof | Pis_null | Pis_not_none | Psome
     | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pnull_to_opt
-    | Pnull_undefined_to_opt | Pjs_fn_make _ | Pjs_fn_make_unit
-    | Pjs_object_create _ | Pimport
+    | Pnull_undefined_to_opt | Pjs_object_create _ | Pimport
     (* TODO: check *)
     | Pmakeblock _
     (* whether it's mutable or not *)

compiler/core/lam_compile.ml

@@ -1828,12 +1828,6 @@ let compile output_prefix =
                       }
                       body))))
       | _ -> assert false)
-    | {primitive = Pjs_fn_make arity; args = [fn]; loc} ->
-      compile_lambda lambda_cxt
-        (Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:arity ?from:None fn)
-    | {primitive = Pjs_fn_make_unit; args = [fn]; loc} ->
-      compile_lambda lambda_cxt fn
-    | {primitive = Pjs_fn_make _; args = [] | _ :: _ :: _} -> assert false
     | {primitive = Pjs_object_create labels; args} ->
       let args_block, args_expr =
         if args = [] then ([], [])

compiler/core/lam_compile_primitive.ml

@@ -155,8 +155,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
   | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args)
   | Pis_null_undefined -> E.is_null_undefined (Ext_list.singleton_exn args)
   | Ptypeof -> E.typeof (Ext_list.singleton_exn args)
-  | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_make _ | Pjs_fn_make_unit
-  | Pjs_fn_method ->
+  | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_method ->
     assert false (* already handled by {!Lam_compile} *)
   | Pstringadd -> (
     match args with

compiler/core/lam_convert.ml

@@ -315,8 +315,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
   | Pis_poly_var_block -> prim ~primitive:Pis_poly_var_block ~args loc
   | Pjs_raw_expr -> assert false
   | Pjs_raw_stmt -> assert false
-  | Pjs_fn_make arity -> prim ~primitive:(Pjs_fn_make arity) ~args loc
-  | Pjs_fn_make_unit -> prim ~primitive:Pjs_fn_make_unit ~args loc
   | Pjs_fn_method -> prim ~primitive:Pjs_fn_method ~args loc
 
 (* Does not exist since we compile array in js backend unlike native backend *)

compiler/core/lam_eta_conversion.ml

@@ -73,233 +73,3 @@ let transform_under_supply n ap_info fn args =
     Ext_list.fold_left bindings rest (fun lam (id, x) ->
         Lam.let_ Strict id x lam)
   | _, _ -> assert false
-
-(* Invariant: mk0 : (unit -> 'a0) -> 'a0 t
-                TODO: this case should be optimized,
-                we need check where we handle [arity=0]
-                as a special case --
-                if we do an optimization before compiling
-                into lambda
-
-   {[Fn.mk0]} is not intended for use by normal users
-
-   so we assume [Fn.mk0] is only used in such cases
-   {[
-     Fn.mk0 (fun _ -> .. )
-   ]}
-   when it is passed as a function directly
-*)
-(*TODO: can be optimized ?
-  {[\ x y -> (\u -> body x) x y]}
-  {[\u x -> body x]}
-    rewrite rules
-  {[
-    \x -> body
-          --
-          \y (\x -> body ) y
-  ]}
-  {[\ x y -> (\a b c -> g a b c) x y]}
-  {[ \a b -> \c -> g a b c ]}
-*)
-
-(** Unsafe function, we are changing arity here, it should be applied 
-    cautiously, since 
-    [let u = f] and we are chaning the arity of [f] it will affect 
-    the collection of [u]
-    A typical use case is to pass an OCaml function to JS side as a callback (i.e, [@uncurry])
-*)
-let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) :
-    Lam.t =
-  let ap_info : Lam.ap_info =
-    {ap_loc = loc; ap_inlined = Default_inline; ap_status = App_na}
-  in
-  let is_async_fn =
-    match fn with
-    | Lfunction {attr = {async}} -> async
-    | _ -> false
-  in
-  match (from, fn) with
-  | Some from, _ | None, Lfunction {arity = from} -> (
-    if from = to_ || is_async_fn then fn
-    else if to_ = 0 then
-      match fn with
-      | Lfunction {params = [param]; body; loc} ->
-        Lam.function_ ~loc ~arity:0 ~attr:Lambda.default_function_attribute
-          ~params:[]
-          ~body:(Lam.let_ Alias param Lam.unit body)
-        (* could be only introduced by
-           {[ Pjs_fn_make 0 ]} <-
-           {[ fun [@bs] () -> .. ]}
-        *)
-      | _ -> (
-        let wrapper, new_fn =
-          match fn with
-          | Lvar _
-          | Lprim
-              {
-                primitive = Pfield (_, Fld_module _);
-                args = [(Lglobal_module _ | Lvar _)];
-                _;
-              } ->
-            (None, fn)
-          | _ ->
-            let partial_arg = Ext_ident.create Literals.partial_arg in
-            (Some partial_arg, Lam.var partial_arg)
-        in
-
-        let cont =
-          Lam.function_ ~loc ~attr:Lambda.default_function_attribute ~arity:0
-            ~params:[]
-            ~body:(Lam.apply new_fn [Lam.unit] ap_info)
-        in
-
-        match wrapper with
-        | None -> cont
-        | Some partial_arg -> Lam.let_ Strict partial_arg fn cont)
-    else if to_ > from then
-      match fn with
-      | Lfunction {params; body; loc} ->
-        (* {[fun x -> f]} ->
-           {[ fun x y -> f y ]}
-        *)
-        let extra_args =
-          Ext_list.init (to_ - from) (fun _ -> Ident.create Literals.param)
-        in
-        let rec mk_apply body vars =
-          match vars with
-          | [] -> body
-          | var :: vars -> mk_apply (Lam.apply body [var] ap_info) vars
-        in
-        Lam.function_ ~loc ~attr:Lambda.default_function_attribute ~arity:to_
-          ~params:(Ext_list.append params extra_args)
-          ~body:(mk_apply body (Ext_list.map extra_args Lam.var))
-      | _ -> (
-        let arity = to_ in
-        let extra_args =
-          Ext_list.init to_ (fun _ -> Ident.create Literals.param)
-        in
-        let wrapper, new_fn =
-          match fn with
-          | Lvar _
-          | Lprim
-              {
-                primitive = Pfield (_, Fld_module _);
-                args = [(Lglobal_module _ | Lvar _)];
-                _;
-              } ->
-            (None, fn)
-          | _ ->
-            let partial_arg = Ext_ident.create Literals.partial_arg in
-            (Some partial_arg, Lam.var partial_arg)
-        in
-        let cont =
-          Lam.function_ ~loc ~arity ~attr:Lambda.default_function_attribute
-            ~params:extra_args
-            ~body:
-              (let first_args, rest_args = Ext_list.split_at extra_args from in
-               Lam.apply
-                 (Lam.apply new_fn
-                    (Ext_list.map first_args Lam.var)
-                    {ap_info with ap_status = App_infer_full})
-                 (Ext_list.map rest_args Lam.var)
-                 ap_info)
-        in
-        match wrapper with
-        | None -> cont
-        | Some partial_arg -> Lam.let_ Strict partial_arg fn cont)
-    else
-      (* add3  --adjust to arity 1 ->
-         fun x -> (fun y z -> add3 x y z )
-
-         [fun x y z -> f x y z ]
-         [fun x -> [fun y z -> f x y z ]]
-         This is okay if the function is not held by other..
-      *)
-      match fn with
-      | Lfunction {params; body; loc}
-      (* TODO check arity = List.length params in debug mode *) ->
-        let arity = to_ in
-        let extra_outer_args, extra_inner_args =
-          Ext_list.split_at params arity
-        in
-        Lam.function_ ~loc ~arity ~attr:Lambda.default_function_attribute
-          ~params:extra_outer_args
-          ~body:
-            (Lam.function_ ~loc ~arity:(from - to_)
-               ~attr:Lambda.default_function_attribute ~params:extra_inner_args
-               ~body)
-      | _ -> (
-        let extra_outer_args =
-          Ext_list.init to_ (fun _ -> Ident.create Literals.param)
-        in
-        let wrapper, new_fn =
-          match fn with
-          | Lvar _
-          | Lprim
-              {
-                primitive = Pfield (_, Fld_module _);
-                args = [(Lglobal_module _ | Lvar _)];
-                _;
-              } ->
-            (None, fn)
-          | _ ->
-            let partial_arg = Ext_ident.create Literals.partial_arg in
-            (Some partial_arg, Lam.var partial_arg)
-        in
-        let cont =
-          Lam.function_ ~loc ~arity:to_ ~params:extra_outer_args
-            ~attr:Lambda.default_function_attribute
-            ~body:
-              (let arity = from - to_ in
-               let extra_inner_args =
-                 Ext_list.init arity (fun _ -> Ident.create Literals.param)
-               in
-               Lam.function_ ~loc ~arity ~params:extra_inner_args
-                 ~attr:Lambda.default_function_attribute
-                 ~body:
-                   (Lam.apply new_fn
-                      (Ext_list.map_append extra_outer_args
-                         (Ext_list.map extra_inner_args Lam.var)
-                         Lam.var)
-                      {ap_info with ap_status = App_infer_full}))
-        in
-        match wrapper with
-        | None -> cont
-        | Some partial_arg -> Lam.let_ Strict partial_arg fn cont))
-  | None, _ ->
-    (* In this case [fn] is not [Lfunction], otherwise we would get [arity] *)
-    if to_ = 0 then
-      let wrapper, new_fn =
-        match fn with
-        | Lvar _
-        | Lprim
-            {
-              primitive = Pfield (_, Fld_module _);
-              args = [(Lglobal_module _ | Lvar _)];
-              _;
-            } ->
-          (None, fn)
-        | _ ->
-          let partial_arg = Ext_ident.create Literals.partial_arg in
-          (Some partial_arg, Lam.var partial_arg)
-      in
-
-      let cont =
-        Lam.function_ ~loc ~attr:Lambda.default_function_attribute ~arity:0
-          ~params:[]
-          ~body:(Lam.apply new_fn [Lam.unit] ap_info)
-      in
-
-      match wrapper with
-      | None -> cont
-      | Some partial_arg -> Lam.let_ Strict partial_arg fn cont
-    else transform_under_supply to_ ap_info fn []
-
-(* | _ ->
-   let partial_arg = Ext_ident.create Literals.partial_arg in
-   Lam.let_ Strict partial_arg fn
-    (let arity = to_ in
-     let extra_args = Ext_list.init arity (fun _ -> Ident.create Literals.param) in
-     Lam.function_ ~arity ~kind:Curried ~params:extra_args
-       ~body:(Lam.apply fn (Ext_list.map Lam.var extra_args ) loc Lam.App_na )
-    ) *)

compiler/core/lam_eta_conversion.mli

@@ -29,6 +29,3 @@
 *)
 
 val transform_under_supply : int -> Lam.ap_info -> Lam.t -> Lam.t list -> Lam.t
-
-val unsafe_adjust_to_arity :
-  Location.t -> to_:int -> ?from:int -> Lam.t -> Lam.t

compiler/core/lam_pass_alpha_conversion.ml

@@ -64,25 +64,6 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
       let bindings = Ext_list.map_snd bindings simpl in
       Lam.letrec bindings (simpl body)
     | Lglobal_module _ -> lam
-    | Lprim {primitive = Pjs_fn_make len as primitive; args = [arg]; loc} -> (
-      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
-      | None -> Lam.prim ~primitive ~args:[simpl arg] loc)
-    | Lprim {primitive = Pjs_fn_make_unit; args = [arg]; loc} ->
-      let arg =
-        match arg with
-        | Lfunction {arity = 1; params = [x]; attr; body; loc}
-          when Ident.name x = "param" (* "()" *) ->
-          Lam.function_ ~loc ~params:[x]
-            ~attr:{attr with one_unit_arg = true}
-            ~body ~arity:1
-        | _ -> arg
-      in
-      simpl arg
     | Lprim {primitive; args; loc} ->
       Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc
     | Lfunction {arity; params; body; attr; loc} ->

compiler/core/lam_pass_deep_flatten.ml

@@ -114,6 +114,19 @@ let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t
     since its semantics depend on whether v is used or not
     return value are in reverse order, but handled by [lambda_of_groups]
 *)
+(* The shape [let x = <immutable block> in ... in apply f args]: the residue
+   left by beta reduction of an immediately applied function. *)
+let rec rhs_is_beta_residue (lam : Lam.t) =
+  match lam with
+  | Llet
+      ( (Alias | Strict | StrictOpt),
+        _,
+        (Lprim {primitive = Pmakeblock (_, _, Immutable)} | Lvar _),
+        rest ) ->
+    rhs_is_beta_residue rest
+  | Lapply _ -> true
+  | _ -> false
+
 let deep_flatten (lam : Lam.t) : Lam.t =
   let rec flatten (acc : Lam_group.t list) (lam : Lam.t) :
       Lam.t * Lam_group.t list =
@@ -145,6 +158,13 @@ let deep_flatten (lam : Lam.t) : Lam.t =
                  ~args:[Lam.var new_id]
                  Location.none (* FIXME*))
               body))
+    | Llet (str, id, arg, body) when rhs_is_beta_residue arg ->
+      (* A let chain of immutable blocks and aliases feeding a final apply is
+         the residue of beta reducing an immediately applied function. Keep
+         it local: hoisting the bindings into the enclosing group would put
+         them beyond [Lam_pass_lets_dce]'s reach, which substitutes
+         single-use arguments back into the call. *)
+      flatten (Single (str, id, aux arg) :: acc) body
     | Llet (str, id, arg, body) -> (
       (*
                          {[ let match = (a,b,c)