Pass through the is_exception everywhere it's needed

Author: DZakh

jscomp/ml/ctype.ml

@@ -3674,7 +3674,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
             true (* handled in the fields checks *)
           | Record_unboxed b1, Record_unboxed b2 -> b1 = b2
           | Record_inlined _, Record_inlined _ -> repr1 = repr2
-          | Record_extension, Record_extension -> true
+          | Record_extension b1, Record_extension b2 -> b1.is_exception = b2.is_exception
           | _ -> false in
         if same_repr then
           let violation, tl1, tl2 = Record_coercion.check_record_fields ~repr1 ~repr2 fields1 fields2 in

jscomp/ml/datarepr.ml

@@ -194,7 +194,7 @@ let extension_descr path_ext ext =
   in
   let existentials, cstr_args, cstr_inlined =
     constructor_args ext.ext_private ext.ext_args ext.ext_ret_type
-      path_ext Record_extension
+      path_ext (Record_extension { is_exception = ext.ext_is_exception })
   in
     { cstr_name = Path.last path_ext;
       cstr_res = ty_res;

jscomp/ml/lambda.ml

@@ -48,14 +48,13 @@ type tag_info =
   | Blk_module of string list
   | Blk_module_export of Ident.t list
   | Blk_extension of {
-    is_exception: bool;
-   }
+      is_exception: bool; }
   | Blk_some
   | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *)
   | Blk_record_ext of {
-     fields:  string array;
-     mutable_flag: Asttypes.mutable_flag;
-    }
+      fields:  string array;
+      mutable_flag: Asttypes.mutable_flag;
+      is_exception: bool; }
   | Blk_lazy_general
 
 let tag_of_tag_info (tag : tag_info ) = 
@@ -114,14 +113,14 @@ let blk_record (fields : (label * _) array) mut record_repr =
     { fields = all_labels_info; mutable_flag = mut; record_repr }
 
 
-let blk_record_ext fields mutable_flag =
+let blk_record_ext fields mutable_flag is_exception =
   let all_labels_info =
     Array.map
       (fun ((lbl : label), _) ->
         Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name)
       fields
   in
-  Blk_record_ext {fields = all_labels_info; mutable_flag }
+  Blk_record_ext {fields = all_labels_info; mutable_flag; is_exception }
 
 let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs mutable_flag =
   let fields =

jscomp/ml/lambda.mli

@@ -47,8 +47,7 @@ type tag_info =
   | Blk_module of string list
   | Blk_module_export of Ident.t list 
   | Blk_extension of {
-    is_exception: bool;
-  }
+      is_exception: bool; }
     (* underlying is the same as tuple, immutable block
       {[
          exception A of int * int 
@@ -63,9 +62,9 @@ type tag_info =
   | Blk_some
   | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *)
   | Blk_record_ext of {
-    fields: string array;
-    mutable_flag: mutable_flag;
-   }
+      fields: string array;
+      mutable_flag: mutable_flag;
+      is_exception: bool; }
   | Blk_lazy_general    
 
 val find_name :
@@ -83,6 +82,7 @@ val blk_record :
 val blk_record_ext :
   (Types.label_description* Typedtree.record_label_definition) array ->
   mutable_flag -> 
+  bool ->
   tag_info
 
 

jscomp/ml/matching.ml

@@ -1602,7 +1602,7 @@ let make_record_matching loc all_labels def = function
             | Record_inlined _ ->
               Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc)
             | Record_unboxed _ -> arg
-            | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], loc) 
+            | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], loc) 
           in
           let str =
             match lbl.lbl_mut with

jscomp/ml/printtyped.ml

@@ -150,7 +150,7 @@ let record_representation i ppf = let open Types in function
     line i ppf "Record_optional_labels %s\n" (lbls |> String.concat ", ")
   | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
   | Record_inlined {tag = i} -> line i ppf "Record_inlined %d\n" i
-  | Record_extension -> line i ppf "Record_extension\n"
+  | Record_extension _ -> line i ppf "Record_extension\n"
 
 let attributes i ppf l =
   let i = i + 1 in

jscomp/ml/rec_check.ml

@@ -256,7 +256,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t =
         match rep with
         | Record_unboxed _ -> fun x -> x
         | Record_float_unused -> assert false
