Store an application's location directly in Lambda.lambda_apply

compiler/core/lam_beta_reduce_util.ml

@@ -94,7 +94,7 @@ let simple_beta_reduce params body args =
           (Lvar _ | Lprim {primitive = Pfield _; args = [Lglobal_module _]}) as
           f;
         ap_args;
-        ap_info;
+        ap_loc;
       } -> (
     let () =
       List.iter2
@@ -114,7 +114,7 @@ let simple_beta_reduce params body args =
         | _ -> f
       in
       let result =
-        Hash_ident.fold param_hash (Lambda.apply f new_args ap_info)
+        Hash_ident.fold param_hash (Lambda.apply f new_args ap_loc)
           (fun _param stat acc ->
             let {lambda; used} = stat in
             if not used then Lambda.seq lambda acc else acc)

compiler/core/lam_bounded_vars.ml

@@ -118,10 +118,10 @@ let rewrite (map : _ Hash_ident.t) (lam : Lambda.t) : Lambda.t =
       (* here it makes sure that global vars are not rebound *)
       Lambda.prim ~primitive ~args:(Ext_list.map args aux) loc
     | Lglobal_module _ -> lam
-    | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} ->
+    | Lapply {ap_func; ap_args; ap_loc; ap_transformed_jsx} ->
       let fn = aux ap_func in
       let args = Ext_list.map ap_args aux in
