Prepare for #1340

CHANGES.md

@@ -1,12 +1,16 @@
 # dev (202?-??) - ??
 ## Features/Changes
 * Compiler: small refactoring in code generation
+* Compiler: check build info compatibility when linking js file.
 * Misc: fix and update benchmarks
 * Misc: upgrade CI
 * Toplevel: recover more names when generating code during toplevel evaluation
+* Runtime: wrapping exception or not is now controled in the runtime.
+
 
 ## Bug fixes
 * Runime: Gc.finalise_last should not be eliminated
+* Toplevel: Make sure the toplevel uses the correct memory representaion for strings
 
 # 4.1.0 (2022-11-15) - Lille
 ## Features/Changes

compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml

@@ -15,6 +15,7 @@ let split_primitives p =
 
 let () =
   let global = J.pure_js_expr "globalThis" in
+  Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.use_js_string ());
   (* this needs to stay synchronized with toplevel.js *)
   let toplevel_compile (s : bytes array) (debug : Instruct.debug_event list array) :
       unit -> J.t =

compiler/lib/build_info.ml

@@ -0,0 +1,105 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2022 Hugo Heuzard
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+
+open! Stdlib
+
+type t = string StringMap.t
+
+let create () =
+  let version =
+    match Compiler_version.git_version with
+    | "" -> Compiler_version.s
+    | v -> Printf.sprintf "%s+git-%s" Compiler_version.s v
+  in
+
+  [ "use-js-string", string_of_bool (Config.Flag.use_js_string ())
+  ; "effects", "false"
+  ; "version", version
+  ]
+  |> List.fold_left ~init:StringMap.empty ~f:(fun acc (k, v) -> StringMap.add k v acc)
+
+let prefix = "//# buildInfo:"
+
+let to_string info =
+  let str =
+    StringMap.bindings info
+    |> List.map ~f:(fun (k, v) -> Printf.sprintf "%s=%s" k v)
+    |> String.concat ~sep:", "
+  in
+  Printf.sprintf "%s%s\n" prefix str
+
+let parse s =
+  match String.drop_prefix ~prefix s with
+  | None -> None
+  | Some suffix ->
+      let t =
+        suffix
+        |> String.split_on_char ~sep:','
+        |> List.map ~f:String.trim
+        |> List.map ~f:(fun s ->
+               match String.lsplit2 ~on:'=' s with
+               | None -> s, ""
+               | Some (k, v) -> k, v)
+        |> List.fold_left ~init:StringMap.empty ~f:(fun acc (k, v) ->
+               StringMap.add k v acc)
+      in
+      Some t
+
+exception
+  Incompatible_build_info of
+    { key : string
+    ; first : (string * string option)
+    ; second : (string * string option)
+    }
+
+let merge fname1 info1 fname2 info2 =
+  if String.equal fname1 fname2
+  then
+    StringMap.merge
+      (fun k v1 v2 ->
+        match v1, v2 with
+        | Some v1, Some v2 when String.equal v1 v2 -> Some v1
+        | Some v1, Some v2 ->
+            failwith
+              (Printf.sprintf
+                 "%s: Duplicated build info with incompatible value. key=%s, v1=%s, v2=%s"
+                 fname1
+                 k
+                 v1
+                 v2)
+        | Some x, None | None, Some x -> Some x
+        | None, None -> assert false)
+      info1
+      info2
+  else
+    StringMap.merge
+      (fun k v1 v2 ->
+        match k, v1, v2 with
+        | ("effects" | "use-js-string" | "version"), Some v1, Some v2
+          when String.equal v1 v2 -> Some v1
+        | (("effects" | "use-js-string" | "version") as key), v1, v2 ->
+            raise
+              (Incompatible_build_info { key; first = fname1, v1; second = fname2, v2 })
+        | _, Some v1, Some v2 when String.equal v1 v2 -> Some v1
+        (* ignore info that are present on one side only or have a different value *)
+        | _, Some _, Some _ -> None
+        | _, None, Some _ | _, Some _, None -> None
+        | _, None, None -> assert false)
+      info1
+      info2

compiler/lib/build_info.mli

@@ -0,0 +1,36 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2022 Hugo Heuzard
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+open! Stdlib
+
+type t
+
+val create : unit -> t
+
+val to_string : t -> string
+
+val parse : string -> t option
+
+exception
+  Incompatible_build_info of
+    { key : string
+    ; first : (string * string option)
+    ; second : (string * string option)
+    }
+
+val merge : string -> t -> string -> t -> t