-        | Record_optional_labels _ | Record_regular | Record_inlined _ | Record_extension
+        | Record_optional_labels _ | Record_regular | Record_inlined _ | Record_extension _
           ->
             Use.guard
       in

jscomp/ml/translcore.ml

@@ -943,7 +943,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
               [ targ ],
               e.exp_loc )
       | Record_unboxed _ -> targ
-      | Record_extension ->
+      | Record_extension _ ->
           Lprim
             ( Pfield
                 (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl),
@@ -958,7 +958,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
         | Record_inlined _ ->
             Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl)
         | Record_unboxed _ -> assert false
-        | Record_extension ->
+        | Record_extension _ ->
             Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl)
       in
       Lprim (access, [ transl_exp arg; transl_exp newval ], e.exp_loc)
@@ -1212,7 +1212,7 @@ and transl_record loc env fields repres opt_init_expr =
                     | Record_inlined _ ->
                         Pfield (i, Lambda.fld_record_inline lbl)
                     | Record_unboxed _ -> assert false
-                    | Record_extension ->
+                    | Record_extension _ ->
                         Pfield
                           (i + 1, Lambda.fld_record_extension lbl)
                   in
@@ -1246,7 +1246,7 @@ and transl_record loc env fields repres opt_init_expr =
                        cl ))
             | Record_unboxed _ ->
                 Lconst (match cl with [ v ] -> v | _ -> assert false)
-            | Record_extension -> raise Not_constant
+            | Record_extension _ -> raise Not_constant
           with Not_constant -> (
             match repres with
             | Record_regular ->
@@ -1269,7 +1269,7 @@ and transl_record loc env fields repres opt_init_expr =
                     loc )
             | Record_unboxed _ -> (
                 match ll with [ v ] -> v | _ -> assert false)
-            | Record_extension ->
+            | Record_extension { is_exception } ->
                 let path =
                   let label, _ = fields.(0) in
                   match label.lbl_res.desc with
@@ -1278,7 +1278,7 @@ and transl_record loc env fields repres opt_init_expr =
                 in
                 let slot = transl_extension_path env path in
                 Lprim
-                  ( Pmakeblock (Lambda.blk_record_ext fields mut),
+                  ( Pmakeblock (Lambda.blk_record_ext fields mut is_exception),
                     slot :: ll,
                     loc ))
         in
@@ -1302,7 +1302,7 @@ and transl_record loc env fields repres opt_init_expr =
                 | Record_inlined _ ->
                     Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl)
                 | Record_unboxed _ -> assert false
-                | Record_extension ->
+                | Record_extension _ ->
                     Psetfield
                       (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl)
               in

jscomp/ml/typedecl.ml

@@ -1549,7 +1549,7 @@ let transl_extension_constructor env type_path type_params
               List.iter2 (Ctype.unify env) decl.type_params tl;
               let lbls =
                 match decl.type_kind with
-                | Type_record (lbls, Record_extension) -> lbls
+                | Type_record (lbls, Record_extension _) -> lbls
                 | _ -> assert false
               in
               Types.Cstr_record lbls

jscomp/ml/types.ml

@@ -155,7 +155,8 @@ and record_representation =
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
       { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes}
-  | Record_extension                      (* Inlined record under extension *)
+  | Record_extension of                   (* Inlined record under extension *)
+      { is_exception : bool }
   | Record_optional_labels of string list (* List of optional labels *)
 
 and label_declaration =
@@ -322,5 +323,8 @@ let same_record_representation x y =
       | Record_inlined y ->
           tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts && optional_labels = y.optional_labels
       | _ -> false)
-  | Record_extension -> y = Record_extension
+  | Record_extension {is_exception} -> (
+      match y with
+        | Record_extension y -> is_exception = y.is_exception
+        | _ -> false)
   | Record_unboxed x -> ( match y with Record_unboxed y -> x = y | _ -> false)

jscomp/ml/types.mli

@@ -302,7 +302,8 @@ and record_representation =
   | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
   | Record_inlined of                     (* Inlined record *)
       { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes }
-  | Record_extension                      (* Inlined record under extension *)
+  | Record_extension of                   (* Inlined record under extension *)
+      { is_exception : bool }
   | Record_optional_labels of string list (* List of optional labels *)
 
 and label_declaration =