Propagate the label names of optional parameters (#1723)

Author: mshinwell

middle_end/backend_var.ml

@@ -18,10 +18,17 @@ include Ident
 
 type backend_var = t
 
-let name_for_debugger t = name t
+let name_for_debugger t =
+  let prefix = "*opt*" in
+  let prefix_len = String.length prefix in
+  let name = name t in
+  if String.starts_with ~prefix name
+     && String.length name > prefix_len
+  then (String.sub name prefix_len (String.length name - prefix_len)) ^ "_opt"
+  else name
 
 let unique_name_for_debugger t =
-  Printf.sprintf "%s/%d" (name t) (stamp t)
+  Printf.sprintf "%s/%d" (name_for_debugger t) (stamp t)
 
 module Provenance = struct
   type t = {

middle_end/closure/closure.ml

@@ -829,8 +829,10 @@ let bind_params { backend; mutable_vars; _ } loc fdesc params args funct body =
         else begin
           let p1' = VP.rename p1 in
           let u1, u2, layout =
-            match VP.name p1, a1 with
-            | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind, mode), [a], dbg) ->
+            let p1_name = VP.name p1 in
+            match a1 with
+            | Uprim(P.Pmakeblock(0, Immutable, kind, mode), [a], dbg)
+              when String.starts_with ~prefix:"*opt*" p1_name ->
                 (* This parameter corresponds to an optional parameter,
                    and although it is used twice pushing the expression down
                    actually allows us to remove the allocation as it will
@@ -1629,7 +1631,8 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_
        their wrapper functions) to be inlined *)
     let n =
       List.fold_left
-        (fun n (id, _, _) -> n + if V.name id = "*opt*" then 8 else 1)
+        (fun n (id, _, _) ->
+          n + if String.starts_with (V.name id) ~prefix:"*opt*" then 8 else 1)
         0
         fun_params
     in

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -794,10 +794,13 @@ let is_user_visible env id : IR.user_visible =
   then Not_user_visible
   else
     let name = Ident.name id in
-    let len = String.length name in
-    if len > 0 && Char.equal name.[0] '*'
-    then Not_user_visible
-    else User_visible
+    if String.starts_with ~prefix:"*opt*" name
+    then User_visible
+    else
+      let len = String.length name in
+      if len > 0 && Char.equal name.[0] '*'
+      then Not_user_visible
+      else User_visible
 
 let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler
     ~params

ocaml/lambda/simplif.ml

@@ -779,7 +779,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body
     | Llet(Strict, k, id,
            (Lifthenelse(Lprim (Pisint _, [Lvar optparam], _), _, _, _) as def),
            rest) when
-        Ident.name optparam = "*opt*" &&
+        String.starts_with (Ident.name optparam) ~prefix:"*opt*" &&
         List.exists (fun p -> Ident.same p.name optparam) params
           && not (List.mem_assoc optparam map)
       ->

ocaml/middle_end/closure/closure.ml

@@ -829,8 +829,10 @@ let bind_params { backend; mutable_vars; _ } loc fdesc params args funct body =
         else begin
           let p1' = VP.rename p1 in
           let u1, u2, layout =
-            match VP.name p1, a1 with
-            | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind, mode), [a], dbg) ->
+            let p1_name = VP.name p1 in
+            match a1 with
+            | Uprim(P.Pmakeblock(0, Immutable, kind, mode), [a], dbg)
+              when String.starts_with ~prefix:"*opt*" p1_name ->
                 (* This parameter corresponds to an optional parameter,
                    and although it is used twice pushing the expression down
                    actually allows us to remove the allocation as it will
@@ -1618,7 +1620,8 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_
        their wrapper functions) to be inlined *)
     let n =
       List.fold_left
-        (fun n (id, _, _) -> n + if V.name id = "*opt*" then 8 else 1)
+        (fun n (id, _, _) ->
+          n + if String.starts_with (V.name id) ~prefix:"*opt*" then 8 else 1)
         0
         fun_params
     in

ocaml/ocamldoc/odoc_ast.ml

