Fix modes in build_apply for partial applications

lpw25 · lpw25 · commit ee3be10c8f31 · 2021-11-13T11:23:04.000Z
diff --git a/lambda/translcore.ml b/lambda/translcore.ml
@@ -84,12 +84,15 @@ let extract_float = function
     Const_base(Const_float f) -> f
   | _ -> fatal_error "Translcore.extract_float"
 
-let transl_value_mode mode : Lambda.alloc_mode =
-  let alloc_mode = Types.Value_mode.regional_to_global_alloc mode in
+let transl_alloc_mode alloc_mode : Lambda.alloc_mode =
   match Types.Alloc_mode.constrain_lower alloc_mode with
   | Global -> Alloc_heap
   | Local -> Alloc_local
 
+let transl_value_mode mode =
+  let alloc_mode = Types.Value_mode.regional_to_global_alloc mode in
+  transl_alloc_mode alloc_mode
+
 let join_mode a b =
   match a, b with
   | Alloc_local, _ | _, Alloc_local -> Alloc_local
@@ -245,6 +248,10 @@ let maybe_region parent_mode (children : Lambda.alloc_mode list) e =
   else
     e
 
+let is_omitted = function
+  | Arg _ -> false
+  | Omitted _ -> true
+
 let rec transl_exp ~scopes e =
   transl_exp1 ~scopes ~in_new_scope:false e
 
@@ -284,10 +291,10 @@ and transl_exp0 ~in_new_scope ~scopes e =
   | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
                 exp_type = prim_type } as funct, oargs)
     when List.length oargs >= p.prim_arity
-    && List.for_all (fun (_, arg) -> arg <> None) oargs ->
+    && List.for_all (fun (_, arg) -> not (is_omitted arg)) oargs ->
       let argl, extra_args = cut p.prim_arity oargs in
       let arg_exps =
-         List.map (function _, Some x -> x | _ -> assert false) argl
+         List.map (function _, Arg x -> x | _ -> assert false) argl
       in
       let args = transl_list ~scopes arg_exps in
       let prim_exp = if extra_args = [] then Some e else None in
@@ -733,8 +740,9 @@ and transl_apply ~scopes
   =
   let bound_modes =
     List.map (function
-        | (_,Some e) -> transl_value_mode e.exp_mode
-        | (_,None) -> Alloc_heap) sargs in
+        | (_,Arg e) -> transl_value_mode e.exp_mode
+        | (_,Omitted _) -> Alloc_heap) sargs
+  in
   let lapply funct args =
     match funct with
       Lsend(k, lmet, lobj, largs, _) ->
@@ -754,7 +762,7 @@ and transl_apply ~scopes
         }
   in
   let rec build_apply lam args = function
-      (None, optional) :: l ->
+      (Omitted { mode_closure; mode_arg; mode_ret }, optional) :: l ->
         let defs = ref [] in
         let protect name lam =
           match lam with
@@ -769,31 +777,48 @@ and transl_apply ~scopes
         in
         let handle = protect "func" lam in
         let l =
-          List.map (fun (arg, opt) -> Option.map (protect "arg") arg, opt) l
+          List.map
+            (fun (arg, opt) ->
+               match arg with
+               | Omitted _ -> arg, opt
+               | Arg arg -> Arg (protect "arg" arg), opt)
+            l
         in
         let id_arg = Ident.create_local "param" in
-        (* FIXME modes / Curried nlocals are completely wrong here *)
         let body =
           let body = build_apply handle [Lvar id_arg, optional] l in
-          Lfunction{kind = Curried {nlocal=0}; params = [id_arg, Pgenval];
-                    return = Pgenval; body; mode=Alloc_heap;
-                    ret_mode=Alloc_heap; attr = default_stub_attribute;
-                    loc = loc}
+          let mode = transl_alloc_mode mode_closure in
+          let arg_mode = transl_alloc_mode mode_arg in
+          let ret_mode = transl_alloc_mode mode_ret in
+          let nlocal =
+            match join_mode mode (join_mode arg_mode ret_mode) with
+            | Alloc_local -> 1
+            | Alloc_heap -> 0
+          in
+          Lfunction{kind = Curried {nlocal}; params = [id_arg, Pgenval];
+                    return = Pgenval; body; mode; ret_mode;
+                    attr = default_stub_attribute; loc = loc}
         in
         List.fold_right
           (fun (id, lam) body -> Llet(Strict, Pgenval, id, lam, body))
           !defs body
-    | (Some arg, optional) :: l ->
+    | (Arg arg, optional) :: l ->
         build_apply lam ((arg, optional) :: args) l
     | [] ->
         lapply lam (List.rev_map fst args)
   in
