Pass is_exception to Blk_extension

DZakh · DZakh · commit bf82c06dca22 · 2024-08-26T23:52:18.000+04:00
diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml
@@ -104,7 +104,7 @@ let exn_block_as_obj ~(stack : bool) (el : J.expression list) (ext : J.tag_info)
     : J.expression =
   let field_name =
     match ext with
-    | Blk_extension -> (
+    | Blk_extension _ -> (
         fun i ->
           match i with 0 -> Literals.exception_id | i -> "_" ^ string_of_int i)
     | Blk_record_ext { fields = ss } -> (
@@ -170,7 +170,7 @@ let exp_need_paren (e : J.expression) =
       ( _,
         _,
         _,
-        ( Blk_record _ | Blk_module _ | Blk_poly_var _ | Blk_extension
+        ( Blk_record _ | Blk_module _ | Blk_poly_var _ | Blk_extension _
         | Blk_record_ext _ | Blk_record_inlined _ | Blk_constructor _ ) )
   | Object _ ->
       true
@@ -774,7 +774,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
                  (Lit Literals.polyvar_value, value);
                ])
       | _ -> assert false)
-  | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) ->
+  | Caml_block (el, _, _, ((Blk_extension _ | Blk_record_ext _) as ext)) ->
       expression cxt ~level f (exn_block_as_obj ~stack:false el ext)
   | Caml_block (el, _, tag, Blk_record_inlined p) ->
       let untagged = Ast_untagged_variants.process_untagged p.attrs in
@@ -1236,7 +1236,7 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt =
   | Throw e ->
       let e =
         match e.expression_desc with
-        | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) ->
+        | Caml_block (el, _, _, ((Blk_extension _ | Blk_record_ext _) as ext)) ->
             { e with expression_desc = (exn_block_as_obj ~stack:true el ext).expression_desc }
         | exp -> { e with expression_desc = (exn_ref_as_obj exp).expression_desc }
       in
diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml
@@ -250,7 +250,7 @@ let dummy_obj ?comment (info : Lam_tag_info.t) : t =
   *)
   match info with
   | Blk_record _ | Blk_module _ | Blk_constructor _ | Blk_record_inlined _
-  | Blk_poly_var _ | Blk_extension | Blk_record_ext _ ->
+  | Blk_poly_var _ | Blk_extension _ | Blk_record_ext _ ->
       { comment; expression_desc = Object [] }
   | Blk_tuple | Blk_module_export _ ->
       { comment; expression_desc = Array ([], Mutable) }
diff --git a/jscomp/core/lam_constant_convert.ml b/jscomp/core/lam_constant_convert.ml
@@ -69,7 +69,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t =
           Const_some (convert_constant (Ext_list.singleton_exn xs))
       | Blk_some -> Const_some (convert_constant (Ext_list.singleton_exn xs))
       | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_module _