@@ -298,11 +298,12 @@ module Analyser =
 
           in
          (* For optional parameters with a default value, a special treatment is required *)
-         (* we look if the name of the parameter we just add is "*opt*", which means
+         (* we look if the name of the parameter we just add starts with "*opt*", which means
             that there is a let param_name = ... in ... just right now *)
           let (p, next_exp) =
             match parameter with
-              Simple_name { sn_name = "*opt*" } ->
+              Simple_name { sn_name }
+                when String.starts_with ~prefix:"*opt*" sn_name ->
                 (
                  (
                   match func_body.exp_desc with
@@ -457,11 +458,12 @@ module Analyser =
                           pattern_param
                       in
                       (* For optional parameters with a default value, a special treatment is required. *)
-                      (* We look if the name of the parameter we just add is "*opt*", which means
+                      (* We look if the name of the parameter we just add starts with "*opt*", which means
                          that there is a let param_name = ... in ... just right now. *)
                       let (current_param, next_exp) =
                         match parameter with
-                          Simple_name { sn_name = "*opt*"} ->
+                          Simple_name { sn_name }
+                            when String.starts_with ~prefix:"*opt*" sn_name ->
                             (
                              (
                               match body.exp_desc with
@@ -726,7 +728,7 @@ module Analyser =
               a default value. In this case, we look for the good parameter pattern *)
            let (parameter, next_tt_class_exp) =
              match pat.Typedtree.pat_desc with
-               Typedtree.Tpat_var (ident, _, _) when Name.from_ident ident = "*opt*" ->
+               Typedtree.Tpat_var (ident, _, _) when String.starts_with (Name.from_ident ident) ~prefix:"*opt*" ->
                  (
                   (* there must be a Tcl_let just after *)
                   match tt_class_expr2.Typedtree.cl_desc with

ocaml/typing/typeclass.ml

@@ -1175,14 +1175,21 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
           default;
        ]
       in
+      let param_suffix =
+        match l with
+        | Optional name -> name
+        | Nolabel | Labelled _ ->
+          Misc.fatal_error "[default] allowed only with optional argument"
+      in
+      let param_name = "*opt*" ^ param_suffix in
       let smatch =
-        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident param_name)))
           scases
       in
       let sfun =
         Cl.fun_ ~loc:scl.pcl_loc
           l None
-          (Pat.var ~loc (mknoloc "*opt*"))
+          (Pat.var ~loc (mknoloc param_name))
           (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
           (* Note: we don't put the '#default' attribute, as it
              is not detected for class-level let bindings.  See #5975.*)

ocaml/typing/typecore.ml

@@ -4367,7 +4367,12 @@ and type_expect_
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_fun (l, Some default, spat, sbody) ->
-      assert(is_optional l); (* default allowed only with optional argument *)
+      let param_suffix =
+        match l with
+        | Optional name -> name
+        | Nolabel | Labelled _ ->
+          Misc.fatal_error "[default] allowed only with optional argument"
+      in
       let open Ast_helper in
       let default_loc = default.pexp_loc in
       (* Defaults are always global. They can be moved out of the function's
@@ -4396,12 +4401,13 @@ and type_expect_
           loc_end = default_loc.Location.loc_end;
           loc_ghost = true }
       in
+      let param_name = "*opt*" ^ param_suffix in
       let smatch =
         Exp.match_ ~loc:sloc
-          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+          (Exp.ident ~loc (mknoloc (Longident.Lident param_name)))
           scases
       in
-      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
+      let pat = Pat.var ~loc:sloc (mknoloc param_name) in
       let body =
         Exp.let_ ~loc Nonrecursive
           ~attrs:[Attr.mk (mknoloc "#default") (PStr [])]
@@ -7007,7 +7013,8 @@ and type_let
   let is_fake_let =
     match spat_sexp_list with
     | [{pvb_expr={pexp_desc=Pexp_match(
-           {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
+           {pexp_desc=Pexp_ident({ txt = Longident.Lident name})},_)}}]
+      when String.starts_with ~prefix:"*opt*" name ->
         true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
     | _ ->
         false