feat: emit new Error(ID, {cause: CAML_EXN}) for exceptions

Changes.md

@@ -5,6 +5,9 @@ Unreleased
   ([#1040](https://github.com/melange-re/melange/pull/1040))
 - runtime: add some bindings to `Js.Bigint`
   ([#1044](https://github.com/melange-re/melange/pull/1044))
+- core: emit `throw new Error(..)` rather than throwing a JS object with the
+  Melange exception payload
+  ([#1036](https://github.com/melange-re/melange/pull/1036))
 
 3.0.0 2024-01-28
 ---------------

jscomp/core/j.mli

@@ -142,7 +142,7 @@ and expression_desc =
   (* A string is UTF-8 encoded, the string may contain
      escape sequences.
      The first argument is used to mark it is non-pure, please
-     don't optimize it, since it does have side effec,
+     don't optimize it, since it does have side effects,
      examples like "use asm;" and our compiler may generate "error;..."
      which is better to leave it alone
      The last argument is passed from as `j` from `{j||j}`

jscomp/core/js_dump.ml

@@ -130,8 +130,11 @@ let throw_indent = String.length L.throw / Js_pp.indent_length
 let semi cxt = string cxt L.semi
 let comma cxt = string cxt 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)
-    : J.expression_desc =
+    : J.expression =
   let field_name =
     match ext with
     | Blk_extension -> (
@@ -140,11 +143,32 @@ let exn_block_as_obj ~(stack : bool) (el : J.expression list) (ext : J.tag_info)
         fun i -> match i with 0 -> L.exception_id | i -> ss.(i - 1))
     | _ -> assert false
   in
-  Object
-    (if stack then
-       List.mapi ~f:(fun i e -> (Js_op.Lit (field_name i), e)) el
-       @ [ (Js_op.Lit "Error", E.new_ (E.js_global "Error") []) ]
-     else List.mapi ~f:(fun i e -> (Js_op.Lit (field_name i), e)) el)
+  let cause =
+    {
+      J.expression_desc =
+        Object (List.mapi ~f:(fun i e -> (Js_op.Lit (field_name i), e)) el);
+      comment = None;
+      loc = None;
+    }
+  in
+  if stack then
+    new_error (List.hd el)
+      {
+        J.expression_desc = Object [ (Lit Js_dump_lit.cause, cause) ];
+        comment = None;
+        loc = None;
+      }
+  else cause
+
+let exn_ref_as_obj e : J.expression =
+  let cause = { J.expression_desc = e; comment = None; loc = 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;
+      loc = None;
+    }
 
 let rec iter_lst cxt ls element inter =
   match ls with
@@ -785,7 +809,7 @@ and expression_desc cxt ~(level : int) x : cxt =
                ])
       | _ -> assert false)
   | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) ->
-      expression_desc cxt ~level (exn_block_as_obj ~stack:false el ext)
+      expression cxt ~level (exn_block_as_obj ~stack:false el ext)
   | Caml_block (el, _, tag, Blk_record_inlined p) ->
       let objs =
         let tails =
@@ -809,9 +833,7 @@ and expression_desc cxt ~(level : int) x : cxt =
         let tails =
           List.mapi
             ~f:(fun i e ->
-              ( Js_op.Lit
-                  (Js_exp_make.variant_pos ~constr:p.name (Int32.of_int i)),
-                e ))
+              (Js_op.Lit (E.variant_pos ~constr:p.name (Int32.of_int i)), e))
             el
           @
           if !Js_config.debug && not_is_cons then
@@ -1218,8 +1240,13 @@ and statement_desc top cxt (s : J.statement_desc) : cxt =
       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 }
-        | _ -> e
+            {
+              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
       string cxt L.throw;
       space cxt;

jscomp/core/js_dump_lit.ml

@@ -80,6 +80,8 @@ let minus_minus = "--"
 (** debug symbols *)
 
 let case = "case"
+let cause = "cause"
+let error = "Error"
 let exception_id = "MEL_EXN_ID"
 let polyvar_hash = "NAME"
 let polyvar_value = "VAL"

jscomp/core/js_exp_make.ml

@@ -350,7 +350,7 @@ let poly_var_value_access (e : t) =
       match l with _ :: v :: _ -> v | _ -> assert false)
   | _ -> make_expression (Static_index (e, Js_dump_lit.polyvar_value, Some 1l))
 
-let extension_access (e : t) name (pos : int32) : t =
+let extension_access (e : t) ?name (pos : int32) : t =
   match e.expression_desc with
   | Array (l, _) (* Float i -- should not appear here *)
   | Caml_block (l, _, _, _)

