finish the new encoding, prepare to add stacktrace under a flag

Author: bobzhang

jscomp/core/js_dump.ml

@@ -819,13 +819,20 @@ and expression_desc cxt ~(level:int) f x : cxt  =
         (* name convention of Record is slight different from modules 
         *)
   | Caml_block(el,_, _, (Blk_extension | Blk_record_ext _ as ext )) ->        
+      let len = List.length el in       
       let field_name  = 
         match ext with 
-        | Blk_extension -> (fun i -> if i = 0 then "CamlExt" else "_" ^ string_of_int i)
+        | Blk_extension -> (fun i -> 
+          match i with 
+          | 0 ->  Literals.exception_id
+          | i ->  
+            if i < len - 1 then "_" ^ string_of_int i
+            else Literals.exception_debug)
         | Blk_record_ext ss ->   
-          fun i ->  
-          if i = 0 then "CamlExt" 
-          else ss.(i-1) 
+          (fun i ->  
+          match i with 
+          | 0 -> Literals.exception_id
+          | i ->  if i < len - 1 then ss.(i-1) else Literals.exception_debug)
         | _ -> assert false in   
     expression_desc cxt ~level f (Object (
         (Ext_list.mapi  el (fun i e -> field_name i, e

jscomp/core/js_exp_make.ml

@@ -413,13 +413,13 @@ let extension_access (e : t) name (pos : int32)  : t  =
      | None -> 
       let name = 
         match name with Some n -> n | None ->   
-        if pos = 0l then "CamlExt" else "_" ^ Int32.to_string pos in 
+         "_" ^ Int32.to_string pos in 
        { expression_desc = Static_index (e, name, Some pos); comment = None}     
     )
   | _ -> 
     let name = 
       match name with Some n -> n | None ->     
-      if pos = 0l then "CamlExt" else "_" ^ Int32.to_string pos in 
+       "_" ^ Int32.to_string pos in 
     { expression_desc = Static_index (e, name, Some pos); comment = None} 
 
 let string_index ?comment (e0 : t)  (e1 : t) : t = 

jscomp/core/lam_convert.ml

@@ -22,9 +22,56 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-let caml_id_field_info : Lam_primitive.t = (Pfield (0, Fld_record {name = "CamlId"; mutable_flag = Mutable;}))
+
+let caml_id_field_info : Lambda.field_dbg_info = Fld_record {name = Literals.exception_id; mutable_flag = Mutable;}
+let name_info : Lambda.field_dbg_info = Fld_record {name = Literals.exception_debug; mutable_flag = Immutable;}
+let lam_caml_id : Lam_primitive.t = Pfield(0, caml_id_field_info)
+let lam_name : Lam_primitive.t = Pfield (1, name_info) 
 let prim = Lam.prim 
 
+
+let num_of_ident name = 
+  begin match name with 
+  | "Out_of_memory" -> 0
+  | "Sys_error" -> -1 
+  | "Failure" -> -2
+  | "Invalid_argument" -> -3 
+  | "End_of_file" -> -4
+  | "Division_by_zero" -> -5 
+  | "Not_found" -> -6
+  | "Match_failure" -> -7
+  | "Stack_overflow" -> -8
+  | "Assert_failure" -> -9
+  | "Sys_blocked_io" -> -10
+  | "Undefined_recursive_module" -> -11
+  | _ -> assert false
+  end   
+
+
+let lam_extension_id loc (head : Lam.t) =
+  match head with 
+  | Lprim {primitive = Pglobal_exception id} -> 
+    Lam.const (Const_int {value = num_of_ident id.name; comment = Some id.name} )
+  | _ -> prim ~primitive:lam_caml_id ~args:[head] loc    
+
+
+let unbox_extension info (args : Lam.t list) mutable_flag loc =
+  begin match args with 
+  | head :: rest -> 
+    let args = 
+      match head with 
+      | Lprim {primitive = Pglobal_exception id}  -> 
+        let name = Ident.name id in 
+        let id = num_of_ident name in 
+        Lam.const (Const_int {value = id; comment = None}) 
+        :: (Ext_list.append_one rest (Lam.const (Const_string (name)))) 
+      | _ -> 
+        prim ~primitive:lam_caml_id ~args:[head] loc :: 
+        (Ext_list.append_one rest (prim ~primitive:lam_name ~args:[head] loc))        
+    in 
+    prim ~primitive:(Pmakeblock (0,info,mutable_flag)) ~args loc
+  | _ -> assert false end    
+
 (** A conservative approach to avoid packing exceptions
     for lambda expression like {[
       try { ... }catch(id){body}
@@ -227,7 +274,19 @@ let lam_prim ~primitive:( p : Lambda.primitive) ~args loc : Lam.t =
       prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc
     | Blk_extension  -> 
       let info : Lam_tag_info.t = Blk_extension in
-      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc  
+      unbox_extension info args mutable_flag loc 
+    | Blk_record_ext s ->
+      let info : Lam_tag_info.t = Blk_record_ext s in
+      unbox_extension info args mutable_flag loc 
+    | Blk_extension_slot -> 
+      ( 
+        match args with 
+        | [ Lconst (Const_string name)] -> 
+          prim ~primitive:(Pcreate_extension name) ~args:[] loc
+        | _ ->
+          assert false
+      )
+
     | Blk_class  -> 
       let info : Lam_tag_info.t = Blk_class in
       prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc  

jscomp/ext/literals.ml

@@ -139,3 +139,5 @@ let sourcedirs_meta = ".sourcedirs.json"
 *)
 let ns_sep_char = '-'
 let ns_sep = "-"
+let exception_id = "ExceptionID"
+let exception_debug = "Debug"

jscomp/ext/literals.mli

@@ -135,4 +135,7 @@ val bsbuild_cache : string
 val sourcedirs_meta : string
 
 val ns_sep_char : char
-val ns_sep : string
+val ns_sep : string
+
+val exception_id : string
+val exception_debug : string

jscomp/main/builtin_cmj_datasets.ml

@@ -22,7 +22,15 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-(** *)
+ type t = {
+  mutable id : nativeint [@bs.as "ExceptionID"];
+  name : string [@bs.as "Debug"];
+} 
+
+
+let make name id = { 
+name ; id }
+
 
 
 
@@ -55,9 +63,9 @@ let caml_set_oo_id (b : Caml_obj_extern.t)  : Caml_obj_extern.t =
 
 (* let object_tag = 248 *)
 
-let create (str : string) : Caml_builtin_exceptions.t = 
+let create (str : string) : t = 
   id .contents <- Caml_nativeint_extern.add id.contents 1n;  
-  Caml_builtin_exceptions.make str id.contents
+  make str id.contents
 
 (* let makeExtension (str : string) : Caml_builtin_exceptions.exception_block =  *)
 (*   let v = ( str, get_id ()) in  *)
@@ -98,14 +106,14 @@ let create (str : string) : Caml_builtin_exceptions.t =
    This is not a problem in `try .. with` since the logic above is not expressible, see more design in [destruct_exn.md]
 *)
 let caml_is_extension = [%raw {|function (e){
-  if(e == null || e.CamlExt == null) {
+  if(e == null ) {
     return false 
   }
-  return typeof e.CamlExt.CamlId === "number"
+  return typeof e.ExceptionID === "number" 
 }    
 |}]
 
-type exn = { exn : Caml_builtin_exceptions.t [@bs.as "CamlExt"]}
+(* type exn = { exn : Caml_builtin_exceptions.t [@bs.as "CamlExt"]} *)
 
-let caml_exn_slot_id x = x.exn.id
-let caml_exn_slot_name x = x.exn.name
+let caml_exn_slot_id (x : t) = x.id
+let caml_exn_slot_name (x : t) = x.name

jscomp/runtime/caml_exceptions.ml

@@ -24,21 +24,23 @@
 
 
 
+type t
 
-
-
+val make : 
+  string -> 
+  nativeint -> 
+  t 
 (* It is not relevant to exception, just to piggy back on uuid mechanism *)
 val caml_set_oo_id :
   Caml_obj_extern.t ->
   Caml_obj_extern.t
 
 
-val create : string -> Caml_builtin_exceptions.t
+val create : string -> t
 
 val caml_is_extension : 
   'a -> bool
 
-type exn   
 
-val caml_exn_slot_id : exn -> nativeint 
-val caml_exn_slot_name : exn -> string   
+val caml_exn_slot_id : t -> nativeint 
+val caml_exn_slot_name : t -> string