-      Lambda.apply ~ap_transformed_jsx fn args ap_info
+      Lambda.apply ~ap_transformed_jsx fn args ap_loc
     | Lswitch
         ( l,
           {

compiler/core/lam_compile.ml

@@ -34,7 +34,7 @@ let with_source_loc loc (exp : J.expression) =
 
 let rec source_loc_of_lam (lam : Lambda.t) =
   match lam with
-  | Lapply {ap_info = {ap_loc}} -> Some ap_loc
+  | Lapply {ap_loc} -> Some ap_loc
   | Lprim {loc} | Lfunction {loc} -> Some loc
   | Llet (_, _, arg, body) -> (
     match source_loc_of_lam arg with
@@ -356,7 +356,7 @@ let compile output_prefix =
                appinfo)
           fn args
       in
-      let expression = with_source_loc appinfo.ap_info.ap_loc expression in
+      let expression = with_source_loc appinfo.ap_loc expression in
       Js_output.output_of_block_and_expression lambda_cxt.continuation args_code
         expression
   (*
@@ -1606,7 +1606,7 @@ let compile output_prefix =
       | _ ->
         Js_output.output_of_block_and_expression lambda_cxt.continuation
           args_code
-          (with_source_loc appinfo.ap_info.ap_loc
+          (with_source_loc appinfo.ap_loc
              (E.call
                 ~info:
                   (call_info_of_apply lambda_cxt.meta appinfo.ap_transformed_jsx

compiler/core/lam_pass_remove_alias.ml

@@ -130,7 +130,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t =
                 _;
               } as l1;
           ap_args = args;
-          ap_info;
+          ap_loc;
         } -> (
       match Lam_compile_env.query_external_id_info ident fld_name with
       | {
@@ -151,22 +151,22 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t =
         let fn = simpl l1 in
         let args' = Ext_list.map_sharing args simpl in
         if fn == l1 && args' == args then lam
-        else Lambda.apply fn args' ap_info ?ap_transformed_jsx:None)
+        else Lambda.apply fn args' ap_loc ?ap_transformed_jsx:None)
     (* Function inlining interact with other optimizations...
 
        - parameter attributes
        - scope issues
        - code bloat
     *)
     | Lapply
-        {ap_func = Lvar v as fn; ap_args = args; ap_info; ap_transformed_jsx}
+        {ap_func = Lvar v as fn; ap_args = args; ap_loc; ap_transformed_jsx}
       -> (
       (* Check info for always inlining *)
       let ap_args = Ext_list.map_sharing args simpl in
       let[@local] normal () =
         let fn' = simpl fn in
         if fn' == fn && ap_args == args then lam
-        else Lambda.apply fn' ap_args ap_info ~ap_transformed_jsx
+        else Lambda.apply fn' ap_args ap_loc ~ap_transformed_jsx
       in
       match Hash_ident.find_opt meta.ident_tbl v with
       | Some

compiler/core/lam_util.ml

@@ -105,12 +105,12 @@ let refine_let ?original ~kind param (arg : Lambda.t) (l : Lambda.t) : Lambda.t
          with `value`. This only happens for primitives that are pure and do not
          allocate new blocks, so evaluation order and side effects stay the same. *)
     Lambda.prim ~primitive ~args:[arg] loc
-  | _, _, Lapply {ap_func = fn; ap_args = [Lvar w]; ap_info; ap_transformed_jsx}
+  | _, _, Lapply {ap_func = fn; ap_args = [Lvar w]; ap_loc; ap_transformed_jsx}
     when Ident.same w param && not (Lam_hit.hit_variable param fn) ->
     (* For a function call such as `{ let x = value; someFn(x) }`, we can
          rewrite to `someFn(value)` as long as the callee does not capture `x`.
          This removes the temporary binding while preserving the call semantics. *)
-    Lambda.apply fn [arg] ap_info ~ap_transformed_jsx
+    Lambda.apply fn [arg] ap_loc ~ap_transformed_jsx
   | (Strict | StrictOpt), arg, _ when is_safe_to_alias arg ->
     (* `Strict` and `StrictOpt` bindings both evaluate the RHS immediately
          (with `StrictOpt` allowing later elimination if unused). When that RHS

compiler/ml/lambda.ml

@@ -362,12 +362,10 @@ and lfunction = {
 
 and prim_info = {primitive: primitive; args: t list; loc: Location.t}
 
-and ap_info = {ap_loc: Location.t}
-
 and lambda_apply = {
   ap_func: t;
   ap_args: t list;
-  ap_info: ap_info;
+  ap_loc: Location.t;
   ap_transformed_jsx: bool;
 }
 
@@ -1074,7 +1072,7 @@ let prim ~primitive:(prim : primitive) ~args loc : t =
     *)
     | _ -> default ())
 
-let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t =
+let rec apply ?(ap_transformed_jsx = false) fn args (ap_loc : Location.t) : t =
   match fn with
   | Lfunction
       {
@@ -1091,21 +1089,20 @@ let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t =
       } -> (
     match is_eta_conversion_exn params inner_args args with
     | args ->
-      let loc = ap_info.ap_loc in
       prim ~primitive:wrap
-        ~args:[prim ~primitive:primitive_call.primitive ~args loc]
-        loc
+        ~args:[prim ~primitive:primitive_call.primitive ~args ap_loc]
+        ap_loc
     | exception Not_simple_form ->
-      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx})
+      Lapply {ap_func = fn; ap_args = args; ap_loc; ap_transformed_jsx})
   | Lfunction
       {
         params;
         body = Lprim ({primitive = _; args = inner_args} as primitive_call);
       } -> (
     match is_eta_conversion_exn params inner_args args with
-    | args -> prim ~primitive:primitive_call.primitive ~args ap_info.ap_loc
+    | args -> prim ~primitive:primitive_call.primitive ~args ap_loc
     | exception _ ->
-      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx})
+      Lapply {ap_func = fn; ap_args = args; ap_loc; ap_transformed_jsx})
   | Lfunction
       {
         params;
@@ -1115,20 +1112,19 @@ let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t =
               (Lconst _ as const) );
       } -> (
     match is_eta_conversion_exn params inner_args args with
-    | args ->
-      seq (prim ~primitive:primitive_call.primitive ~args ap_info.ap_loc) const
+    | args -> seq (prim ~primitive:primitive_call.primitive ~args ap_loc) const
     | exception _ ->
-      Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}
+      Lapply {ap_func = fn; ap_args = args; ap_loc; ap_transformed_jsx}
       (* | Lfunction {params;body} when Ext_list.same_length params args ->
           Ext_list.fold_right2 (fun p arg acc ->
             Llet(Strict,p,arg,acc)
           ) params args body *)
       (* TODO: more rigirous analysis on [let_kind] *))
   | Llet (kind, id, e, (Lfunction _ as fn)) ->
-    let_ kind id e (apply fn args ap_info ~ap_transformed_jsx)
+    let_ kind id e (apply fn args ap_loc ~ap_transformed_jsx)
   (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) ->
      Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *)
-  | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}
+  | _ -> Lapply {ap_func = fn; ap_args = args; ap_loc; ap_transformed_jsx}
 
 let not_ loc x : t =
   match x with

compiler/ml/lambda.mli

