Track types of variables bound by as (#3507)

lpw25 · lthls · goldfirere · web-flow · commit 12b9b6ea4cd9 · 2025-02-12T14:15:54.000Z
* Track types of variables bound by `as`

Keep the types of variables bound by `as` because they may not equal the
types of the `as` patterns themselves. This fixes some incorrect value
kinds that can lead to miscompilation.

* Add test

* Get ocamldoc compiling

* Fix chamelon

---------

Co-authored-by: Vincent Laviron &lt;vincent.laviron@gmail.com&gt;
Co-authored-by: Richard Eisenberg &lt;reisenberg@janestreet.com&gt;
diff --git a/chamelon/compat.jst.ml b/chamelon/compat.jst.ml
@@ -297,10 +297,10 @@ type tpat_var_identifier = Value.l
 let mkTpat_var ?id:(mode = dummy_value_mode) (ident, name) =
   Tpat_var (ident, name, Uid.internal_not_actually_unique, mode)
 
-type tpat_alias_identifier = Value.l
+type tpat_alias_identifier = Value.l * Types.type_expr
 
-let mkTpat_alias ?id:(mode = dummy_value_mode) (p, ident, name) =
-  Tpat_alias (p, ident, name, Uid.internal_not_actually_unique, mode)
+let mkTpat_alias ~id:(mode, ty) (p, ident, name) =
+  Tpat_alias (p, ident, name, Uid.internal_not_actually_unique, mode, ty)
 
 type tpat_array_identifier = mutability * Jkind.sort
 
@@ -340,7 +340,8 @@ type 'a matched_pattern_desc =
 let view_tpat (type a) (p : a pattern_desc) : a matched_pattern_desc =
   match p with
   | Tpat_var (ident, name, _uid, mode) -> Tpat_var (ident, name, mode)
-  | Tpat_alias (p, ident, name, _uid, mode) -> Tpat_alias (p, ident, name, mode)
+  | Tpat_alias (p, ident, name, _uid, mode, ty) ->
+      Tpat_alias (p, ident, name, (mode, ty))
   | Tpat_array (mut, arg_sort, l) -> Tpat_array (l, (mut, arg_sort))
   | Tpat_tuple pats ->
       let labels, pats = List.split pats in
diff --git a/chamelon/compat.mli b/chamelon/compat.mli
@@ -121,7 +121,7 @@ val mkTpat_var :
   ?id:tpat_var_identifier -> Ident.t * string Location.loc -> value pattern_desc
 
 val mkTpat_alias :
-  ?id:tpat_alias_identifier ->
+  id:tpat_alias_identifier ->
   value general_pattern * Ident.t * string Location.loc ->
   value pattern_desc
 
diff --git a/chamelon/compat.upstream.ml b/chamelon/compat.upstream.ml
@@ -175,7 +175,7 @@ let mkTpat_var ?id:(() = ()) (ident, name) = Tpat_var (ident, name)
 
 type tpat_alias_identifier = unit
 
-let mkTpat_alias ?id:(() = ()) (p, ident, name) = Tpat_alias (p, ident, name)
+let mkTpat_alias ~id:() (p, ident, name) = Tpat_alias (p, ident, name)
 
 type tpat_array_identifier = unit
 
diff --git a/lambda/matching.ml b/lambda/matching.ml
@@ -239,8 +239,9 @@ end = struct
     | Tpat_any
     | Tpat_var _ ->
         p
-    | Tpat_alias (q, id, s, uid, mode) ->
-        { p with pat_desc = Tpat_alias (simpl_under_orpat q, id, s, uid, mode) }
+    | Tpat_alias (q, id, s, uid, mode, ty) ->
+        { p with pat_desc =
+            Tpat_alias (simpl_under_orpat q, id, s, uid, mode, ty) }
     | Tpat_or (p1, p2, o) ->
         let p1, p2 = (simpl_under_orpat p1, simpl_under_orpat p2) in
         if le_pat p1 p2 then
@@ -267,8 +268,8 @@ end = struct
       match p.pat_desc with
       | `Any -> stop p `Any
       | `Var (id, s, uid, mode) ->
-        continue p (`Alias (Patterns.omega, id, s, uid, mode))
-      | `Alias (p, id, _, _, _) ->
+        continue p (`Alias (Patterns.omega, id, s, uid, mode, p.pat_type))
+      | `Alias (p, id, _, _, _, _) ->
           aux
             ( (General.view p, patl),
               bind_alias p id ~arg ~arg_sort ~action )
@@ -375,10 +376,11 @@ end = struct
       match p.pat_desc with
       | `Or (p1, p2, _) ->
           split_explode p1 aliases (split_explode p2 aliases rem)
