Use RescriptError for exceptions

CHANGELOG.md

@@ -16,6 +16,7 @@
 
 - Allow coercing polyvariants to variants when we can guarantee that the runtime representation matches. https://github.com/rescript-lang/rescript-compiler/pull/6981
 - Add new dict literal syntax (`dict{"foo": "bar"}`). https://github.com/rescript-lang/rescript-compiler/pull/6774
+- Use `RescriptError` for runtime representation of exceptions and fix regression with not being able to throw raw Js values. https://github.com/rescript-lang/rescript-compiler/pull/6979
 
 #### :nail_care: Polish
 

jscomp/core/js_block_runtime.ml

@@ -26,8 +26,13 @@ let option_id = Ident.create_persistent Js_runtime_modules.option
 
 let curry_id = Ident.create_persistent Js_runtime_modules.curry
 
+let caml_js_exceptions_id = Ident.create_persistent Js_runtime_modules.caml_js_exceptions
+
+(* This function is responsible for checking the expressions used in the file,
+   and listing the additional runtime dependencies it requires *)
 let check_additional_id (x : J.expression) : Ident.t option =
   match x.expression_desc with
   | Optional_block (_, false) -> Some option_id
   | Call (_, _, { arity = NA }) -> Some curry_id
+  | Caml_block (el, _, _, ((Blk_extension { is_exception = true } | Blk_record_ext { is_exception = true }))) -> Some caml_js_exceptions_id
   | _ -> None

jscomp/core/js_dump.ml

@@ -97,43 +97,29 @@ type cxt = Ext_pp_scope.t
 let semi f = P.string f L.semi
 let comma f = P.string f L.comma
 
-let new_error name cause =
-  E.new_ (E.js_global Js_dump_lit.error) [ name; cause ]
-
-let exn_block_as_obj ~(stack : bool) (el : J.expression list) (ext : J.tag_info)
+let exn_block_as_obj ~(is_exception : 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 } -> (
         fun i -> match i with 0 -> Literals.exception_id | i -> ss.(i - 1))
     | _ -> assert false
   in
-    let cause =
+    let extension =
     {
       J.expression_desc =
         Object (List.mapi (fun i e -> (Js_op.Lit (field_name i), e)) el);
       comment = None;
     }
   in
-   if stack then
-      new_error (List.hd el)
-        {
-          J.expression_desc = Object [ (Lit Js_dump_lit.cause, cause) ];
-          comment = None;
-        }
-    else cause
-
-let exn_ref_as_obj e : J.expression =
-  let cause = { J.expression_desc = e; comment = None; } in
-  new_error
-    (E.record_access cause Js_dump_lit.exception_id 0l)
-    {
-      J.expression_desc = Object [ (Lit Js_dump_lit.cause, cause) ];
-      comment = None;
-    }
+  if is_exception then
+    match el with 
+    | [extension_id] -> E.runtime_call Js_runtime_modules.caml_js_exceptions "internalMakeExn" [extension_id]
+    | _ -> E.runtime_call Js_runtime_modules.caml_js_exceptions "internalFromExtension" [extension]   
+  else extension
 
 let rec iter_lst cxt (f : P.t) ls element inter =
   match ls with
@@ -170,7 +156,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,8 +760,8 @@ 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)) ->
-      expression cxt ~level f (exn_block_as_obj ~stack:false el ext)
+  | Caml_block (el, _, _, ((Blk_extension { is_exception } | Blk_record_ext { is_exception}) as ext)) ->
+      expression cxt ~level f (exn_block_as_obj ~is_exception el ext)
   | Caml_block (el, _, tag, Blk_record_inlined p) ->
       let untagged = Ast_untagged_variants.process_untagged p.attrs in
       let objs =
@@ -1234,12 +1220,6 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt =
                   P.newline f;
                   statements false cxt f def))
   | Throw e ->
-      let e =
-        match e.expression_desc with
-        | 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
       P.string f L.throw;
       P.space f;
       P.group f 0 (fun _ ->

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) }

jscomp/core/lam_compile_primitive.ml

@@ -79,7 +79,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
   | Pcreate_extension s -> E.make_exception s
   | Pwrap_exn ->
       E.runtime_call Js_runtime_modules.caml_js_exceptions
-        "internalToOCamlException" args
+        "internalAnyToExn" args
   | Praw_js_code { code; code_info } -> E.raw_js_code code_info code
   (* FIXME: save one allocation
      trim can not be done before syntax checking

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 -> (

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

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,14 +194,14 @@ 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;
       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;

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 =

jscomp/ml/lambda.ml

@@ -47,11 +47,14 @@ 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;
+      is_exception: bool; }
   | Blk_lazy_general
 
 let tag_of_tag_info (tag : tag_info ) = 
@@ -63,7 +66,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 +84,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
@@ -110,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

@@ -46,7 +46,8 @@ 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 +61,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;
+      is_exception: bool; }
   | Blk_lazy_general    
 
 val find_name :
@@ -78,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
@@ -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));

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

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

@@ -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 =
@@ -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