compiler/lib/config.ml

@@ -34,6 +34,14 @@ module Flag = struct
     in
     fun () -> !state
 
+  let find s =
+    try !(List.assoc s !optims)
+    with Not_found -> failwith (Printf.sprintf "The option named %S doesn't exist" s)
+
+  let set s b =
+    try List.assoc s !optims := b
+    with Not_found -> failwith (Printf.sprintf "The option named %S doesn't exist" s)
+
   let disable s =
     try List.assoc s !optims := false
     with Not_found -> failwith (Printf.sprintf "The option named %S doesn't exist" s)
@@ -83,6 +91,8 @@ module Flag = struct
   let check_magic = o ~name:"check-magic-number" ~default:true
 
   let compact_vardecl = o ~name:"vardecl" ~default:false
+
+  let header = o ~name:"header" ~default:true
 end
 
 module Param = struct

compiler/lib/config.mli

@@ -19,6 +19,10 @@
 module Flag : sig
   val available : unit -> string list
 
+  val find : string -> bool
+
+  val set : string -> bool -> unit
+
   val deadcode : unit -> bool
 
   val optcall : unit -> bool
@@ -61,6 +65,8 @@ module Flag : sig
 
   val check_magic : unit -> bool
 
+  val header : unit -> bool
+
   val enable : string -> unit
 
   val disable : string -> unit

compiler/lib/driver.ml

@@ -150,15 +150,13 @@ let generate d ~exported_runtime ~wrap_with_fun (p, live_vars) =
   Generate.f p ~exported_runtime ~live_vars ~should_export d
 
 let header formatter ~custom_header =
-  (match custom_header with
+  match custom_header with
   | None -> ()
-  | Some c -> Pretty_print.string formatter (c ^ "\n"));
-  let version =
-    match Compiler_version.git_version with
-    | "" -> Compiler_version.s
-    | v -> Printf.sprintf "%s+git-%s" Compiler_version.s v
-  in
-  Pretty_print.string formatter ("// Generated by js_of_ocaml " ^ version ^ "\n")
+  | Some c -> Pretty_print.string formatter (c ^ "\n")
+
+let jsoo_header formatter build_info =
+  Pretty_print.string formatter "// Generated by js_of_ocaml\n";
+  Pretty_print.string formatter (Build_info.to_string build_info)
 
 let debug_linker = Debug.find "linker"
 
@@ -337,10 +335,11 @@ let coloring js =
   if times () then Format.eprintf "  coloring: %a@." Timer.print t;
   js
 
-let output formatter ~standalone ~custom_header ~source_map () js =
+let output formatter build_info ~standalone ~custom_header ~source_map () js =
   let t = Timer.make () in
   if times () then Format.eprintf "Start Writing file...@.";
   if standalone then header ~custom_header formatter;
+  if Config.Flag.header () then jsoo_header formatter build_info;
   Js_output.program formatter ?source_map js;
   if times () then Format.eprintf "  write: %a@." Timer.print t
 
@@ -510,6 +509,7 @@ let full
     ~linkall
     ~source_map
     ~custom_header
+    ~build_info
     formatter
     d
     p =
@@ -527,7 +527,7 @@ let full
     +> pack ~wrap_with_fun ~standalone
     +> coloring
     +> check_js
-    +> output formatter ~standalone ~custom_header ~source_map ()
+    +> output formatter build_info ~standalone ~custom_header ~source_map ()
   in
   if times () then Format.eprintf "Start Optimizing...@.";
   let t = Timer.make () in
@@ -545,18 +545,21 @@ let f
     formatter
     d
     p =
+  let build_info = Build_info.create () in
   full
     ~standalone
     ~wrap_with_fun
     ~profile
     ~linkall
     ~source_map
     ~custom_header
+    ~build_info
     formatter
     d
     p
 
 let from_string ~prims ~debug s formatter =
+  let build_info = Build_info.create () in
   let p, d = Parse_bytecode.from_string ~prims ~debug s in
   full
     ~standalone:false
@@ -565,6 +568,7 @@ let from_string ~prims ~debug s formatter =
     ~linkall:false
     ~source_map:None
     ~custom_header:None