-      | `Alias (p, id, _, _, _) -> split_explode p (id :: aliases) rem
+      | `Alias (p, id, _, _, _, _) -> split_explode p (id :: aliases) rem
       | `Var (id, str, uid, mode) ->
           explode
-            { p with pat_desc = `Alias (Patterns.omega, id, str, uid, mode) }
+            { p with pat_desc =
+                `Alias (Patterns.omega, id, str, uid, mode, p.pat_type) }
             aliases rem
       | #view as view ->
           (* We are doing two things here:
@@ -626,7 +628,7 @@ end = struct
           match p.pat_desc with
           | `Or (p1, p2, _) ->
               filter_rec ((left, p1, right) :: (left, p2, right) :: rem)
-          | `Alias (p, _, _, _, _) -> filter_rec ((left, p, right) :: rem)
+          | `Alias (p, _, _, _, _, _) -> filter_rec ((left, p, right) :: rem)
           | `Var _ -> filter_rec ((left, Patterns.omega, right) :: rem)
           | #Simple.view as view -> (
               let p = { p with pat_desc = view } in
@@ -676,7 +678,7 @@ let rec flatten_pat_line size p k =
   | Tpat_tuple args -> (List.map snd args) :: k
   | Tpat_or (p1, p2, _) ->
       flatten_pat_line size p1 (flatten_pat_line size p2 k)
-  | Tpat_alias (p, _, _, _, _) ->
+  | Tpat_alias (p, _, _, _, _, _) ->
       (* Note: we are only called from flatten_matrix,
          which is itself only ever used in places
          where variables do not matter (default environments,
@@ -754,7 +756,7 @@ end = struct
       | (p, ps) :: rem -> (
           let p = General.view p in
           match p.pat_desc with
-          | `Alias (p, _, _, _, _) -> filter_rec ((p, ps) :: rem)
+          | `Alias (p, _, _, _, _, _) -> filter_rec ((p, ps) :: rem)
           | `Var _ -> filter_rec ((Patterns.omega, ps) :: rem)
           | `Or (p1, p2, _) -> filter_rec_or p1 p2 ps rem
           | #Simple.view as view -> (
@@ -1304,7 +1306,7 @@ let rec omega_like p =
   | Tpat_any
   | Tpat_var _ ->
       true
-  | Tpat_alias (p, _, _, _, _) -> omega_like p
+  | Tpat_alias (p, _, _, _, _, _) -> omega_like p
   | Tpat_or (p1, p2, _) -> omega_like p1 || omega_like p2
   | _ -> false
 
@@ -3723,7 +3725,7 @@ let rec name_pattern default = function
   | ((pat, _), _) :: rem -> (
       match pat.pat_desc with
       | Tpat_var (id, _, _, _) -> id
-      | Tpat_alias (_, id, _, _, _) -> id
+      | Tpat_alias (_, id, _, _, _, _) -> id
       | _ -> name_pattern default rem
     )
   | _ -> Ident.create_local default
@@ -4267,7 +4269,7 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body =
          for "let _ = ...". See #6865. *)
       Lsequence (param, body)
   | Tpat_var (id, _, _, _)
-  | Tpat_alias ({ pat_desc = Tpat_any }, id, _, _, _) ->
+  | Tpat_alias ({ pat_desc = Tpat_any }, id, _, _, _, _) ->
       (* Fast path, and keep track of simple bindings to unboxable numbers.
 
          Note: the (Tpat_alias (Tpat_any, id)) case needs to be
diff --git a/lambda/translclass.ml b/lambda/translclass.ml
@@ -155,7 +155,7 @@ let create_object cl obj init =
 let name_pattern default p =
   match p.pat_desc with
   | Tpat_var (id, _, _, _) -> id
-  | Tpat_alias(_, id, _, _, _) -> id
+  | Tpat_alias(_, id, _, _, _, _) -> id
   | _ -> Ident.create_local default
 
 let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl =
diff --git a/lambda/translcore.ml b/lambda/translcore.ml
@@ -322,7 +322,7 @@ let fuse_method_arity (parent : fusable_function) : fusable_function =
 let rec iter_exn_names f pat =
   match pat.pat_desc with
   | Tpat_var (id, _, _, _) -> f id
-  | Tpat_alias (p, id, _, _, _) ->
+  | Tpat_alias (p, id, _, _, _, _) ->
       f id;
       iter_exn_names f p
   | _ -> ()
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
@@ -51,7 +51,7 @@ module Typedtree_search =
     let iter_val_pattern = function
       | Typedtree.Tpat_any -> None
       | Typedtree.Tpat_var (name, _, _, _)
-      | Typedtree.Tpat_alias (_, name, _, _, _)  -> Some (Name.from_ident name)
+      | Typedtree.Tpat_alias (_, name, _, _, _, _)  -> Some (Name.from_ident name)
       | Typedtree.Tpat_tuple _ -> None (* FIXME when we will handle tuples *)
       | _ -> None
 
@@ -258,7 +258,7 @@ module Analyser =
                           sn_type = Odoc_env.subst_type env pat.pat_type
                         }
 
-        | Typedtree.Tpat_alias (pat, _, _, _, _) ->
+        | Typedtree.Tpat_alias (pat, _, _, _, _, _) ->
             iter_pattern pat
 
         | Typedtree.Tpat_tuple patlist ->
diff --git a/testsuite/tests/asmcomp/regression_value_kinds.ml b/testsuite/tests/asmcomp/regression_value_kinds.ml
@@ -0,0 +1,21 @@
+(* TEST
+ native;
+*)
+
+type r = { foo : float }
+
+type 'a t = Left of 'a | Right of r
+
+type 'a ty =
+  | Float : float ty
+  | Anything : 'a ty
+
+let f (type a) (ty : a ty) (x : a t) =
+  match ty, x with
+  | Float, Right { foo = (((3.5 : a) as a) : float) }
+  | _, Left a -> ignore (Sys.opaque_identity a)
+  | _, _ -> ()
+
+let f = Sys.opaque_identity f
+
+let () = f Anything (Left 0)
diff --git a/typing/cmt2annot.ml b/typing/cmt2annot.ml
@@ -23,7 +23,7 @@ let variables_iterator scope =
   let super = default_iterator in
   let pat sub (type k) (p : k general_pattern) =
     begin match p.pat_desc with
-    | Tpat_var (id, _, _, _) | Tpat_alias (_, id, _, _, _) ->
+    | Tpat_var (id, _, _, _) | Tpat_alias (_, id, _, _, _, _) ->
         Stypes.record (Stypes.An_ident (p.pat_loc,
                                         Ident.name id,
                                         Annot.Idef scope))
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
@@ -335,8 +335,8 @@ module Compat
   | ((Tpat_any|Tpat_var _),_)
   | (_,(Tpat_any|Tpat_var _)) -> true
 (* Structural induction *)
-  | Tpat_alias (p,_,_,_,_),_      -> compat p q
-  | _,Tpat_alias (q,_,_,_,_)      -> compat p q
+  | Tpat_alias (p,_,_,_,_,_),_      -> compat p q
+  | _,Tpat_alias (q,_,_,_,_,_)      -> compat p q
   | Tpat_or (p1,p2,_),_ ->
       (compat p1 q || compat p2 q)
   | _,Tpat_or (q1,q2,_) ->
@@ -1216,7 +1216,7 @@ let build_other ext env =
 let rec has_instance p = match p.pat_desc with
   | Tpat_variant (l,_,r) when is_absent l r -> false
   | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
-  | Tpat_alias (p,_,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
+  | Tpat_alias (p,_,_,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
   | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
   | Tpat_construct (_,_,ps, _) | Tpat_array (_, _, ps) ->
       has_instances ps
@@ -1676,7 +1676,7 @@ let is_var_column rs =
 (* Standard or-args for left-to-right matching *)
 let rec or_args p = match p.pat_desc with
 | Tpat_or (p1,p2,_) -> p1,p2
-| Tpat_alias (p,_,_,_,_)  -> or_args p
+| Tpat_alias (p,_,_,_,_,_)  -> or_args p
 | _                 -> assert false
 
 (* Just remove current column *)
@@ -1856,8 +1856,8 @@ and every_both pss qs q1 q2 =
 let rec le_pat p q =
   match (p.pat_desc, q.pat_desc) with
   | (Tpat_var _|Tpat_any),_ -> true
-  | Tpat_alias(p,_,_,_,_), _ -> le_pat p q
-  | _, Tpat_alias(q,_,_,_,_) -> le_pat p q
+  | Tpat_alias(p,_,_,_,_,_), _ -> le_pat p q
+  | _, Tpat_alias(q,_,_,_,_,_) -> le_pat p q
   | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
   | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) ->
       Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
@@ -1917,8 +1917,8 @@ let get_mins le ps =
 *)
 
 let rec lub p q = match p.pat_desc,q.pat_desc with
-| Tpat_alias (p,_,_,_,_),_      -> lub p q
-| _,Tpat_alias (q,_,_,_,_)      -> lub p q
+| Tpat_alias (p,_,_,_,_,_),_      -> lub p q
+| _,Tpat_alias (q,_,_,_,_,_)      -> lub p q
 | (Tpat_any|Tpat_var _),_ -> q
 | _,(Tpat_any|Tpat_var _) -> p
 | Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
@@ -2150,7 +2150,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
     List.fold_left
       (fun r (_, _, p) -> collect_paths_from_pat r p)
       r lps
-| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_,_) ->
+| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_,_,_) ->
     collect_paths_from_pat r p
 | Tpat_or (p1,p2,_) ->
     collect_paths_from_pat (collect_paths_from_pat r p1) p2
@@ -2290,7 +2290,7 @@ let inactive ~partial pat =
             List.for_all (fun (_,p,_) -> loop p) ps
         | Tpat_construct (_, _, ps, _) | Tpat_array (Immutable, _, ps) ->
             List.for_all (fun p -> loop p) ps
-        | Tpat_alias (p,_,_,_,_) | Tpat_variant (_, Some p, _) ->
+        | Tpat_alias (p,_,_,_,_,_) | Tpat_variant (_, Some p, _) ->
             loop p
         | Tpat_record (ldps,_) ->
             List.for_all
@@ -2419,7 +2419,7 @@ type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
 let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
   let rec simpl head_bound_variables varsets p ps k =
     match (Patterns.General.view p).pat_desc with
-    | `Alias (p,x,_,_,_) ->
+    | `Alias (p,x,_,_,_,_) ->
       simpl (Ident.Set.add x head_bound_variables) varsets p ps k
     | `Var (x, _, _, _) ->
       simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k
diff --git a/typing/patterns.ml b/typing/patterns.ml
@@ -85,7 +85,8 @@ module General = struct
   type view = [
     | Half_simple.view
     | `Var of Ident.t * string loc * Uid.t * Mode.Value.l
-    | `Alias of pattern * Ident.t * string loc * Uid.t * Mode.Value.l
+    | `Alias of pattern * Ident.t * string loc
+                * Uid.t * Mode.Value.l * Types.type_expr
   ]
   type pattern = view pattern_data
 
@@ -94,8 +95,8 @@ module General = struct
        `Any
     | Tpat_var (id, str, uid, mode) ->
        `Var (id, str, uid, mode)
-    | Tpat_alias (p, id, str, uid, mode) ->
-       `Alias (p, id, str, uid, mode)
+    | Tpat_alias (p, id, str, uid, mode, ty) ->
+       `Alias (p, id, str, uid, mode, ty)
     | Tpat_constant cst ->
        `Constant cst
     | Tpat_tuple ps ->
@@ -120,7 +121,8 @@ module General = struct
   let erase_desc = function
     | `Any -> Tpat_any
     | `Var (id, str, uid, mode) -> Tpat_var (id, str, uid, mode)
-    | `Alias (p, id, str, uid, mode) -> Tpat_alias (p, id, str, uid, mode)
+    | `Alias (p, id, str, uid, mode, ty) ->
+       Tpat_alias (p, id, str, uid, mode, ty)
     | `Constant cst -> Tpat_constant cst
     | `Tuple ps -> Tpat_tuple ps
     | `Unboxed_tuple ps -> Tpat_unboxed_tuple ps
@@ -141,7 +143,7 @@ module General = struct
 
   let rec strip_vars (p : pattern) : Half_simple.pattern =
     match p.pat_desc with
-    | `Alias (p, _, _, _, _) -> strip_vars (view p)
+    | `Alias (p, _, _, _, _, _) -> strip_vars (view p)
     | `Var _ -> { p with pat_desc = `Any }
     | #Half_simple.view as view -> { p with pat_desc = view }
 end
diff --git a/typing/patterns.mli b/typing/patterns.mli
@@ -69,7 +69,8 @@ module General : sig
   type view = [
     | Half_simple.view
     | `Var of Ident.t * string loc * Uid.t * Mode.Value.l
-    | `Alias of pattern * Ident.t * string loc * Uid.t * Mode.Value.l
+    | `Alias of pattern * Ident.t * string loc * Uid.t
+                * Mode.Value.l * Types.type_expr
   ]
   type pattern = view pattern_data
 
diff --git a/typing/printpat.ml b/typing/printpat.ml
@@ -114,7 +114,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
       fprintf ppf "@[[%c %a %c]@]" punct (pretty_vals " ;") vs punct
   | Tpat_lazy v ->
       fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
-  | Tpat_alias (v, x, _, _, _) ->
+  | Tpat_alias (v, x, _, _, _, _) ->
       fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
   | Tpat_value v ->
       fprintf ppf "%a" pretty_val (v :> pattern)
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
@@ -327,7 +327,7 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x ->
   | Tpat_var (s,_,_,m) ->
       line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
       value_mode i ppf m
-  | Tpat_alias (p, s,_,_,m) ->
+  | Tpat_alias (p, s,_,_,m,_) ->
       line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
       value_mode i ppf m;
       pattern i ppf p;
diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml
@@ -270,7 +270,7 @@ let pat
   | Tpat_record_unboxed_product (l, _) ->
       List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l
   | Tpat_array (_, _, l) -> List.iter (sub.pat sub) l
-  | Tpat_alias (p, _, s, _, _) -> sub.pat sub p; iter_loc sub s
+  | Tpat_alias (p, _, s, _, _, _) -> sub.pat sub p; iter_loc sub s
   | Tpat_lazy p -> sub.pat sub p
   | Tpat_value p -> sub.pat sub (p :> pattern)
   | Tpat_exception p -> sub.pat sub p
diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
@@ -319,8 +319,8 @@ let pat
         Tpat_record_unboxed_product
           (List.map (tuple3 (map_loc sub) id (sub.pat sub)) l, closed)
     | Tpat_array (am, arg_sort, l) -> Tpat_array (am, arg_sort, List.map (sub.pat sub) l)
-    | Tpat_alias (p, id, s, uid, m) ->
-        Tpat_alias (sub.pat sub p, id, map_loc sub s, uid, m)
+    | Tpat_alias (p, id, s, uid, m, ty) ->
+        Tpat_alias (sub.pat sub p, id, map_loc sub s, uid, m, ty)
     | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
     | Tpat_value p ->
        (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc
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/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml
diff --git a/typing/untypeast.ml b/typing/untypeast.ml
diff --git a/typing/value_rec_check.ml b/typing/value_rec_check.ml

Original file line number	Diff line number	Diff line change
`@@ -69,7 +69,8 @@ module General : sig`
`69`	`69`	`type view = [`
`70`	`70`	`\| Half_simple.view`
`71`	`71`	\| `Var of Ident.t * string loc * Uid.t * Mode.Value.l
`72`		- \| `Alias of pattern * Ident.t * string loc * Uid.t * Mode.Value.l
	`72`	+ \| `Alias of pattern * Ident.t * string loc * Uid.t
	`73`	`+ * Mode.Value.l * Types.type_expr`
`73`	`74`	`]`
`74`	`75`	`type pattern = view pattern_data`
`75`	`76`