-      | Blk_module_export _ | Blk_extension | Blk_record_inlined _
+      | Blk_module_export _ | Blk_extension _ | Blk_record_inlined _
       | Blk_record_ext _ ->
           Const_block (tag, t, Ext_list.map xs convert_constant)
       | Blk_poly_var s -> (
diff --git a/jscomp/core/lam_convert.ml b/jscomp/core/lam_convert.ml
@@ -179,7 +179,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
       | Blk_some_not_nested -> prim ~primitive:Psome_not_nest ~args loc
       | Blk_some -> prim ~primitive:Psome ~args loc
       | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _
-      | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ ->
+      | Blk_module _ | Blk_module_export _ | Blk_extension _ | Blk_record_ext _ ->
           prim ~primitive:(Pmakeblock (tag, info, mutable_flag)) ~args loc
       | Blk_poly_var s -> (
           match args with
diff --git a/jscomp/ml/datarepr.ml b/jscomp/ml/datarepr.ml
@@ -201,7 +201,7 @@ let extension_descr path_ext ext =
       cstr_existentials = existentials;
       cstr_args;
       cstr_arity = List.length cstr_args;
-      cstr_tag = Cstr_extension(path_ext);
+      cstr_tag = Cstr_extension(path_ext, ext.ext_is_exception);
       cstr_consts = -1;
       cstr_nonconsts = -1;
       cstr_private = ext.ext_private;
diff --git a/jscomp/ml/env.ml b/jscomp/ml/env.ml
@@ -549,7 +549,7 @@ let is_ident = function
   | Pdot _ | Papply _ -> false
 
 let is_local_ext = function
-  | {cstr_tag = Cstr_extension(p)} -> is_ident p
+  | {cstr_tag = Cstr_extension(p, _)} -> is_ident p
   | _ -> false
 
 let diff env1 env2 =
diff --git a/jscomp/ml/lambda.ml b/jscomp/ml/lambda.ml
@@ -47,11 +47,15 @@ type tag_info =
   | Blk_record of {fields : string array; mutable_flag : Asttypes.mutable_flag; record_repr : record_repr}  
   | Blk_module of string list
   | Blk_module_export of Ident.t list
-
-  | Blk_extension  
+  | Blk_extension of {
+    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}
+  | Blk_record_ext of {
+     fields:  string array;
+     mutable_flag: Asttypes.mutable_flag;
+    }
   | Blk_lazy_general
 
 let tag_of_tag_info (tag : tag_info ) = 
@@ -63,7 +67,7 @@ let tag_of_tag_info (tag : tag_info ) =
   | Blk_record _ 
   | Blk_module _ 
   | Blk_module_export _ 
-  | Blk_extension 
+  | Blk_extension _
   | Blk_some (* tag not make sense *)
   | Blk_some_not_nested (* tag not make sense *)
   | Blk_lazy_general (* tag not make sense 248 *)
@@ -81,7 +85,7 @@ let mutable_flag_of_tag_info (tag : tag_info) =
   | Blk_poly_var _ 
   | Blk_module _
   | Blk_module_export _ 
-  | Blk_extension
+  | Blk_extension _
   | Blk_some_not_nested
   | Blk_some 
    -> Immutable
diff --git a/jscomp/ml/lambda.mli b/jscomp/ml/lambda.mli
@@ -46,7 +46,9 @@ type tag_info =
   | Blk_record of {fields : string array; mutable_flag : mutable_flag; record_repr : record_repr }
   | Blk_module of string list
   | Blk_module_export of Ident.t list 
-  | Blk_extension
+  | Blk_extension of {
+    is_exception: bool;
+  }
     (* underlying is the same as tuple, immutable block
       {[
          exception A of int * int 
@@ -60,7 +62,10 @@ 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}
+  | Blk_record_ext of {
+    fields: string array;
+    mutable_flag: mutable_flag;
+   }
   | Blk_lazy_general    
 
 val find_name :
diff --git a/jscomp/ml/matching.ml b/jscomp/ml/matching.ml
@@ -2279,7 +2279,7 @@ let get_extension_cases tag_lambda_list =
     | (cstr, act) :: rem ->
         let nonconsts = split_rec rem in
         match cstr with
-        | Cstr_extension(path) -> ((path, act) :: nonconsts)
+        | Cstr_extension(path, _) -> ((path, act) :: nonconsts)
         | _ -> assert false in
   split_rec tag_lambda_list
 
@@ -2918,7 +2918,9 @@ let partial_function loc () =
   let fname = 
     Filename.basename fname
   in   
-  Lprim(Praise Raise_regular, [Lprim(Pmakeblock(Blk_extension),
+  Lprim(Praise Raise_regular, [Lprim(Pmakeblock(Blk_extension {
+    is_exception = true;
+  }),
           [transl_normal_path Predef.path_match_failure;
            Lconst(Const_block(Blk_tuple,
               [Const_base(Const_string (fname, None));
diff --git a/jscomp/ml/printlambda.ml b/jscomp/ml/printlambda.ml
@@ -106,7 +106,7 @@ let str_of_field_info (fld_info : Lambda.field_dbg_info)=
   | Fld_cons -> "cons"
   | Fld_array -> "[||]" 
 let print_taginfo ppf = function
-  | Blk_extension -> fprintf ppf "ext" 
+  | Blk_extension _ -> fprintf ppf "ext" 
   | Blk_record_ext {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) )
   | Blk_tuple -> fprintf ppf "tuple"
   | Blk_constructor {name ;num_nonconst} -> fprintf ppf "%s/%i" name num_nonconst
diff --git a/jscomp/ml/rec_check.ml b/jscomp/ml/rec_check.ml
@@ -240,7 +240,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t =
   | Texp_construct (_, desc, exprs) ->
       let access_constructor =
         match desc.cstr_tag with
-        | Cstr_extension (pth) -> Use.inspect (path env pth)
+        | Cstr_extension (pth, _) -> Use.inspect (path env pth)
         | _ -> Use.empty
       in
       let use =
diff --git a/jscomp/ml/translcore.ml b/jscomp/ml/translcore.ml
@@ -685,7 +685,7 @@ let assert_failed exp =
     ( Praise Raise_regular,
       [
         Lprim
-          ( Pmakeblock Blk_extension,
+          ( Pmakeblock (Blk_extension {is_exception = true}),
             [
               transl_normal_path Predef.path_assert_failure;
               Lconst
@@ -905,9 +905,9 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
             in
             try Lconst (Const_block (tag_info, List.map extract_constant ll))
             with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc))
-        | Cstr_extension (path) ->
+        | Cstr_extension (path, is_exception) ->
             Lprim
-              ( Pmakeblock Blk_extension,
+              ( Pmakeblock (Blk_extension {is_exception}),
                 transl_extension_path e.exp_env path :: ll,
                 e.exp_loc ))
   | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path
diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml
@@ -2839,7 +2839,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty
                } ] ->
           let path =
             match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with
-            | Cstr_extension (path) -> path
+            | Cstr_extension (path, _) -> path
             | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
           in
           rue {
diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml
@@ -1531,7 +1531,7 @@ let transl_extension_constructor env type_path type_params
         end;
         let path =
           match cdescr.cstr_tag with
-            Cstr_extension(path) -> path
+            Cstr_extension (path, _) -> path
           | _ -> assert false
         in
         let args =
diff --git a/jscomp/ml/types.ml b/jscomp/ml/types.ml
@@ -282,15 +282,15 @@ and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
   | Cstr_unboxed                        (* Constructor of an unboxed type *)
-  | Cstr_extension of Path.t            (* Extension constructor *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor. true if is_exception *)
 
 let equal_tag t1 t2 = 
   match (t1, t2) with
   | Cstr_constant i1, Cstr_constant i2 -> i2 = i1
   | Cstr_block i1, Cstr_block i2 -> i2 = i1
   | Cstr_unboxed, Cstr_unboxed -> true
-  | Cstr_extension (path1), Cstr_extension (path2) -> 
-      Path.same path1 path2
+  | Cstr_extension (path1, is_exception1), Cstr_extension (path2, is_exception2) -> 
+      Path.same path1 path2 && is_exception1 = is_exception2
   | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false
 
 let may_equal_constr c1 c2 = match c1.cstr_tag,c2.cstr_tag with
diff --git a/jscomp/ml/types.mli b/jscomp/ml/types.mli
@@ -434,7 +434,7 @@ and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
   | Cstr_unboxed                        (* Constructor of an unboxed type *)
-  | Cstr_extension of Path.t            (* Extension constructor *)
+  | Cstr_extension of Path.t * bool     (* Extension constructor. true if is_exception *)
 
 (* Constructors are the same *)
 val equal_tag :  constructor_tag -> constructor_tag -> bool