-  let lam =
-    build_apply lam [] (List.map (fun (l, x) ->
-                            Option.map (transl_exp ~scopes) x,
-                            Btype.is_optional l)
-                          sargs)
+  let args =
+    List.map
+      (fun (l, arg) ->
+         let arg =
+           match arg with
+           | Omitted _ as arg -> arg
+           | Arg exp -> Arg (transl_exp ~scopes exp)
+         in
+         arg, Btype.is_optional l)
+      sargs
   in
+  let lam = build_apply lam [] args in
   maybe_region mode bound_modes lam
 
 and transl_curried_function
diff --git a/lambda/translcore.mli b/lambda/translcore.mli
@@ -29,7 +29,7 @@ val transl_apply: scopes:scopes
                   -> ?inlined:inline_attribute
                   -> ?specialised:specialise_attribute
                   -> lambda -> ?mode:Lambda.alloc_mode
-                  -> (arg_label * expression option) list
+                  -> (arg_label * apply_arg) list
                   -> scoped_location -> lambda
 val transl_let: scopes:scopes -> ?in_structure:bool ->
                 ?mode:Lambda.alloc_mode -> rec_flag
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
@@ -765,7 +765,7 @@ module Analyser =
             in
            (parameter :: params, k)
 
-      | (Parsetree.Pcl_apply (p_class_expr2, _), Tcl_apply (tt_class_expr2, exp_opt_optional_list)) ->
+      | (Parsetree.Pcl_apply (p_class_expr2, _), Tcl_apply (tt_class_expr2, arg_list)) ->
           let applied_name =
             (* we want an ident, or else the class applied will appear in the form object ... end,
                because if the class applied has no name, the code is kinda ugly, isn't it ? *)
@@ -781,12 +781,12 @@ module Analyser =
                     Odoc_messages.object_end
           in
           let param_exps = List.fold_left
-              (fun acc -> fun (_, exp_opt) ->
-                match exp_opt with
-                  None -> acc
-                | Some e -> acc @ [e])
+              (fun acc -> fun (_, arg) ->
+                match arg with
+                | Omitted _ -> acc
+                | Arg e -> acc @ [e])
               []
-              exp_opt_optional_list
+              arg_list
           in
           let param_types = List.map (fun e -> e.Typedtree.exp_type) param_exps in
           let params_code =
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
@@ -334,7 +334,7 @@ and expression i ppf x =
   | Texp_apply (e, l) ->
       line i ppf "Texp_apply\n";
       expression i ppf e;
-      list i label_x_expression ppf l;
+      list i label_x_apply_arg ppf l;
   | Texp_match (e, l, _partial) ->
       line i ppf "Texp_match\n";
       expression i ppf e;
@@ -611,7 +611,7 @@ and class_expr i ppf x =
   | Tcl_apply (ce, l) ->
       line i ppf "Tcl_apply\n";
       class_expr i ppf ce;
-      list i label_x_expression ppf l;
+      list i label_x_apply_arg ppf l;
   | Tcl_let (rf, l1, l2, ce) ->
       line i ppf "Tcl_let %a\n" fmt_rec_flag rf;
       list i value_binding ppf l1;
@@ -923,10 +923,10 @@ and record_field i ppf = function
   | _, Kept _ ->
       line i ppf "<kept>"
 
-and label_x_expression i ppf (l, e) =
+and label_x_apply_arg i ppf (l, e) =
   line i ppf "<arg>\n";
   arg_label (i+1) ppf l;
-  (match e with None -> () | Some e -> expression (i+1) ppf e)
+  (match e with Omitted _ -> () | Arg e -> expression (i+1) ppf e)
 
 and ident_x_expression_def i ppf (l, e) =
   line i ppf "<def> \"%a\"\n" fmt_ident l;
diff --git a/typing/rec_check.ml b/typing/rec_check.ml
@@ -117,9 +117,9 @@ let is_ref : Types.value_description -> bool = function
 
 (* See the note on abstracted arguments in the documentation for
     Typedtree.Texp_apply *)
-let is_abstracted_arg : arg_label * expression option -> bool = function
-  | (_, None) -> true
-  | (_, Some _) -> false
+let is_abstracted_arg : arg_label * apply_arg -> bool = function
+  | (_, Omitted _) -> true
+  | (_, Arg _) -> false
 
 let classify_expression : Typedtree.expression -> sd =
   (* We need to keep track of the size of expressions
@@ -564,7 +564,7 @@ let rec expression : Typedtree.expression -> term_judg =
       path pth << Dereference
     | Texp_instvar (self_path, pth, _inst_var) ->
         join [path self_path << Dereference; path pth]
-    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg])
+    | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Arg arg])
       when is_ref vd ->
       (*
         G |- e: m[Guard]
@@ -573,7 +573,11 @@ let rec expression : Typedtree.expression -> term_judg =
       *)
       expression arg << Guard
     | Texp_apply (e, args)  ->
