Represent optional parameters with defaults structurally instead of by name sniffing

The desugaring of an optional parameter with a default (~x=3) binds the
option-carrying parameter to a synthetic *opt_<label>* variable, and that
fact was recovered downstream by pattern-matching on the variable name in
four places across three compiler layers: typecore's is_fake_let (matching
the pre-n-ary name "*opt*" exactly, so it had silently rotted into dead
code), matching's *sth* let-elimination peephole, lam_convert's
rename_optional_parameters (which also had to re-recognize the whole
compiled body shape to rename the parameter to xOpt for JS output), and
gentype's *opt prefix check.

Represent the fact structurally instead:

- Typedtree.function_param gains an fp_has_default field.
- type_function replaces the carrier ident right after typing: fp_param
  becomes a fresh ident named <label>Opt, substituted at the carrier's
  only two occurrences (the parameter pattern's binder and the synthetic
  match's scrutinee), both nodes the desugaring itself generated. The
  unspellable name still exists during typing, where names must be
  impossible to capture or shadow, but dies before the typedtree leaves
  the function. The Lambda IR is born with the final parameter name and
  no residual binding.
- lam_convert's rename_optional_parameters and is_opt_param_name are
  deleted; the Lfunction case is a plain conversion.
- matching's *sth* peephole is generalized to eliminate any alias binding
  of the form let v = arg in v, with no name test.
- gentype uses fp_has_default instead of sniffing the ident name.
- is_fake_let now keys on the #optional_arg_default attribute the
  desugaring plants, restoring its intended behavior: an unused defaulted
  parameter warns as an unused parameter (27), not an unused let (26).
- The write-only #default attribute is removed, along with its dead
  parsetree consumer.

Visible improvements: parameter names in emitted JS now consistently
derive from the label, including cases the old shape-match silently
missed and leaked mangled names for (mario_game.mjs's make$2 had
$staropt_id$star as a parameter; it is now idOpt).

Signed-Off-By: Cristiano Calcagno <ccrisccris@gmail.com>
Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw

Author: cristianoc

compiler/core/lam_convert.ml

@@ -321,40 +321,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
 
 let may_depend = Lam_module_ident.Hash_set.add
 
-let is_opt_param_name name =
-  (* [*opt*] historically; [*opt_<label>*] with the n-ary representation *)
-  String.length name >= 5
-  && String.sub name 0 4 = "*opt"
-  && String.get name (String.length name - 1) = '*'
-
-let rec rename_optional_parameters map params (body : Lambda.lambda) =
-  match body with
-  | Llet
-      ( k,
-        value_kind,
-        id,
-        Lifthenelse
-          ( Lprim (p, [Lvar ({name = opt_name} as opt)], p_loc),
-            Lprim (p1, [Lvar ({name = opt_name2} as opt2)], x_loc),
-            f ),
-        rest )
-    when is_opt_param_name opt_name
-         && is_opt_param_name opt_name2
-         && Ident.same opt opt2 && List.mem opt params ->
-    let map, rest = rename_optional_parameters map params rest in
-    let new_id = Ident.create (id.name ^ "Opt") in
-    ( Map_ident.add map opt new_id,
-      Lambda.Llet
-        ( k,
-          value_kind,
-          id,
-          Lifthenelse
-            ( Lprim (p, [Lvar new_id], p_loc),
-              Lprim (p1, [Lvar new_id], x_loc),
-              f ),
-          rest ) )
-  | _ -> (map, body)
-
 let convert (exports : Set_ident.t) (lam : Lambda.lambda) :
     Lam.t * Lam_module_ident.Hash_set.t =
   let alias_tbl = Hash_ident.create 64 in
@@ -416,18 +382,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) :
         {ap_loc = loc; ap_inlined; ap_status = App_uncurry}
         ~ap_transformed_jsx
     | Lfunction {params; body; attr; loc} ->