+    ~build_info
     formatter
     d
     p

compiler/lib/generate.ml

@@ -1538,30 +1538,34 @@ and compile_block_no_loop st queue (pc : Addr.t) loop_stack frontier interm =
       in
       if debug () then Format.eprintf "}@]@,";
       Addr.Set.iter (decr_preds st) handler_frontier;
+      let exn_is_live = st.ctx.Ctx.live.(Var.idx x) > 0 in
       (* TODO: Cleanup exn_escape *)
       let exn_escape =
-        match Addr.Set.choose handler_frontier_cont with
-        | exception Not_found -> None
-        | pc -> (
-            let exception Escape in
-            let find_in_block pc () =
-              let map_var y =
-                if Code.Var.equal x y then raise Escape;
-                y
+        if not exn_is_live
+        then None
+        else
+          match Addr.Set.choose handler_frontier_cont with
+          | exception Not_found -> None
+          | pc -> (
+              let exception Escape in
+              let find_in_block pc () =
+                let map_var y =
+                  if Code.Var.equal x y then raise Escape;
+                  y
+                in
+                let (_ : Code.block) = Subst.block map_var (Addr.Map.find pc st.blocks) in
+                ()
               in
-              let (_ : Code.block) = Subst.block map_var (Addr.Map.find pc st.blocks) in
-              ()
-            in
-            (* We don't want to traverse backward edges. we rely on
-               [st.succs] instead of [Code.fold_children]. *)
-            let fold _blocs pc f acc =
-              let succs = Hashtbl.find st.succs pc in
-              List.fold_left succs ~init:acc ~f:(fun acc pc -> f pc acc)
-            in
-            try
-              Code.traverse { fold } find_in_block pc st.blocks ();
-              None
-            with Escape -> Some (Var.fork x))
+              (* We don't want to traverse backward edges. we rely on
+                 [st.succs] instead of [Code.fold_children]. *)
+              let fold _blocs pc f acc =
+                let succs = Hashtbl.find st.succs pc in
+                List.fold_left succs ~init:acc ~f:(fun acc pc -> f pc acc)
+              in
+              try
+                Code.traverse { fold } find_in_block pc st.blocks ();
+                None
+              with Escape -> Some (Var.fork x))
       in
       let never_after, after =
         match Addr.Set.choose handler_frontier_cont with
@@ -1577,22 +1581,19 @@ and compile_block_no_loop st queue (pc : Addr.t) loop_stack frontier interm =
           [ J.EVar (J.V x) ]
           J.N
       in
-      let should_wrap_exn = st.ctx.Ctx.live.(Var.idx x) > 0 && Config.Flag.excwrap () in
       let handler_var =
         match exn_escape with
         | None -> x
         | Some x' -> x'
       in
       let handler =
-        match should_wrap_exn, exn_escape with
+        match exn_is_live, exn_escape with
+        | false, _ -> handler
         | true, Some x' ->
             (J.Variable_statement [ J.V x, Some (wrap_exn x', J.N) ], J.N) :: handler
-        | false, Some x' ->
-            (J.Variable_statement [ J.V x, Some (EVar (J.V x'), J.N) ], J.N) :: handler
         | true, None ->
             (J.Expression_statement (J.EBin (J.Eq, J.EVar (J.V x), wrap_exn x)), J.N)
             :: handler
-        | false, None -> handler
       in
       ( (never_body && never_handler) || never_after
       , seq

compiler/lib/js_traverse.ml

@@ -981,6 +981,11 @@ let assign_op = function
     when Poly.(exp = exp') -> Some (EBin (translate_assign_op unop, exp, y))
   | _ -> None
 
+let opt_cons b l =
+  match b with
+  | Some b -> b :: l
+  | None -> l
+
 class simpl =
   object (m)
     inherit map as super
@@ -1017,6 +1022,8 @@ class simpl =
       let s = super#statements s in
       List.fold_right s ~init:[] ~f:(fun (st, loc) rem ->
           match st with
+          | If_statement (ENum n, iftrue, _) when Num.is_one n -> iftrue :: rem
+          | If_statement (ENum n, _, iffalse) when Num.is_zero n -> opt_cons iffalse rem
           | If_statement
               (cond, (Return_statement (Some e1), _), Some (Return_statement (Some e2), _))
             -> (Return_statement (Some (ECond (cond, e1, e2))), loc) :: rem