-        let arg (_, eo) = option expression eo in
+        let arg (_, arg) =
+          match arg with
+          | Omitted _ -> empty
+          | Arg e -> expression e
+        in
         let app_mode = if List.exists is_abstracted_arg args
           then (* see the comment on Texp_apply in typedtree.mli;
                   the non-abstracted arguments are bound to local
@@ -1033,7 +1037,11 @@ and class_expr : Typedtree.class_expr -> term_judg =
         let ids = List.map fst args in
         remove_ids ids (class_expr ce << Delay)
     | Tcl_apply (ce, args) ->
-        let arg (_label, eo) = option expression eo in
+        let arg (_, arg) =
+          match arg with
+          | Omitted _ -> empty
+          | Arg e -> expression e
+        in
         join [
           class_expr ce << Dereference;
           list arg args << Dereference;
diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml
@@ -197,7 +197,10 @@ let expr sub {exp_extra; exp_desc; exp_env; _} =
      List.iter (sub.case sub) cases
   | Texp_apply (exp, list) ->
       sub.expr sub exp;
-      List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list
+      List.iter (function
+        | (_, Arg exp) -> sub.expr sub exp
+        | (_, Omitted _) -> ())
+        list
   | Texp_match (exp, cases, _) ->
       sub.expr sub exp;
       List.iter (sub.case sub) cases
@@ -370,7 +373,10 @@ let class_expr sub {cl_desc; cl_env; _} =
       sub.class_expr sub cl
   | Tcl_apply (cl, args) ->
       sub.class_expr sub cl;
-      List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args
+      List.iter (function
+        | (_, Arg exp) -> sub.expr sub exp
+        | (_, Omitted _) -> ())
+        args
   | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
       sub.value_bindings sub (rec_flag, value_bindings);
       List.iter (fun (_, e) -> sub.expr sub e) ivars;
diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
@@ -253,7 +253,10 @@ let expr sub x =
     | Texp_apply (exp, list) ->
         Texp_apply (
           sub.expr sub exp,
-          List.map (tuple2 id (Option.map (sub.expr sub))) list
+          List.map (function
+            | (lbl, Arg exp) -> (lbl, Arg (sub.expr sub exp))
+            | (lbl, Omitted o) -> (lbl, Omitted o))
+            list
         )
     | Texp_match (exp, cases, p) ->
         Texp_match (
@@ -543,7 +546,10 @@ let class_expr sub x =
     | Tcl_apply (cl, args) ->
         Tcl_apply (
           sub.class_expr sub cl,
-          List.map (tuple2 id (Option.map (sub.expr sub))) args
+          List.map (function
+            | (lbl, Arg exp) -> (lbl, Arg (sub.expr sub exp))
+            | (lbl, Omitted o) -> (lbl, Omitted o))
+            args
         )
     | Tcl_let (rec_flag, value_bindings, ivars, cl) ->
         let (rec_flag, value_bindings) =
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
@@ -1120,7 +1120,7 @@ and class_expr_aux cl_num val_env met_env scl =
             let name = Btype.label_name l
             and optional = Btype.is_optional l in
             let use_arg sarg l' =
-              Some (
+              Arg (
                 if not optional || Btype.is_optional l' then
                   type_argument val_env sarg ty ty0
                 else
@@ -1131,7 +1131,7 @@ and class_expr_aux cl_num val_env met_env scl =
               )
             in
             let eliminate_optional_arg () =
-              Some (option_none val_env ty0 Value_mode.global Location.none)
+              Arg (option_none val_env ty0 Value_mode.global Location.none)
             in
             let remaining_sargs, arg =
               if ignore_labels then begin
@@ -1162,10 +1162,18 @@ and class_expr_aux cl_num val_env met_env scl =
                     sargs,
                     if Btype.is_optional l && List.mem_assoc Nolabel sargs then
                       eliminate_optional_arg ()
-                    else
-                      None
+                    else begin
+                      let mode_closure = Alloc_mode.global in
+                      let mode_arg = Alloc_mode.global in
+                      let mode_ret = Alloc_mode.global in
+                      Omitted { mode_closure; mode_arg; mode_ret }
+                    end
+            in
+            let omitted =
+              match arg with
+              | Omitted _ -> (l,ty0) :: omitted
+              | Arg _ -> omitted
             in
-            let omitted = if arg = None then (l,ty0) :: omitted else omitted in
             type_args ((l,arg)::args) omitted ty_fun ty_fun0 remaining_sargs
         | _ ->
             match sargs with
diff --git a/typing/typecore.ml b/typing/typecore.ml
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
diff --git a/typing/untypeast.ml b/typing/untypeast.ml