-      let new_map, body =
-        rename_optional_parameters Map_ident.empty params body
-      in
-      if Map_ident.is_empty new_map then
-        Lam.function_ ~loc ~attr ~arity:(List.length params) ~params
-          ~body:(convert_aux body)
-      else
-        let params =
-          Ext_list.map params (fun x -> Map_ident.find_default new_map x x)
-        in
-        Lam.function_ ~loc ~attr ~arity:(List.length params) ~params
-          ~body:(convert_aux body)
+      Lam.function_ ~loc ~attr ~arity:(List.length params) ~params
+        ~body:(convert_aux body)
     | Llet (_, _, _, Lprim (Pgetglobal id, args, _), _body) when dynamic_import
       ->
       (*

compiler/core/lam_stats_export.ml

@@ -23,9 +23,6 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 (* let pp = Format.fprintf  *)
-(* we should exclude meaninglist names and do the convert as well *)
-
-(* let meaningless_names  = ["*opt*"; "param";] *)
 
 let single_na = Js_cmj_format.single_na
 

compiler/gentype/translate_structure.ml

@@ -7,16 +7,15 @@ let rec addAnnotationsToTypes_ ~config ~(expr : Typedtree.expression)
     let rec zip (params : Typedtree.function_param list)
         (arg_types : arg_type list) =
       match (params, arg_types) with
-      | {fp_lbl; fp_param} :: rest_params, {a_type} :: rest_types ->
-        let a_name = Ident.name fp_param in
+      | ( {fp_lbl; fp_param; fp_has_default} :: rest_params,
+          {a_type} :: rest_types ) ->
         let a_name =
-          (* optional parameters with a default are bound to a synthetic
-             [*opt_<label>*] variable; show the label instead *)
-          if String.length a_name >= 4 && String.sub a_name 0 4 = "*opt" then
-            match fp_lbl with
-            | Optional {txt = l} -> l
-            | _ -> "" (* should not happen *)
-          else a_name
+          match fp_lbl with
+          | Optional {txt = l} when fp_has_default ->
+            (* the compiled parameter is a synthetic option carrier; show the
+               label instead *)
+            l
+          | _ -> Ident.name fp_param
         in
         {a_name; a_type} :: zip rest_params rest_types
       | [], rest -> rest |> addAnnotationsToTypes_ ~config ~expr:body

compiler/ml/matching.ml

@@ -2356,8 +2356,10 @@ let rec lower_bind v arg lam =
   | Llet (Alias, k, vv, lv, l) ->
     if approx_present v lv then bind Alias v arg lam
     else Llet (Alias, k, vv, lv, lower_bind v arg l)
-  | Lvar u when Ident.same u v && Ident.name u = "*sth*" ->
-    arg (* eliminate let *sth* = from_option x in *sth* *)
+  | Lvar u when Ident.same u v ->
+    (* eliminate [let v = arg in v]; [lower_bind] is only used for alias
+       bindings, so [arg] is pure *)
+    arg
   | _ -> bind Alias v arg lam
 
 let bind_check str v arg lam =

compiler/ml/typecore.ml

@@ -2441,10 +2441,9 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp
       ty_expected
   | Pexp_let (rec_flag, spat_sexp_list, sbody) ->
     let scp =
-      match (sexp.pexp_attributes, rec_flag) with
-      | [({txt = "#default"}, _)], _ -> None
-      | _, Recursive -> Some (Annot.Idef loc)
-      | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
+      match rec_flag with
+      | Recursive -> Some (Annot.Idef loc)
+      | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
     in
     let pat_exp_list, new_env, unpacks =
       type_let ~context:None env rec_flag spat_sexp_list scp true
@@ -3530,7 +3529,7 @@ and type_function ~async loc attrs env ty_expected_
     (sparams : Parsetree.fun_param list) sbody =
   (* Desugar optional-parameter defaults: the parameter becomes a fresh
      [*opt_<label>*] variable and the original pattern is bound in a
-     [#default]-annotated let at the head of the body. The let syntax is kept
+     let at the head of the body. The let syntax is kept
      alongside its parameter rather than wrapped into the body here: each
      binding is typed while the parameter environment accumulates left to
      right, so a default only sees the parameters before it (typing it as
@@ -3722,20 +3721,77 @@ and type_function ~async loc attrs env ty_expected_
          parameter enters the environment, mirroring the curried per-level
          typing this replaced: a default sees only the parameters to its
          left, and its pattern's bindings are in scope for what follows. *)
-      let ext_env, unpacks, defaults_acc =
+      let pat, ext_env, unpacks, defaults_acc, opt_param =
         match default_binding with
-        | None -> (ext_env, unpacks, defaults_acc)
+        | None -> (pat, ext_env, unpacks, defaults_acc, None)
         | Some vb ->
           let let_env = ext_env in
           let pat_exp_list, ext_env, let_unpacks =
             type_let ~context:None ext_env Nonrecursive [vb] None true
           in
-          ( ext_env,
+          (* The pattern binds the option carrier under an unspellable name
+             ([*opt_<label>*]), which typing needs so that user code can
+             neither reference nor shadow it. Everything mentioning the
+             carrier has been typed at this point: replace it with a fresh
+             user-legible parameter ident derived from the label, both at its
+             binder and at its single use, the scrutinee of the synthetic
+             match. The carrier then never reaches the lambda layer. *)
+          let param_id = Ident.create (label_name p.p_lbl ^ "Opt") in
+          let pat =
+            match pat.pat_desc with
+            | Tpat_var (_, name) ->
+              {
+                pat with
+                pat_desc =
+                  Tpat_var (param_id, {name with txt = Ident.name param_id});
+              }
+            | _ -> assert false
+          in
+          let pat_exp_list =
+            match pat_exp_list with
+            | [
+             ({
+                vb_expr =
+                  {
+                    exp_desc =
+                      Texp_match
+                        ( ({exp_desc = Texp_ident (Path.Pident _, lid, vd)} as
+                           scrut),
+                          cases,
+                          exn_cases,
+                          m_partial );
+                  } as vb_expr;
+              } as vb);
+            ] ->
+              [
+                {
+                  vb with
+                  vb_expr =
+                    {
+                      vb_expr with
+                      exp_desc =
+                        Texp_match
+                          ( {
+                              scrut with
+                              exp_desc =
+                                Texp_ident (Path.Pident param_id, lid, vd);
+                            },
+                            cases,
+                            exn_cases,
+                            m_partial );
+                    };
+                };
+              ]
+            | _ -> assert false
+          in
+          ( pat,
+            ext_env,
             unpacks @ let_unpacks,
-            (pat_exp_list, let_env) :: defaults_acc )
+            (pat_exp_list, let_env) :: defaults_acc,
+            Some param_id )
       in
       type_params
-        ((p, pat, ty_arg_c) :: typed_acc)
+        ((p, opt_param, pat, ty_arg_c) :: typed_acc)
         ext_env (unpacks_acc @ unpacks) defaults_acc rest_params rest_tys
     | _ -> assert false
   in
@@ -3754,8 +3810,8 @@ and type_function ~async loc attrs env ty_expected_
      let ty_res' = instance env ty_res in
      unify_exp ~context:None env body_exp ty_res');
   (* Stack the typed default bindings back onto the body, leftmost parameter
-     outermost — the same [#default] let shape [type_expect] would have
-     produced had the lets been part of the body's syntax. *)
+     outermost — the same let shape [type_expect] would have produced had the
+     lets been part of the body's syntax. *)
   let body_exp =
     List.fold_right
       (fun (pat_exp_list, let_env) inner ->
@@ -3765,22 +3821,22 @@ and type_function ~async loc attrs env ty_expected_
             exp_loc = loc;
             exp_extra = [];
             exp_type = inner.exp_type;
-            exp_attributes = [(mknoloc "#default", Parsetree.PStr [])];
+            exp_attributes = [];
             exp_env = let_env;
           })
       default_lets body_exp
   in
   let needs_exhaust_check =
     List.exists
-      (fun ((p : Parsetree.fun_param), _, _) -> not (is_var p.p_pat))
+      (fun ((p : Parsetree.fun_param), _, _, _) -> not (is_var p.p_pat))
       typed_params
   in
   let do_init = has_gadts || needs_exhaust_check in
   let lev, env = if do_init && not has_gadts then init_env () else (lev, env) in
   ignore lev;
   let tparams =
     List.map
-      (fun ((p : Parsetree.fun_param), pat, ty_arg_c) ->
+      (fun ((p : Parsetree.fun_param), opt_param, pat, ty_arg_c) ->
         let case = {c_lhs = pat; c_guard = None; c_rhs = body_exp} in
         let ty_arg_check =
           if do_init then
@@ -3796,11 +3852,17 @@ and type_function ~async loc attrs env ty_expected_
         if contains_polyvars || do_init then
           Delayed_checks.add_delayed_check unused_check
         else unused_check ();
+        let fp_param =
+          match opt_param with
+          | Some id -> id
+          | None -> name_pattern "param" [case]
+        in
         {
           fp_lbl = p.p_lbl;
-          fp_param = name_pattern "param" [case];
+          fp_param;
           fp_pat = pat;
           fp_partial = partial;
+          fp_has_default = opt_param <> None;
         })
       typed_params
   in
@@ -4516,18 +4578,13 @@ and type_let ~context ?(check = fun s -> Warnings.Unused_var s)
   in
   begin_def ();
   let is_fake_let =
+    (* the synthetic let-declaration introduced for an optional parameter's
+       default: its variables are parameters from the user's point of view,
+       so an unused one gets the strict (parameter) warning *)
     match spat_sexp_list with
-    | [
-     {
-       pvb_expr =
-         {
-           pexp_desc =
-             Pexp_match
-               ({pexp_desc = Pexp_ident {txt = Longident.Lident "*opt*"}}, _);
-         };
-     };
-    ] ->
-      true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | [{pvb_expr = {pexp_attributes}}] ->
+      Ext_list.exists pexp_attributes (fun ({txt}, _) ->
+          txt = "#optional_arg_default")
     | _ -> false
   in
   let check = if is_fake_let then check_strict else check in

compiler/ml/typedtree.ml

@@ -144,6 +144,11 @@ and function_param = {
   fp_param: Ident.t; (* the name the compiled parameter binds to *)
   fp_pat: pattern;
   fp_partial: partial; (* whether [fp_pat] is exhaustive *)
+  fp_has_default: bool;
+      (* optional parameter with a default value. [fp_pat] then binds the
+         option carrier directly to [fp_param] -- a fresh ident named after
+         the label -- and the user's pattern is bound by a let at the head
+         of the body. *)
 }
 
 and record_label_definition =

compiler/ml/typedtree.mli

@@ -245,6 +245,11 @@ and function_param = {
   fp_param: Ident.t; (* the name the compiled parameter binds to *)
   fp_pat: pattern;
   fp_partial: partial; (* whether [fp_pat] is exhaustive *)
+  fp_has_default: bool;
+      (* optional parameter with a default value. [fp_pat] then binds the
+         option carrier directly to [fp_param] -- a fresh ident named after
+         the label -- and the user's pattern is bound by a let at the head
+         of the body. *)
 }
 
 and record_label_definition =

tests/tests/src/mario_game.mjs

@@ -25,13 +25,13 @@ let Actors = {};
 
 let Dom_html = {};
 
-function setup_sprite(loopOpt, bbox_offsetOpt, bbox_sizeOpt, img_src, max_frames, max_ticks, frame_size, src_offset) {
+function setup_sprite(loopOpt, bb_offOpt, bb_szOpt, img_src, max_frames, max_ticks, frame_size, src_offset) {
   let loop = loopOpt !== undefined ? loopOpt : true;
-  let bbox_offset = bbox_offsetOpt !== undefined ? bbox_offsetOpt : [
+  let bbox_offset = bb_offOpt !== undefined ? bb_offOpt : [
       0,
       0
     ];
-  let bbox_size = bbox_sizeOpt !== undefined ? bbox_sizeOpt : [
+  let bbox_size = bb_szOpt !== undefined ? bb_szOpt : [
       0,
       0
     ];
@@ -794,9 +794,9 @@ let id_counter = {
   contents: Stdlib_Int.Constants.minValue
 };
 
-function setup_obj(has_gravityOpt, speedOpt, param) {
-  let has_gravity = has_gravityOpt !== undefined ? has_gravityOpt : true;
-  let speed = speedOpt !== undefined ? speedOpt : 1;
+function setup_obj(gOpt, spdOpt, param) {
+  let has_gravity = gOpt !== undefined ? gOpt : true;
+  let speed = spdOpt !== undefined ? spdOpt : 1;
   return {
     has_gravity: has_gravity,
     speed: speed
@@ -847,9 +847,9 @@ function new_id() {
   return id_counter.contents;
 }
 
-function make$2($staropt_id$star, $staropt_dir$star, spawnable, context, param) {
-  let id = $staropt_id$star !== undefined ? Primitive_option.valFromOption($staropt_id$star) : undefined;
-  let dir = $staropt_dir$star !== undefined ? $staropt_dir$star : "Left";
+function make$2(idOpt, dirOpt, spawnable, context, param) {
+  let id = idOpt !== undefined ? Primitive_option.valFromOption(idOpt) : undefined;
+  let dir = dirOpt !== undefined ? dirOpt : "Left";
   let spr = make(spawnable, dir, context);
   let params = make_type$2(spawnable);
   let id$1 = id !== undefined ? id : new_id();