@@ -375,12 +375,10 @@ and lfunction = {
 
 and prim_info = private {primitive: primitive; args: t list; loc: Location.t}
 
-and ap_info = {ap_loc: Location.t}
-
 and lambda_apply = private {
   ap_func: t;
   ap_args: t list;
-  ap_info: ap_info;
+  ap_loc: Location.t;
   ap_transformed_jsx: bool;
 }
 
@@ -456,7 +454,7 @@ val global_module : Ident.t -> t
 
 val const : structured_constant -> t
 
-val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t
+val apply : ?ap_transformed_jsx:bool -> t -> t list -> Location.t -> t
 
 val function_ :
   loc:Location.t ->

compiler/ml/lambda_traverse.ml

@@ -40,7 +40,7 @@ let shallow_map_sharing (f : t -> t) (lam : t) : t =
     let fn = f ap.ap_func in
     let args = Ext_list.map_sharing ap.ap_args f in
     if fn == ap.ap_func && args == ap.ap_args then lam
-    else apply fn args ap.ap_info ~ap_transformed_jsx:ap.ap_transformed_jsx
+    else apply fn args ap.ap_loc ~ap_transformed_jsx:ap.ap_transformed_jsx
   | Lfunction {params; body; attr; loc} ->
     let body' = f body in
     if body' == body then lam else function_ ~loc ~attr ~params ~body:body'
@@ -124,7 +124,7 @@ let make_key e =
     | Lglobal_module _ | Lconst _ -> e
     | Lapply ap ->
       apply ~ap_transformed_jsx:ap.ap_transformed_jsx (tr_rec env ap.ap_func)
-        (tr_recs env ap.ap_args) {ap_loc = Location.none}
+        (tr_recs env ap.ap_args) Location.none
     | Llet (Alias, x, ex, e) ->
       (* Ignore aliases -> substitute *)
       let ex = tr_rec env ex in

compiler/ml/translcore.ml

@@ -909,7 +909,7 @@ let wrap_exn loc arg =
        ~args:
          [global_module (Ident.create_persistent Primitive_modules.exceptions)]
        loc)
-    [arg] {ap_loc = loc}
+    [arg] loc
 let exception_id_destructed (l : Lambda.t) (fv : Ident.t) : bool =
   let rec hit_opt = function
     | None -> false
@@ -1314,7 +1314,7 @@ and transl_cases cases = List.map transl_case cases
 and transl_apply ?(uncurried_partial_application = None)
     ?(transformed_jsx = false) lam sargs loc =
   let lapply ap_func ap_args =
-    apply ~ap_transformed_jsx:transformed_jsx ap_func ap_args {ap_loc = loc}
+    apply ~ap_transformed_jsx:transformed_jsx ap_func ap_args loc
   in
   let rec build_apply lam args = function
     | (None, optional) :: l ->
@@ -1364,9 +1364,7 @@ and transl_apply ?(uncurried_partial_application = None)
     in
     let extra_args = Ext_list.map extra_ids (fun id -> var id) in
     let ap_args = args @ extra_args in
-    let l0 =
-      apply ~ap_transformed_jsx:transformed_jsx lam ap_args {ap_loc = loc}
-    in
+    let l0 = apply ~ap_transformed_jsx:transformed_jsx lam ap_args loc in
     function_ ~loc ~attr:default_function_attribute
       ~params:(List.rev_append !none_ids extra_ids)
       ~body:l0

compiler/ml/translmod.ml

@@ -125,8 +125,7 @@ and apply_coercion_result loc strict funct param arg cc_res =
         ~params:[param]
         ~body:
           (apply_coercion loc Strict cc_res
-             (Lambda.apply ~ap_transformed_jsx:false (Lambda.var id) [arg]
-                {ap_loc = loc})))
+             (Lambda.apply ~ap_transformed_jsx:false (Lambda.var id) [arg] loc)))
 
 and wrap_id_pos_list loc id_pos_list get_field lam =
   let fv = Lambda_traverse.free_variables lam in
@@ -289,7 +288,7 @@ and transl_module0 cc rootpath mexp =
         (Lambda.apply ~ap_transformed_jsx:false
            (transl_module Tcoerce_none None funct)
            [transl_module ccarg None arg]
-           {ap_loc = loc})
+           loc)
     | Tmod_constraint (arg, _, _, ccarg) ->
       transl_module (compose_coercions cc ccarg) rootpath arg
     | Tmod_unpack (arg, _) ->

tests/ounit_tests/ounit_lambda_traverse_tests.ml

@@ -10,7 +10,7 @@ let var = Lambda.var x
    would pass either check below without exercising anything. *)
 let nodes : (string * Lambda.t) list =
   [
-    ("apply", Lambda.apply var [var] {ap_loc = loc});
+    ("apply", Lambda.apply var [var] loc);
     ( "function",
       Lambda.function_ ~loc ~attr:Lambda.default_function_attribute ~params:[x]
         ~body:debugger );