jscomp/core/js_exp_make.mli

@@ -155,7 +155,7 @@ val inline_record_access : t -> string -> Int32.t -> t
 val variant_pos : constr:string -> int32 -> string
 val variant_access : t -> int32 -> t
 val cons_access : t -> int32 -> t
-val extension_access : t -> string option -> Int32.t -> t
+val extension_access : t -> ?name:string -> Int32.t -> t
 val record_assign : t -> int32 -> string -> t -> t
 val poly_var_tag_access : t -> t
 val poly_var_value_access : t -> t

jscomp/core/js_of_lam_block.ml

@@ -48,8 +48,8 @@ let field (field_info : Lam_compat.field_dbg_info) e (i : int32) =
         e i
   | Fld_poly_var_content -> E.poly_var_value_access e
   | Fld_poly_var_tag -> E.poly_var_tag_access e
-  | Fld_record_extension { name } -> E.extension_access e (Some name) i
-  | Fld_extension -> E.extension_access e None i
+  | Fld_record_extension { name } -> E.extension_access e ~name i
+  | Fld_extension -> E.extension_access e i
   | Fld_variant -> E.variant_access e i
   | Fld_cons -> E.cons_access e i
   | Fld_record_inline { name } -> E.inline_record_access e name i

jscomp/core/lam_convert.cppo.ml

@@ -24,14 +24,17 @@
 
 open Import
 
-let caml_id_field_info : Lambda.field_dbg_info =
-  Fld_record { name = Js_dump_lit.exception_id; mutable_flag = Immutable }
-
-let lam_caml_id : Lam_primitive.t = Pfield (0, caml_id_field_info)
 let prim = Lam.prim
 
-let lam_extension_id loc (head : Lam.t) =
-  prim ~primitive:lam_caml_id ~args:[ head ] loc
+let lam_extension_id =
+  let lam_caml_id : Lam_primitive.t =
+    let caml_id_field_info : Lambda.field_dbg_info =
+      Fld_record { name = Js_dump_lit.exception_id; mutable_flag = Immutable }
+    in
+    Pfield (0, caml_id_field_info)
+  in
+  fun loc (head : Lam.t) ->
+    prim ~primitive:lam_caml_id ~args:[ head ] loc
 
 let lazy_block_info : Lam.Tag_info.t =
   let lazy_done = "LAZY_DONE" and lazy_val = "VAL" in

jscomp/runtime/caml_format.ml

@@ -616,7 +616,7 @@ let float_of_string : string -> exn -> float =
         return Infinity;
     if (/^-inf(inity)?$/i.test(s))
         return -Infinity;
-    throw exn;
+    throw new Error(exn.MEL_EXN_ID, { cause: exn });
 }
 |}]
 

jscomp/runtime/caml_js_exceptions.ml

@@ -1,6 +1,7 @@
 open Melange_mini_stdlib
 
 type t = Any : 'a -> t [@@unboxed]
+type js_error = { cause : exn }
 
 exception Error of t
 
@@ -9,7 +10,10 @@ exception Error of t
    [Error] is defined here
 *)
 let internalToOCamlException (e : Obj.t) =
-  if Caml_exceptions.caml_is_extension e then (Obj.magic e : exn)
+  if
+    (not (Js_internal.testAny e))
+    && Caml_exceptions.caml_is_extension (Obj.magic e : js_error).cause
+  then (Obj.magic e : js_error).cause
   else Error (Any e)
 
 let caml_as_js_exn exn = match exn with Error t -> Some t | _ -> None

jscomp/runtime/caml_lexer.ml

@@ -159,7 +159,7 @@ let caml_lex_engine_aux : lex_tables -> int -> lexbuf -> exn -> int =
         if (state < 0) {
             lexbuf.lex_curr_pos = lexbuf.lex_last_pos;
             if (lexbuf.lex_last_action == -1)
-                throw exn
+              throw new Error(exn.MEL_EXN_ID, { cause: exn })
             else
                 return lexbuf.lex_last_action;
         }
@@ -305,7 +305,7 @@ let caml_new_lex_engine_aux : lex_tables -> int -> lexbuf -> exn -> int =
         if (state < 0) {
             lexbuf.lex_curr_pos = lexbuf.lex_last_pos;
             if (lexbuf.lex_last_action == -1)
-                throw exn;
+                throw new Error(exn.MEL_EXN_ID, { cause: exn })
             else
                 return lexbuf.lex_last_action;
         }