From 5a0a1197c66b4fc602bd7e1d601fcd613f18a86e Mon Sep 17 00:00:00 2001
From: Julien Sagot <1826552+sagotch@users.noreply.github.com>
Date: Thu, 29 Feb 2024 16:13:25 +0100
Subject: [PATCH 01/28] Lib: Dialog element support (#1257)

* Support for dialogElement

* Added cancel and close events

---------

Co-authored-by: Hugo Heuzard <hugo.heuzard@gmail.com>
---
 dune-project                  |  2 +-
 js_of_ocaml-tyxml.opam        |  2 +-
 lib/js_of_ocaml/dom_html.ml   | 27 +++++++++++++++++++++++++++
 lib/js_of_ocaml/dom_html.mli  | 27 +++++++++++++++++++++++++++
 lib/tyxml/tyxml_cast.ml       |  4 ++++
 lib/tyxml/tyxml_cast_sigs.ml  |  4 ++++
 lib/tyxml/tyxml_cast_sigs.mli |  4 ++++
 7 files changed, 68 insertions(+), 2 deletions(-)

diff --git a/dune-project b/dune-project
index a8fa29678..d436ec2af 100644
--- a/dune-project
+++ b/dune-project
@@ -111,7 +111,7 @@
   (js_of_ocaml-ppx (= :version))
   (react (>= 1.2.1))
   (reactiveData (>= 0.2))
-  (tyxml (>= 4.3))
+  (tyxml (>= 4.6))
   (num :with-test)
   (ppx_expect (and (>= v0.14.2) :with-test))
   (ppxlib (and (>= 0.22.0) :with-test))
diff --git a/js_of_ocaml-tyxml.opam b/js_of_ocaml-tyxml.opam
index 34d89bb0e..71390abd6 100644
--- a/js_of_ocaml-tyxml.opam
+++ b/js_of_ocaml-tyxml.opam
@@ -18,7 +18,7 @@ depends: [
   "js_of_ocaml-ppx" {= version}
   "react" {>= "1.2.1"}
   "reactiveData" {>= "0.2"}
-  "tyxml" {>= "4.3"}
+  "tyxml" {>= "4.6"}
   "num" {with-test}
   "ppx_expect" {>= "v0.14.2" & with-test}
   "ppxlib" {>= "0.22.0" & with-test}
diff --git a/lib/js_of_ocaml/dom_html.ml b/lib/js_of_ocaml/dom_html.ml
index df2e90c58..acdd556ef 100644
--- a/lib/js_of_ocaml/dom_html.ml
+++ b/lib/js_of_ocaml/dom_html.ml
@@ -773,8 +773,12 @@ let invoke_handler = Dom.invoke_handler
 module Event = struct
   type 'a typ = 'a Dom.Event.typ
 
+  let cancel = Dom.Event.make "cancel"
+
   let click = Dom.Event.make "click"
 
+  let close = Dom.Event.make "close"
+
   let copy = Dom.Event.make "copy"
 
   let cut = Dom.Event.make "cut"
@@ -1292,6 +1296,26 @@ class type dListElement = element
 
 class type liElement = element
 
+class type dialogElement = object
+  inherit element
+
+  method close : unit meth
+
+  method close_returnValue : js_string t -> unit meth
+
+  method open_ : bool t prop
+
+  method returnValue : js_string t prop
+
+  method show : unit meth
+
+  method showModal : unit meth
+
+  method oncancel : ('self t, event t) event_listener prop
+
+  method onclose : ('self t, event t) event_listener prop
+end
+
 class type divElement = element
 
 class type paragraphElement = element
@@ -2527,6 +2551,8 @@ let createDl doc : dListElement t = unsafeCreateElement doc "dl"
 
 let createLi doc : liElement t = unsafeCreateElement doc "li"
 
+let createDialog doc : dialogElement t = unsafeCreateElement doc "dialog"
+
 let createDiv doc : divElement t = unsafeCreateElement doc "div"
 
 let createEmbed doc : embedElement t = unsafeCreateElement doc "embed"
@@ -3350,6 +3376,7 @@ type taggedElement =
   | Col of tableColElement t
   | Colgroup of tableColElement t
   | Del of modElement t
+  | Dialog of dialogElement t
   | Div of divElement t
   | Dl of dListElement t
   | Embed of embedElement t
diff --git a/lib/js_of_ocaml/dom_html.mli b/lib/js_of_ocaml/dom_html.mli
index 34a5fe8d0..27da214f2 100644
--- a/lib/js_of_ocaml/dom_html.mli
+++ b/lib/js_of_ocaml/dom_html.mli
@@ -1114,6 +1114,26 @@ class type dListElement = element
 
 class type liElement = element
 
+class type dialogElement = object
+  inherit element
+
+  method close : unit meth
+
+  method close_returnValue : js_string t -> unit meth
+
+  method open_ : bool t prop
+
+  method returnValue : js_string t prop
+
+  method show : unit meth
+
+  method showModal : unit meth
+
+  method oncancel : ('self t, event t) event_listener prop
+
+  method onclose : ('self t, event t) event_listener prop
+end
+
 class type divElement = element
 
 class type paragraphElement = element
@@ -2284,8 +2304,12 @@ val eventRelatedTarget : #mouseEvent t -> element t opt
 module Event : sig
   type 'a typ = 'a Dom.Event.typ
 
+  val cancel : event t typ
+
   val click : mouseEvent t typ
 
+  val close : event t typ
+
   val copy : clipboardEvent t typ
 
   val cut : clipboardEvent t typ
@@ -2760,6 +2784,8 @@ val createDl : document t -> dListElement t
 
 val createLi : document t -> liElement t
 
+val createDialog : document t -> dialogElement t
+
 val createDiv : document t -> divElement t
 
 val createEmbed : document t -> embedElement t
@@ -2906,6 +2932,7 @@ type taggedElement =
   | Col of tableColElement t
   | Colgroup of tableColElement t
   | Del of modElement t
+  | Dialog of dialogElement t
   | Div of divElement t
   | Dl of dListElement t
   | Embed of embedElement t
diff --git a/lib/tyxml/tyxml_cast.ml b/lib/tyxml/tyxml_cast.ml
index 79991501a..53c21ffec 100644
--- a/lib/tyxml/tyxml_cast.ml
+++ b/lib/tyxml/tyxml_cast.ml
@@ -79,6 +79,8 @@ end) : Tyxml_cast_sigs.TO with type 'a elt = 'a C.elt = struct
 
   let of_li elt = rebuild_node "of_li" elt
 
+  let of_dialog elt = rebuild_node "of_dialog" elt
+
   let of_div elt = rebuild_node "of_div" elt
 
   let of_p elt = rebuild_node "of_p" elt
@@ -309,6 +311,8 @@ end) : Tyxml_cast_sigs.OF with type 'a elt = 'a C.elt = struct
 
   let of_li elt = rebuild_node "of_li" elt
 
+  let of_dialog elt = rebuild_node "of_dialog" elt
+
   let of_div elt = rebuild_node "of_div" elt
 
   let of_paragraph elt = rebuild_node "of_paragraph" elt
diff --git a/lib/tyxml/tyxml_cast_sigs.ml b/lib/tyxml/tyxml_cast_sigs.ml
index 3b634527d..08d8605ce 100644
--- a/lib/tyxml/tyxml_cast_sigs.ml
+++ b/lib/tyxml/tyxml_cast_sigs.ml
@@ -71,6 +71,8 @@ module type OF = sig
 
   val of_li : Dom_html.liElement Js.t -> [> Html_types.li ] elt
 
+  val of_dialog : Dom_html.dialogElement Js.t -> [> Html_types.dialog ] elt
+
   val of_div : Dom_html.divElement Js.t -> [> Html_types.div ] elt
 
   val of_paragraph : Dom_html.paragraphElement Js.t -> [> Html_types.p ] elt
@@ -180,6 +182,8 @@ module type TO = sig
 
   val of_li : [< Html_types.li ] elt -> Dom_html.liElement Js.t
 
+  val of_dialog : [< Html_types.dialog ] elt -> Dom_html.dialogElement Js.t
+
   val of_div : [< Html_types.div ] elt -> Dom_html.divElement Js.t
 
   val of_p : [< Html_types.p ] elt -> Dom_html.paragraphElement Js.t
diff --git a/lib/tyxml/tyxml_cast_sigs.mli b/lib/tyxml/tyxml_cast_sigs.mli
index a9136c911..42007a2ec 100644
--- a/lib/tyxml/tyxml_cast_sigs.mli
+++ b/lib/tyxml/tyxml_cast_sigs.mli
@@ -70,6 +70,8 @@ module type OF = sig
 
   val of_li : Dom_html.liElement Js.t -> [> Html_types.li ] elt
 
+  val of_dialog : Dom_html.dialogElement Js.t -> [> Html_types.dialog ] elt
+
   val of_div : Dom_html.divElement Js.t -> [> Html_types.div ] elt
 
   val of_paragraph : Dom_html.paragraphElement Js.t -> [> Html_types.p ] elt
@@ -179,6 +181,8 @@ module type TO = sig
 
   val of_li : [< Html_types.li ] elt -> Dom_html.liElement Js.t
 
+  val of_dialog : [< Html_types.dialog ] elt -> Dom_html.dialogElement Js.t
+
   val of_div : [< Html_types.div ] elt -> Dom_html.divElement Js.t
 
   val of_p : [< Html_types.p ] elt -> Dom_html.paragraphElement Js.t

From 4ce9356772e9f91c26d7aefc363db98616d70930 Mon Sep 17 00:00:00 2001
From: Guillaume Petiot <guillaume@tarides.com>
Date: Fri, 1 Mar 2024 10:55:07 +0000
Subject: [PATCH 02/28] Lib: fix paragraph construction and coercion

---
 lib/js_of_ocaml/dom_html.ml  | 2 +-
 lib/js_of_ocaml/dom_html.mli | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/lib/js_of_ocaml/dom_html.ml b/lib/js_of_ocaml/dom_html.ml
index acdd556ef..14cb2043c 100644
--- a/lib/js_of_ocaml/dom_html.ml
+++ b/lib/js_of_ocaml/dom_html.ml
@@ -3407,7 +3407,7 @@ type taggedElement =
   | Ol of oListElement t
   | Optgroup of optGroupElement t
   | Option of optionElement t
-  | P of paramElement t
+  | P of paragraphElement t
   | Param of paramElement t
   | Pre of preElement t
   | Q of quoteElement t
diff --git a/lib/js_of_ocaml/dom_html.mli b/lib/js_of_ocaml/dom_html.mli
index 27da214f2..0caf77382 100644
--- a/lib/js_of_ocaml/dom_html.mli
+++ b/lib/js_of_ocaml/dom_html.mli
@@ -2963,7 +2963,7 @@ type taggedElement =
   | Ol of oListElement t
   | Optgroup of optGroupElement t
   | Option of optionElement t
-  | P of paramElement t
+  | P of paragraphElement t
   | Param of paramElement t
   | Pre of preElement t
   | Q of quoteElement t
@@ -3095,7 +3095,7 @@ module CoerceTo : sig
 
   val option : #element t -> optionElement t opt
 
-  val p : #element t -> paramElement t opt
+  val p : #element t -> paragraphElement t opt
 
   val param : #element t -> paramElement t opt
 

From e3f7aa1ffc15e549d179f7a263f4d28b642998f0 Mon Sep 17 00:00:00 2001
From: John Jackson <37978984+johnridesabike@users.noreply.github.com>
Date: Fri, 3 May 2024 17:28:13 -0400
Subject: [PATCH 03/28] Lib: Add Typed_array.Bytes module (#1609)

---
 lib/js_of_ocaml/js_of_ocaml_stubs.c |  8 ++++++++
 lib/js_of_ocaml/typed_array.ml      | 10 ++++++++++
 lib/js_of_ocaml/typed_array.mli     | 17 +++++++++++++++++
 3 files changed, 35 insertions(+)

diff --git a/lib/js_of_ocaml/js_of_ocaml_stubs.c b/lib/js_of_ocaml/js_of_ocaml_stubs.c
index 4617e0720..f1ed497ad 100644
--- a/lib/js_of_ocaml/js_of_ocaml_stubs.c
+++ b/lib/js_of_ocaml/js_of_ocaml_stubs.c
@@ -1,5 +1,9 @@
 #include <stdlib.h>
 #include <stdio.h>
+void caml_bytes_of_array () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_bytes_of_array!\n");
+  exit(1);
+}
 void caml_custom_identifier () {
   fprintf(stderr, "Unimplemented Javascript primitive caml_custom_identifier!\n");
   exit(1);
@@ -24,6 +28,10 @@ void caml_js_on_ie () {
   fprintf(stderr, "Unimplemented Javascript primitive caml_js_on_ie!\n");
   exit(1);
 }
+void caml_uint8_array_of_bytes () {
+  fprintf(stderr, "Unimplemented Javascript primitive caml_uint8_array_of_bytes!\n");
+  exit(1);
+}
 void caml_xmlhttprequest_create () {
   fprintf(stderr, "Unimplemented Javascript primitive caml_xmlhttprequest_create!\n");
   exit(1);
diff --git a/lib/js_of_ocaml/typed_array.ml b/lib/js_of_ocaml/typed_array.ml
index 253837b16..e06f3b50b 100644
--- a/lib/js_of_ocaml/typed_array.ml
+++ b/lib/js_of_ocaml/typed_array.ml
@@ -277,3 +277,13 @@ module String = struct
     let uint8 = new%js uint8Array_fromBuffer ab in
     of_uint8Array uint8
 end
+
+module Bytes = struct
+  external of_uint8Array : uint8Array Js.t -> bytes = "caml_bytes_of_array"
+
+  external to_uint8Array : bytes -> uint8Array Js.t = "caml_uint8_array_of_bytes"
+
+  let of_arrayBuffer ab =
+    let uint8 = new%js uint8Array_fromBuffer ab in
+    of_uint8Array uint8
+end
diff --git a/lib/js_of_ocaml/typed_array.mli b/lib/js_of_ocaml/typed_array.mli
index cea6fc32a..33d5eca01 100644
--- a/lib/js_of_ocaml/typed_array.mli
+++ b/lib/js_of_ocaml/typed_array.mli
@@ -273,3 +273,20 @@ module String : sig
 
   val of_uint8Array : uint8Array Js.t -> string
 end
+
+module Bytes : sig
+  val of_uint8Array : uint8Array Js.t -> bytes
+  (** This efficiently converts a typed array to [bytes] because it will usually
+      not copy its input.
+
+      Modifying its input may also modify its output, and vice versa when
+      modifying its output. This is not a guarantee, however, since certain
+      [bytes] operations may require the runtime to make a copy. One should not
+      use this on input that is sensitive to modification. *)
+
+  val to_uint8Array : bytes -> uint8Array Js.t
+  (** See the words of caution for {!of_uint8Array}. *)
+
+  val of_arrayBuffer : arrayBuffer Js.t -> bytes
+  (** See the words of caution for {!of_uint8Array}. *)
+end

From de31b5a384c821a917925c98b655c211fa3b0497 Mon Sep 17 00:00:00 2001
From: Stephane Legrand <slegrand45@gmail.com>
Date: Sun, 3 Sep 2023 13:27:18 +0200
Subject: [PATCH 04/28] Add download attribute to anchor element

---
 lib/js_of_ocaml/dom_html.ml  | 2 ++
 lib/js_of_ocaml/dom_html.mli | 2 ++
 2 files changed, 4 insertions(+)

diff --git a/lib/js_of_ocaml/dom_html.ml b/lib/js_of_ocaml/dom_html.ml
index 14cb2043c..b366a3603 100644
--- a/lib/js_of_ocaml/dom_html.ml
+++ b/lib/js_of_ocaml/dom_html.ml
@@ -1351,6 +1351,8 @@ class type anchorElement = object
 
   method coords : js_string t prop
 
+  method download : js_string t prop
+
   method href : js_string t prop
 
   method hreflang : js_string t prop
diff --git a/lib/js_of_ocaml/dom_html.mli b/lib/js_of_ocaml/dom_html.mli
index 0caf77382..57db485ea 100644
--- a/lib/js_of_ocaml/dom_html.mli
+++ b/lib/js_of_ocaml/dom_html.mli
@@ -1169,6 +1169,8 @@ class type anchorElement = object
 
   method coords : js_string t prop
 
+  method download : js_string t prop
+
   method href : js_string t prop
 
   method hreflang : js_string t prop

From 6dc669706290673b7a4f5ecdd3ae7f107f787092 Mon Sep 17 00:00:00 2001
From: hhugo <hugo.heuzard@gmail.com>
Date: Fri, 1 Mar 2024 14:08:33 +0100
Subject: [PATCH 05/28] Compiler: dedicated type for "special" values  (#1573)

---
 compiler/lib/code.ml                 | 12 ++++++++++++
 compiler/lib/code.mli                |  5 +++++
 compiler/lib/deadcode.ml             |  1 +
 compiler/lib/eval.ml                 |  3 ++-
 compiler/lib/flow.ml                 |  9 +++++----
 compiler/lib/freevars.ml             |  1 +
 compiler/lib/generate.ml             | 14 ++++++--------
 compiler/lib/global_flow.ml          |  2 ++
 compiler/lib/inline.ml               |  5 ++---
 compiler/lib/parse_bytecode.ml       |  9 ++++-----
 compiler/lib/partial_cps_analysis.ml |  4 ++--
 compiler/lib/phisimpl.ml             |  2 +-
 compiler/lib/primitive.ml            |  5 ++++-
 compiler/lib/pure_fun.ml             |  1 +
 compiler/lib/specialize.ml           |  2 +-
 compiler/lib/subst.ml                |  1 +
 compiler/lib/wasm/wa_generate.ml     |  2 ++
 compiler/lib/wasm/wa_globalize.ml    |  2 +-
 compiler/lib/wasm/wa_liveness.ml     |  4 ++--
 compiler/lib/wasm/wa_spilling.ml     |  8 ++++----
 compiler/tests-dynlink/export        |  3 ++-
 21 files changed, 61 insertions(+), 34 deletions(-)

diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml
index efdbc4f52..ddd4d7157 100644
--- a/compiler/lib/code.ml
+++ b/compiler/lib/code.ml
@@ -334,6 +334,10 @@ type prim_arg =
   | Pv of Var.t
   | Pc of constant
 
+type special =
+  | Undefined
+  | Alias_prim of string
+
 type expr =
   | Apply of
       { f : Var.t
@@ -345,6 +349,7 @@ type expr =
   | Closure of Var.t list * cont
   | Constant of constant
   | Prim of prim * prim_arg list
+  | Special of special
 
 type instr =
   | Let of Var.t * expr
@@ -476,6 +481,11 @@ module Print = struct
     | Ult, [ x; y ] -> Format.fprintf f "%a <= %a" arg x arg y
     | _ -> assert false
 
+  let special f s =
+    match s with
+    | Undefined -> Format.fprintf f "undefined"
+    | Alias_prim s -> Format.fprintf f "alias %s" s
+
   let expr f e =
     match e with
     | Apply { f = g; args; exact } ->
@@ -492,6 +502,7 @@ module Print = struct
     | Closure (l, c) -> Format.fprintf f "fun(%a){%a}" var_list l cont c
     | Constant c -> Format.fprintf f "CONST{%a}" constant c
     | Prim (p, l) -> prim f p l
+    | Special s -> special f s
 
   let instr f (i, _loc) =
     match i with
@@ -756,6 +767,7 @@ let invariant { blocks; start; _ } =
           check_cont cont
       | Constant _ -> ()
       | Prim (_, _) -> ()
+      | Special _ -> ()
     in
     let check_instr (i, _loc) =
       match i with
diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli
index 13f036fd1..2f6125f83 100644
--- a/compiler/lib/code.mli
+++ b/compiler/lib/code.mli
@@ -181,6 +181,10 @@ type prim_arg =
   | Pv of Var.t
   | Pc of constant
 
+type special =
+  | Undefined
+  | Alias_prim of string
+
 type expr =
   | Apply of
       { f : Var.t
@@ -192,6 +196,7 @@ type expr =
   | Closure of Var.t list * cont
   | Constant of constant
   | Prim of prim * prim_arg list
+  | Special of special
 
 type instr =
   | Let of Var.t * expr
diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml
index 5468232a6..cd2a88736 100644
--- a/compiler/lib/deadcode.ml
+++ b/compiler/lib/deadcode.ml
@@ -64,6 +64,7 @@ and mark_expr st e =
   | Block (_, a, _) -> Array.iter a ~f:(fun x -> mark_var st x)
   | Field (x, _) -> mark_var st x
   | Closure (_, (pc, _)) -> mark_reachable st pc
+  | Special _ -> ()
   | Prim (_, l) ->
       List.iter l ~f:(fun x ->
           match x with
diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml
index 6c1a26465..7370e5b4e 100644
--- a/compiler/lib/eval.ml
+++ b/compiler/lib/eval.ml
@@ -367,7 +367,7 @@ let the_cond_of info x =
             | Float_array _
             | Int64 _ )) -> Non_zero
       | Expr (Block (_, _, _)) -> Non_zero
-      | Expr (Field _ | Closure _ | Prim _ | Apply _) -> Unknown
+      | Expr (Field _ | Closure _ | Prim _ | Apply _ | Special _) -> Unknown
       | Param | Phi _ -> Unknown)
     Unknown
     (fun u v ->
@@ -416,6 +416,7 @@ let rec do_not_raise pc visited blocks =
             match e with
             | Block (_, _, _) | Field (_, _) | Constant _ | Closure _ -> ()
             | Apply _ -> raise May_raise
+            | Special _ -> ()
             | Prim (Extern name, _) when Primitive.is_pure name -> ()
             | Prim (Extern _, _) -> raise May_raise
             | Prim (_, _) -> ()));
diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml
index e6b5b600e..7e719142f 100644
--- a/compiler/lib/flow.ml
+++ b/compiler/lib/flow.ml
@@ -89,7 +89,7 @@ let cont_deps blocks vars deps defs (pc, args) =
 
 let expr_deps blocks vars deps defs x e =
   match e with
-  | Constant _ | Apply _ | Prim _ -> ()
+  | Constant _ | Apply _ | Prim _ | Special _ -> ()
   | Closure (l, cont) ->
       List.iter l ~f:(fun x -> add_param_def vars defs x);
       cont_deps blocks vars deps defs cont
@@ -137,7 +137,8 @@ let propagate1 deps defs st x =
   | Phi s -> var_set_lift (fun y -> Var.Tbl.get st y) s
   | Expr e -> (
       match e with
-      | Constant _ | Apply _ | Prim _ | Closure _ | Block _ -> Var.Set.singleton x
+      | Constant _ | Apply _ | Prim _ | Special _ | Closure _ | Block _ ->
+          Var.Set.singleton x
       | Field (y, n) ->
           var_set_lift
             (fun z ->
@@ -190,7 +191,7 @@ let rec block_escape st x =
 
 let expr_escape st _x e =
   match e with
-  | Constant _ | Closure _ | Block _ | Field _ -> ()
+  | Special _ | Constant _ | Closure _ | Block _ | Field _ -> ()
   | Apply { args; _ } -> List.iter args ~f:(fun x -> block_escape st x)
   | Prim (Array_get, [ Pv x; _ ]) -> block_escape st x
   | Prim ((Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) -> ()
@@ -266,7 +267,7 @@ let propagate2 ?(skip_param = false) defs known_origins possibly_mutable st x =
   | Phi s -> Var.Set.exists (fun y -> Var.Tbl.get st y) s
   | Expr e -> (
       match e with
-      | Constant _ | Closure _ | Apply _ | Prim _ | Block _ -> false
+      | Constant _ | Closure _ | Apply _ | Prim _ | Block _ | Special _ -> false
       | Field (y, n) ->
           Var.Tbl.get st y
           || Var.Set.exists
diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml
index f7e3daf3b..a635ee508 100644
--- a/compiler/lib/freevars.ml
+++ b/compiler/lib/freevars.ml
@@ -36,6 +36,7 @@ let iter_expr_free_vars f e =
   | Block (_, a, _) -> Array.iter ~f a
   | Field (x, _) -> f x
   | Closure _ -> ()
+  | Special _ -> ()
   | Prim (_, l) ->
       List.iter l ~f:(fun x ->
           match x with
diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml
index cafd0748a..baeb4ecd6 100644
--- a/compiler/lib/generate.ml
+++ b/compiler/lib/generate.ml
@@ -165,7 +165,7 @@ module Share = struct
                   if (not exact) || cps
                   then add_apply { arity = List.length args; exact; cps } share
                   else share
-              | Let (_, Prim (Extern "%closure", [ Pc (String name) ])) ->
+              | Let (_, Special (Alias_prim name)) ->
                   let name = Primitive.resolve name in
                   let share =
                     if Primitive.exists name then add_prim name share else share
@@ -1261,6 +1261,11 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
   | Constant c ->
       let js, instrs = constant ~ctx c level in
       (js, const_p, queue), instrs
+  | Special (Alias_prim name) ->
+      let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
+      (prim, const_p, queue), []
+  | Special Undefined ->
+      (J.(EVar (ident (Utf8_string.of_string_exn "undefined"))), const_p, queue), []
   | Prim (Extern "debugger", _) ->
       let ins =
         if Config.Flag.debugger () then J.Debugger_statement else J.Empty_statement
@@ -1319,10 +1324,6 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
                 ~init:([], const_p, queue)
             in
             J.array args, prop, queue
-        | Extern "%closure", [ Pc (String name) ] ->
-            let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
-            prim, const_p, queue
-        | Extern "%closure", _ -> assert false
         | Extern "%caml_js_opt_call", f :: o :: l ->
             let (pf, cf), queue = access_queue' ~ctx queue f in
             let (po, co), queue = access_queue' ~ctx queue o in
@@ -1393,9 +1394,6 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
            | Extern "caml_js_delete", [ _; Pc (String _) ] -> assert false
            ]}
         *)
-        | Extern "%overrideMod", [ Pc (String m); Pc (String f) ] ->
-            runtime_fun ctx (Printf.sprintf "caml_%s_%s" m f), const_p, queue
-        | Extern "%overrideMod", _ -> assert false
         | Extern "%caml_js_opt_object", fields ->
             let rec build_fields queue l =
               match l with
diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml
index 15b383776..baeb0cd83 100644
--- a/compiler/lib/global_flow.ml
+++ b/compiler/lib/global_flow.ml
@@ -153,6 +153,7 @@ let expr_deps blocks st x e =
   match e with
   | Constant _ | Prim ((Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) | Block _
     -> ()
+  | Special _ -> ()
   | Prim
       ( ( Extern
             ( "caml_check_bound"
@@ -462,6 +463,7 @@ let propagate st ~update approx x =
              block *)
           Domain.bot
       | Prim (Extern _, _) -> Domain.others
+      | Special _ -> Domain.others
       | Apply { f; args; _ } -> (
           match Var.Tbl.get approx f with
           | Values { known; others } ->
diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml
index 26c8ad397..0b8fec6ef 100644
--- a/compiler/lib/inline.ml
+++ b/compiler/lib/inline.ml
@@ -167,6 +167,7 @@ let simple blocks cont mapping =
                    })
           | Prim (prim, args) ->
               `Exp (Prim (prim, List.map args ~f:(map_prim_arg mapping)))
+          | Special _ -> `Exp exp
           | Block (tag, args, aon) ->
               `Exp (Block (tag, Array.map args ~f:(map_var mapping), aon))
           | Field (x, i) -> `Exp (Field (map_var mapping x, i))
@@ -252,9 +253,7 @@ let inline ~first_class_primitives live_vars closures pc (outer, blocks, free_pc
                 if Code.Var.compare y y' = 0
                    && Primitive.has_arity prim len
                    && args_equal l args
-                then
-                  ( (Let (x, Prim (Extern "%closure", [ Pc (String prim) ])), loc) :: rem
-                  , state )
+                then (Let (x, Special (Alias_prim prim)), loc) :: rem, state
                 else i :: rem, state
             | _ -> i :: rem, state)
         | _ -> i :: rem, state)
diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml
index 6646b2ba5..988249314 100644
--- a/compiler/lib/parse_bytecode.ml
+++ b/compiler/lib/parse_bytecode.ml
@@ -2507,9 +2507,6 @@ let override_global =
   match Ocaml_version.v with
   | `V4_13 | `V4_14 | `V5_00 | `V5_01 | `V5_02 -> []
   | `V4_08 | `V4_09 | `V4_10 | `V4_11 | `V4_12 ->
-      let jsmodule name func =
-        Prim (Extern "%overrideMod", [ Pc (String name); Pc (String func) ])
-      in
       [ ( "CamlinternalMod"
         , fun _orig instrs ->
             let x = Var.fresh_n "internalMod" in
@@ -2517,8 +2514,10 @@ let override_global =
             let update_mod = Var.fresh_n "update_mod" in
             ( x
             , (Let (x, Block (0, [| init_mod; update_mod |], NotArray)), noloc)
-              :: (Let (init_mod, jsmodule "CamlinternalMod" "init_mod"), noloc)
-              :: (Let (update_mod, jsmodule "CamlinternalMod" "update_mod"), noloc)
+              :: ( Let (init_mod, Special (Alias_prim "caml_CamlinternalMod_init_mod"))
+                 , noloc )
+              :: ( Let (update_mod, Special (Alias_prim "caml_CamlinternalMod_update_mod"))
+                 , noloc )
               :: instrs ) )
       ]
 
diff --git a/compiler/lib/partial_cps_analysis.ml b/compiler/lib/partial_cps_analysis.ml
index feb8189fb..e2424fac1 100644
--- a/compiler/lib/partial_cps_analysis.ml
+++ b/compiler/lib/partial_cps_analysis.ml
@@ -88,7 +88,7 @@ let block_deps ~info ~vars ~tail_deps ~deps ~blocks ~fun_name pc =
                  in CPS *)
               add_dep deps f x)
       | Let (x, Closure _) -> add_var vars x
-      | Let (_, (Prim _ | Block _ | Constant _ | Field _))
+      | Let (_, (Prim _ | Block _ | Constant _ | Field _ | Special _))
       | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ())
 
 let program_deps ~info ~vars ~tail_deps ~deps p =
@@ -141,7 +141,7 @@ let cps_needed ~info ~in_mutual_recursion ~rev_deps st x =
   | Expr (Prim (Extern ("%perform" | "%reperform" | "%resume"), _)) ->
       (* Effects primitives are in CPS *)
       true
-  | Expr (Prim _ | Block _ | Constant _ | Field _) | Phi _ -> false
+  | Expr (Prim _ | Block _ | Constant _ | Field _ | Special _) | Phi _ -> false
 
 module SCC = Strongly_connected_components.Make (struct
   type t = Var.t
diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml
index d4a481ef7..7cc81c476 100644
--- a/compiler/lib/phisimpl.ml
+++ b/compiler/lib/phisimpl.ml
@@ -50,7 +50,7 @@ let cont_deps blocks vars deps defs (pc, args) =
 
 let expr_deps blocks vars deps defs x e =
   match e with
-  | Constant _ | Apply _ | Prim _ -> ()
+  | Constant _ | Apply _ | Prim _ | Special _ -> ()
   | Closure (_, cont) -> cont_deps blocks vars deps defs cont
   | Block (_, a, _) -> Array.iter a ~f:(fun y -> add_dep deps x y)
   | Field (y, _) -> add_dep deps x y
diff --git a/compiler/lib/primitive.ml b/compiler/lib/primitive.ml
index 3a94dee69..9ccfd71df 100644
--- a/compiler/lib/primitive.ml
+++ b/compiler/lib/primitive.ml
@@ -73,7 +73,10 @@ let arity nm = Hashtbl.find arities (resolve nm)
 
 let has_arity nm a = try Hashtbl.find arities (resolve nm) = a with Not_found -> false
 
-let is_pure nm = Poly.(kind nm <> `Mutator)
+let is_pure nm =
+  match nm with
+  | "%identity" | "%direct_int_div" | "%direct_int_mod" | "%direct_int_mul" -> true
+  | _ -> Poly.(kind nm <> `Mutator)
 
 let exists p = Hashtbl.mem kinds p
 
diff --git a/compiler/lib/pure_fun.ml b/compiler/lib/pure_fun.ml
index 714dbe774..8e566fd13 100644
--- a/compiler/lib/pure_fun.ml
+++ b/compiler/lib/pure_fun.ml
@@ -25,6 +25,7 @@ open Code
 let pure_expr pure_funs e =
   match e with
   | Block _ | Field _ | Closure _ | Constant _ -> true
+  | Special (Alias_prim _ | Undefined) -> true
   | Apply { f; exact; _ } -> exact && Var.Set.mem f pure_funs
   | Prim (p, _l) -> (
       match p with
diff --git a/compiler/lib/specialize.ml b/compiler/lib/specialize.ml
index c1e1c620b..1ab1f7174 100644
--- a/compiler/lib/specialize.ml
+++ b/compiler/lib/specialize.ml
@@ -28,7 +28,7 @@ let function_arity info x =
       (fun x ->
         match info.info_defs.(Var.idx x) with
         | Expr (Closure (l, _)) -> Some (List.length l)
-        | Expr (Prim (Extern "%closure", [ Pc (String prim) ])) -> (
+        | Expr (Special (Alias_prim prim)) -> (
             try Some (Primitive.arity prim) with Not_found -> None)
         | Expr (Apply { f; args; _ }) -> (
             if List.mem f ~set:acc
diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml
index d6a03a7a8..7e4d22b08 100644
--- a/compiler/lib/subst.ml
+++ b/compiler/lib/subst.ml
@@ -31,6 +31,7 @@ let expr s e =
   | Block (n, a, k) -> Block (n, Array.map a ~f:(fun x -> s x), k)
   | Field (x, n) -> Field (s x, n)
   | Closure (l, pc) -> Closure (l, subst_cont s pc)
+  | Special _ -> e
   | Prim (p, l) ->
       Prim
         ( p
diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml
index 6eb088ad7..fb574316a 100644
--- a/compiler/lib/wasm/wa_generate.ml
+++ b/compiler/lib/wasm/wa_generate.ml
@@ -165,6 +165,8 @@ module Generate (Target : Wa_target_sig.S) = struct
           ~cps:(Var.Set.mem x ctx.in_cps)
           x
     | Constant c -> Constant.translate c
+    | Special Undefined -> Constant.translate (Int (Regular, 0l))
+    | Special (Alias_prim _) -> assert false
     | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int (_, arity)) ])
       when Poly.(target = `GC) ->
         Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:(Int32.to_int arity)
diff --git a/compiler/lib/wasm/wa_globalize.ml b/compiler/lib/wasm/wa_globalize.ml
index 8f78ef420..e27c078bd 100644
--- a/compiler/lib/wasm/wa_globalize.ml
+++ b/compiler/lib/wasm/wa_globalize.ml
@@ -80,7 +80,7 @@ let traverse_expression x e st =
         ~f:(fun st x -> use x st)
         ~init:st
         (Code.Var.Map.find x st.closures).Wa_closure_conversion.free_variables
-  | Constant _ -> st
+  | Constant _ | Special _ -> st
   | Prim (_, args) ->
       List.fold_left
         ~f:(fun st a ->
diff --git a/compiler/lib/wasm/wa_liveness.ml b/compiler/lib/wasm/wa_liveness.ml
index 784266424..349842aee 100644
--- a/compiler/lib/wasm/wa_liveness.ml
+++ b/compiler/lib/wasm/wa_liveness.ml
@@ -110,7 +110,7 @@ let expr_used ~context ~closures ~ctx x e s =
   | Block (_, a, _) -> add_array ~ctx s a
   | Prim (_, l) -> add_prim_args ~ctx s l
   | Closure _ -> add_list ~ctx s (function_free_variables ~context ~closures x)
-  | Constant _ -> s
+  | Constant _ | Special _ -> s
   | Field (x, _) -> add_var ~ctx s x
 
 let propagate_through_instr ~context ~closures ~ctx (i, _) s =
@@ -185,7 +185,7 @@ let compute_instr_info ~blocks ~context ~closures ~domain ~ctx st =
                   | Apply _ | Prim _ ->
                       Var.Map.add x (Var.Set.remove x live_vars) live_info
                   | Block _ | Closure _ -> Var.Map.add x live_vars' live_info
-                  | Constant _ | Field _ -> live_info)
+                  | Constant _ | Field _ | Special _ -> live_info)
               | Assign _ | Offset_ref _ | Set_field _ | Array_set _ -> live_info
             in
             live_vars', live_info)
diff --git a/compiler/lib/wasm/wa_spilling.ml b/compiler/lib/wasm/wa_spilling.ml
index 441d23326..4c28b2f64 100644
--- a/compiler/lib/wasm/wa_spilling.ml
+++ b/compiler/lib/wasm/wa_spilling.ml
@@ -167,7 +167,7 @@ let function_deps blocks ~context ~closures pc params =
           match i with
           | Let (x, e) -> (
               match e with
-              | Constant _ -> mark_non_spillable x
+              | Constant _ | Special _ -> mark_non_spillable x
               | Prim (p, _) when no_pointer p -> mark_non_spillable x
               | Closure _
                 when List.is_empty (function_free_variables ~context ~closures x) ->
@@ -205,7 +205,7 @@ let propagate_through_expr ~context ~closures s x e =
       if List.is_empty (function_free_variables ~context ~closures x)
       then s
       else Var.Set.empty
-  | Constant _ | Field _ -> s
+  | Constant _ | Field _ | Special _ -> s
 
 let propagate_through_instr ~context ~closures s (i, _) =
   match i with
@@ -310,7 +310,7 @@ let spilled_variables
                         ~f:(fun reloaded x -> check_spilled ~ctx loaded' x reloaded)
                         fv
                         ~init:Var.Set.empty
-                  | Constant _ -> Var.Set.empty
+                  | Constant _ | Special _ -> Var.Set.empty
                   | Field (x, _) -> check_spilled ~ctx loaded x Var.Set.empty)
               | Assign (_, x) | Offset_ref (x, _) ->
                   check_spilled ~ctx loaded x Var.Set.empty
@@ -490,7 +490,7 @@ let spilling blocks st env bound_vars spilled_vars live_info pc params =
                       in
                       instr_info := Var.Map.add x sp !instr_info;
                       stack, Var.Set.empty
-                  | Prim _ | Constant _ | Field _ -> stack, vars)
+                  | Prim _ | Constant _ | Field _ | Special _ -> stack, vars)
               | Assign _ | Offset_ref _ | Set_field _ | Array_set _ -> stack, vars
             in
             let vars =
diff --git a/compiler/tests-dynlink/export b/compiler/tests-dynlink/export
index f516f0a52..7aee0c5d9 100644
--- a/compiler/tests-dynlink/export
+++ b/compiler/tests-dynlink/export
@@ -1,2 +1,3 @@
 Stdlib
-Stdlib__Buffer
\ No newline at end of file
+Stdlib__Buffer
+Stdlib__buffer
\ No newline at end of file

From c860567760972633b83f177ea23e7472e3917e91 Mon Sep 17 00:00:00 2001
From: hhugo <hugo.heuzard@gmail.com>
Date: Fri, 1 Mar 2024 15:29:25 +0100
Subject: [PATCH 06/28] Compiler: remove last argument of Pushtrap (#1575)

---
 compiler/lib/code.ml              | 62 +++++++++++++++++++++++--------
 compiler/lib/code.mli             |  4 +-
 compiler/lib/deadcode.ml          | 12 ++----
 compiler/lib/effects.ml           |  9 ++---
 compiler/lib/eval.ml              |  7 +---
 compiler/lib/flow.ml              |  2 +-
 compiler/lib/freevars.ml          |  4 +-
 compiler/lib/generate.ml          |  6 +--
 compiler/lib/global_flow.ml       |  2 +-
 compiler/lib/inline.ml            |  3 +-
 compiler/lib/parse_bytecode.ml    | 55 +++------------------------
 compiler/lib/phisimpl.ml          |  2 +-
 compiler/lib/subst.ml             |  3 +-
 compiler/lib/tailcall.ml          |  3 +-
 compiler/lib/wasm/wa_generate.ml  |  2 +-
 compiler/lib/wasm/wa_liveness.ml  |  4 +-
 compiler/lib/wasm/wa_spilling.ml  |  4 +-
 compiler/lib/wasm/wa_structure.ml |  4 +-
 18 files changed, 85 insertions(+), 103 deletions(-)

diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml
index ddd4d7157..779f8711f 100644
--- a/compiler/lib/code.ml
+++ b/compiler/lib/code.ml
@@ -365,7 +365,7 @@ type last =
   | Branch of cont
   | Cond of Var.t * cont * cont
   | Switch of Var.t * cont array * cont array
-  | Pushtrap of cont * Var.t * cont * Addr.Set.t
+  | Pushtrap of cont * Var.t * cont
   | Poptrap of cont
 
 type block =
@@ -528,17 +528,8 @@ module Print = struct
         Array.iteri a1 ~f:(fun i c -> Format.fprintf f "int %d -> %a; " i cont c);
         Array.iteri a2 ~f:(fun i c -> Format.fprintf f "tag %d -> %a; " i cont c);
         Format.fprintf f "}"
-    | Pushtrap (cont1, x, cont2, pcs) ->
-        Format.fprintf
-          f
-          "pushtrap %a handler %a => %a continuation %s"
-          cont
-          cont1
-          Var.print
-          x
-          cont
-          cont2
-          (String.concat ~sep:", " (List.map (Addr.Set.elements pcs) ~f:string_of_int))
+    | Pushtrap (cont1, x, cont2) ->
+        Format.fprintf f "pushtrap %a handler %a => %a" cont cont1 Var.print x cont cont2
     | Poptrap c -> Format.fprintf f "poptrap %a" cont c
 
   type xinstr =
@@ -609,12 +600,51 @@ let is_empty p =
       | _ -> false)
   | _ -> false
 
+let poptraps blocks pc =
+  let rec loop blocks pc visited depth acc =
+    if Addr.Set.mem pc visited
+    then acc, visited
+    else
+      let visited = Addr.Set.add pc visited in
+      let block = Addr.Map.find pc blocks in
+      match fst block.branch with
+      | Return _ | Raise _ | Stop -> acc, visited
+      | Branch (pc', _) -> loop blocks pc' visited depth acc
+      | Poptrap (pc', _) ->
+          if depth = 0
+          then Addr.Set.add pc' acc, visited
+          else loop blocks pc' visited (depth - 1) acc
+      | Pushtrap ((pc', _), _, (pc_h, _)) ->
+          let acc, visited = loop blocks pc' visited (depth + 1) acc in
+          let acc, visited = loop blocks pc_h visited depth acc in
+          acc, visited
+      | Cond (_, (pc1, _), (pc2, _)) ->
+          let acc, visited = loop blocks pc1 visited depth acc in
+          let acc, visited = loop blocks pc2 visited depth acc in
+          acc, visited
+      | Switch (_, a1, a2) ->
+          let acc, visited =
+            Array.fold_right
+              ~init:(acc, visited)
+              ~f:(fun (pc, _) (acc, visited) -> loop blocks pc visited depth acc)
+              a1
+          in
+          let acc, visited =
+            Array.fold_right
+              ~init:(acc, visited)
+              ~f:(fun (pc, _) (acc, visited) -> loop blocks pc visited depth acc)
+              a2
+          in
+          acc, visited
+  in
+  loop blocks pc Addr.Set.empty 0 Addr.Set.empty |> fst
+
 let fold_children blocks pc f accu =
   let block = Addr.Map.find pc blocks in
   match fst block.branch with
   | Return _ | Raise _ | Stop -> accu
   | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu
-  | Pushtrap ((pc', _), _, (pc_h, _), _) ->
+  | Pushtrap ((pc', _), _, (pc_h, _)) ->
       let accu = f pc' accu in
       let accu = f pc_h accu in
       accu
@@ -632,8 +662,8 @@ let fold_children_skip_try_body blocks pc f accu =
   match fst block.branch with
   | Return _ | Raise _ | Stop -> accu
   | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu
-  | Pushtrap (_, _, (pc_h, _), pcs) ->
-      let accu = Addr.Set.fold f pcs accu in
+  | Pushtrap ((pc', _), _, (pc_h, _)) ->
+      let accu = Addr.Set.fold f (poptraps blocks pc') accu in
       let accu = f pc_h accu in
       accu
   | Cond (_, (pc1, _), (pc2, _)) ->
@@ -791,7 +821,7 @@ let invariant { blocks; start; _ } =
       | Switch (_x, a1, a2) ->
           Array.iteri a1 ~f:(fun _ cont -> check_cont cont);
           Array.iteri a2 ~f:(fun _ cont -> check_cont cont)
-      | Pushtrap (cont1, _x, cont2, _pcs) ->
+      | Pushtrap (cont1, _x, cont2) ->
           check_cont cont1;
           check_cont cont2
       | Poptrap cont -> check_cont cont
diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli
index 2f6125f83..9c1d5cc59 100644
--- a/compiler/lib/code.mli
+++ b/compiler/lib/code.mli
@@ -212,7 +212,7 @@ type last =
   | Branch of cont
   | Cond of Var.t * cont * cont
   | Switch of Var.t * cont array * cont array
-  | Pushtrap of cont * Var.t * cont * Addr.Set.t
+  | Pushtrap of cont * Var.t * cont
   | Poptrap of cont
 
 type block =
@@ -276,6 +276,8 @@ val fold_children : 'c fold_blocs
 
 val fold_children_skip_try_body : 'c fold_blocs
 
+val poptraps : block Addr.Map.t -> Addr.t -> Addr.Set.t
+
 val traverse :
   fold_blocs_poly -> (Addr.t -> 'c -> 'c) -> Addr.t -> block Addr.Map.t -> 'c -> 'c
 
diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml
index cd2a88736..c04af06ff 100644
--- a/compiler/lib/deadcode.ml
+++ b/compiler/lib/deadcode.ml
@@ -102,7 +102,7 @@ and mark_reachable st pc =
         mark_var st x;
         Array.iter a1 ~f:(fun cont -> mark_cont_reachable st cont);
         Array.iter a2 ~f:(fun cont -> mark_cont_reachable st cont)
-    | Pushtrap (cont1, _, cont2, _) ->
+    | Pushtrap (cont1, _, cont2) ->
         mark_cont_reachable st cont1;
         mark_cont_reachable st cont2)
 
@@ -142,12 +142,8 @@ let filter_live_last blocks st (l, loc) =
           ( x
           , Array.map a1 ~f:(fun cont -> filter_cont blocks st cont)
           , Array.map a2 ~f:(fun cont -> filter_cont blocks st cont) )
-    | Pushtrap (cont1, x, cont2, pcs) ->
-        Pushtrap
-          ( filter_cont blocks st cont1
-          , x
-          , filter_cont blocks st cont2
-          , Addr.Set.inter pcs st.reachable_blocks )
+    | Pushtrap (cont1, x, cont2) ->
+        Pushtrap (filter_cont blocks st cont1, x, filter_cont blocks st cont2)
     | Poptrap cont -> Poptrap (filter_cont blocks st cont)
   in
   l, loc
@@ -208,7 +204,7 @@ let f ({ blocks; _ } as p : Code.program) =
       | Switch (_, a1, a2) ->
           Array.iter a1 ~f:(fun cont -> add_cont_dep blocks defs cont);
           Array.iter a2 ~f:(fun cont -> add_cont_dep blocks defs cont)
-      | Pushtrap (cont, _, cont_h, _) ->
+      | Pushtrap (cont, _, cont_h) ->
           add_cont_dep blocks defs cont_h;
           add_cont_dep blocks defs cont
       | Poptrap cont -> add_cont_dep blocks defs cont)
diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml
index 1dd38eb10..6803085d8 100644
--- a/compiler/lib/effects.ml
+++ b/compiler/lib/effects.ml
@@ -191,7 +191,7 @@ let compute_needed_transformations ~cfg ~idom ~cps_needed ~blocks ~start =
               List.iter ~f:mark_needed englobing_exn_handlers;
               mark_continuation dst x
           | _ -> ())
-      | Pushtrap (_, x, (handler_pc, _), _) -> mark_continuation handler_pc x
+      | Pushtrap (_, x, (handler_pc, _)) -> mark_continuation handler_pc x
       | Poptrap _ | Raise _ -> (
           match englobing_exn_handlers with
           | handler_pc :: _ -> Hashtbl.add matching_exn_handler pc handler_pc
@@ -203,7 +203,7 @@ let compute_needed_transformations ~cfg ~idom ~cps_needed ~blocks ~start =
         (fun pc visited ->
           let englobing_exn_handlers =
             match block.branch with
-            | Pushtrap (_, _, (handler_pc, _), _), _ when pc <> handler_pc ->
+            | Pushtrap (_, _, (handler_pc, _)), _ when pc <> handler_pc ->
                 handler_pc :: englobing_exn_handlers
             | Poptrap _, _ -> List.tl englobing_exn_handlers
             | _ -> englobing_exn_handlers
@@ -438,7 +438,7 @@ let cps_last ~st ~alloc_jump_closures pc ((last, last_loc) : last * loc) ~k :
       ( alloc_jump_closures
       , ( Switch (x, Array.map c1 ~f:cps_jump_cont, Array.map c2 ~f:cps_jump_cont)
         , last_loc ) )
-  | Pushtrap (body_cont, exn, ((handler_pc, _) as handler_cont), _) -> (
+  | Pushtrap (body_cont, exn, ((handler_pc, _) as handler_cont)) -> (
       assert (Hashtbl.mem st.is_continuation handler_pc);
       match Addr.Set.mem handler_pc st.blocks_to_transform with
       | false -> alloc_jump_closures, (last, last_loc)
@@ -931,8 +931,7 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program =
                | Cond (x, cont1, cont2) -> Cond (x, resolve cont1, resolve cont2)
                | Switch (x, a1, a2) ->
                    Switch (x, Array.map ~f:resolve a1, Array.map ~f:resolve a2)
-               | Pushtrap (cont1, x, cont2, s) ->
-                   Pushtrap (resolve cont1, x, resolve cont2, s)
+               | Pushtrap (cont1, x, cont2) -> Pushtrap (resolve cont1, x, resolve cont2)
                | Poptrap cont -> Poptrap (resolve cont)
                | Return _ | Raise _ | Stop -> branch
              in
diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml
index 7370e5b4e..19886b4ee 100644
--- a/compiler/lib/eval.ml
+++ b/compiler/lib/eval.ml
@@ -444,8 +444,7 @@ let drop_exception_handler blocks =
   Addr.Map.fold
     (fun pc _ blocks ->
       match Addr.Map.find pc blocks with
-      | { branch = Pushtrap (((addr, _) as cont1), _x, _cont2, addrset), loc; _ } as b
-        -> (
+      | { branch = Pushtrap (((addr, _) as cont1), _x, _cont2), loc; _ } as b -> (
           try
             let visited = do_not_raise addr Addr.Set.empty blocks in
             let b = { b with branch = Branch cont1, loc } in
@@ -456,9 +455,7 @@ let drop_exception_handler blocks =
                   let b = Addr.Map.find pc2 blocks in
                   let branch =
                     match b.branch with
-                    | Poptrap ((addr, _) as cont), loc ->
-                        assert (Addr.Set.mem addr addrset);
-                        Branch cont, loc
+                    | Poptrap cont, loc -> Branch cont, loc
                     | x -> x
                   in
                   let b = { b with branch } in
diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml
index 7e719142f..3d3833999 100644
--- a/compiler/lib/flow.ml
+++ b/compiler/lib/flow.ml
@@ -122,7 +122,7 @@ let program_deps { blocks; _ } =
       | Switch (_, a1, a2) ->
           Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont);
           Array.iter a2 ~f:(fun cont -> cont_deps blocks vars deps defs cont)
-      | Pushtrap (cont, x, cont_h, _) ->
+      | Pushtrap (cont, x, cont_h) ->
           add_param_def vars defs x;
           cont_deps blocks vars deps defs cont_h;
           cont_deps blocks vars deps defs cont)
diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml
index a635ee508..feeacef21 100644
--- a/compiler/lib/freevars.ml
+++ b/compiler/lib/freevars.ml
@@ -69,7 +69,7 @@ let iter_last_free_var f l =
       f x;
       Array.iter a1 ~f:(fun c -> iter_cont_free_vars f c);
       Array.iter a2 ~f:(fun c -> iter_cont_free_vars f c)
-  | Pushtrap (cont1, _, cont2, _) ->
+  | Pushtrap (cont1, _, cont2) ->
       iter_cont_free_vars f cont1;
       iter_cont_free_vars f cont2
 
@@ -85,7 +85,7 @@ let iter_instr_bound_vars f i =
 let iter_last_bound_vars f l =
   match l with
   | Return _ | Raise _ | Stop | Branch _ | Cond _ | Switch _ | Poptrap _ -> ()
-  | Pushtrap (_, x, _, _) -> f x
+  | Pushtrap (_, x, _) -> f x
 
 let iter_block_bound_vars f block =
   List.iter ~f block.params;
diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml
index baeb4ecd6..4413d2904 100644
--- a/compiler/lib/generate.ml
+++ b/compiler/lib/generate.ml
@@ -758,7 +758,7 @@ let fold_children blocks pc f accu =
   match fst block.branch with
   | Return _ | Raise _ | Stop -> accu
   | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu
-  | Pushtrap ((pc1, _), _, (pc2, _), _) ->
+  | Pushtrap ((pc1, _), _, (pc2, _)) ->
       let accu = f pc1 accu in
       let accu = f pc2 accu in
       accu
@@ -805,7 +805,7 @@ let build_graph ctx pc =
       List.iter pc_succs ~f:(fun pc' ->
           let pushtrap =
             match fst b.branch with
-            | Pushtrap ((pc1, _), _, (pc2, _), _remove) ->
+            | Pushtrap ((pc1, _), _, (pc2, _)) ->
                 if pc' = pc1
                 then (
                   Hashtbl.add poptrap pc Addr.Set.empty;
@@ -1866,7 +1866,7 @@ and compile_conditional st queue last loop_stack backs frontier interm =
         in
         true, flush_all queue [ J.Return_statement e_opt, loc ]
     | Branch cont -> compile_branch st queue cont loop_stack backs frontier interm
-    | Pushtrap (c1, x, e1, _) ->
+    | Pushtrap (c1, x, e1) ->
         let never_body, body = compile_branch st [] c1 loop_stack backs frontier interm in
         if debug () then Format.eprintf "@,}@]@,@[<hv 2>catch {@;";
         let never_handler, handler =
diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml
index baeb0cd83..4742ad589 100644
--- a/compiler/lib/global_flow.ml
+++ b/compiler/lib/global_flow.ml
@@ -273,7 +273,7 @@ let program_deps st { blocks; _ } =
                     | _ -> ())
                   block.body)
               h
-      | Pushtrap (cont, x, cont_h, _) ->
+      | Pushtrap (cont, x, cont_h) ->
           add_var st x;
           st.defs.(Var.idx x) <- Phi { known = Var.Set.empty; others = true };
           cont_deps blocks st cont_h;
diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml
index 0b8fec6ef..e23bcf9d6 100644
--- a/compiler/lib/inline.ml
+++ b/compiler/lib/inline.ml
@@ -107,7 +107,8 @@ let fold_children blocks pc f accu =
   match fst block.branch with
   | Return _ | Raise _ | Stop -> accu
   | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu
-  | Pushtrap (_, _, (pc1, _), pcs) -> f pc1 (Addr.Set.fold f pcs accu)
+  | Pushtrap ((try_body, _), _, (pc1, _)) ->
+      f pc1 (Addr.Set.fold f (Code.poptraps blocks try_body) accu)
   | Cond (_, (pc1, _), (pc2, _)) ->
       let accu = f pc1 accu in
       let accu = f pc2 accu in
diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml
index 988249314..358303f99 100644
--- a/compiler/lib/parse_bytecode.ml
+++ b/compiler/lib/parse_bytecode.ml
@@ -554,10 +554,7 @@ module State = struct
     | Var (x, _) -> Format.fprintf f "%a" Var.print x
     | Dummy -> Format.fprintf f "???"
 
-  type handler =
-    { block_pc : Addr.t
-    ; stack : elt list
-    }
+  type handler = { stack : elt list }
 
   type t =
     { accu : elt
@@ -566,7 +563,6 @@ module State = struct
     ; env_offset : int
     ; handlers : handler list
     ; globals : globals
-    ; current_pc : Addr.t
     }
 
   let fresh_var state loc =
@@ -647,7 +643,7 @@ module State = struct
   let start_function state env offset =
     { state with accu = Dummy; stack = []; env; env_offset = offset; handlers = [] }
 
-  let start_block current_pc state =
+  let start_block _current_pc state =
     let stack =
       List.fold_right state.stack ~init:[] ~f:(fun e stack ->
           match e with
@@ -656,7 +652,7 @@ module State = struct
               let y = Var.fork x in
               Var (y, l) :: stack)
     in
-    let state = { state with stack; current_pc } in
+    let state = { state with stack } in
     match state.accu with
     | Dummy -> state
     | Var (x, loc) ->
@@ -665,26 +661,12 @@ module State = struct
         state
 
   let push_handler state =
-    { state with
-      handlers = { block_pc = state.current_pc; stack = state.stack } :: state.handlers
-    }
+    { state with handlers = { stack = state.stack } :: state.handlers }
 
   let pop_handler state = { state with handlers = List.tl state.handlers }
 
-  let addr_of_current_handler state =
-    match state.handlers with
-    | [] -> assert false
-    | x :: _ -> x.block_pc
-
   let initial g =
-    { accu = Dummy
-    ; stack = []
-    ; env = [||]
-    ; env_offset = 0
-    ; handlers = []
-    ; globals = g
-    ; current_pc = -1
-    }
+    { accu = Dummy; stack = []; env = [||]; env_offset = 0; handlers = []; globals = g }
 
   let rec print_stack f l =
     match l with
@@ -832,8 +814,6 @@ let tagged_blocks = ref Addr.Set.empty
 
 let compiled_blocks = ref Addr.Map.empty
 
-let pushpop = ref Addr.Map.empty
-
 let method_cache_id = ref 1
 
 let clo_offset_3 = if new_closure_repr then 3 else 2
@@ -1727,8 +1707,7 @@ and compile infos pc state instrs =
             , ( Pushtrap
                   ( (body_addr, State.stack_vars state)
                   , x
-                  , (handler_addr, State.stack_vars handler_state)
-                  , Addr.Set.empty )
+                  , (handler_addr, State.stack_vars handler_state) )
               , loc ) )
             !compiled_blocks;
         compile_block
@@ -1756,12 +1735,6 @@ and compile infos pc state instrs =
         instrs, (Branch (interm_addr, State.stack_vars state), loc), state
     | POPTRAP ->
         let addr = pc + 1 in
-        let handler_addr = State.addr_of_current_handler state in
-        let set =
-          try Addr.Set.add addr (Addr.Map.find handler_addr !pushpop)
-          with Not_found -> Addr.Set.singleton addr
-        in
-        pushpop := Addr.Map.add handler_addr set !pushpop;
         compile_block
           infos.blocks
           infos.debug
@@ -2449,20 +2422,6 @@ and compile infos pc state instrs =
 
 (****)
 
-let match_exn_traps (blocks : 'a Addr.Map.t) =
-  Addr.Map.fold
-    (fun pc conts' blocks ->
-      match Addr.Map.find pc blocks with
-      | { branch = Pushtrap (cont1, x, cont2, conts), loc; _ } as block ->
-          assert (Addr.Set.is_empty conts);
-          let branch = Pushtrap (cont1, x, cont2, conts'), loc in
-          Addr.Map.add pc { block with branch } blocks
-      | _ -> assert false)
-    !pushpop
-    blocks
-
-(****)
-
 type one =
   { code : Code.program
   ; cmis : StringSet.t
@@ -2491,12 +2450,10 @@ let parse_bytecode code globals debug_data ~target =
             { params = State.stack_vars state; body = instr; branch = last })
           !compiled_blocks
       in
-      let blocks = match_exn_traps blocks in
       let free_pc = String.length code / 4 in
       { start; blocks; free_pc })
     else Code.empty
   in
-  pushpop := Addr.Map.empty;
   compiled_blocks := Addr.Map.empty;
   tagged_blocks := Addr.Set.empty;
   p
diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml
index 7cc81c476..65d7b3960 100644
--- a/compiler/lib/phisimpl.ml
+++ b/compiler/lib/phisimpl.ml
@@ -80,7 +80,7 @@ let program_deps { blocks; _ } =
       | Switch (_, a1, a2) ->
           Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont);
           Array.iter a2 ~f:(fun cont -> cont_deps blocks vars deps defs cont)
-      | Pushtrap (cont, _, cont_h, _) ->
+      | Pushtrap (cont, _, cont_h) ->
           cont_deps blocks vars deps defs cont_h;
           cont_deps blocks vars deps defs cont
       | Poptrap cont -> cont_deps blocks vars deps defs cont)
diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml
index 7e4d22b08..5f438c941 100644
--- a/compiler/lib/subst.ml
+++ b/compiler/lib/subst.ml
@@ -55,8 +55,7 @@ let last s (l, loc) =
     match l with
     | Stop -> l
     | Branch cont -> Branch (subst_cont s cont)
-    | Pushtrap (cont1, x, cont2, pcs) ->
-        Pushtrap (subst_cont s cont1, x, subst_cont s cont2, pcs)
+    | Pushtrap (cont1, x, cont2) -> Pushtrap (subst_cont s cont1, x, subst_cont s cont2)
     | Return x -> Return (s x)
     | Raise (x, k) -> Raise (s x, k)
     | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2)
diff --git a/compiler/lib/tailcall.ml b/compiler/lib/tailcall.ml
index b37ff698c..209625abe 100644
--- a/compiler/lib/tailcall.ml
+++ b/compiler/lib/tailcall.ml
@@ -63,7 +63,8 @@ let fold_children blocks pc f accu =
   match fst block.branch with
   | Return _ | Raise _ | Stop -> accu
   | Branch (pc', _) | Poptrap (pc', _) -> f pc' accu
-  | Pushtrap (_, _, (pc1, _), pcs) -> f pc1 (Addr.Set.fold f pcs accu)
+  | Pushtrap ((try_body, _), _, (pc1, _)) ->
+      f pc1 (Addr.Set.fold f (Code.poptraps blocks try_body) accu)
   | Cond (_, (pc1, _), (pc2, _)) ->
       let accu = f pc1 accu in
       let accu = f pc2 accu in
diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml
index fb574316a..282d6b91a 100644
--- a/compiler/lib/wasm/wa_generate.ml
+++ b/compiler/lib/wasm/wa_generate.ml
@@ -959,7 +959,7 @@ module Generate (Target : Wa_target_sig.S) = struct
                 let* e = load x in
                 let* tag = register_import ~name:exception_name (Tag Value.value) in
                 instr (Throw (tag, e))
-            | Pushtrap (cont, x, cont', _) ->
+            | Pushtrap (cont, x, cont') ->
                 handle_exceptions
                   ~result_typ
                   ~fall_through
diff --git a/compiler/lib/wasm/wa_liveness.ml b/compiler/lib/wasm/wa_liveness.ml
index 349842aee..5b2d39cf7 100644
--- a/compiler/lib/wasm/wa_liveness.ml
+++ b/compiler/lib/wasm/wa_liveness.ml
@@ -61,7 +61,7 @@ let block_deps deps block pc =
   | Switch (_, a1, a2) ->
       Array.iter a1 ~f:(fun cont -> cont_deps deps pc cont);
       Array.iter a2 ~f:(fun cont -> cont_deps deps pc cont)
-  | Pushtrap (cont, _, cont_h, _) ->
+  | Pushtrap (cont, _, cont_h) ->
       cont_deps deps pc cont;
       cont_deps deps pc cont_h
 
@@ -131,7 +131,7 @@ let propagate_through_branch ~ctx (b, _) s =
   | Switch (_, a1, a2) ->
       let s = Array.fold_right a1 ~f:(fun cont s -> cont_used ~ctx cont s) ~init:s in
       Array.fold_right a2 ~f:(fun cont s -> cont_used ~ctx cont s) ~init:s
-  | Pushtrap (cont, x, cont_h, _) ->
+  | Pushtrap (cont, x, cont_h) ->
       s |> cont_used ~ctx cont |> cont_used ~ctx cont_h |> Var.Set.remove x
 
 let propagate blocks ~context ~closures ~ctx rev_deps st pc =
diff --git a/compiler/lib/wasm/wa_spilling.ml b/compiler/lib/wasm/wa_spilling.ml
index 4c28b2f64..3ccb0a5c0 100644
--- a/compiler/lib/wasm/wa_spilling.ml
+++ b/compiler/lib/wasm/wa_spilling.ml
@@ -146,7 +146,7 @@ let block_deps bound_vars deps block pc =
   | Switch (_, a1, a2) ->
       Array.iter a1 ~f:(fun cont -> cont_deps deps pc cont);
       Array.iter a2 ~f:(fun cont -> cont_deps deps pc cont)
-  | Pushtrap (cont, exn, cont_h, _) ->
+  | Pushtrap (cont, exn, cont_h) ->
       cont_deps deps pc cont;
       bound_vars := Var.Set.add exn !bound_vars;
       cont_deps deps pc ~exn cont_h
@@ -342,7 +342,7 @@ let spilled_variables
       | Switch (_, a1, a2) ->
           let spilled = Array.fold_right a1 ~f:handle_cont ~init:spilled in
           Array.fold_right a2 ~f:handle_cont ~init:spilled
-      | Pushtrap (cont, _, cont_h, _) -> spilled |> handle_cont cont |> handle_cont cont_h)
+      | Pushtrap (cont, _, cont_h) -> spilled |> handle_cont cont |> handle_cont cont_h)
     domain
     spilled
 
diff --git a/compiler/lib/wasm/wa_structure.ml b/compiler/lib/wasm/wa_structure.ml
index 80ea1e567..520465a56 100644
--- a/compiler/lib/wasm/wa_structure.ml
+++ b/compiler/lib/wasm/wa_structure.ml
@@ -83,7 +83,7 @@ let build_graph blocks pc =
         (fun pc' ->
           let englobing_exn_handlers =
             match fst block.branch with
-            | Pushtrap ((body_pc, _), _, _, _) when pc' = body_pc ->
+            | Pushtrap ((body_pc, _), _, _) when pc' = body_pc ->
                 pc :: englobing_exn_handlers
             | Poptrap (leave_pc, _) -> (
                 match englobing_exn_handlers with
@@ -219,7 +219,7 @@ let shrink_loops blocks ({ succs; preds; reverse_post_order; _ } as g) =
            moved outside *)
         let ignored =
           match fst block.branch with
-          | Pushtrap ((body_pc, _), _, _, _) when pc' = body_pc ->
+          | Pushtrap ((body_pc, _), _, _) when pc' = body_pc ->
               Addr.Set.union ignored loops
           | _ -> ignored
         in

From 5db44d2d2ef16bd0582606e7b1f16223ae5a172d Mon Sep 17 00:00:00 2001
From: hhugo <hugo.heuzard@gmail.com>
Date: Thu, 18 Apr 2024 09:52:24 +0200
Subject: [PATCH 07/28] Compiler: track block mutability (#1603)

---
 compiler/lib/code.ml              | 18 +++++++++---
 compiler/lib/code.mli             |  6 +++-
 compiler/lib/deadcode.ml          |  2 +-
 compiler/lib/eval.ml              | 10 +++----
 compiler/lib/flow.ml              | 17 +++++------
 compiler/lib/freevars.ml          |  2 +-
 compiler/lib/generate.ml          |  2 +-
 compiler/lib/generate_closure.ml  |  2 +-
 compiler/lib/global_flow.ml       | 12 ++++----
 compiler/lib/inline.ml            |  4 +--
 compiler/lib/parse_bytecode.ml    | 48 ++++++++++++++++++++++++-------
 compiler/lib/phisimpl.ml          |  2 +-
 compiler/lib/specialize_js.ml     | 12 ++++----
 compiler/lib/subst.ml             |  2 +-
 compiler/lib/wasm/wa_generate.ml  |  2 +-
 compiler/lib/wasm/wa_globalize.ml |  2 +-
 compiler/lib/wasm/wa_liveness.ml  |  2 +-
 compiler/lib/wasm/wa_spilling.ml  |  2 +-
 18 files changed, 94 insertions(+), 53 deletions(-)

diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml
index 779f8711f..3fda9f32a 100644
--- a/compiler/lib/code.ml
+++ b/compiler/lib/code.ml
@@ -338,13 +338,17 @@ type special =
   | Undefined
   | Alias_prim of string
 
+type mutability =
+  | Immutable
+  | Maybe_mutable
+
 type expr =
   | Apply of
       { f : Var.t
       ; args : Var.t list
       ; exact : bool
       }
-  | Block of int * Var.t array * array_or_not
+  | Block of int * Var.t array * array_or_not * mutability
   | Field of Var.t * int
   | Closure of Var.t list * cont
   | Constant of constant
@@ -492,8 +496,14 @@ module Print = struct
         if exact
         then Format.fprintf f "%a!(%a)" Var.print g var_list args
         else Format.fprintf f "%a(%a)" Var.print g var_list args
-    | Block (t, a, _) ->
-        Format.fprintf f "{tag=%d" t;
+    | Block (t, a, _, mut) ->
+        Format.fprintf
+          f
+          "%s{tag=%d"
+          (match mut with
+          | Immutable -> "imm"
+          | Maybe_mutable -> "")
+          t;
         for i = 0 to Array.length a - 1 do
           Format.fprintf f "; %d = %a" i Var.print a.(i)
         done;
@@ -790,7 +800,7 @@ let invariant { blocks; start; _ } =
     in
     let check_expr = function
       | Apply _ -> ()
-      | Block (_, _, _) -> ()
+      | Block (_, _, _, _) -> ()
       | Field (_, _) -> ()
       | Closure (l, cont) ->
           List.iter l ~f:define;
diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli
index 9c1d5cc59..67bd0d4de 100644
--- a/compiler/lib/code.mli
+++ b/compiler/lib/code.mli
@@ -185,13 +185,17 @@ type special =
   | Undefined
   | Alias_prim of string
 
+type mutability =
+  | Immutable
+  | Maybe_mutable
+
 type expr =
   | Apply of
       { f : Var.t
       ; args : Var.t list
       ; exact : bool (* if true, then # of arguments = # of parameters *)
       }
-  | Block of int * Var.t array * array_or_not
+  | Block of int * Var.t array * array_or_not * mutability
   | Field of Var.t * int
   | Closure of Var.t list * cont
   | Constant of constant
diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml
index c04af06ff..0dd662213 100644
--- a/compiler/lib/deadcode.ml
+++ b/compiler/lib/deadcode.ml
@@ -61,7 +61,7 @@ and mark_expr st e =
   | Apply { f; args; _ } ->
       mark_var st f;
       List.iter args ~f:(fun x -> mark_var st x)
-  | Block (_, a, _) -> Array.iter a ~f:(fun x -> mark_var st x)
+  | Block (_, a, _, _) -> Array.iter a ~f:(fun x -> mark_var st x)
   | Field (x, _) -> mark_var st x
   | Closure (_, (pc, _)) -> mark_reachable st pc
   | Special _ -> ()
diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml
index 19886b4ee..bb637bdfb 100644
--- a/compiler/lib/eval.ml
+++ b/compiler/lib/eval.ml
@@ -200,7 +200,7 @@ let is_int ~target info x =
               match target with
               | `JavaScript -> Y
               | `Wasm -> N)
-          | Expr (Block (_, _, _)) | Expr (Constant _) -> N
+          | Expr (Block (_, _, _, _)) | Expr (Constant _) -> N
           | _ -> Unknown)
         Unknown
         (fun u v ->
@@ -275,7 +275,7 @@ let eval_instr ~target info ((x, loc) as i) =
                    | `JavaScript -> "js_of_ocaml"
                    | `Wasm -> "wasm_of_ocaml")) )
         , noloc )
-      ; Let (x, Block (0, [| jsoo |], NotArray)), loc
+      ; Let (x, Block (0, [| jsoo |], NotArray, Immutable)), loc
       ]
   | Let (_, Prim (Extern ("%resume" | "%perform" | "%reperform"), _)) ->
       [ i ] (* We need that the arguments to this primitives remain variables *)
@@ -331,7 +331,7 @@ let the_case_of info x =
         (fun x ->
           match info.info_defs.(Var.idx x) with
           | Expr (Constant (Int (_, i))) -> CConst (Int32.to_int i)
-          | Expr (Block (j, _, _)) ->
+          | Expr (Block (j, _, _, _)) ->
               if Var.ISet.mem info.info_possibly_mutable x then Unknown else CTag j
           | Expr (Constant (Tuple (j, _, _))) -> CTag j
           | _ -> Unknown)
@@ -366,7 +366,7 @@ let the_cond_of info x =
             | NativeString _
             | Float_array _
             | Int64 _ )) -> Non_zero
-      | Expr (Block (_, _, _)) -> Non_zero
+      | Expr (Block (_, _, _, _)) -> Non_zero
       | Expr (Field _ | Closure _ | Prim _ | Apply _ | Special _) -> Unknown
       | Param | Phi _ -> Unknown)
     Unknown
@@ -414,7 +414,7 @@ let rec do_not_raise pc visited blocks =
         | Array_set (_, _, _) | Offset_ref (_, _) | Set_field (_, _, _) | Assign _ -> ()
         | Let (_, e) -> (
             match e with
-            | Block (_, _, _) | Field (_, _) | Constant _ | Closure _ -> ()
+            | Block (_, _, _, _) | Field (_, _) | Constant _ | Closure _ -> ()
             | Apply _ -> raise May_raise
             | Special _ -> ()
             | Prim (Extern name, _) when Primitive.is_pure name -> ()
diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml
index 3d3833999..b23fc060b 100644
--- a/compiler/lib/flow.ml
+++ b/compiler/lib/flow.ml
@@ -93,7 +93,7 @@ let expr_deps blocks vars deps defs x e =
   | Closure (l, cont) ->
       List.iter l ~f:(fun x -> add_param_def vars defs x);
       cont_deps blocks vars deps defs cont
-  | Block (_, a, _) -> Array.iter a ~f:(fun y -> add_dep deps x y)
+  | Block (_, a, _, _) -> Array.iter a ~f:(fun y -> add_dep deps x y)
   | Field (y, _) -> add_dep deps x y
 
 let program_deps { blocks; _ } =
@@ -143,7 +143,7 @@ let propagate1 deps defs st x =
           var_set_lift
             (fun z ->
               match defs.(Var.idx z) with
-              | Expr (Block (_, a, _)) when n < Array.length a ->
+              | Expr (Block (_, a, _, _)) when n < Array.length a ->
                   let t = a.(n) in
                   add_dep deps x t;
                   Var.Tbl.get st t
@@ -185,7 +185,7 @@ let rec block_escape st x =
         Code.Var.ISet.add st.may_escape y;
         Code.Var.ISet.add st.possibly_mutable y;
         match st.defs.(Var.idx y) with
-        | Expr (Block (_, l, _)) -> Array.iter l ~f:(fun z -> block_escape st z)
+        | Expr (Block (_, l, _, _)) -> Array.iter l ~f:(fun z -> block_escape st z)
         | _ -> ()))
     (Var.Tbl.get st.known_origins x)
 
@@ -217,15 +217,16 @@ let expr_escape st _x e =
             | Pv v, `Shallow_const -> (
                 match st.defs.(Var.idx v) with
                 | Expr (Constant (Tuple _)) -> ()
-                | Expr (Block (_, a, _)) -> Array.iter a ~f:(fun x -> block_escape st x)
+                | Expr (Block (_, a, _, _)) ->
+                    Array.iter a ~f:(fun x -> block_escape st x)
                 | _ -> block_escape st v)
             | Pv v, `Object_literal -> (
                 match st.defs.(Var.idx v) with
                 | Expr (Constant (Tuple _)) -> ()
-                | Expr (Block (_, a, _)) ->
+                | Expr (Block (_, a, _, _)) ->
                     Array.iter a ~f:(fun x ->
                         match st.defs.(Var.idx x) with
-                        | Expr (Block (_, [| _k; v |], _)) -> block_escape st v
+                        | Expr (Block (_, [| _k; v |], _, _)) -> block_escape st v
                         | Expr (Constant _) -> ()
                         | _ -> block_escape st x)
                 | _ -> block_escape st v)
@@ -273,7 +274,7 @@ let propagate2 ?(skip_param = false) defs known_origins possibly_mutable st x =
           || Var.Set.exists
                (fun z ->
                  match defs.(Var.idx z) with
-                 | Expr (Block (_, a, _)) ->
+                 | Expr (Block (_, a, _, _)) ->
                      n >= Array.length a
                      || Var.ISet.mem possibly_mutable z
                      || Var.Tbl.get st a.(n)
@@ -368,7 +369,7 @@ let direct_approx info x =
           then None
           else
             match info.info_defs.(Var.idx z) with
-            | Expr (Block (_, a, _)) when n < Array.length a -> Some a.(n)
+            | Expr (Block (_, a, _, _)) when n < Array.length a -> Some a.(n)
             | _ -> None)
         None
         (fun u v ->
diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml
index feeacef21..ef964ee23 100644
--- a/compiler/lib/freevars.ml
+++ b/compiler/lib/freevars.ml
@@ -33,7 +33,7 @@ let iter_expr_free_vars f e =
   | Apply { f = x; args; _ } ->
       f x;
       List.iter ~f args
-  | Block (_, a, _) -> Array.iter ~f a
+  | Block (_, a, _, _) -> Array.iter ~f a
   | Field (x, _) -> f x
   | Closure _ -> ()
   | Special _ -> ()
diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml
index 4413d2904..1426ace70 100644
--- a/compiler/lib/generate.ml
+++ b/compiler/lib/generate.ml
@@ -1222,7 +1222,7 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
       let prop = or_p prop prop' in
       let e = apply_fun ctx f args exact cps loc in
       (e, prop, queue), []
-  | Block (tag, a, array_or_not) ->
+  | Block (tag, a, array_or_not, _mut) ->
       let contents, prop, queue =
         List.fold_right
           ~f:(fun x (args, prop, queue) ->
diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml
index f32d0a68c..9a638169a 100644
--- a/compiler/lib/generate_closure.ml
+++ b/compiler/lib/generate_closure.ml
@@ -377,7 +377,7 @@ let rewrite_mutable
           ; body =
               closures_intern
               @ proj
-              @ [ Let (b, Block (0, Array.of_list new_xs, NotArray)), noloc ]
+              @ [ Let (b, Block (0, Array.of_list new_xs, NotArray, Immutable)), noloc ]
           ; branch = Return b, noloc
           }
         in
diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml
index 4742ad589..d6541cb41 100644
--- a/compiler/lib/global_flow.ml
+++ b/compiler/lib/global_flow.ml
@@ -201,15 +201,15 @@ let expr_deps blocks st x e =
             | Pv v, `Const -> do_escape st Escape_constant v
             | Pv v, `Shallow_const -> (
                 match st.defs.(Var.idx v) with
-                | Expr (Block (_, a, _)) ->
+                | Expr (Block (_, a, _, _)) ->
                     Array.iter a ~f:(fun x -> do_escape st Escape x)
                 | _ -> do_escape st Escape v)
             | Pv v, `Object_literal -> (
                 match st.defs.(Var.idx v) with
-                | Expr (Block (_, a, _)) ->
+                | Expr (Block (_, a, _, _)) ->
                     Array.iter a ~f:(fun x ->
                         match st.defs.(Var.idx x) with
-                        | Expr (Block (_, [| _k; v |], _)) -> do_escape st Escape v
+                        | Expr (Block (_, [| _k; v |], _, _)) -> do_escape st Escape v
                         | _ -> do_escape st Escape x)
                 | _ -> do_escape st Escape v)
             | Pv v, `Mutable -> do_escape st Escape v);
@@ -323,7 +323,7 @@ module Domain = struct
     then (
       st.may_escape.(idx) <- s;
       match st.defs.(idx) with
-      | Expr (Block (_, a, _)) ->
+      | Expr (Block (_, a, _, _)) ->
           Array.iter ~f:(fun y -> variable_escape ~update ~st ~approx s y) a;
           if Poly.equal s Escape
           then (
@@ -407,7 +407,7 @@ let propagate st ~update approx x =
                 ~approx
                 (fun z ->
                   match st.defs.(Var.idx z) with
-                  | Expr (Block (t, a, _))
+                  | Expr (Block (t, a, _, _))
                     when n < Array.length a
                          &&
                          match tags with
@@ -441,7 +441,7 @@ let propagate st ~update approx x =
                   ~others
                   (fun z ->
                     match st.defs.(Var.idx z) with
-                    | Expr (Block (_, lst, _)) ->
+                    | Expr (Block (_, lst, _, _)) ->
                         Array.iter ~f:(fun t -> add_dep st x t) lst;
                         let a =
                           Array.fold_left
diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml
index e23bcf9d6..9913505ca 100644
--- a/compiler/lib/inline.ml
+++ b/compiler/lib/inline.ml
@@ -169,8 +169,8 @@ let simple blocks cont mapping =
           | Prim (prim, args) ->
               `Exp (Prim (prim, List.map args ~f:(map_prim_arg mapping)))
           | Special _ -> `Exp exp
-          | Block (tag, args, aon) ->
-              `Exp (Block (tag, Array.map args ~f:(map_var mapping), aon))
+          | Block (tag, args, aon, mut) ->
+              `Exp (Block (tag, Array.map args ~f:(map_var mapping), aon, mut))
           | Field (x, i) -> `Exp (Field (map_var mapping x, i))
           | Closure _ -> `Fail
           | Constant _ -> `Fail
diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml
index 358303f99..609573981 100644
--- a/compiler/lib/parse_bytecode.ml
+++ b/compiler/lib/parse_bytecode.ml
@@ -1346,26 +1346,42 @@ and compile infos pc state instrs =
         let x, state = State.fresh_var state loc in
 
         if debug_parser () then Format.printf "%a = ATOM(0)@." Var.print x;
-        compile infos (pc + 1) state ((Let (x, Block (0, [||], Unknown)), loc) :: instrs)
+        compile
+          infos
+          (pc + 1)
+          state
+          ((Let (x, Block (0, [||], Unknown, Maybe_mutable)), loc) :: instrs)
     | ATOM ->
         let i = getu code (pc + 1) in
         let x, state = State.fresh_var state loc in
 
         if debug_parser () then Format.printf "%a = ATOM(%d)@." Var.print x i;
-        compile infos (pc + 2) state ((Let (x, Block (i, [||], NotArray)), loc) :: instrs)
+        compile
+          infos
+          (pc + 2)
+          state
+          ((Let (x, Block (i, [||], Unknown, Maybe_mutable)), loc) :: instrs)
     | PUSHATOM0 ->
         let state = State.push state loc in
         let x, state = State.fresh_var state loc in
 
         if debug_parser () then Format.printf "%a = ATOM(0)@." Var.print x;
-        compile infos (pc + 1) state ((Let (x, Block (0, [||], Unknown)), loc) :: instrs)
+        compile
+          infos
+          (pc + 1)
+          state
+          ((Let (x, Block (0, [||], Unknown, Maybe_mutable)), loc) :: instrs)
     | PUSHATOM ->
         let state = State.push state loc in
 
         let i = getu code (pc + 1) in
         let x, state = State.fresh_var state loc in
         if debug_parser () then Format.printf "%a = ATOM(%d)@." Var.print x i;
-        compile infos (pc + 2) state ((Let (x, Block (i, [||], NotArray)), loc) :: instrs)
+        compile
+          infos
+          (pc + 2)
+          state
+          ((Let (x, Block (i, [||], Unknown, Maybe_mutable)), loc) :: instrs)
     | MAKEBLOCK ->
         let size = getu code (pc + 1) in
         let tag = getu code (pc + 2) in
@@ -1384,7 +1400,12 @@ and compile infos pc state instrs =
           infos
           (pc + 3)
           state
-          ((Let (x, Block (tag, Array.of_list (List.map ~f:fst contents), Unknown)), loc)
+          (( Let
+               ( x
+               , Block
+                   (tag, Array.of_list (List.map ~f:fst contents), Unknown, Maybe_mutable)
+               )
+           , loc )
           :: instrs)
     | MAKEBLOCK1 ->
         let tag = getu code (pc + 1) in
@@ -1396,7 +1417,7 @@ and compile infos pc state instrs =
           infos
           (pc + 2)
           state
-          ((Let (x, Block (tag, [| y |], NotArray)), loc) :: instrs)
+          ((Let (x, Block (tag, [| y |], Unknown, Maybe_mutable)), loc) :: instrs)
     | MAKEBLOCK2 ->
         let tag = getu code (pc + 1) in
         let y, _ = State.accu state in
@@ -1410,7 +1431,7 @@ and compile infos pc state instrs =
           infos
           (pc + 2)
           (State.pop 1 state)
-          ((Let (x, Block (tag, [| y; z |], NotArray)), loc) :: instrs)
+          ((Let (x, Block (tag, [| y; z |], Unknown, Maybe_mutable)), loc) :: instrs)
     | MAKEBLOCK3 ->
         let tag = getu code (pc + 1) in
         let y, _ = State.accu state in
@@ -1434,7 +1455,7 @@ and compile infos pc state instrs =
           infos
           (pc + 2)
           (State.pop 2 state)
-          ((Let (x, Block (tag, [| y; z; t |], NotArray)), loc) :: instrs)
+          ((Let (x, Block (tag, [| y; z; t |], Unknown, Maybe_mutable)), loc) :: instrs)
     | MAKEFLOATBLOCK ->
         let size = getu code (pc + 1) in
         let state = State.push state loc in
@@ -1452,7 +1473,12 @@ and compile infos pc state instrs =
           infos
           (pc + 2)
           state
-          ((Let (x, Block (254, Array.of_list (List.map ~f:fst contents), Unknown)), loc)
+          (( Let
+               ( x
+               , Block
+                   (254, Array.of_list (List.map ~f:fst contents), Unknown, Maybe_mutable)
+               )
+           , loc )
           :: instrs)
     | GETFIELD0 ->
         let y, _ = State.accu state in
@@ -2470,7 +2496,7 @@ let override_global =
             let init_mod = Var.fresh_n "init_mod" in
             let update_mod = Var.fresh_n "update_mod" in
             ( x
-            , (Let (x, Block (0, [| init_mod; update_mod |], NotArray)), noloc)
+            , (Let (x, Block (0, [| init_mod; update_mod |], NotArray, Immutable)), noloc)
               :: ( Let (init_mod, Special (Alias_prim "caml_CamlinternalMod_init_mod"))
                  , noloc )
               :: ( Let (update_mod, Special (Alias_prim "caml_CamlinternalMod_update_mod"))
@@ -3050,7 +3076,7 @@ let predefined_exceptions ~target =
                          Regular
                        , Int32.of_int (-index - 1) )) )
             , noloc )
-          ; Let (exn, Block (248, [| v_name; v_index |], NotArray)), noloc
+          ; Let (exn, Block (248, [| v_name; v_index |], NotArray, Immutable)), noloc
           ; ( Let
                 ( Var.fresh ()
                 , Prim
diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml
index 65d7b3960..965c37fe3 100644
--- a/compiler/lib/phisimpl.ml
+++ b/compiler/lib/phisimpl.ml
@@ -52,7 +52,7 @@ let expr_deps blocks vars deps defs x e =
   match e with
   | Constant _ | Apply _ | Prim _ | Special _ -> ()
   | Closure (_, cont) -> cont_deps blocks vars deps defs cont
-  | Block (_, a, _) -> Array.iter a ~f:(fun y -> add_dep deps x y)
+  | Block (_, a, _, _) -> Array.iter a ~f:(fun y -> add_dep deps x y)
   | Field (y, _) -> add_dep deps x y
 
 let program_deps { blocks; _ } =
diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml
index 808c6d62a..d3a376bee 100644
--- a/compiler/lib/specialize_js.ml
+++ b/compiler/lib/specialize_js.ml
@@ -55,13 +55,13 @@ let specialize_instr ~target info i =
       | None -> i)
   | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])), _ -> (
       match the_def_of info a with
-      | Some (Block (_, a, _)) ->
+      | Some (Block (_, a, _, _)) ->
           let a = Array.map a ~f:(fun x -> Pv x) in
           Let (x, Prim (Extern "%caml_js_opt_call", f :: o :: Array.to_list a))
       | _ -> i)
   | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])), _ -> (
       match the_def_of info a with
-      | Some (Block (_, a, _)) ->
+      | Some (Block (_, a, _, _)) ->
           let a = Array.map a ~f:(fun x -> Pv x) in
           Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a))
       | _ -> i)
@@ -69,7 +69,7 @@ let specialize_instr ~target info i =
       match the_string_of info m with
       | Some m when Javascript.is_ident m -> (
           match the_def_of info a with
-          | Some (Block (_, a, _)) ->
+          | Some (Block (_, a, _, _)) ->
               let a = Array.map a ~f:(fun x -> Pv x) in
               Let
                 ( x
@@ -82,7 +82,7 @@ let specialize_instr ~target info i =
       | _ -> i)
   | Let (x, Prim (Extern "caml_js_new", [ c; a ])), _ -> (
       match the_def_of info a with
-      | Some (Block (_, a, _)) ->
+      | Some (Block (_, a, _, _)) ->
           let a = Array.map a ~f:(fun x -> Pv x) in
           Let (x, Prim (Extern "%caml_js_opt_new", c :: Array.to_list a))
       | _ -> i)
@@ -90,13 +90,13 @@ let specialize_instr ~target info i =
       try
         let a =
           match the_def_of info a with
-          | Some (Block (_, a, _)) -> a
+          | Some (Block (_, a, _, _)) -> a
           | _ -> raise Exit
         in
         let a =
           Array.map a ~f:(fun x ->
               match the_def_of info (Pv x) with
-              | Some (Block (_, [| k; v |], _)) ->
+              | Some (Block (_, [| k; v |], _, _)) ->
                   let k =
                     match the_string_of info (Pv k) with
                     | Some s when String.is_valid_utf_8 s ->
diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml
index 5f438c941..dc3404fa2 100644
--- a/compiler/lib/subst.ml
+++ b/compiler/lib/subst.ml
@@ -28,7 +28,7 @@ let expr s e =
   | Constant _ -> e
   | Apply { f; args; exact } ->
       Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact }
-  | Block (n, a, k) -> Block (n, Array.map a ~f:(fun x -> s x), k)
+  | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut)
   | Field (x, n) -> Field (s x, n)
   | Closure (l, pc) -> Closure (l, subst_cont s pc)
   | Special _ -> e
diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml
index 282d6b91a..3b8267add 100644
--- a/compiler/lib/wasm/wa_generate.ml
+++ b/compiler/lib/wasm/wa_generate.ml
@@ -154,7 +154,7 @@ module Generate (Target : Wa_target_sig.S) = struct
         let* closure = load f in
         Stack.kill_variables stack_ctx;
         return (W.Call (apply, args @ [ closure ]))
-    | Block (tag, a, _) ->
+    | Block (tag, a, _, _) ->
         Memory.allocate stack_ctx x ~tag (List.map ~f:(fun x -> `Var x) (Array.to_list a))
     | Field (x, n) -> Memory.field (load x) n
     | Closure _ ->
diff --git a/compiler/lib/wasm/wa_globalize.ml b/compiler/lib/wasm/wa_globalize.ml
index e27c078bd..deaed96b3 100644
--- a/compiler/lib/wasm/wa_globalize.ml
+++ b/compiler/lib/wasm/wa_globalize.ml
@@ -73,7 +73,7 @@ let traverse_expression x e st =
   match e with
   | Code.Apply { f; args; _ } ->
       st |> use f |> fun st -> List.fold_left ~f:(fun st x -> use x st) ~init:st args
-  | Block (_, a, _) -> Array.fold_right ~f:use a ~init:st
+  | Block (_, a, _, _) -> Array.fold_right ~f:use a ~init:st
   | Field (x, _) -> st |> use x
   | Closure _ ->
       List.fold_left
diff --git a/compiler/lib/wasm/wa_liveness.ml b/compiler/lib/wasm/wa_liveness.ml
index 5b2d39cf7..796cf36b4 100644
--- a/compiler/lib/wasm/wa_liveness.ml
+++ b/compiler/lib/wasm/wa_liveness.ml
@@ -107,7 +107,7 @@ let add_array ~ctx s a = Array.fold_left ~f:(fun s x -> add_var ~ctx s x) ~init:
 let expr_used ~context ~closures ~ctx x e s =
   match e with
   | Apply { f; args; _ } -> add_list ~ctx s (f :: args)
-  | Block (_, a, _) -> add_array ~ctx s a
+  | Block (_, a, _, _) -> add_array ~ctx s a
   | Prim (_, l) -> add_prim_args ~ctx s l
   | Closure _ -> add_list ~ctx s (function_free_variables ~context ~closures x)
   | Constant _ | Special _ -> s
diff --git a/compiler/lib/wasm/wa_spilling.ml b/compiler/lib/wasm/wa_spilling.ml
index 3ccb0a5c0..9c7c3e661 100644
--- a/compiler/lib/wasm/wa_spilling.ml
+++ b/compiler/lib/wasm/wa_spilling.ml
@@ -291,7 +291,7 @@ let spilled_variables
                         ~f:(fun reloaded x -> check_spilled ~ctx loaded x reloaded)
                         (f :: args)
                         ~init:Var.Set.empty
-                  | Block (_, l, _) ->
+                  | Block (_, l, _, _) ->
                       Array.fold_left
                         ~f:(fun reloaded x -> check_spilled ~ctx loaded' x reloaded)
                         l

From e2c98ec840673ee0f716fdf912c72638c54481f4 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 27 Jul 2023 18:07:37 +0200
Subject: [PATCH 08/28] Compiler: lower level switch

---
 compiler/lib/code.ml                       |  23 +-
 compiler/lib/code.mli                      |   2 +-
 compiler/lib/deadcode.ml                   |  16 +-
 compiler/lib/effects.ml                    |   9 +-
 compiler/lib/eval.ml                       |  94 ++++---
 compiler/lib/flow.ml                       |   5 +-
 compiler/lib/freevars.ml                   |   5 +-
 compiler/lib/generate.ml                   |  61 +----
 compiler/lib/global_flow.ml                |  43 +--
 compiler/lib/inline.ml                     |   5 +-
 compiler/lib/parse_bytecode.ml             |  71 +++--
 compiler/lib/phisimpl.ml                   |   5 +-
 compiler/lib/subst.ml                      |   6 +-
 compiler/lib/tailcall.ml                   |   3 +-
 compiler/lib/wasm/wa_core_target.ml        |   4 +-
 compiler/lib/wasm/wa_gc_target.ml          |   2 +-
 compiler/lib/wasm/wa_generate.ml           |  20 +-
 compiler/lib/wasm/wa_liveness.ml           |   8 +-
 compiler/lib/wasm/wa_spilling.ml           |   8 +-
 compiler/tests-compiler/static_eval.ml     |  44 +++
 compiler/tests-full/stdlib.cma.expected.js | 294 +++++++++++----------
 21 files changed, 371 insertions(+), 357 deletions(-)

diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml
index 3fda9f32a..c4b47bd19 100644
--- a/compiler/lib/code.ml
+++ b/compiler/lib/code.ml
@@ -368,7 +368,7 @@ type last =
   | Stop
   | Branch of cont
   | Cond of Var.t * cont * cont
-  | Switch of Var.t * cont array * cont array
+  | Switch of Var.t * cont array
   | Pushtrap of cont * Var.t * cont
   | Poptrap of cont
 
@@ -533,10 +533,9 @@ module Print = struct
     | Branch c -> Format.fprintf f "branch %a" cont c
     | Cond (x, cont1, cont2) ->
         Format.fprintf f "if %a then %a else %a" Var.print x cont cont1 cont cont2
-    | Switch (x, a1, a2) ->
+    | Switch (x, a1) ->
         Format.fprintf f "switch %a {" Var.print x;
         Array.iteri a1 ~f:(fun i c -> Format.fprintf f "int %d -> %a; " i cont c);
-        Array.iteri a2 ~f:(fun i c -> Format.fprintf f "tag %d -> %a; " i cont c);
         Format.fprintf f "}"
     | Pushtrap (cont1, x, cont2) ->
         Format.fprintf f "pushtrap %a handler %a => %a" cont cont1 Var.print x cont cont2
@@ -632,19 +631,13 @@ let poptraps blocks pc =
           let acc, visited = loop blocks pc1 visited depth acc in
           let acc, visited = loop blocks pc2 visited depth acc in
           acc, visited
-      | Switch (_, a1, a2) ->
+      | Switch (_, a1) ->
           let acc, visited =
             Array.fold_right
               ~init:(acc, visited)
               ~f:(fun (pc, _) (acc, visited) -> loop blocks pc visited depth acc)
               a1
           in
-          let acc, visited =
-            Array.fold_right
-              ~init:(acc, visited)
-              ~f:(fun (pc, _) (acc, visited) -> loop blocks pc visited depth acc)
-              a2
-          in
           acc, visited
   in
   loop blocks pc Addr.Set.empty 0 Addr.Set.empty |> fst
@@ -662,9 +655,8 @@ let fold_children blocks pc f accu =
       let accu = f pc1 accu in
       let accu = f pc2 accu in
       accu
-  | Switch (_, a1, a2) ->
+  | Switch (_, a1) ->
       let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a1 in
-      let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a2 in
       accu
 
 let fold_children_skip_try_body blocks pc f accu =
@@ -680,9 +672,8 @@ let fold_children_skip_try_body blocks pc f accu =
       let accu = f pc1 accu in
       let accu = f pc2 accu in
       accu
-  | Switch (_, a1, a2) ->
+  | Switch (_, a1) ->
       let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a1 in
-      let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a2 in
       accu
 
 type 'c fold_blocs = block Addr.Map.t -> Addr.t -> (Addr.t -> 'c -> 'c) -> 'c -> 'c
@@ -828,9 +819,7 @@ let invariant { blocks; start; _ } =
       | Cond (_x, cont1, cont2) ->
           check_cont cont1;
           check_cont cont2
-      | Switch (_x, a1, a2) ->
-          Array.iteri a1 ~f:(fun _ cont -> check_cont cont);
-          Array.iteri a2 ~f:(fun _ cont -> check_cont cont)
+      | Switch (_x, a1) -> Array.iteri a1 ~f:(fun _ cont -> check_cont cont)
       | Pushtrap (cont1, _x, cont2) ->
           check_cont cont1;
           check_cont cont2
diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli
index 67bd0d4de..8a22b98bf 100644
--- a/compiler/lib/code.mli
+++ b/compiler/lib/code.mli
@@ -215,7 +215,7 @@ type last =
   | Stop
   | Branch of cont
   | Cond of Var.t * cont * cont
-  | Switch of Var.t * cont array * cont array
+  | Switch of Var.t * cont array
   | Pushtrap of cont * Var.t * cont
   | Poptrap of cont
 
diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml
index 0dd662213..ae182423f 100644
--- a/compiler/lib/deadcode.ml
+++ b/compiler/lib/deadcode.ml
@@ -98,10 +98,9 @@ and mark_reachable st pc =
         mark_var st x;
         mark_cont_reachable st cont1;
         mark_cont_reachable st cont2
-    | Switch (x, a1, a2) ->
+    | Switch (x, a1) ->
         mark_var st x;
-        Array.iter a1 ~f:(fun cont -> mark_cont_reachable st cont);
-        Array.iter a2 ~f:(fun cont -> mark_cont_reachable st cont)
+        Array.iter a1 ~f:(fun cont -> mark_cont_reachable st cont)
     | Pushtrap (cont1, _, cont2) ->
         mark_cont_reachable st cont1;
         mark_cont_reachable st cont2)
@@ -137,11 +136,8 @@ let filter_live_last blocks st (l, loc) =
     | Branch cont -> Branch (filter_cont blocks st cont)
     | Cond (x, cont1, cont2) ->
         Cond (x, filter_cont blocks st cont1, filter_cont blocks st cont2)
-    | Switch (x, a1, a2) ->
-        Switch
-          ( x
-          , Array.map a1 ~f:(fun cont -> filter_cont blocks st cont)
-          , Array.map a2 ~f:(fun cont -> filter_cont blocks st cont) )
+    | Switch (x, a1) ->
+        Switch (x, Array.map a1 ~f:(fun cont -> filter_cont blocks st cont))
     | Pushtrap (cont1, x, cont2) ->
         Pushtrap (filter_cont blocks st cont1, x, filter_cont blocks st cont2)
     | Poptrap cont -> Poptrap (filter_cont blocks st cont)
@@ -201,9 +197,7 @@ let f ({ blocks; _ } as p : Code.program) =
       | Cond (_, cont1, cont2) ->
           add_cont_dep blocks defs cont1;
           add_cont_dep blocks defs cont2
-      | Switch (_, a1, a2) ->
-          Array.iter a1 ~f:(fun cont -> add_cont_dep blocks defs cont);
-          Array.iter a2 ~f:(fun cont -> add_cont_dep blocks defs cont)
+      | Switch (_, a1) -> Array.iter a1 ~f:(fun cont -> add_cont_dep blocks defs cont)
       | Pushtrap (cont, _, cont_h) ->
           add_cont_dep blocks defs cont_h;
           add_cont_dep blocks defs cont
diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml
index 6803085d8..26054b1f0 100644
--- a/compiler/lib/effects.ml
+++ b/compiler/lib/effects.ml
@@ -431,13 +431,11 @@ let cps_last ~st ~alloc_jump_closures pc ((last, last_loc) : last * loc) ~k :
             , cps_jump_cont ~st ~src:pc cont1 last_loc
             , cps_jump_cont ~st ~src:pc cont2 last_loc )
         , last_loc ) )
-  | Switch (x, c1, c2) ->
+  | Switch (x, c1) ->
       (* To avoid code duplication during JavaScript generation, we need
          to create a single block per continuation *)
       let cps_jump_cont = Fun.memoize (fun x -> cps_jump_cont ~st ~src:pc x last_loc) in
-      ( alloc_jump_closures
-      , ( Switch (x, Array.map c1 ~f:cps_jump_cont, Array.map c2 ~f:cps_jump_cont)
-        , last_loc ) )
+      alloc_jump_closures, (Switch (x, Array.map c1 ~f:cps_jump_cont), last_loc)
   | Pushtrap (body_cont, exn, ((handler_pc, _) as handler_cont)) -> (
       assert (Hashtbl.mem st.is_continuation handler_pc);
       match Addr.Set.mem handler_pc st.blocks_to_transform with
@@ -929,8 +927,7 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program =
                match branch with
                | Branch cont -> Branch (resolve cont)
                | Cond (x, cont1, cont2) -> Cond (x, resolve cont1, resolve cont2)
-               | Switch (x, a1, a2) ->
-                   Switch (x, Array.map ~f:resolve a1, Array.map ~f:resolve a2)
+               | Switch (x, a1) -> Switch (x, Array.map ~f:resolve a1)
                | Pushtrap (cont1, x, cont2) -> Pushtrap (resolve cont1, x, resolve cont2)
                | Poptrap cont -> Poptrap (resolve cont)
                | Return _ | Raise _ | Stop -> branch
diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml
index bb637bdfb..5a2f5fb93 100644
--- a/compiler/lib/eval.ml
+++ b/compiler/lib/eval.ml
@@ -216,6 +216,46 @@ let is_int ~target info x =
       | `Wasm -> N)
   | Pc _ -> N
 
+let the_tag_of info x get =
+  match x with
+  | Pv x ->
+      get_approx
+        info
+        (fun x ->
+          match info.info_defs.(Var.idx x) with
+          | Expr (Block (j, _, _, _)) ->
+              if Var.ISet.mem info.info_possibly_mutable x then None else get j
+          | Expr (Constant (Tuple (j, _, _))) -> get j
+          | _ -> None)
+        None
+        (fun u v ->
+          match u, v with
+          | Some i, Some j when Poly.(i = j) -> u
+          | _ -> None)
+        x
+  | Pc (Tuple (j, _, _)) -> get j
+  | _ -> None
+
+let the_cont_of info x (a : cont array) =
+  (* The value of [x] might be meaningless when we're inside a dead code.
+     The proper fix would be to remove the deadcode entirely.
+     Meanwhile, add guards to prevent Invalid_argument("index out of bounds")
+     see https://github.com/ocsigen/js_of_ocaml/issues/485 *)
+  let get i = if i >= 0 && i < Array.length a then Some a.(i) else None in
+  get_approx
+    info
+    (fun x ->
+      match info.info_defs.(Var.idx x) with
+      | Expr (Prim (Extern "%direct_obj_tag", [ b ])) -> the_tag_of info b get
+      | Expr (Constant (Int (_, j))) -> get (Int32.to_int j)
+      | _ -> None)
+    None
+    (fun u v ->
+      match u, v with
+      | Some i, Some j when Poly.(i = j) -> u
+      | _ -> None)
+    x
+
 let eval_instr ~target info ((x, loc) as i) =
   match x with
   | Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> (
@@ -265,6 +305,13 @@ let eval_instr ~target info ((x, loc) as i) =
           let c = Constant (Int (Regular, b)) in
           Flow.update_def info x c;
           [ Let (x, c), loc ])
+  | Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> (
+      match the_tag_of info y (fun x -> Some x) with
+      | Some tag ->
+          let c = Constant (Int (Regular, Int32.of_int tag)) in
+          Flow.update_def info x c;
+          [ Let (x, c), loc ]
+      | None -> [ i ])
   | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) ->
       let jsoo = Code.Var.fresh () in
       [ ( Let
@@ -318,34 +365,6 @@ let eval_instr ~target info ((x, loc) as i) =
           ])
   | _ -> [ i ]
 
-type case_of =
-  | CConst of int
-  | CTag of int
-  | Unknown
-
-let the_case_of info x =
-  match x with
-  | Pv x ->
-      get_approx
-        info
-        (fun x ->
-          match info.info_defs.(Var.idx x) with
-          | Expr (Constant (Int (_, i))) -> CConst (Int32.to_int i)
-          | Expr (Block (j, _, _, _)) ->
-              if Var.ISet.mem info.info_possibly_mutable x then Unknown else CTag j
-          | Expr (Constant (Tuple (j, _, _))) -> CTag j
-          | _ -> Unknown)
-        Unknown
-        (fun u v ->
-          match u, v with
-          | CTag i, CTag j when i = j -> u
-          | CConst i, CConst j when i = j -> u
-          | _ -> Unknown)
-        x
-  | Pc (Int (_, i)) -> CConst (Int32.to_int i)
-  | Pc (Tuple (j, _, _)) -> CTag j
-  | _ -> Unknown
-
 type cond_of =
   | Zero
   | Non_zero
@@ -388,15 +407,10 @@ let eval_branch info (l, loc) =
           | Zero -> Branch ffalse
           | Non_zero -> Branch ftrue
           | Unknown -> b)
-    | Switch (x, const, tags) as b -> (
-        (* [the_case_of info (Pv x)] might be meaningless when we're inside a dead code.
-           The proper fix would be to remove the deadcode entirely.
-           Meanwhile, add guards to prevent Invalid_argument("index out of bounds")
-           see https://github.com/ocsigen/js_of_ocaml/issues/485 *)
-        match the_case_of info (Pv x) with
-        | CConst j when j >= 0 && j < Array.length const -> Branch const.(j)
-        | CTag j when j >= 0 && j < Array.length tags -> Branch tags.(j)
-        | CConst _ | CTag _ | Unknown -> b)
+    | Switch (x, a) as b -> (
+        match the_cont_of info x a with
+        | Some cont -> Branch cont
+        | None -> b)
     | _ as b -> b
   in
   l, loc
@@ -428,15 +442,11 @@ let rec do_not_raise pc visited blocks =
         let visited = do_not_raise pc1 visited blocks in
         let visited = do_not_raise pc2 visited blocks in
         visited
-    | Switch (_, a1, a2) ->
+    | Switch (_, a1) ->
         let visited =
           Array.fold_left a1 ~init:visited ~f:(fun visited (pc, _) ->
               do_not_raise pc visited blocks)
         in
-        let visited =
-          Array.fold_left a2 ~init:visited ~f:(fun visited (pc, _) ->
-              do_not_raise pc visited blocks)
-        in
         visited
     | Pushtrap _ -> raise May_raise
 
diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml
index b23fc060b..ebf5773f5 100644
--- a/compiler/lib/flow.ml
+++ b/compiler/lib/flow.ml
@@ -119,9 +119,8 @@ let program_deps { blocks; _ } =
       | Cond (_, cont1, cont2) ->
           cont_deps blocks vars deps defs cont1;
           cont_deps blocks vars deps defs cont2
-      | Switch (_, a1, a2) ->
-          Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont);
-          Array.iter a2 ~f:(fun cont -> cont_deps blocks vars deps defs cont)
+      | Switch (_, a1) ->
+          Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont)
       | Pushtrap (cont, x, cont_h) ->
           add_param_def vars defs x;
           cont_deps blocks vars deps defs cont_h;
diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml
index ef964ee23..fdeaa8321 100644
--- a/compiler/lib/freevars.ml
+++ b/compiler/lib/freevars.ml
@@ -65,10 +65,9 @@ let iter_last_free_var f l =
       f x;
       iter_cont_free_vars f cont1;
       iter_cont_free_vars f cont2
-  | Switch (x, a1, a2) ->
+  | Switch (x, a1) ->
       f x;
-      Array.iter a1 ~f:(fun c -> iter_cont_free_vars f c);
-      Array.iter a2 ~f:(fun c -> iter_cont_free_vars f c)
+      Array.iter a1 ~f:(fun c -> iter_cont_free_vars f c)
   | Pushtrap (cont1, _, cont2) ->
       iter_cont_free_vars f cont1;
       iter_cont_free_vars f cont2
diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml
index 1426ace70..08de2518f 100644
--- a/compiler/lib/generate.ml
+++ b/compiler/lib/generate.ml
@@ -763,10 +763,9 @@ let fold_children blocks pc f accu =
       let accu = f pc2 accu in
       accu
   | Cond (_, cont1, cont2) -> DTree.fold_cont f (DTree.build_if cont1 cont2) accu
-  | Switch (_, a1, a2) ->
-      let a1 = DTree.build_switch a1 and a2 = DTree.build_switch a2 in
+  | Switch (_, a1) ->
+      let a1 = DTree.build_switch a1 in
       let accu = DTree.fold_cont f a1 accu in
-      let accu = DTree.fold_cont f a2 accu in
       accu
 
 let build_graph ctx pc =
@@ -1102,6 +1101,7 @@ let _ =
   register_un_prim_ctx "%caml_format_int_special" `Pure (fun ctx cx loc ->
       let s = J.EBin (J.Plus, str_js_utf8 "", cx) in
       ocaml_string ~ctx ~loc s);
+  register_un_prim "%direct_obj_tag" `Mutator (fun cx _loc -> Mlvalue.Block.tag cx);
   register_bin_prim "caml_array_unsafe_get" `Mutable (fun cx cy _ ->
       Mlvalue.Array.field cx cy);
   register_bin_prim "%int_add" `Pure (fun cx cy _ -> to_int (plus_int cx cy));
@@ -1769,7 +1769,7 @@ and colapse_frontier name st (new_frontier' : Addr.Set.t) interm =
     let branch =
       let cases = Array.of_list (List.map a ~f:(fun pc -> pc, [])) in
       if Array.length cases > 2
-      then Code.Switch (x, cases, [||]), Code.noloc
+      then Code.Switch (x, cases), Code.noloc
       else Code.Cond (x, cases.(1), cases.(0)), Code.noloc
     in
     ( [ J.variable_declaration [ J.V x, (int default, J.N) ], J.N ]
@@ -1850,7 +1850,7 @@ and compile_conditional st queue last loop_stack backs frontier interm =
      | Raise _ -> Format.eprintf "raise;@;"
      | Stop -> Format.eprintf "stop;@;"
      | Cond (x, _, _) -> Format.eprintf "@[<hv 2>cond(%a){@;" Code.Var.print x
-     | Switch (x, _, _) -> Format.eprintf "@[<hv 2>switch(%a){@;" Code.Var.print x);
+     | Switch (x, _) -> Format.eprintf "@[<hv 2>switch(%a){@;" Code.Var.print x);
   let loc = source_location_ctx st.ctx pc in
   let res =
     match last with
@@ -1912,21 +1912,7 @@ and compile_conditional st queue last loop_stack backs frontier interm =
             (DTree.build_if c1 c2)
         in
         never, flush_all queue b
-    | Switch (x, [||], a2) ->
-        let (_px, cx), queue = access_queue queue x in
-        let never, code =
-          compile_decision_tree
-            st
-            loop_stack
-            backs
-            frontier
-            interm
-            loc
-            (Mlvalue.Block.tag cx)
-            (DTree.build_switch a2)
-        in
-        never, flush_all queue code
-    | Switch (x, a1, [||]) ->
+    | Switch (x, a1) ->
         let (_px, cx), queue = access_queue queue x in
         let never, code =
           compile_decision_tree
@@ -1940,41 +1926,6 @@ and compile_conditional st queue last loop_stack backs frontier interm =
             (DTree.build_switch a1)
         in
         never, flush_all queue code
-    | Switch (x, a1, a2) ->
-        (* The variable x is accessed several times, so we can directly
-           refer to it *)
-        let never1, b1 =
-          compile_decision_tree
-            st
-            loop_stack
-            backs
-            frontier
-            interm
-            loc
-            (var x)
-            (DTree.build_switch a1)
-        in
-        let never2, b2 =
-          compile_decision_tree
-            st
-            loop_stack
-            backs
-            frontier
-            interm
-            loc
-            (Mlvalue.Block.tag (var x))
-            (DTree.build_switch a2)
-        in
-        let code =
-          Js_simpl.if_statement
-            (Mlvalue.is_immediate (var x))
-            loc
-            (Js_simpl.block b1)
-            never1
-            (Js_simpl.block b2)
-            never2
-        in
-        never1 && never2, flush_all queue code
   in
   (if debug ()
    then
diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml
index d6541cb41..26b4f45d3 100644
--- a/compiler/lib/global_flow.ml
+++ b/compiler/lib/global_flow.ml
@@ -252,27 +252,34 @@ let program_deps st { blocks; _ } =
       | Cond (x, cont1, cont2) ->
           cont_deps blocks st cont1;
           cont_deps blocks st ~ignore:x cont2
-      | Switch (x, a1, a2) ->
+      | Switch (x, a1) -> (
           Array.iter a1 ~f:(fun cont -> cont_deps blocks st cont);
-          Array.iter a2 ~f:(fun cont -> cont_deps blocks st cont);
-          let h = Hashtbl.create 16 in
-          Array.iteri
-            ~f:(fun i (pc, _) ->
-              Hashtbl.replace h pc (i :: (try Hashtbl.find h pc with Not_found -> [])))
-            a2;
           if not st.fast
           then
-            Hashtbl.iter
-              (fun pc tags ->
-                let block = Addr.Map.find pc blocks in
-                List.iter
-                  ~f:(fun (i, _) ->
-                    match i with
-                    | Let (y, Field (x', _)) when Var.equal x x' ->
-                        Hashtbl.add st.known_cases y tags
-                    | _ -> ())
-                  block.body)
-              h
+            (* looking up the def of x is fine here, because the tag
+               we're looking for is at addr [pc - 2] (see
+               parse_bytecode.ml) and [Addr.Map.iter] iterate in
+               increasing order *)
+            match st.defs.(Code.Var.idx x) with
+            | Expr (Prim (Extern "%direct_obj_tag", [ Pv b ])) ->
+                let h = Hashtbl.create 16 in
+                Array.iteri a1 ~f:(fun i (pc, _) ->
+                    Hashtbl.replace
+                      h
+                      pc
+                      (i :: (try Hashtbl.find h pc with Not_found -> [])));
+                Hashtbl.iter
+                  (fun pc tags ->
+                    let block = Addr.Map.find pc blocks in
+                    List.iter
+                      ~f:(fun (i, _) ->
+                        match i with
+                        | Let (y, Field (x', _)) when Var.equal b x' ->
+                            Hashtbl.add st.known_cases y tags
+                        | _ -> ())
+                      block.body)
+                  h
+            | Expr _ | Phi _ -> ())
       | Pushtrap (cont, x, cont_h) ->
           add_var st x;
           st.defs.(Var.idx x) <- Phi { known = Var.Set.empty; others = true };
diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml
index 9913505ca..40cebb0ad 100644
--- a/compiler/lib/inline.ml
+++ b/compiler/lib/inline.ml
@@ -38,7 +38,7 @@ let optimizable blocks pc _ =
             +
             match fst branch with
             | Cond _ -> 2
-            | Switch (_, a1, a2) -> Array.length a1 + Array.length a2
+            | Switch (_, a1) -> Array.length a1
             | _ -> 0)
       in
       let optimizable =
@@ -113,9 +113,8 @@ let fold_children blocks pc f accu =
       let accu = f pc1 accu in
       let accu = f pc2 accu in
       accu
-  | Switch (_, a1, a2) ->
+  | Switch (_, a1) ->
       let accu = Array.fold_right a1 ~init:accu ~f:(fun (pc, _) accu -> f pc accu) in
-      let accu = Array.fold_right a2 ~init:accu ~f:(fun (pc, _) accu -> f pc accu) in
       accu
 
 let rewrite_closure blocks cont_pc clos_pc =
diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml
index 609573981..9ed5bf484 100644
--- a/compiler/lib/parse_bytecode.ml
+++ b/compiler/lib/parse_bytecode.ml
@@ -870,12 +870,9 @@ let rec compile_block blocks debug_data ~target code pc state =
     | Cond (_, (pc1, _), (pc2, _)) ->
         compile_block blocks debug_data ~target code pc1 state';
         compile_block blocks debug_data ~target code pc2 state'
-    | Switch (_, l1, l2) ->
-        Array.iter l1 ~f:(fun (pc', _) ->
-            compile_block blocks debug_data ~target code pc' state');
-        Array.iter l2 ~f:(fun (pc', _) ->
-            compile_block blocks debug_data ~target code pc' state')
-    | Pushtrap _ | Raise _ | Return _ | Stop -> ())
+    | Switch (_, _) -> ()
+    | Pushtrap _ -> ()
+    | Raise _ | Return _ | Stop -> ())
 
 and compile infos pc state instrs =
   if debug_parser () then State.print state;
@@ -1694,20 +1691,62 @@ and compile infos pc state instrs =
         let x, _ = State.accu state in
         let args = State.stack_vars state in
         instrs, (Cond (x, (pc + 2, args), (pc + offset + 1, args)), loc), state
-    | SWITCH ->
+    | SWITCH -> (
         if debug_parser () then Format.printf "switch ...@.";
-
         let sz = getu code (pc + 1) in
         let x, _ = State.accu state in
         let args = State.stack_vars state in
-        let l = sz land 0xFFFF in
-        let it =
-          Array.init (sz land 0XFFFF) ~f:(fun i -> pc + 2 + gets code (pc + 2 + i), args)
-        in
-        let bt =
-          Array.init (sz lsr 16) ~f:(fun i -> pc + 2 + gets code (pc + 2 + l + i), args)
-        in
-        instrs, (Switch (x, it, bt), loc), state
+        let isize = sz land 0XFFFF in
+        let bsize = sz lsr 16 in
+        let base = pc + 2 in
+        let it = Array.init isize ~f:(fun i -> base + gets code (base + i)) in
+        let bt = Array.init bsize ~f:(fun i -> base + gets code (base + isize + i)) in
+        Array.iter it ~f:(fun pc' ->
+            compile_block infos.blocks infos.debug ~target:infos.target code pc' state);
+        Array.iter bt ~f:(fun pc' ->
+            compile_block infos.blocks infos.debug ~target:infos.target code pc' state);
+        match isize, bsize with
+        | _, 0 -> instrs, (Switch (x, Array.map it ~f:(fun pc -> pc, args)), loc), state
+        | 0, _ ->
+            let x_tag = Var.fresh () in
+            let instrs =
+              (Let (x_tag, Prim (Extern "%direct_obj_tag", [ Pv x ])), loc) :: instrs
+            in
+            instrs, (Switch (x_tag, Array.map bt ~f:(fun pc -> pc, args)), loc), state
+        | _, _ ->
+            let isint_branch = pc + 1 in
+            let isblock_branch = pc + 2 in
+            let () =
+              tagged_blocks := Addr.Set.add isint_branch !tagged_blocks;
+              let i_state = State.start_block isint_branch state in
+              let i_args = State.stack_vars i_state in
+              compiled_blocks :=
+                Addr.Map.add
+                  isint_branch
+                  (i_state, [], (Switch (x, Array.map it ~f:(fun pc -> pc, i_args)), loc))
+                  !compiled_blocks
+            in
+            let () =
+              tagged_blocks := Addr.Set.add isblock_branch !tagged_blocks;
+              let x_tag = Var.fresh () in
+              let b_state = State.start_block isblock_branch state in
+              let b_args = State.stack_vars b_state in
+              let instrs =
+                [ Let (x_tag, Prim (Extern "%direct_obj_tag", [ Pv x ])), loc ]
+              in
+              compiled_blocks :=
+                Addr.Map.add
+                  isblock_branch
+                  ( b_state
+                  , instrs
+                  , (Switch (x_tag, Array.map bt ~f:(fun pc -> pc, b_args)), loc) )
+                  !compiled_blocks
+            in
+            let isint_var = Var.fresh () in
+            let instrs = (Let (isint_var, Prim (IsInt, [ Pv x ])), loc) :: instrs in
+            ( instrs
+            , (Cond (isint_var, (isint_branch, args), (isblock_branch, args)), loc)
+            , state ))
     | BOOLNOT ->
         let y, _ = State.accu state in
         let x, state = State.fresh_var state loc in
diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml
index 965c37fe3..159c8570a 100644
--- a/compiler/lib/phisimpl.ml
+++ b/compiler/lib/phisimpl.ml
@@ -77,9 +77,8 @@ let program_deps { blocks; _ } =
       | Cond (_, cont1, cont2) ->
           cont_deps blocks vars deps defs cont1;
           cont_deps blocks vars deps defs cont2
-      | Switch (_, a1, a2) ->
-          Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont);
-          Array.iter a2 ~f:(fun cont -> cont_deps blocks vars deps defs cont)
+      | Switch (_, a1) ->
+          Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont)
       | Pushtrap (cont, _, cont_h) ->
           cont_deps blocks vars deps defs cont_h;
           cont_deps blocks vars deps defs cont
diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml
index dc3404fa2..4e735576c 100644
--- a/compiler/lib/subst.ml
+++ b/compiler/lib/subst.ml
@@ -59,11 +59,7 @@ let last s (l, loc) =
     | Return x -> Return (s x)
     | Raise (x, k) -> Raise (s x, k)
     | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2)
-    | Switch (x, a1, a2) ->
-        Switch
-          ( s x
-          , Array.map a1 ~f:(fun cont -> subst_cont s cont)
-          , Array.map a2 ~f:(fun cont -> subst_cont s cont) )
+    | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont s cont))
     | Poptrap cont -> Poptrap (subst_cont s cont)
   in
   l, loc
diff --git a/compiler/lib/tailcall.ml b/compiler/lib/tailcall.ml
index 209625abe..84d31c368 100644
--- a/compiler/lib/tailcall.ml
+++ b/compiler/lib/tailcall.ml
@@ -69,9 +69,8 @@ let fold_children blocks pc f accu =
       let accu = f pc1 accu in
       let accu = f pc2 accu in
       accu
-  | Switch (_, a1, a2) ->
+  | Switch (_, a1) ->
       let accu = Array.fold_right a1 ~init:accu ~f:(fun (pc, _) accu -> f pc accu) in
-      let accu = Array.fold_right a2 ~init:accu ~f:(fun (pc, _) accu -> f pc accu) in
       accu
 
 let rec traverse f pc visited blocks =
diff --git a/compiler/lib/wasm/wa_core_target.ml b/compiler/lib/wasm/wa_core_target.ml
index 762a1d979..ed4079d0e 100644
--- a/compiler/lib/wasm/wa_core_target.ml
+++ b/compiler/lib/wasm/wa_core_target.ml
@@ -109,7 +109,9 @@ module Memory = struct
       Arith.(load p + const 4l)
   (*ZZZ Float array?*)
 
-  let tag e = Arith.(mem_load (e - const 4l) land const 0xffl)
+  let tag e =
+    let val_int i = Arith.((i lsl const 1l) + const 1l) in
+    val_int Arith.(mem_load (e - const 4l) land const 0xffl)
 
   let block_length e = Arith.(mem_load (e - const 4l) lsr const 10l)
 
diff --git a/compiler/lib/wasm/wa_gc_target.ml b/compiler/lib/wasm/wa_gc_target.ml
index 67bb57cda..d0b85b737 100644
--- a/compiler/lib/wasm/wa_gc_target.ml
+++ b/compiler/lib/wasm/wa_gc_target.ml
@@ -688,7 +688,7 @@ module Memory = struct
       let* ty = Type.block_type in
       return (W.ArrayNewFixed (ty, RefI31 (Const (I32 (Int32.of_int tag))) :: l))
 
-  let tag e = Value.int_val (wasm_array_get e (Arith.const 0l))
+  let tag e = wasm_array_get e (Arith.const 0l)
 
   let array_length e =
     let* block = Type.block_type in
diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml
index 3b8267add..74197663c 100644
--- a/compiler/lib/wasm/wa_generate.ml
+++ b/compiler/lib/wasm/wa_generate.ml
@@ -256,6 +256,7 @@ module Generate (Target : Wa_target_sig.S) = struct
             | Extern "%int_lsl", [ x; y ] -> Value.int_lsl x y
             | Extern "%int_lsr", [ x; y ] -> Value.int_lsr x y
             | Extern "%int_asr", [ x; y ] -> Value.int_asr x y
+            | Extern "%direct_obj_tag", [ x ] -> Memory.tag x
             | Extern "caml_check_bound", [ x; y ] ->
                 seq
                   (let* cond = Arith.uge (Value.int_val y) (Memory.array_length x) in
@@ -914,7 +915,7 @@ module Generate (Target : Wa_target_sig.S) = struct
                 match fall_through with
                 | `Return -> instr (Push e)
                 | `Block _ -> instr (Return (Some e)))
-            | Switch (x, a1, a2) ->
+            | Switch (x, a1) ->
                 let l =
                   List.filter
                     ~f:(fun pc' ->
@@ -941,18 +942,7 @@ module Generate (Target : Wa_target_sig.S) = struct
                       in
                       let* () = Stack.adjust_stack stack_ctx ~src:pc ~dst:pc' in
                       instr (Br (label_index context pc', None))
-                  | [] -> (
-                      match a1, a2 with
-                      | [||], _ -> br_table (Memory.tag (load x)) a2 context
-                      | _, [||] -> br_table (Value.int_val (load x)) a1 context
-                      | _ ->
-                          (*ZZZ Use Br_on_cast *)
-                          let context' = extend_context fall_through context in
-                          if_
-                            { params = []; result = result_typ }
-                            (Value.check_is_int (load x))
-                            (br_table (Value.int_val (load x)) a1 context')
-                            (br_table (Memory.tag (load x)) a2 context'))
+                  | [] -> br_table (Value.int_val (load x)) a1 context
                 in
                 nest l context
             | Raise (x, _) ->
@@ -1211,9 +1201,7 @@ let fix_switch_branches p =
   Addr.Map.iter
     (fun _ block ->
       match fst block.branch with
-      | Switch (_, l, l') ->
-          fix_branches l;
-          fix_branches l'
+      | Switch (_, l) -> fix_branches l
       | _ -> ())
     p.blocks;
   !p'
diff --git a/compiler/lib/wasm/wa_liveness.ml b/compiler/lib/wasm/wa_liveness.ml
index 796cf36b4..4a2dd9084 100644
--- a/compiler/lib/wasm/wa_liveness.ml
+++ b/compiler/lib/wasm/wa_liveness.ml
@@ -58,9 +58,7 @@ let block_deps deps block pc =
   | Cond (_, cont1, cont2) ->
       cont_deps deps pc cont1;
       cont_deps deps pc cont2
-  | Switch (_, a1, a2) ->
-      Array.iter a1 ~f:(fun cont -> cont_deps deps pc cont);
-      Array.iter a2 ~f:(fun cont -> cont_deps deps pc cont)
+  | Switch (_, a1) -> Array.iter a1 ~f:(fun cont -> cont_deps deps pc cont)
   | Pushtrap (cont, _, cont_h) ->
       cont_deps deps pc cont;
       cont_deps deps pc cont_h
@@ -128,9 +126,7 @@ let propagate_through_branch ~ctx (b, _) s =
   | Stop -> s
   | Branch cont | Poptrap cont -> cont_used ~ctx cont s
   | Cond (_, cont1, cont2) -> s |> cont_used ~ctx cont1 |> cont_used ~ctx cont2
-  | Switch (_, a1, a2) ->
-      let s = Array.fold_right a1 ~f:(fun cont s -> cont_used ~ctx cont s) ~init:s in
-      Array.fold_right a2 ~f:(fun cont s -> cont_used ~ctx cont s) ~init:s
+  | Switch (_, a1) -> Array.fold_right a1 ~f:(fun cont s -> cont_used ~ctx cont s) ~init:s
   | Pushtrap (cont, x, cont_h) ->
       s |> cont_used ~ctx cont |> cont_used ~ctx cont_h |> Var.Set.remove x
 
diff --git a/compiler/lib/wasm/wa_spilling.ml b/compiler/lib/wasm/wa_spilling.ml
index 9c7c3e661..2d1051c7b 100644
--- a/compiler/lib/wasm/wa_spilling.ml
+++ b/compiler/lib/wasm/wa_spilling.ml
@@ -143,9 +143,7 @@ let block_deps bound_vars deps block pc =
   | Cond (_, cont1, cont2) ->
       cont_deps deps pc cont1;
       cont_deps deps pc cont2
-  | Switch (_, a1, a2) ->
-      Array.iter a1 ~f:(fun cont -> cont_deps deps pc cont);
-      Array.iter a2 ~f:(fun cont -> cont_deps deps pc cont)
+  | Switch (_, a1) -> Array.iter a1 ~f:(fun cont -> cont_deps deps pc cont)
   | Pushtrap (cont, exn, cont_h) ->
       cont_deps deps pc cont;
       bound_vars := Var.Set.add exn !bound_vars;
@@ -339,9 +337,7 @@ let spilled_variables
       | Stop -> spilled
       | Branch cont | Poptrap cont -> handle_cont cont spilled
       | Cond (_, cont1, cont2) -> spilled |> handle_cont cont1 |> handle_cont cont2
-      | Switch (_, a1, a2) ->
-          let spilled = Array.fold_right a1 ~f:handle_cont ~init:spilled in
-          Array.fold_right a2 ~f:handle_cont ~init:spilled
+      | Switch (_, a1) -> Array.fold_right a1 ~f:handle_cont ~init:spilled
       | Pushtrap (cont, _, cont_h) -> spilled |> handle_cont cont |> handle_cont cont_h)
     domain
     spilled
diff --git a/compiler/tests-compiler/static_eval.ml b/compiler/tests-compiler/static_eval.ml
index d904da2cc..204d45b3e 100644
--- a/compiler/tests-compiler/static_eval.ml
+++ b/compiler/tests-compiler/static_eval.ml
@@ -157,3 +157,47 @@ let%expect_test "static eval of string get" =
      }
     }
     //end |}]
+
+let%expect_test "static eval of tags" =
+  let program =
+    compile_and_parse
+      {|
+
+      type t = A | B | C of t | D of t | E of t
+
+      let foobar =
+        let x = if Random.int 3 > 1 then C (D A) else D (A) in
+        match x with
+        | A -> 1
+        | B -> 2
+        | C _
+        | D _ -> 3
+        | E _ -> 5
+
+      let export = [|foobar;foobar|]
+  |}
+  in
+  print_program program;
+  [%expect
+    {|
+    (function(globalThis){
+       "use strict";
+       var runtime = globalThis.jsoo_runtime;
+       function caml_call1(f, a0){
+        return (f.l >= 0 ? f.l : f.l = f.length) == 1
+                ? f(a0)
+                : runtime.caml_call_gen(f, [a0]);
+       }
+       var
+        global_data = runtime.caml_get_global_data(),
+        Stdlib_Random = global_data.Stdlib__Random,
+        _a_ = [0, [1, 0]],
+        _b_ = [1, 0],
+        x = 1 < caml_call1(Stdlib_Random[5], 3) ? _a_ : _b_;
+       x[0];
+       var export$0 = [0, 3, 3], Test = [0, 3, export$0];
+       runtime.caml_register_global(3, Test, "Test");
+       return;
+      }
+      (globalThis));
+    //end |}]
diff --git a/compiler/tests-full/stdlib.cma.expected.js b/compiler/tests-full/stdlib.cma.expected.js
index c4be1fc1d..befd4f3db 100644
--- a/compiler/tests-full/stdlib.cma.expected.js
+++ b/compiler/tests-full/stdlib.cma.expected.js
@@ -14794,12 +14794,13 @@
                ([0, Assert_failure, _b_], 1);
      }
     }
-    else
+    else{
+     var switch$1 = 0;
      switch(ty1[0]){
        case 0:
-        var rest1 = ty1[1], switch$1 = 0;
+        var rest1 = ty1[1], switch$2 = 0;
         if(typeof ty2 === "number")
-         switch$1 = 1;
+         switch$2 = 1;
         else
          switch(ty2[0]){
            case 0:
@@ -14807,26 +14808,26 @@
              /*<<camlinternalFormat.ml:804:36>>*/ return [0,
                     trans(rest1, rest2)];
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
-            switch$0 = 6; break;
-           case 10: break;
+            switch$0 = 6; switch$1 = 1; break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$1 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$2 = 1;
          }
-        if(switch$1) switch$0 = 7;
         break;
        case 1:
-        var rest1$0 = ty1[1], switch$2 = 0;
+        var rest1$0 = ty1[1], switch$3 = 0;
         if(typeof ty2 === "number")
-         switch$2 = 1;
+         switch$3 = 1;
         else
          switch(ty2[0]){
            case 1:
@@ -14834,26 +14835,26 @@
              /*<<camlinternalFormat.ml:805:40>>*/ return [1,
                     trans(rest1$0, rest2$0)];
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
-            switch$0 = 6; break;
-           case 10: break;
+            switch$0 = 6; switch$1 = 1; break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$2 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$3 = 1;
          }
-        if(switch$2) switch$0 = 7;
         break;
        case 2:
-        var rest1$1 = ty1[1], switch$3 = 0;
+        var rest1$1 = ty1[1], switch$4 = 0;
         if(typeof ty2 === "number")
-         switch$3 = 1;
+         switch$4 = 1;
         else
          switch(ty2[0]){
            case 2:
@@ -14861,26 +14862,26 @@
              /*<<camlinternalFormat.ml:807:34>>*/ return [2,
                     trans(rest1$1, rest2$1)];
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
-            switch$0 = 6; break;
-           case 10: break;
+            switch$0 = 6; switch$1 = 1; break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$3 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$4 = 1;
          }
-        if(switch$3) switch$0 = 7;
         break;
        case 3:
-        var rest1$2 = ty1[1], switch$4 = 0;
+        var rest1$2 = ty1[1], switch$5 = 0;
         if(typeof ty2 === "number")
-         switch$4 = 1;
+         switch$5 = 1;
         else
          switch(ty2[0]){
            case 3:
@@ -14888,26 +14889,26 @@
              /*<<camlinternalFormat.ml:808:38>>*/ return [3,
                     trans(rest1$2, rest2$2)];
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
-            switch$0 = 6; break;
-           case 10: break;
+            switch$0 = 6; switch$1 = 1; break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$4 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$5 = 1;
          }
-        if(switch$4) switch$0 = 7;
         break;
        case 4:
-        var rest1$3 = ty1[1], switch$5 = 0;
+        var rest1$3 = ty1[1], switch$6 = 0;
         if(typeof ty2 === "number")
-         switch$5 = 1;
+         switch$6 = 1;
         else
          switch(ty2[0]){
            case 4:
@@ -14915,26 +14916,26 @@
              /*<<camlinternalFormat.ml:810:46>>*/ return [4,
                     trans(rest1$3, rest2$3)];
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
-            switch$0 = 6; break;
-           case 10: break;
+            switch$0 = 6; switch$1 = 1; break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$5 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$6 = 1;
          }
-        if(switch$5) switch$0 = 7;
         break;
        case 5:
-        var rest1$4 = ty1[1], switch$6 = 0;
+        var rest1$4 = ty1[1], switch$7 = 0;
         if(typeof ty2 === "number")
-         switch$6 = 1;
+         switch$7 = 1;
         else
          switch(ty2[0]){
            case 5:
@@ -14942,26 +14943,26 @@
              /*<<camlinternalFormat.ml:809:38>>*/ return [5,
                     trans(rest1$4, rest2$4)];
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
-            switch$0 = 6; break;
-           case 10: break;
+            switch$0 = 6; switch$1 = 1; break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$6 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$7 = 1;
          }
-        if(switch$6) switch$0 = 7;
         break;
        case 6:
-        var rest1$5 = ty1[1], switch$7 = 0;
+        var rest1$5 = ty1[1], switch$8 = 0;
         if(typeof ty2 === "number")
-         switch$7 = 1;
+         switch$8 = 1;
         else
          switch(ty2[0]){
            case 6:
@@ -14969,26 +14970,26 @@
              /*<<camlinternalFormat.ml:811:38>>*/ return [6,
                     trans(rest1$5, rest2$5)];
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
-            switch$0 = 6; break;
-           case 10: break;
+            switch$0 = 6; switch$1 = 1; break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$7 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$8 = 1;
          }
-        if(switch$7) switch$0 = 7;
         break;
        case 7:
-        var rest1$6 = ty1[1], switch$8 = 0;
+        var rest1$6 = ty1[1], switch$9 = 0;
         if(typeof ty2 === "number")
-         switch$8 = 1;
+         switch$9 = 1;
         else
          switch(ty2[0]){
            case 7:
@@ -14996,26 +14997,26 @@
              /*<<camlinternalFormat.ml:806:36>>*/ return [7,
                     trans(rest1$6, rest2$6)];
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
-            switch$0 = 6; break;
-           case 10: break;
+            switch$0 = 6; switch$1 = 1; break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$8 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$9 = 1;
          }
-        if(switch$8) switch$0 = 7;
         break;
        case 8:
-        var rest1$7 = ty1[2], ty1$0 = ty1[1], switch$9 = 0;
+        var rest1$7 = ty1[2], ty1$0 = ty1[1], switch$10 = 0;
         if(typeof ty2 === "number")
-         switch$9 = 1;
+         switch$10 = 1;
         else
          switch(ty2[0]){
            case 8:
@@ -15027,29 +15028,30 @@
              /*<<camlinternalFormat.ml:835:4>>*/ return [8,
                     trans(ty1$0, ty2$0),
                     _de_];
-           case 10: break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$9 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$10 = 1;
          }
-        if(switch$9)
+        if(switch$10)
           /*<<camlinternalFormat.ml:836:26>>*/ throw  /*<<camlinternalFormat.ml:836:26>>*/ caml_maybe_attach_backtrace
                 ([0, Assert_failure, _k_], 1);
         break;
        case 9:
-        var rest1$8 = ty1[3], ty12 = ty1[2], ty11 = ty1[1], switch$10 = 0;
+        var rest1$8 = ty1[3], ty12 = ty1[2], ty11 = ty1[1], switch$11 = 0;
         if(typeof ty2 === "number")
-         switch$10 = 1;
+         switch$11 = 1;
         else
          switch(ty2[0]){
            case 8:
-            switch$0 = 5; break;
+            switch$0 = 5; switch$1 = 1; break;
            case 9:
              /*<<camlinternalFormat.ml:841:13>>*/ var
              rest2$8 = ty2[3],
@@ -15066,18 +15068,19 @@
                     ty11,
                     ty22,
                     trans(rest1$8, rest2$8)];
-           case 10: break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
-            switch$0 = 4; break;
-           default: switch$10 = 1;
+            switch$0 = 4; switch$1 = 1; break;
+           default: switch$11 = 1;
          }
-        if(switch$10)
+        if(switch$11)
           /*<<camlinternalFormat.ml:846:28>>*/ throw  /*<<camlinternalFormat.ml:846:28>>*/ caml_maybe_attach_backtrace
                 ([0, Assert_failure, _l_], 1);
         break;
@@ -15091,85 +15094,93 @@
          /*<<camlinternalFormat.ml:814:21>>*/ throw  /*<<camlinternalFormat.ml:814:21>>*/ caml_maybe_attach_backtrace
                ([0, Assert_failure, _m_], 1);
        case 11:
-        var rest1$10 = ty1[1], switch$11 = 0;
+        var rest1$10 = ty1[1], switch$12 = 0;
         if(typeof ty2 === "number")
-         switch$11 = 1;
+         switch$12 = 1;
         else
          switch(ty2[0]){
-           case 10: break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
             var rest2$10 = ty2[1];
              /*<<camlinternalFormat.ml:817:38>>*/ return [11,
                     trans(rest1$10, rest2$10)];
-           default: switch$11 = 1;
+           default: switch$12 = 1;
          }
-        if(switch$11)
+        if(switch$12)
           /*<<camlinternalFormat.ml:818:21>>*/ throw  /*<<camlinternalFormat.ml:818:21>>*/ caml_maybe_attach_backtrace
                 ([0, Assert_failure, _n_], 1);
         break;
        case 12:
-        var rest1$11 = ty1[1], switch$12 = 0;
+        var rest1$11 = ty1[1], switch$13 = 0;
         if(typeof ty2 === "number")
-         switch$12 = 1;
+         switch$13 = 1;
         else
          switch(ty2[0]){
-           case 10: break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
             var rest2$11 = ty2[1];
              /*<<camlinternalFormat.ml:821:34>>*/ return [12,
                     trans(rest1$11, rest2$11)];
-           default: switch$12 = 1;
+           default: switch$13 = 1;
          }
-        if(switch$12)
+        if(switch$13)
           /*<<camlinternalFormat.ml:822:19>>*/ throw  /*<<camlinternalFormat.ml:822:19>>*/ caml_maybe_attach_backtrace
                 ([0, Assert_failure, _o_], 1);
         break;
        case 13:
-        var rest1$12 = ty1[1], switch$13 = 0;
+        var rest1$12 = ty1[1], switch$14 = 0;
         if(typeof ty2 === "number")
-         switch$13 = 1;
+         switch$14 = 1;
         else
          switch(ty2[0]){
-           case 10: break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
             var rest2$12 = ty2[1];
              /*<<camlinternalFormat.ml:825:40>>*/ return [13,
                     trans(rest1$12, rest2$12)];
-           default: switch$13 = 1;
+           default: switch$14 = 1;
          }
-        if(switch$13)
+        if(switch$14)
           /*<<camlinternalFormat.ml:826:22>>*/ throw  /*<<camlinternalFormat.ml:826:22>>*/ caml_maybe_attach_backtrace
                 ([0, Assert_failure, _p_], 1);
         break;
        default:
-        var rest1$13 = ty1[1], switch$14 = 0;
+        var rest1$13 = ty1[1], switch$15 = 0;
         if(typeof ty2 === "number")
-         switch$14 = 1;
+         switch$15 = 1;
         else
          switch(ty2[0]){
-           case 10: break;
+           case 10:
+            switch$1 = 1; break;
            case 11:
-            switch$0 = 1; break;
+            switch$0 = 1; switch$1 = 1; break;
            case 12:
-            switch$0 = 2; break;
+            switch$0 = 2; switch$1 = 1; break;
            case 13:
-            switch$0 = 3; break;
+            switch$0 = 3; switch$1 = 1; break;
            case 14:
             var rest2$13 = ty2[1];
              /*<<camlinternalFormat.ml:830:4>>*/ return [14,
                     trans(rest1$13, rest2$13)];
-           default: switch$14 = 1;
+           default: switch$15 = 1;
          }
-        if(switch$14)
+        if(switch$15)
           /*<<camlinternalFormat.ml:831:30>>*/ throw  /*<<camlinternalFormat.ml:831:30>>*/ caml_maybe_attach_backtrace
                 ([0, Assert_failure, _q_], 1);
      }
+     if(! switch$1)
+       /*<<camlinternalFormat.ml:851:23>>*/ throw  /*<<camlinternalFormat.ml:851:23>>*/ caml_maybe_attach_backtrace
+             ([0, Assert_failure, _j_], 1);
+    }
     switch(switch$0){
       case 0:
         /*<<camlinternalFormat.ml:815:21>>*/ throw  /*<<camlinternalFormat.ml:815:21>>*/ caml_maybe_attach_backtrace
@@ -15189,12 +15200,9 @@
       case 5:
         /*<<camlinternalFormat.ml:837:26>>*/ throw  /*<<camlinternalFormat.ml:837:26>>*/ caml_maybe_attach_backtrace
               ([0, Assert_failure, _c_], 1);
-      case 6:
+      default:
         /*<<camlinternalFormat.ml:847:28>>*/ throw  /*<<camlinternalFormat.ml:847:28>>*/ caml_maybe_attach_backtrace
               ([0, Assert_failure, _d_], 1);
-      default:
-        /*<<camlinternalFormat.ml:851:23>>*/ throw  /*<<camlinternalFormat.ml:851:23>>*/ caml_maybe_attach_backtrace
-              ([0, Assert_failure, _j_], 1);
     }
     /*<<camlinternalFormat.ml:851:35>>*/ }
    function fmtty_of_padding_fmtty(pad, fmtty){
@@ -26423,8 +26431,9 @@
     }
     /*<<format.ml:1344:75>>*/ }
    function output_acc(ppf, acc){
-     /*<<format.ml:1350:29>>*/ var switch$0 = 0;
-    if(typeof acc === "number")  /*<<format.ml:1376:32>>*/ return 0;
+     /*<<format.ml:1350:29>>*/ if(typeof acc === "number")
+      /*<<format.ml:1376:32>>*/ return 0;
+    var switch$0 = 0;
     switch(acc[0]){
       case 0:
        var f = acc[2], p = acc[1];
@@ -26536,8 +26545,9 @@
     }
     /*<<format.ml:1376:34>>*/ }
    function strput_acc(ppf, acc){
-     /*<<format.ml:1382:29>>*/ var switch$0 = 0;
-    if(typeof acc === "number")  /*<<format.ml:1411:32>>*/ return 0;
+     /*<<format.ml:1382:29>>*/ if(typeof acc === "number")
+      /*<<format.ml:1411:32>>*/ return 0;
+    var switch$0 = 0;
     switch(acc[0]){
       case 0:
        var f = acc[2], p = acc[1];

From 3146b3240624c912e3f1c11693a5e1b69315de55 Mon Sep 17 00:00:00 2001
From: hhugo <hugo.heuzard@gmail.com>
Date: Sat, 11 Nov 2023 13:44:12 +0100
Subject: [PATCH 09/28] Compiler: fix free variable for classes (#1524)

* Compiler: fix free variable for classes
---
 compiler/lib/js_traverse.ml       | 22 +++++++++++++++++++++-
 compiler/tests-compiler/minify.ml | 12 ++++++------
 2 files changed, 27 insertions(+), 7 deletions(-)

diff --git a/compiler/lib/js_traverse.ml b/compiler/lib/js_traverse.ml
index 41efb1a78..14d760fdf 100644
--- a/compiler/lib/js_traverse.ml
+++ b/compiler/lib/js_traverse.ml
@@ -825,6 +825,15 @@ class free =
           tbody#record_block (Params params);
           m#merge_info tbody;
           EFun (ident, (k, params, body, nid))
+      | EClass (ident_o, cl_decl) ->
+          let ident_o =
+            Option.map
+              ~f:(fun id ->
+                m#def_var id;
+                m#ident id)
+              ident_o
+          in
+          EClass (ident_o, m#class_decl cl_decl)
       | _ -> super#expression x
 
     method record_block _ = ()
@@ -855,6 +864,9 @@ class free =
           m#def_var id;
           m#merge_info tbody;
           Function_declaration (id, (k, params, body, nid))
+      | Class_declaration (id, cl_decl) ->
+          m#def_var id;
+          Class_declaration (id, m#class_decl cl_decl)
       | Block b -> Block (m#block b)
       | Try_statement (b, w, f) ->
           let same_level = level in
@@ -928,7 +940,12 @@ class rename_variable =
 
        inherit iter as super
 
-       method expression _ = ()
+       method expression e =
+         match e with
+         | EClass (ido, _) ->
+             Option.iter ido ~f:decl_var;
+             super#expression e
+         | _ -> super#expression e
 
        method fun_decl _ = ()
 
@@ -938,6 +955,9 @@ class rename_variable =
              decl_var id;
              self#fun_decl fd
          | Lexical_block, Function_declaration (_, fd) -> self#fun_decl fd
+         | (Fun_block _ | Lexical_block), Class_declaration (id, _) ->
+             decl_var id;
+             super#statement x
          | (Fun_block _ | Lexical_block), _ -> super#statement x
 
        method variable_declaration k l =
diff --git a/compiler/tests-compiler/minify.ml b/compiler/tests-compiler/minify.ml
index 1fd6f4d9a..357f7ea96 100644
--- a/compiler/tests-compiler/minify.ml
+++ b/compiler/tests-compiler/minify.ml
@@ -304,8 +304,8 @@ let%expect_test _ =
       let js_prog =
         {|
 (function () {
-  class f {
-    f() {
+  class longname {
+    longname() {
       const y = 2;
       return v
     }
@@ -327,8 +327,8 @@ let%expect_test _ =
         $ cat "test.js"
           1:
           2: (function () {
-          3:   class f {
-          4:     f() {
+          3:   class longname {
+          4:     longname() {
           5:       const y = 2;
           6:       return v
           7:     }
@@ -338,9 +338,9 @@ let%expect_test _ =
          11:
         $ cat "test.min.js"
           1: (function(){class
-          2: f{f(){const
+          2: a{longname(){const
           3: a=2;return v}}const
-          4: a=y}()); |}])
+          4: b=y}()); |}])
 
 let%expect_test _ =
   with_temp_dir ~f:(fun () ->

From 0ef5c70e4e4f39339eae0b892fe4ac6ba0c703bb Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Aug 2023 08:14:24 +0200
Subject: [PATCH 10/28] Compiler: minify labels

---
 compiler/lib/generate.ml    |  6 +----
 compiler/lib/javascript.ml  | 14 ++--------
 compiler/lib/javascript.mli | 10 +++----
 compiler/lib/js_assign.ml   | 52 +++++++++++++++++++++++++++++++++++--
 compiler/lib/js_output.ml   | 10 ++++---
 compiler/lib/js_traverse.ml | 26 +++++++++++++++++++
 6 files changed, 90 insertions(+), 28 deletions(-)

diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml
index 08de2518f..2037cd59c 100644
--- a/compiler/lib/generate.ml
+++ b/compiler/lib/generate.ml
@@ -1585,11 +1585,7 @@ and compile_block st queue (pc : Addr.t) loop_stack frontier interm =
     | true ->
         if debug () then Format.eprintf "@[<hv 2>for(;;) {@,";
         let never_body, body =
-          let lab =
-            match loop_stack with
-            | (_, (l, _)) :: _ -> J.Label.succ l
-            | [] -> J.Label.zero
-          in
+          let lab = J.Label.fresh () in
           let lab_used = ref false in
           let loop_stack = (pc, (lab, lab_used)) :: loop_stack in
           let never_body, body =
diff --git a/compiler/lib/javascript.ml b/compiler/lib/javascript.ml
index c1c58273d..756fdefdc 100644
--- a/compiler/lib/javascript.ml
+++ b/compiler/lib/javascript.ml
@@ -143,20 +143,10 @@ end
 
 module Label = struct
   type t =
-    | L of int
+    | L of Code.Var.t
     | S of Utf8_string.t
 
-  let printer = Var_printer.create Var_printer.Alphabet.javascript
-
-  let zero = L 0
-
-  let succ = function
-    | L t -> L (succ t)
-    | S _ -> assert false
-
-  let to_string = function
-    | L t -> Utf8_string.of_string_exn (Var_printer.to_string printer t)
-    | S s -> s
+  let fresh () = L (Code.Var.fresh ())
 
   let of_string s = S s
 end
diff --git a/compiler/lib/javascript.mli b/compiler/lib/javascript.mli
index 3d6ffbaeb..75cf608a7 100644
--- a/compiler/lib/javascript.mli
+++ b/compiler/lib/javascript.mli
@@ -51,13 +51,11 @@ module Num : sig
 end
 
 module Label : sig
-  type t
-
-  val zero : t
-
-  val succ : t -> t
+  type t =
+    | L of Code.Var.t
+    | S of Utf8_string.t
 
-  val to_string : t -> Utf8_string.t
+  val fresh : unit -> t
 
   val of_string : Utf8_string.t -> t
 end
diff --git a/compiler/lib/js_assign.ml b/compiler/lib/js_assign.ml
index ded0a92fb..67974304f 100644
--- a/compiler/lib/js_assign.ml
+++ b/compiler/lib/js_assign.ml
@@ -329,11 +329,48 @@ class traverse record_block =
       super#record_block b
   end
 
+class traverse_labels h =
+  object
+    inherit Js_traverse.iter as super
+
+    val ldepth = 0
+
+    method fun_decl (_k, _params, body, _loc) =
+      let m = {<ldepth = 0>} in
+      m#function_body body
+
+    method statement =
+      function
+      | Labelled_statement (L l, (s, _)) ->
+          let m = {<ldepth = ldepth + 1>} in
+          Hashtbl.add h l ldepth;
+          m#statement s
+      | s -> super#statement s
+  end
+
+class name ident label =
+  object (m)
+    inherit Js_traverse.subst ident as super
+
+    method statement =
+      function
+      | Labelled_statement (l, (s, loc)) ->
+          Labelled_statement (label l, (m#statement s, loc))
+      | Break_statement (Some l) -> Break_statement (Some (label l))
+      | Continue_statement (Some l) -> Continue_statement (Some (label l))
+      | s -> super#statement s
+  end
+
 let program' (module Strategy : Strategy) p =
   let nv = Var.count () in
   let state = Strategy.create nv in
+  let labels = Hashtbl.create 20 in
   let mapper = new traverse (Strategy.record_block state) in
   let p = mapper#program p in
+  let () =
+    let o = new traverse_labels labels in
+    o#program p
+  in
   mapper#record_block Normal;
   let free =
     IdentSet.filter
@@ -350,7 +387,7 @@ let program' (module Strategy : Strategy) p =
       | S _ -> ()
       | V x -> names.(Var.idx x) <- "")
     free;
-  let color = function
+  let ident = function
     | V v -> (
         let name = names.(Var.idx v) in
         match name, has_free_var with
@@ -359,7 +396,18 @@ let program' (module Strategy : Strategy) p =
         | _, (true | false) -> ident ~var:v (Utf8_string.of_string_exn name))
     | x -> x
   in
-  let p = (new Js_traverse.subst color)#program p in
+  let label_printer = Var_printer.create Var_printer.Alphabet.javascript in
+  let max_label_depth = Hashtbl.fold (fun _ d acc -> max d acc) labels 0 in
+  let lname_per_depth =
+    Array.init (max_label_depth + 1) ~f:(fun i -> Var_printer.to_string label_printer i)
+  in
+  let label = function
+    | Label.S _ as l -> l
+    | L v ->
+        let i = Hashtbl.find labels v in
+        S (Utf8_string.of_string_exn lname_per_depth.(i))
+  in
+  let p = (new name ident label)#program p in
   (if has_free_var
    then
      let () =
diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml
index 82ba0c555..2db393ddc 100644
--- a/compiler/lib/js_output.ml
+++ b/compiler/lib/js_output.ml
@@ -60,6 +60,10 @@ end) =
 struct
   open D
 
+  let nane_of_label = function
+    | Javascript.Label.L _ -> assert false
+    | Javascript.Label.S n -> n
+
   let debug_enabled = Config.Flag.debuginfo ()
 
   let output_debug_info f loc =
@@ -1260,7 +1264,7 @@ struct
         last_semi ()
     | Continue_statement (Some s) ->
         PP.string f "continue ";
-        let (Utf8 l) = Javascript.Label.to_string s in
+        let (Utf8 l) = nane_of_label s in
         PP.string f l;
         last_semi ()
     | Break_statement None ->
@@ -1268,7 +1272,7 @@ struct
         last_semi ()
     | Break_statement (Some s) ->
         PP.string f "break ";
-        let (Utf8 l) = Javascript.Label.to_string s in
+        let (Utf8 l) = nane_of_label s in
         PP.string f l;
         last_semi ()
     | Return_statement e -> (
@@ -1309,7 +1313,7 @@ struct
             (* There MUST be a space between the return and its
                argument. A line return will not work *))
     | Labelled_statement (i, s) ->
-        let (Utf8 l) = Javascript.Label.to_string i in
+        let (Utf8 l) = nane_of_label i in
         PP.string f l;
         PP.string f ":";
         PP.space f;
diff --git a/compiler/lib/js_traverse.ml b/compiler/lib/js_traverse.ml
index 14d760fdf..f3d196400 100644
--- a/compiler/lib/js_traverse.ml
+++ b/compiler/lib/js_traverse.ml
@@ -996,6 +996,8 @@ class rename_variable =
 
     val decl = StringSet.empty
 
+    val labels = StringMap.empty
+
     method private update_state scope params iter_body =
       let declared_names = declared scope params iter_body in
       {<subst = StringSet.fold
@@ -1031,6 +1033,30 @@ class rename_variable =
 
     method statement s =
       match s with
+      | Labelled_statement (l, (s, loc)) ->
+          let l, m =
+            match l with
+            | L _ -> l, m
+            | S (Utf8 u) ->
+                let l = Label.fresh () in
+                let m = {<labels = StringMap.add u l labels>} in
+                l, m
+          in
+          Labelled_statement (l, (m#statement s, loc))
+      | Break_statement (Some l) -> (
+          match l with
+          | L _ -> s
+          | S (Utf8 l) -> (
+              match StringMap.find_opt l labels with
+              | None -> s
+              | Some l -> Break_statement (Some l)))
+      | Continue_statement (Some l) -> (
+          match l with
+          | L _ -> s
+          | S (Utf8 l) -> (
+              match StringMap.find_opt l labels with
+              | None -> s
+              | Some l -> Continue_statement (Some l)))
       | Function_declaration (id, (k, params, body, nid)) ->
           let ids = bound_idents_of_params params in
           let m' = m#update_state (Fun_block None) ids body in

From 6beaabe7ffeb5a3892c1c1f650c44ae0efaccf43 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 13 Nov 2023 22:38:01 +0100
Subject: [PATCH 11/28] Compiler: fix es6 scopes

---
 compiler/bin-jsoo_minify/jsoo_minify.ml    |   2 +-
 compiler/lib/js_traverse.ml                | 158 +++++++++++++++++++--
 compiler/lib/js_traverse.mli               |  14 +-
 compiler/lib/stdlib.ml                     |   4 +
 compiler/tests-full/stdlib.cma.expected.js |  16 +--
 5 files changed, 169 insertions(+), 25 deletions(-)

diff --git a/compiler/bin-jsoo_minify/jsoo_minify.ml b/compiler/bin-jsoo_minify/jsoo_minify.ml
index 80fcc9f74..22ffdb132 100644
--- a/compiler/bin-jsoo_minify/jsoo_minify.ml
+++ b/compiler/bin-jsoo_minify/jsoo_minify.ml
@@ -81,7 +81,7 @@ let f { Cmd_arg.common; output_file; use_stdin; files } =
     let true_ () = true in
     let open Config in
     let passes : ((unit -> bool) * (unit -> Js_traverse.mapper)) list =
-      [ (Flag.shortvar, fun () -> new Js_traverse.rename_variable)
+      [ (Flag.shortvar, fun () -> (new Js_traverse.rename_variable :> Js_traverse.mapper))
       ; (true_, fun () -> new Js_traverse.simpl)
       ; (true_, fun () -> new Js_traverse.clean)
       ]
diff --git a/compiler/lib/js_traverse.ml b/compiler/lib/js_traverse.ml
index f3d196400..6f9c79cdf 100644
--- a/compiler/lib/js_traverse.ml
+++ b/compiler/lib/js_traverse.ml
@@ -35,6 +35,8 @@ class type mapper = object
 
   method class_decl : Javascript.class_declaration -> Javascript.class_declaration
 
+  method class_element : Javascript.class_element -> Javascript.class_element
+
   method initialiser :
        Javascript.expression * Javascript.location
     -> Javascript.expression * Javascript.location
@@ -108,7 +110,7 @@ class map : mapper =
       ; body = List.map x.body ~f:m#class_element
       }
 
-    method private class_element x =
+    method class_element x =
       match x with
       | CEMethod (s, n, meth) -> CEMethod (s, m#class_element_name n, m#method_ meth)
       | CEField (s, n, i) -> CEField (s, m#class_element_name n, m#initialiser_o i)
@@ -305,6 +307,8 @@ class map : mapper =
 class type iterator = object
   method fun_decl : Javascript.function_declaration -> unit
 
+  method class_decl : Javascript.class_declaration -> unit
+
   method early_error : Javascript.early_error -> unit
 
   method expression : Javascript.expression -> unit
@@ -373,7 +377,7 @@ class iter : iterator =
       m#formal_parameter_list params;
       m#function_body body
 
-    method private class_decl x =
+    method class_decl x =
       Option.iter x.extends ~f:m#expression;
       List.iter x.body ~f:m#class_element
 
@@ -826,14 +830,19 @@ class free =
           m#merge_info tbody;
           EFun (ident, (k, params, body, nid))
       | EClass (ident_o, cl_decl) ->
+          let same_level = level in
+          let cbody = {<state_ = empty; level = same_level>} in
           let ident_o =
             Option.map
               ~f:(fun id ->
-                m#def_var id;
-                m#ident id)
+                cbody#def_var id;
+                id)
               ident_o
           in
-          EClass (ident_o, m#class_decl cl_decl)
+          let cl_decl = cbody#class_decl cl_decl in
+          cbody#record_block Normal;
+          m#merge_block_info cbody;
+          EClass (ident_o, cl_decl)
       | _ -> super#expression x
 
     method record_block _ = ()
@@ -853,6 +862,16 @@ class free =
       m#merge_block_info tbody;
       b
 
+    method class_element x =
+      match x with
+      | CEStaticBLock l ->
+          let tbody = {<state_ = empty; level = level + 1>} in
+          let l = tbody#statements l in
+          tbody#record_block Normal;
+          m#merge_info tbody;
+          CEStaticBLock l
+      | _ -> super#class_element x
+
     method statement x =
       match x with
       | Function_declaration (id, (k, params, body, nid)) ->
@@ -865,9 +884,56 @@ class free =
           m#merge_info tbody;
           Function_declaration (id, (k, params, body, nid))
       | Class_declaration (id, cl_decl) ->
+          let same_level = level in
+          let cbody = {<state_ = empty; level = same_level>} in
+          let cl_decl = cbody#class_decl cl_decl in
+          cbody#record_block Normal;
+          m#merge_block_info cbody;
           m#def_var id;
-          Class_declaration (id, m#class_decl cl_decl)
+          Class_declaration (id, cl_decl)
       | Block b -> Block (m#block b)
+      | For_statement (Right (((Const | Let) as k), l), e1, e2, (st, loc)) ->
+          let same_level = level in
+          let m' = {<state_ = empty; level = same_level>} in
+          let l = List.map ~f:(m'#variable_declaration k) l in
+          let e1 = Option.map ~f:m'#expression e1 in
+          let e2 = Option.map ~f:m'#expression e2 in
+          let st = m'#statement st in
+          m'#record_block Normal;
+          m#merge_block_info m';
+          For_statement (Right (k, l), e1, e2, (st, m#loc loc))
+      | ForIn_statement (Right (((Const | Let) as k), l), e2, (st, loc)) ->
+          let same_level = level in
+          let m' = {<state_ = empty; level = same_level>} in
+          let l = m'#for_binding k l in
+          let e2 = m'#expression e2 in
+          let st = m'#statement st in
+          m'#record_block Normal;
+          m#merge_block_info m';
+          ForIn_statement (Right (k, l), e2, (st, m#loc loc))
+      | ForOf_statement (Right (((Const | Let) as k), l), e2, (st, loc)) ->
+          let same_level = level in
+          let m' = {<state_ = empty; level = same_level>} in
+          let l = m'#for_binding k l in
+          let e2 = m'#expression e2 in
+          let st = m'#statement st in
+          m'#record_block Normal;
+          m#merge_block_info m';
+          ForOf_statement (Right (k, l), e2, (st, m#loc loc))
+      | Switch_statement (e, l, def, l') ->
+          let same_level = level in
+          let m' = {<state_ = empty; level = same_level>} in
+          let l = List.map l ~f:(fun (e, s) -> m'#switch_case e, m'#statements s) in
+          let l' = List.map l' ~f:(fun (e, s) -> m'#switch_case e, m'#statements s) in
+          let def =
+            match def with
+            | None -> None
+            | Some l -> Some (m'#statements l)
+          in
+          let e = m#expression e in
+          m'#record_block Normal;
+          m#merge_block_info m';
+          Switch_statement (e, l, def, l')
       | Try_statement (b, w, f) ->
           let same_level = level in
           let b = m#block b in
@@ -940,24 +1006,38 @@ class rename_variable =
 
        inherit iter as super
 
-       method expression e =
-         match e with
-         | EClass (ido, _) ->
-             Option.iter ido ~f:decl_var;
-             super#expression e
-         | _ -> super#expression e
+       method expression _ = ()
 
        method fun_decl _ = ()
 
+       method class_decl _ = ()
+
        method statement x =
          match scope, x with
          | Fun_block _, Function_declaration (id, fd) ->
              decl_var id;
              self#fun_decl fd
          | Lexical_block, Function_declaration (_, fd) -> self#fun_decl fd
-         | (Fun_block _ | Lexical_block), Class_declaration (id, _) ->
+         | (Lexical_block | Fun_block _), Class_declaration (id, cl_decl) ->
              decl_var id;
-             super#statement x
+             self#class_decl cl_decl
+         | _, For_statement (Right (((Const | Let) as k), l), _e1, _e2, (st, _loc)) ->
+             let m = {<depth = depth + 1>} in
+             List.iter ~f:(m#variable_declaration k) l;
+             m#statement st
+         | _, ForOf_statement (Right (((Const | Let) as k), l), _e2, (st, _loc)) ->
+             let m = {<depth = depth + 1>} in
+             m#for_binding k l;
+             m#statement st
+         | _, ForIn_statement (Right (((Const | Let) as k), l), _e2, (st, _loc)) ->
+             let m = {<depth = depth + 1>} in
+             m#for_binding k l;
+             m#statement st
+         | _, Switch_statement (_, l, def, l') ->
+             let m = {<depth = depth + 1>} in
+             List.iter l ~f:(fun (_, s) -> m#statements s);
+             Option.iter def ~f:(fun l -> m#statements l);
+             List.iter l' ~f:(fun (_, s) -> m#statements s)
          | (Fun_block _ | Lexical_block), _ -> super#statement x
 
        method variable_declaration k l =
@@ -998,7 +1078,7 @@ class rename_variable =
 
     val labels = StringMap.empty
 
-    method private update_state scope params iter_body =
+    method update_state scope params iter_body =
       let declared_names = declared scope params iter_body in
       {<subst = StringSet.fold
                   (fun name subst -> StringMap.add name (Code.Var.fresh_n name) subst)
@@ -1012,6 +1092,13 @@ class rename_variable =
       | S { name = Utf8 name; _ } -> (
           try V (StringMap.find name subst) with Not_found -> x)
 
+    method class_element x =
+      match x with
+      | CEStaticBLock l ->
+          let m' = m#update_state (Fun_block None) [] l in
+          CEStaticBLock (m'#statements l)
+      | _ -> super#class_element x
+
     method fun_decl (k, params, body, nid) =
       let ids = bound_idents_of_params params in
       let m' = m#update_state (Fun_block None) ids body in
@@ -1029,6 +1116,9 @@ class rename_variable =
           EFun
             ( Option.map ident ~f:m'#ident
             , (k, m'#formal_parameter_list params, m'#function_body body, m#loc nid) )
+      | EClass (Some id, cl_decl) ->
+          let m' = m#update_state Lexical_block [ id ] [] in
+          EClass (Some (m'#ident id), m'#class_decl cl_decl)
       | _ -> super#expression e
 
     method statement s =
@@ -1063,6 +1153,28 @@ class rename_variable =
           Function_declaration
             ( m#ident id
             , (k, m'#formal_parameter_list params, m'#function_body body, m#loc nid) )
+      | For_statement (Right (((Const | Let) as k), l), e1, e2, (st, loc)) ->
+          let ids = List.concat_map ~f:bound_idents_of_variable_declaration l in
+          let m' = m#update_state Lexical_block ids [] in
+          For_statement
+            ( Right (k, List.map ~f:(m'#variable_declaration k) l)
+            , Option.map ~f:m'#expression e1
+            , Option.map ~f:m'#expression e2
+            , (m'#statement st, m'#loc loc) )
+      | ForOf_statement (Right (((Const | Let) as k), l), e2, (st, loc)) ->
+          let ids = bound_idents_of_binding l in
+          let m' = m#update_state Lexical_block ids [] in
+          ForOf_statement
+            ( Right (k, m'#for_binding k l)
+            , m'#expression e2
+            , (m'#statement st, m'#loc loc) )
+      | ForIn_statement (Right (((Const | Let) as k), l), e2, (st, loc)) ->
+          let ids = bound_idents_of_binding l in
+          let m' = m#update_state Lexical_block ids [] in
+          ForOf_statement
+            ( Right (k, m'#for_binding k l)
+            , m'#expression e2
+            , (m'#statement st, m'#loc loc) )
       | Block l ->
           let m' = m#update_state Lexical_block [] l in
           Block (m'#statements l)
@@ -1106,6 +1218,22 @@ class rename_variable =
                 Some (i, m'#statements catch)
           in
           Try_statement (block, catch, final)
+      | Switch_statement (e, l, def, l') ->
+          let all =
+            let r = ref [] in
+            Option.iter def ~f:(fun l -> r := List.rev_append l !r);
+            List.iter l ~f:(fun (_, s) -> r := List.rev_append s !r);
+            List.iter l' ~f:(fun (_, s) -> r := List.rev_append s !r);
+            !r
+          in
+          let m' = m#update_state Lexical_block [] all in
+          Switch_statement
+            ( m#expression e
+            , List.map l ~f:(fun (e, s) -> m'#switch_case e, m'#statements s)
+            , (match def with
+              | None -> None
+              | Some l -> Some (m'#statements l))
+            , List.map l' ~f:(fun (e, s) -> m'#switch_case e, m'#statements s) )
       | _ -> super#statement s
   end
 
diff --git a/compiler/lib/js_traverse.mli b/compiler/lib/js_traverse.mli
index ba625bab2..f931214e1 100644
--- a/compiler/lib/js_traverse.mli
+++ b/compiler/lib/js_traverse.mli
@@ -34,6 +34,8 @@ class type mapper = object
 
   method class_decl : Javascript.class_declaration -> Javascript.class_declaration
 
+  method class_element : Javascript.class_element -> Javascript.class_element
+
   method initialiser : expression * location -> expression * location
 
   method initialiser_o : (expression * location) option -> (expression * location) option
@@ -67,6 +69,8 @@ end
 class type iterator = object
   method fun_decl : Javascript.function_declaration -> unit
 
+  method class_decl : Javascript.class_declaration -> unit
+
   method early_error : Javascript.early_error -> unit
 
   method expression : Javascript.expression -> unit
@@ -147,7 +151,15 @@ end
 
 class free : freevar
 
-class rename_variable : mapper
+type scope =
+  | Lexical_block
+  | Fun_block of ident option
+
+class rename_variable : object ('a)
+  inherit mapper
+
+  method update_state : scope -> Javascript.ident list -> Javascript.statement_list -> 'a
+end
 
 class share_constant : mapper
 
diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml
index 7afd1cd32..d81187b8a 100644
--- a/compiler/lib/stdlib.ml
+++ b/compiler/lib/stdlib.ml
@@ -369,6 +369,10 @@ module Option = struct
     | None -> None
     | Some v -> Some (f v)
 
+  let to_list = function
+    | None -> []
+    | Some x -> [ x ]
+
   let bind ~f x =
     match x with
     | None -> None
diff --git a/compiler/tests-full/stdlib.cma.expected.js b/compiler/tests-full/stdlib.cma.expected.js
index befd4f3db..4d599ef02 100644
--- a/compiler/tests-full/stdlib.cma.expected.js
+++ b/compiler/tests-full/stdlib.cma.expected.js
@@ -30123,11 +30123,11 @@
             function(n, m){
                /*<<?>>*/ return function(obj){
                 /*<<camlinternalOO.ml:492:18>>*/  /*<<camlinternalOO.ml:492:44>>*/ var
-                _k_ =
+                _l_ =
                    /*<<camlinternalOO.ml:492:44>>*/ caml_call1
                    (obj[1][1 + m], obj);
                 /*<<camlinternalOO.ml:492:44>>*/ return  /*<<camlinternalOO.ml:492:44>>*/ caml_call2
-                       (obj[1][1 + n], obj, _k_); /*<<camlinternalOO.ml:492:60>>*/ };
+                       (obj[1][1 + n], obj, _l_); /*<<camlinternalOO.ml:492:60>>*/ };
              }
              (n$15, m$1);
          break;
@@ -30154,8 +30154,8 @@
           clo$0 =
             function(m, n){
                /*<<?>>*/ return function(obj){
-                /*<<camlinternalOO.ml:497:4>>*/ var _j_ = obj[1 + n];
-               return caml_call1(caml_get_public_method(_j_, m, 0), _j_); /*<<camlinternalOO.ml:498:32>>*/ };
+                /*<<camlinternalOO.ml:497:4>>*/ var _k_ = obj[1 + n];
+               return caml_call1(caml_get_public_method(_k_, m, 0), _k_); /*<<camlinternalOO.ml:498:32>>*/ };
              }
              (m$3, n$16);
          break;
@@ -30169,8 +30169,8 @@
           clo$0 =
             function(m, e, n){
                /*<<?>>*/ return function(obj){
-                /*<<camlinternalOO.ml:501:4>>*/ var _i_ = obj[1 + e][1 + n];
-               return caml_call1(caml_get_public_method(_i_, m, 0), _i_); /*<<camlinternalOO.ml:504:34>>*/ };
+                /*<<camlinternalOO.ml:501:4>>*/ var _j_ = obj[1 + e][1 + n];
+               return caml_call1(caml_get_public_method(_j_, m, 0), _j_); /*<<camlinternalOO.ml:504:34>>*/ };
              }
              (m$4, e$4, n$17);
          break;
@@ -30184,11 +30184,11 @@
             function(m, n){
                /*<<?>>*/ return function(obj){
                 /*<<camlinternalOO.ml:507:4>>*/  /*<<camlinternalOO.ml:507:14>>*/ var
-                _l_ =
+                _i_ =
                    /*<<camlinternalOO.ml:507:14>>*/ caml_call1
                    (obj[1][1 + n], obj);
                 /*<<camlinternalOO.ml:507:14>>*/ return  /*<<camlinternalOO.ml:507:14>>*/ caml_call1
-                       (caml_get_public_method(_l_, m, 0), _l_); /*<<camlinternalOO.ml:507:59>>*/ };
+                       (caml_get_public_method(_i_, m, 0), _i_); /*<<camlinternalOO.ml:507:59>>*/ };
              }
              (m$5, n$18);
       }

From 7977f8579c6a6c7611781f65248d32640b18bda4 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Oct 2023 15:28:13 +0200
Subject: [PATCH 12/28] Compiler: improve complexity in parser production

---
 compiler/lib/js_parser.mly | 19 +++++++++++--------
 1 file changed, 11 insertions(+), 8 deletions(-)

diff --git a/compiler/lib/js_parser.mly b/compiler/lib/js_parser.mly
index 8d7d6150a..f3a1ccbfd 100644
--- a/compiler/lib/js_parser.mly
+++ b/compiler/lib/js_parser.mly
@@ -217,19 +217,22 @@ T_BACKQUOTE
 (* Macros *)
 (*************************************************************************)
 
-listc(X):
+listc_rev(X):
  | X              { [$1] }
- | listc(X) "," X { $1 @ [$3] }
+ | listc_rev(X) "," X { $3 :: $1 }
 
-listc_with_empty_trail(X):
- | e=elision               { (List.map (fun () -> None) e) }
- | x=X e=elision           { Some x :: (List.map (fun () -> None) e) }
- | listc_with_empty_trail(X) x=X e=elision { $1 @ [Some x] @ (List.map (fun () -> None) e) }
+%inline listc(X):
+ | listc_rev(X) { List.rev $1 }
+
+listc_with_empty_trail_rev(X):
+ | e=elision               { (List.rev_map (fun () -> None) e) }
+ | x=X e=elision           { List.rev_append (List.rev_map (fun () -> None) e) [ Some x ]   }
+ | listc_with_empty_trail_rev(X) x=X e=elision { List.rev_append (List.rev_map (fun () -> None) e) (Some x :: $1) }
 
 listc_with_empty(X):
   | X                           { [ Some $1 ] }
-  | listc_with_empty_trail(X)   { $1 }
-  | listc_with_empty_trail(X) X { $1 @ [Some $2 ] }
+  | listc_with_empty_trail_rev(X)   { List.rev $1 }
+  | listc_with_empty_trail_rev(X) X { List.rev ((Some $2) :: $1) }
 optl(X):
  | (* empty *) { [] }
  | X           { $1 }

From 2263216f3e526b6f00529145908b41e548b12d65 Mon Sep 17 00:00:00 2001
From: hhugo <hugo.heuzard@gmail.com>
Date: Sun, 26 Nov 2023 16:12:30 +0100
Subject: [PATCH 13/28] Compiler: support for es6 import/export (#1529)

---
 compiler/bin-jsoo_minify/jsoo_minify.ml |   3 +-
 compiler/lib/driver.ml                  |   2 +-
 compiler/lib/javascript.ml              |  40 +++++++
 compiler/lib/javascript.mli             |  40 +++++++
 compiler/lib/js_output.ml               | 153 ++++++++++++++++++++++--
 compiler/lib/js_parser.mly              | 133 ++++++++++++++++++++
 compiler/lib/js_simpl.ml                |   2 +
 compiler/lib/js_token.ml                |   3 +
 compiler/lib/js_token.mli               |   1 +
 compiler/lib/js_traverse.ml             | 135 +++++++++++++++++++--
 compiler/lib/js_traverse.mli            |  11 +-
 compiler/lib/parse_js.ml                |  20 +++-
 compiler/lib/stdlib.ml                  |   4 +
 compiler/lib/wasm/wa_link.ml            |   2 +-
 14 files changed, 526 insertions(+), 23 deletions(-)

diff --git a/compiler/bin-jsoo_minify/jsoo_minify.ml b/compiler/bin-jsoo_minify/jsoo_minify.ml
index 22ffdb132..f607fa369 100644
--- a/compiler/bin-jsoo_minify/jsoo_minify.ml
+++ b/compiler/bin-jsoo_minify/jsoo_minify.ml
@@ -81,7 +81,8 @@ let f { Cmd_arg.common; output_file; use_stdin; files } =
     let true_ () = true in
     let open Config in
     let passes : ((unit -> bool) * (unit -> Js_traverse.mapper)) list =
-      [ (Flag.shortvar, fun () -> (new Js_traverse.rename_variable :> Js_traverse.mapper))
+      [ ( Flag.shortvar
+        , fun () -> (new Js_traverse.rename_variable ~esm:false :> Js_traverse.mapper) )
       ; (true_, fun () -> new Js_traverse.simpl)
       ; (true_, fun () -> new Js_traverse.clean)
       ]
diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml
index 7c0ed54ff..889ef3623 100644
--- a/compiler/lib/driver.ml
+++ b/compiler/lib/driver.ml
@@ -560,7 +560,7 @@ if (typeof module === 'object' && module.exports) {
     if Config.Flag.shortvar ()
     then (
       let t5 = Timer.make () in
-      let js = (new Js_traverse.rename_variable)#program js in
+      let js = (new Js_traverse.rename_variable ~esm:false)#program js in
       if times () then Format.eprintf "    shortten vars: %a@." Timer.print t5;
       js)
     else js
diff --git a/compiler/lib/javascript.ml b/compiler/lib/javascript.ml
index 756fdefdc..256f3cc09 100644
--- a/compiler/lib/javascript.ml
+++ b/compiler/lib/javascript.ml
@@ -346,6 +346,8 @@ and statement =
   | Throw_statement of expression
   | Try_statement of block * (formal_parameter option * block) option * block option
   | Debugger_statement
+  | Import of import * Parse_info.t
+  | Export of export * Parse_info.t
 
 and ('left, 'right) either =
   | Left of 'left
@@ -422,6 +424,44 @@ and function_body = statement_list
 
 and program = statement_list
 
+and export =
+  | ExportVar of variable_declaration_kind * variable_declaration list
+  | ExportFun of ident * function_declaration
+  | ExportClass of ident * class_declaration
+  | ExportNames of (ident * Utf8_string.t) list
+  (* default *)
+  | ExportDefaultFun of ident * function_declaration
+  | ExportDefaultClass of ident * class_declaration
+  | ExportDefaultExpression of expression
+  (* from *)
+  | ExportFrom of
+      { kind : export_from_kind
+      ; from : Utf8_string.t
+      }
+  | CoverExportFrom of early_error
+
+and export_from_kind =
+  | Export_all of Utf8_string.t option
+  | Export_names of (Utf8_string.t * Utf8_string.t) list
+
+and import =
+  { from : Utf8_string.t
+  ; kind : import_kind
+  }
+
+and import_default = ident
+
+and import_kind =
+  | Namespace of import_default option * ident
+  (* import * as name from "fname" *)
+  (* import defaultname, * as name from "fname" *)
+  | Named of import_default option * (Utf8_string.t * ident) list
+  (* import { 'a' as a, ...} from "fname" *)
+  (* import defaultname, { 'a' as a, ...} from "fname" *)
+  | Default of import_default
+  (* import defaultname from "fname" *)
+  | SideEffect (* import "fname" *)
+
 and program_with_annots = (statement_list * (Js_token.Annot.t * Parse_info.t) list) list
 
 let compare_ident t1 t2 =
diff --git a/compiler/lib/javascript.mli b/compiler/lib/javascript.mli
index 75cf608a7..69a87bea9 100644
--- a/compiler/lib/javascript.mli
+++ b/compiler/lib/javascript.mli
@@ -266,6 +266,8 @@ and statement =
   | Throw_statement of expression
   | Try_statement of block * (formal_parameter option * block) option * block option
   | Debugger_statement
+  | Import of import * Parse_info.t
+  | Export of export * Parse_info.t
 
 and ('left, 'right) either =
   | Left of 'left
@@ -342,6 +344,44 @@ and function_body = statement_list
 
 and program = statement_list
 
+and export =
+  | ExportVar of variable_declaration_kind * variable_declaration list
+  | ExportFun of ident * function_declaration
+  | ExportClass of ident * class_declaration
+  | ExportNames of (ident * Utf8_string.t) list
+  (* default *)
+  | ExportDefaultFun of ident * function_declaration
+  | ExportDefaultClass of ident * class_declaration
+  | ExportDefaultExpression of expression
+  (* from *)
+  | ExportFrom of
+      { kind : export_from_kind
+      ; from : Utf8_string.t
+      }
+  | CoverExportFrom of early_error
+
+and export_from_kind =
+  | Export_all of Utf8_string.t option
+  | Export_names of (Utf8_string.t * Utf8_string.t) list
+
+and import =
+  { from : Utf8_string.t
+  ; kind : import_kind
+  }
+
+and import_default = ident
+
+and import_kind =
+  | Namespace of import_default option * ident
+  (* import * as name from "fname" *)
+  (* import defaultname, * as name from "fname" *)
+  | Named of import_default option * (Utf8_string.t * ident) list
+  (* import { 'a' as a, ...} from "fname" *)
+  (* import defaultname, { 'a' as a, ...} from "fname" *)
+  | Default of import_default
+  (* import defaultname from "fname" *)
+  | SideEffect (* import "fname" *)
+
 and program_with_annots = (statement_list * (Js_token.Annot.t * Parse_info.t) list) list
 
 val compare_ident : ident -> ident -> int
diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml
index 2db393ddc..1898a8e01 100644
--- a/compiler/lib/js_output.ml
+++ b/compiler/lib/js_output.ml
@@ -289,7 +289,9 @@ struct
     | Try_statement _
     | Function_declaration _
     | Class_declaration _
-    | Debugger_statement -> false
+    | Debugger_statement
+    | Import _
+    | Export _ -> false
 
   let starts_with ~obj ~funct ~let_identifier ~async_identifier l e =
     let rec traverse l e =
@@ -368,6 +370,13 @@ struct
     Buffer.add_char b quote;
     PP.string f (Buffer.contents b)
 
+  let pp_string_lit f (Stdlib.Utf8_string.Utf8 s) =
+    let quote = best_string_quote s in
+    pp_string f ~quote s
+
+  let pp_ident_or_string_lit f (Stdlib.Utf8_string.Utf8 s_lit as s) =
+    if is_ident s_lit then PP.string f s_lit else pp_string_lit f s
+
   let rec comma_list f f_elt l =
     match l with
     | [] -> ()
@@ -523,9 +532,7 @@ struct
         then (
           PP.string f ")";
           PP.end_group f)
-    | EStr (Utf8 s) ->
-        let quote = best_string_quote s in
-        pp_string f ~quote s
+    | EStr x -> pp_string_lit f x
     | ETemplate l -> template f l
     | EBool b -> PP.string f (if b then "true" else "false")
     | ENum num ->
@@ -833,9 +840,7 @@ struct
   and property_name f n =
     match n with
     | PNI (Utf8 s) -> PP.string f s
-    | PNS (Utf8 s) ->
-        let quote = best_string_quote s in
-        pp_string f ~quote s
+    | PNS s -> pp_string_lit f s
     | PNN v -> expression Expression f (ENum v)
     | PComputed e ->
         PP.string f "[";
@@ -1409,6 +1414,140 @@ struct
             PP.string f "finally";
             block f b);
         PP.end_group f
+    | Import ({ kind; from }, _loc) ->
+        PP.start_group f 0;
+        PP.string f "import";
+        (match kind with
+        | SideEffect -> ()
+        | Default i ->
+            PP.space f;
+            ident f i
+        | Namespace (def, i) ->
+            Option.iter def ~f:(fun def ->
+                PP.space f;
+                ident f def;
+                PP.string f ",");
+            PP.space f;
+            PP.string f "* as ";
+            ident f i
+        | Named (def, l) ->
+            Option.iter def ~f:(fun def ->
+                PP.space f;
+                ident f def;
+                PP.string f ",");
+            PP.space f;
+            PP.string f "{";
+            PP.space f;
+            comma_list
+              f
+              (fun f (s, i) ->
+                if match i with
+                   | S { name; _ } when Stdlib.Utf8_string.equal name s -> true
+                   | _ -> false
+                then ident f i
+                else (
+                  pp_ident_or_string_lit f s;
+                  PP.string f " as ";
+                  ident f i))
+              l;
+            PP.space f;
+            PP.string f "}");
+        (match kind with
+        | SideEffect -> ()
+        | _ ->
+            PP.space f;
+            PP.string f "from");
+        PP.space f;
+        pp_string_lit f from;
+        PP.string f ";";
+        PP.end_group f
+    | Export (e, _loc) ->
+        PP.start_group f 0;
+        PP.string f "export";
+        (match e with
+        | ExportNames l ->
+            PP.space f;
+            PP.string f "{";
+            PP.space f;
+            comma_list
+              f
+              (fun f (i, s) ->
+                if match i with
+                   | S { name; _ } when Stdlib.Utf8_string.equal name s -> true
+                   | _ -> false
+                then ident f i
+                else (
+                  ident f i;
+                  PP.string f " as ";
+                  pp_ident_or_string_lit f s))
+              l;
+            PP.space f;
+            PP.string f "};"
+        | ExportFrom { kind; from } ->
+            PP.space f;
+            (match kind with
+            | Export_all None -> PP.string f "*"
+            | Export_all (Some s) ->
+                PP.string f "* as ";
+                pp_ident_or_string_lit f s
+            | Export_names l ->
+                PP.string f "{";
+                PP.space f;
+                comma_list
+                  f
+                  (fun f (a, b) ->
+                    if Stdlib.Utf8_string.equal a b
+                    then pp_ident_or_string_lit f a
+                    else (
+                      pp_ident_or_string_lit f a;
+                      PP.string f " as ";
+                      pp_ident_or_string_lit f b))
+                  l;
+                PP.space f;
+                PP.string f "}");
+            PP.space f;
+            PP.string f "from";
+            PP.space f;
+            pp_string_lit f from;
+            PP.string f ";"
+        | ExportDefaultExpression ((EFun _ | EClass _) as e) ->
+            PP.space f;
+            PP.string f "default";
+            PP.space f;
+            expression Expression f e
+        | ExportDefaultExpression e ->
+            PP.space f;
+            PP.string f "default";
+            PP.space f;
+            parenthesized_expression
+              ~last_semi
+              ~obj:true
+              ~funct:true
+              ~let_identifier:true
+              Expression
+              f
+              e
+        | ExportDefaultFun (id, decl) ->
+            PP.space f;
+            PP.string f "default";
+            PP.space f;
+            statement f (Function_declaration (id, decl), loc)
+        | ExportDefaultClass (id, decl) ->
+            PP.space f;
+            PP.string f "default";
+            PP.space f;
+            statement f (Class_declaration (id, decl), loc)
+        | ExportFun (id, decl) ->
+            PP.space f;
+            statement f (Function_declaration (id, decl), loc)
+        | ExportClass (id, decl) ->
+            PP.space f;
+            statement f (Class_declaration (id, decl), loc)
+        | ExportVar (k, l) ->
+            PP.space f;
+            variable_declaration_list k (not can_omit_semi) f l
+        | CoverExportFrom e -> early_error e);
+        PP.end_group f
 
   and statement_list f ?skip_last_semi b =
     match b with
diff --git a/compiler/lib/js_parser.mly b/compiler/lib/js_parser.mly
index f3a1ccbfd..3f9588374 100644
--- a/compiler/lib/js_parser.mly
+++ b/compiler/lib/js_parser.mly
@@ -67,6 +67,10 @@ let vartok pos tok =
 
 let utf8_s = Stdlib.Utf8_string.of_string_exn
 
+let name_of_ident = function
+  | S { name; _} -> name
+  | V _ -> assert false
+
 %}
 
 (*************************************************************************)
@@ -120,6 +124,7 @@ T_PACKAGE
 T_DEBUGGER
 T_GET T_SET
 T_FROM
+T_AS
 T_TARGET
 T_META
 (*-----------------------------------------*)
@@ -249,6 +254,9 @@ program:
 
 module_item:
   | item { $symbolstartpos, $1 }
+  | import_decl { $symbolstartpos, $1 }
+  | export_decl { $symbolstartpos, $1 }
+
 
 (*************************************************************************)
 (* statement                                                           *)
@@ -269,6 +277,131 @@ decl:
  | class_decl
    { let i,f = $1 in Class_declaration (i,f), p $symbolstartpos }
 
+(*************************************************************************)
+(* Namespace *)
+(*************************************************************************)
+(*----------------------------*)
+(* import *)
+(*----------------------------*)
+
+import_decl:
+ | T_IMPORT kind=import_clause from=from_clause sc
+    { let pos = $symbolstartpos in
+      Import ({ from; kind }, pi pos), p pos }
+ | T_IMPORT from=module_specifier sc
+    { let pos = $symbolstartpos in
+      Import ({ from; kind = SideEffect }, pi pos), p pos }
+
+import_clause:
+ | import_default                            { Default $1 }
+ | import_default "," "*" T_AS id=binding_id { Namespace (Some $1, id) }
+ | "*" T_AS id=binding_id                    { Namespace (None, id) }
+ | import_default "," x=named_imports { Named (Some $1, x) }
+ | x=named_imports                    { Named (None, x) }
+
+import_default: binding_id { $1 }
+
+named_imports:
+ | "{" "}"                             { [] }
+ | "{" listc(import_specifier) "}"     { $2 }
+ | "{" listc(import_specifier) "," "}" { $2 }
+
+(* also valid for export *)
+from_clause: T_FROM module_specifier {$2 }
+
+import_specifier:
+ | binding_id                 { (name_of_ident $1, $1) }
+ | string_or_ident T_AS binding_id         {
+   let (_,s,_) = $1 in
+   (s, $3) }
+
+%inline string_or_ident:
+ | T_STRING { `String, fst $1, $symbolstartpos }
+ | T_DEFAULT { `Ident, Stdlib.Utf8_string.of_string_exn "default", $symbolstartpos }
+ | id { `Ident, $1, $symbolstartpos }
+
+module_specifier:
+  | T_STRING { (fst $1) }
+
+(*----------------------------*)
+(* export *)
+(*----------------------------*)
+
+export_decl:
+  | T_EXPORT names=export_clause sc {
+    let exception Invalid of Lexing.position in
+    let k =
+      try
+        let names =
+          List.map (fun ((k, id,pos), (_,s,_)) ->
+                     match k with
+                     | `Ident -> (var (p pos) id, s)
+                     | `String -> raise (Invalid pos))
+          names
+        in
+        (ExportNames names)
+      with Invalid pos ->
+         CoverExportFrom (early_error (pi pos))
+    in
+    let pos = $symbolstartpos in
+    Export (k, pi pos), p pos }
+ | T_EXPORT v=variable_stmt
+    {
+      let pos = $symbolstartpos in
+      let k = match v with
+        | Variable_statement (k,l) -> ExportVar (k, l)
+        | _ -> assert false
+      in
+      Export (k, pi pos), p pos }
+ | T_EXPORT d=decl
+    { let k = match d with
+        | Variable_statement (k,l),_ -> ExportVar (k,l)
+        | Function_declaration (id, decl),_ -> ExportFun (id,decl)
+        | Class_declaration (id, decl),_ -> ExportClass (id,decl)
+        | _ -> assert false
+      in
+      let pos = $symbolstartpos in
+      Export (k,pi pos), p pos }
+ (* in theory just func/gen/class, no lexical_decl *)
+ | T_EXPORT T_DEFAULT e=assignment_expr sc
+    {
+      let k = match e with
+      | EFun (Some id, decl) ->
+         ExportDefaultFun (id,decl)
+      | EClass (Some id, decl) ->
+         ExportDefaultClass (id, decl)
+      | e -> ExportDefaultExpression e
+      in
+      let pos = $symbolstartpos in
+      Export (k,pi pos), p pos }
+| T_EXPORT "*" T_FROM from=module_specifier sc {
+    let kind = Export_all None in
+    let pos = $symbolstartpos in
+    Export (ExportFrom ({from; kind}),pi pos), p pos
+  }
+ | T_EXPORT "*" T_AS id=string_or_ident T_FROM from=module_specifier sc {
+    let (_,id,_) = id in
+    let kind = Export_all (Some id) in
+    let pos = $symbolstartpos in
+    Export (ExportFrom ({from; kind}), pi pos), p pos
+  }
+| T_EXPORT names=export_clause T_FROM from=module_specifier sc {
+    let names = List.map (fun ((_,a,_), (_,b,_)) -> a, b) names in
+    let kind = Export_names names in
+    let pos = $symbolstartpos in
+    Export (ExportFrom ({from; kind}), pi pos), p pos
+  }
+
+export_specifier:
+ | string_or_ident                       { ($1, $1) }
+ | string_or_ident T_AS string_or_ident  { ($1, $3) }
+
+export_clause:
+ | "{" "}"                              { [] }
+ | "{" listc(export_specifier) "}"      { $2 }
+ | "{" listc(export_specifier) ","  "}" { $2 }
+
+
 (*************************************************************************)
 (* Variable decl *)
 (*************************************************************************)
diff --git a/compiler/lib/js_simpl.ml b/compiler/lib/js_simpl.ml
index 536dc00bb..f552f5249 100644
--- a/compiler/lib/js_simpl.ml
+++ b/compiler/lib/js_simpl.ml
@@ -179,6 +179,8 @@ let rec depth = function
   | Try_statement (b, _, None) -> depth_block b + 1
   | Try_statement (b, _, Some b2) -> max (depth_block b) (depth_block b2) + 1
   | Debugger_statement -> 1
+  | Import _ -> 1
+  | Export _ -> 1
 
 and depth_block b = List.fold_left b ~init:0 ~f:(fun acc (s, _) -> max acc (depth s))
 
diff --git a/compiler/lib/js_token.ml b/compiler/lib/js_token.ml
index 4f0e56c0d..e6a4a7b61 100644
--- a/compiler/lib/js_token.ml
+++ b/compiler/lib/js_token.ml
@@ -148,6 +148,7 @@ type t =
   | T_BACKQUOTE
   | T_DOLLARCURLY
   | T_ENCAPSED_STRING of string
+  | T_AS
   (* Extra tokens *)
   | T_ERROR of string
   | T_EOF
@@ -303,6 +304,7 @@ let to_string = function
   | T_BACKQUOTE -> "`"
   | T_DOLLARCURLY -> "${"
   | T_ENCAPSED_STRING s -> s
+  | T_AS -> "as"
 
 let to_string_extra x =
   to_string x
@@ -375,4 +377,5 @@ let is_keyword s =
   | "from" -> Some T_FROM
   | "target" -> Some T_TARGET
   | "meta" -> Some T_META
+  | "as" -> Some T_AS
   | _ -> None
diff --git a/compiler/lib/js_token.mli b/compiler/lib/js_token.mli
index 6c6a38e62..2771555d8 100644
--- a/compiler/lib/js_token.mli
+++ b/compiler/lib/js_token.mli
@@ -147,6 +147,7 @@ type t =
   | T_BACKQUOTE
   | T_DOLLARCURLY
   | T_ENCAPSED_STRING of string
+  | T_AS
   (* Extra tokens *)
   | T_ERROR of string
   | T_EOF
diff --git a/compiler/lib/js_traverse.ml b/compiler/lib/js_traverse.ml
index 6f9c79cdf..e747f3aa7 100644
--- a/compiler/lib/js_traverse.ml
+++ b/compiler/lib/js_traverse.ml
@@ -71,6 +71,10 @@ class type mapper = object
   method program : Javascript.program -> Javascript.program
 
   method function_body : statement_list -> statement_list
+
+  method import : import -> import
+
+  method export : export -> export
 end
 
 (* generic js ast walk/map *)
@@ -187,6 +191,47 @@ class map : mapper =
             , match final with
               | None -> None
               | Some s -> Some (m#block s) )
+      | Import (import, loc) -> Import (m#import import, loc)
+      | Export (export, loc) -> Export (m#export export, loc)
+
+    method import { from; kind } =
+      let kind =
+        match kind with
+        | Namespace (iopt, i) -> Namespace (Option.map ~f:m#ident iopt, m#ident i)
+        | Named (iopt, l) ->
+            Named
+              (Option.map ~f:m#ident iopt, List.map ~f:(fun (s, id) -> s, m#ident id) l)
+        | Default import_default -> Default (m#ident import_default)
+        | SideEffect -> SideEffect
+      in
+      { from; kind }
+
+    method export e =
+      match e with
+      | ExportVar (k, l) -> (
+          match m#statement (Variable_statement (k, l)) with
+          | Variable_statement (k, l) -> ExportVar (k, l)
+          | _ -> assert false)
+      | ExportFun (id, f) -> (
+          match m#statement (Function_declaration (id, f)) with
+          | Function_declaration (id, f) -> ExportFun (id, f)
+          | _ -> assert false)
+      | ExportClass (id, f) -> (
+          match m#statement (Class_declaration (id, f)) with
+          | Class_declaration (id, f) -> ExportClass (id, f)
+          | _ -> assert false)
+      | ExportNames l -> ExportNames (List.map ~f:(fun (id, s) -> m#ident id, s) l)
+      | ExportDefaultFun (id, decl) -> (
+          match m#statement (Function_declaration (id, decl)) with
+          | Function_declaration (id, decl) -> ExportDefaultFun (id, decl)
+          | _ -> assert false)
+      | ExportDefaultClass (id, decl) -> (
+          match m#statement (Class_declaration (id, decl)) with
+          | Class_declaration (id, decl) -> ExportDefaultClass (id, decl)
+          | _ -> assert false)
+      | ExportDefaultExpression e -> ExportDefaultExpression (m#expression e)
+      | ExportFrom l -> ExportFrom l
+      | CoverExportFrom e -> CoverExportFrom (m#early_error e)
 
     method statement_o x =
       match x with
@@ -340,6 +385,10 @@ class type iterator = object
   method program : Javascript.program -> unit
 
   method function_body : Javascript.statement_list -> unit
+
+  method import : import -> unit
+
+  method export : export -> unit
 end
 
 (* generic js ast iterator *)
@@ -466,6 +515,31 @@ class iter : iterator =
           match final with
           | None -> ()
           | Some s -> m#block s)
+      | Import (x, _loc) -> m#import x
+      | Export (x, _loc) -> m#export x
+
+    method import { from = _; kind } =
+      match kind with
+      | Namespace (iopt, i) ->
+          Option.iter ~f:m#ident iopt;
+          m#ident i
+      | Named (iopt, l) ->
+          Option.iter ~f:m#ident iopt;
+          List.iter ~f:(fun (_, id) -> m#ident id) l
+      | Default import_default -> m#ident import_default
+      | SideEffect -> ()
+
+    method export e =
+      match e with
+      | ExportVar (k, l) -> m#statement (Variable_statement (k, l))
+      | ExportFun (id, f) -> m#statement (Function_declaration (id, f))
+      | ExportClass (id, f) -> m#statement (Class_declaration (id, f))
+      | ExportNames l -> List.iter ~f:(fun (id, _) -> m#ident id) l
+      | ExportDefaultFun (id, decl) -> m#statement (Function_declaration (id, decl))
+      | ExportDefaultClass (id, decl) -> m#statement (Class_declaration (id, decl))
+      | ExportDefaultExpression e -> m#expression e
+      | ExportFrom { from = _; kind = _ } -> ()
+      | CoverExportFrom e -> m#early_error e
 
     method statement_o x =
       match x with
@@ -968,6 +1042,17 @@ class free =
             | Some f -> Some (m#block f)
           in
           Try_statement (b, w, f)
+      | Import ({ from = _; kind }, _) ->
+          (match kind with
+          | Namespace (iopt, i) ->
+              Option.iter ~f:m#def_local iopt;
+              m#def_local i
+          | Named (iopt, l) ->
+              Option.iter ~f:m#def_local iopt;
+              List.iter ~f:(fun (_, id) -> m#def_local id) l
+          | Default import_default -> m#def_local import_default
+          | SideEffect -> ());
+          super#statement x
       | _ -> super#statement x
 
     method for_binding k x =
@@ -985,10 +1070,11 @@ class free =
   end
 
 type scope =
+  | Module
   | Lexical_block
   | Fun_block of ident option
 
-class rename_variable =
+class rename_variable ~esm =
   let declared scope params body =
     let declared_names = ref StringSet.empty in
     let decl_var x =
@@ -997,6 +1083,7 @@ class rename_variable =
       | _ -> ()
     in
     (match scope with
+    | Module -> ()
     | Lexical_block -> ()
     | Fun_block None -> ()
     | Fun_block (Some x) -> decl_var x);
@@ -1014,13 +1101,14 @@ class rename_variable =
 
        method statement x =
          match scope, x with
-         | Fun_block _, Function_declaration (id, fd) ->
+         | (Fun_block _ | Module), Function_declaration (id, fd) ->
              decl_var id;
              self#fun_decl fd
          | Lexical_block, Function_declaration (_, fd) -> self#fun_decl fd
-         | (Lexical_block | Fun_block _), Class_declaration (id, cl_decl) ->
+         | (Fun_block _ | Module), Class_declaration (id, cl_decl) ->
              decl_var id;
              self#class_decl cl_decl
+         | Lexical_block, Class_declaration (_, cl_decl) -> self#class_decl cl_decl
          | _, For_statement (Right (((Const | Let) as k), l), _e1, _e2, (st, _loc)) ->
              let m = {<depth = depth + 1>} in
              List.iter ~f:(m#variable_declaration k) l;
@@ -1038,13 +1126,35 @@ class rename_variable =
              List.iter l ~f:(fun (_, s) -> m#statements s);
              Option.iter def ~f:(fun l -> m#statements l);
              List.iter l' ~f:(fun (_, s) -> m#statements s)
-         | (Fun_block _ | Lexical_block), _ -> super#statement x
+         | _, Import ({ kind; from = _ }, _loc) -> (
+             match kind with
+             | Namespace (iopt, i) ->
+                 Option.iter ~f:decl_var iopt;
+                 decl_var i
+             | Named (iopt, l) ->
+                 Option.iter ~f:decl_var iopt;
+                 List.iter ~f:(fun (_, id) -> decl_var id) l
+             | Default import_default -> decl_var import_default
+             | SideEffect -> ())
+         | (Fun_block _ | Lexical_block | Module), _ -> super#statement x
+
+       method export e =
+         match e with
+         | ExportVar (_k, _l) -> ()
+         | ExportFun (_id, _f) -> ()
+         | ExportClass (_id, _f) -> ()
+         | ExportNames l -> List.iter ~f:(fun (id, _) -> self#ident id) l
+         | ExportDefaultFun (id, decl) -> self#statement (Function_declaration (id, decl))
+         | ExportDefaultClass (id, decl) -> self#statement (Class_declaration (id, decl))
+         | ExportDefaultExpression e -> self#expression e
+         | ExportFrom { from = _; kind = _ } -> ()
+         | CoverExportFrom _ -> ()
 
        method variable_declaration k l =
          if match scope, k with
-            | (Lexical_block | Fun_block _), (Let | Const) -> depth = 0
+            | (Lexical_block | Fun_block _ | Module), (Let | Const) -> depth = 0
             | Lexical_block, Var -> false
-            | Fun_block _, Var -> true
+            | (Fun_block _ | Module), Var -> true
          then
            let ids = bound_idents_of_variable_declaration l in
            List.iter ids ~f:decl_var
@@ -1055,9 +1165,9 @@ class rename_variable =
 
        method for_binding k p =
          if match scope, k with
-            | (Lexical_block | Fun_block _), (Let | Const) -> depth = 0
+            | (Lexical_block | Fun_block _ | Module), (Let | Const) -> depth = 0
             | Lexical_block, Var -> false
-            | Fun_block _, Var -> true
+            | (Fun_block _ | Module), Var -> true
          then
            match p with
            | BindingIdent i -> decl_var i
@@ -1105,8 +1215,13 @@ class rename_variable =
       k, m'#formal_parameter_list params, m'#function_body body, m#loc nid
 
     method program p =
-      let m' = m#update_state Lexical_block [] p in
-      m'#statements p
+      if esm
+      then
+        let m' = m#update_state Module [] p in
+        m'#statements p
+      else
+        let m' = m#update_state Lexical_block [] p in
+        m'#statements p
 
     method expression e =
       match e with
diff --git a/compiler/lib/js_traverse.mli b/compiler/lib/js_traverse.mli
index f931214e1..062402ece 100644
--- a/compiler/lib/js_traverse.mli
+++ b/compiler/lib/js_traverse.mli
@@ -64,6 +64,10 @@ class type mapper = object
   method program : program -> program
 
   method function_body : statement_list -> statement_list
+
+  method import : import -> import
+
+  method export : export -> export
 end
 
 class type iterator = object
@@ -102,6 +106,10 @@ class type iterator = object
   method program : Javascript.program -> unit
 
   method function_body : Javascript.statement_list -> unit
+
+  method import : import -> unit
+
+  method export : export -> unit
 end
 
 class map : mapper
@@ -152,10 +160,11 @@ end
 class free : freevar
 
 type scope =
+  | Module
   | Lexical_block
   | Fun_block of ident option
 
-class rename_variable : object ('a)
+class rename_variable : esm:bool -> object ('a)
   inherit mapper
 
   method update_state : scope -> Javascript.ident list -> Javascript.statement_list -> 'a
diff --git a/compiler/lib/parse_js.ml b/compiler/lib/parse_js.ml
index 3a9edff26..5dcbfb347 100644
--- a/compiler/lib/parse_js.ml
+++ b/compiler/lib/parse_js.ml
@@ -511,10 +511,26 @@ let parse_aux the_parser (lexbuf : Lexer.t) =
       raise (Parsing_error (Parse_info.t_of_pos p))
 
 let fail_early =
-  object
-    inherit Js_traverse.iter
+  object (m)
+    inherit Js_traverse.iter as super
 
     method early_error p = raise (Parsing_error p.loc)
+
+    method statement s =
+      match s with
+      | Import (_, loc) -> raise (Parsing_error loc)
+      | Export (_, loc) -> raise (Parsing_error loc)
+      | _ -> super#statement s
+
+    method program p =
+      List.iter p ~f:(fun ((p : Javascript.statement), _loc) ->
+          match p with
+          | Import _ -> super#statement p
+          | Export (e, _) -> (
+              match e with
+              | CoverExportFrom e -> m#early_error e
+              | _ -> super#statement p)
+          | _ -> super#statement p)
   end
 
 let check_program p = List.iter p ~f:(function _, p -> fail_early#program [ p ])
diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml
index d81187b8a..f68e8cdb5 100644
--- a/compiler/lib/stdlib.ml
+++ b/compiler/lib/stdlib.ml
@@ -1028,6 +1028,8 @@ module Utf8_string : sig
   val of_string_exn : string -> t
 
   val compare : t -> t -> int
+
+  val equal : t -> t -> bool
 end = struct
   type t = Utf8 of string [@@ocaml.unboxed]
 
@@ -1037,6 +1039,8 @@ end = struct
     else invalid_arg "Utf8_string.of_string: invalid utf8 string"
 
   let compare (Utf8 x) (Utf8 y) = String.compare x y
+
+  let equal (Utf8 x) (Utf8 y) = String.equal x y
 end
 
 module Int = struct
diff --git a/compiler/lib/wasm/wa_link.ml b/compiler/lib/wasm/wa_link.ml
index 0c4efbc9c..f778f9b56 100644
--- a/compiler/lib/wasm/wa_link.ml
+++ b/compiler/lib/wasm/wa_link.ml
@@ -315,7 +315,7 @@ let output_js js =
       | S { name = Utf8 x; _ } -> Var_printer.add_reserved x)
     free;
   let js =
-    if Config.Flag.shortvar () then (new Js_traverse.rename_variable)#program js else js
+    if Config.Flag.shortvar () then (new Js_traverse.rename_variable ~esm:false)#program js else js
   in
   let js = (new Js_traverse.simpl)#program js in
   let js = (new Js_traverse.clean)#program js in

From 924ab20b412bc216ebbfa4ab495a89b172807b59 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Oct 2023 21:00:06 +0200
Subject: [PATCH 14/28] Compiler: lazy cmdliner term

---
 compiler/bin-js_of_ocaml/cmd_arg.ml |  4 +-
 compiler/bin-js_of_ocaml/link.ml    |  2 +-
 compiler/bin-jsoo_minify/cmd_arg.ml |  4 +-
 compiler/lib-cmdline/arg.ml         | 90 +++++++++++++++--------------
 compiler/lib-cmdline/arg.mli        |  2 +-
 5 files changed, 54 insertions(+), 48 deletions(-)

diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml
index fd9657b54..2077da267 100644
--- a/compiler/bin-js_of_ocaml/cmd_arg.ml
+++ b/compiler/bin-js_of_ocaml/cmd_arg.ml
@@ -365,7 +365,7 @@ let options =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ set_param
       $ set_env
       $ dynlink
@@ -604,7 +604,7 @@ let options_runtime_only =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ toplevel
       $ no_cmis
       $ set_param
diff --git a/compiler/bin-js_of_ocaml/link.ml b/compiler/bin-js_of_ocaml/link.ml
index 402573401..090913d20 100644
--- a/compiler/bin-js_of_ocaml/link.ml
+++ b/compiler/bin-js_of_ocaml/link.ml
@@ -126,7 +126,7 @@ let options =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ no_sourcemap
       $ sourcemap
       $ sourcemap_inline_in_js
diff --git a/compiler/bin-jsoo_minify/cmd_arg.ml b/compiler/bin-jsoo_minify/cmd_arg.ml
index 0260359a8..743cbe0e2 100644
--- a/compiler/bin-jsoo_minify/cmd_arg.ml
+++ b/compiler/bin-jsoo_minify/cmd_arg.ml
@@ -42,7 +42,9 @@ let options =
   let build_t common files output_file use_stdin =
     `Ok { common; use_stdin; output_file; files }
   in
-  let t = Term.(const build_t $ Jsoo_cmdline.Arg.t $ files $ output_file $ use_stdin) in
+  let t =
+    Term.(const build_t $ Lazy.force Jsoo_cmdline.Arg.t $ files $ output_file $ use_stdin)
+  in
   Term.ret t
 
 let info =
diff --git a/compiler/lib-cmdline/arg.ml b/compiler/lib-cmdline/arg.ml
index aa793f1d4..925dc0f8a 100644
--- a/compiler/lib-cmdline/arg.ml
+++ b/compiler/lib-cmdline/arg.ml
@@ -35,28 +35,31 @@ type t =
   }
 
 let debug =
-  let doc = "enable debug [$(docv)]." in
-  let all = List.map (Debug.available ()) ~f:(fun s -> s, s) in
-  let arg =
-    Arg.(value & opt_all (list (enum all)) [] & info [ "debug" ] ~docv:"SECTION" ~doc)
-  in
-  Term.(const List.flatten $ arg)
+  lazy
+    (let doc = "enable debug [$(docv)]." in
+     let all = List.map (Debug.available ()) ~f:(fun s -> s, s) in
+     let arg =
+       Arg.(value & opt_all (list (enum all)) [] & info [ "debug" ] ~docv:"SECTION" ~doc)
+     in
+     Term.(const List.flatten $ arg))
 
 let enable =
-  let doc = "Enable optimization [$(docv)]." in
-  let all = List.map (Config.Flag.available ()) ~f:(fun s -> s, s) in
-  let arg =
-    Arg.(value & opt_all (list (enum all)) [] & info [ "enable" ] ~docv:"OPT" ~doc)
-  in
-  Term.(const List.flatten $ arg)
+  lazy
+    (let doc = "Enable optimization [$(docv)]." in
+     let all = List.map (Config.Flag.available ()) ~f:(fun s -> s, s) in
+     let arg =
+       Arg.(value & opt_all (list (enum all)) [] & info [ "enable" ] ~docv:"OPT" ~doc)
+     in
+     Term.(const List.flatten $ arg))
 
 let disable =
-  let doc = "Disable optimization [$(docv)]." in
-  let all = List.map (Config.Flag.available ()) ~f:(fun s -> s, s) in
-  let arg =
-    Arg.(value & opt_all (list (enum all)) [] & info [ "disable" ] ~docv:"OPT" ~doc)
-  in
-  Term.(const List.flatten $ arg)
+  lazy
+    (let doc = "Disable optimization [$(docv)]." in
+     let all = List.map (Config.Flag.available ()) ~f:(fun s -> s, s) in
+     let arg =
+       Arg.(value & opt_all (list (enum all)) [] & info [ "disable" ] ~docv:"OPT" ~doc)
+     in
+     Term.(const List.flatten $ arg))
 
 let pretty =
   let doc = "Pretty print the output." in
@@ -86,31 +89,32 @@ let custom_header =
   Arg.(value & opt (some string) None & info [ "custom-header" ] ~doc)
 
 let t =
-  Term.(
-    const (fun debug enable disable pretty debuginfo noinline quiet werror c_header ->
-        let enable = if pretty then "pretty" :: enable else enable in
-        let enable = if debuginfo then "debuginfo" :: enable else enable in
-        let disable = if noinline then "inline" :: disable else disable in
-        let disable_if_pretty name disable =
-          if pretty && not (List.mem name ~set:enable) then name :: disable else disable
-        in
-        let disable = disable_if_pretty "shortvar" disable in
-        let disable = disable_if_pretty "share" disable in
-        { debug = { enable = debug; disable = [] }
-        ; optim = { enable; disable }
-        ; quiet
-        ; werror
-        ; custom_header = c_header
-        })
-    $ debug
-    $ enable
-    $ disable
-    $ pretty
-    $ debuginfo
-    $ noinline
-    $ is_quiet
-    $ is_werror
-    $ custom_header)
+  lazy
+    Term.(
+      const (fun debug enable disable pretty debuginfo noinline quiet werror c_header ->
+          let enable = if pretty then "pretty" :: enable else enable in
+          let enable = if debuginfo then "debuginfo" :: enable else enable in
+          let disable = if noinline then "inline" :: disable else disable in
+          let disable_if_pretty name disable =
+            if pretty && not (List.mem name ~set:enable) then name :: disable else disable
+          in
+          let disable = disable_if_pretty "shortvar" disable in
+          let disable = disable_if_pretty "share" disable in
+          { debug = { enable = debug; disable = [] }
+          ; optim = { enable; disable }
+          ; quiet
+          ; werror
+          ; custom_header = c_header
+          })
+      $ Lazy.force debug
+      $ Lazy.force enable
+      $ Lazy.force disable
+      $ pretty
+      $ debuginfo
+      $ noinline
+      $ is_quiet
+      $ is_werror
+      $ custom_header)
 
 let on_off on off t =
   List.iter ~f:on t.enable;
diff --git a/compiler/lib-cmdline/arg.mli b/compiler/lib-cmdline/arg.mli
index dfa35da02..295f58ac7 100644
--- a/compiler/lib-cmdline/arg.mli
+++ b/compiler/lib-cmdline/arg.mli
@@ -30,6 +30,6 @@ type t =
   ; custom_header : string option
   }
 
-val t : t Cmdliner.Term.t
+val t : t Cmdliner.Term.t Lazy.t
 
 val eval : t -> unit

From ad7a1c800507ec64d9e57a327a91d934471a9fa3 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 11 Dec 2023 14:23:43 +0100
Subject: [PATCH 15/28] Compiler: js-parser: fix class member printing

---
 compiler/lib/js_output.ml                    | 54 ++++++++++++--------
 compiler/tests-compiler/js_parser_printer.ml | 48 +++++++----------
 2 files changed, 51 insertions(+), 51 deletions(-)

diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml
index 1898a8e01..247282fde 100644
--- a/compiler/lib/js_output.ml
+++ b/compiler/lib/js_output.ml
@@ -435,14 +435,7 @@ struct
           | { async = false; generator = true } -> "function*"
         in
         function_declaration f prefix ident i l b pc
-    | EClass (i, cl_decl) ->
-        PP.string f "class";
-        (match i with
-        | None -> ()
-        | Some i ->
-            PP.space f;
-            ident f i);
-        class_declaration f cl_decl
+    | EClass (i, cl_decl) -> class_declaration f i cl_decl
     | EArrow ((k, p, b, pc), _) ->
         if Prec.(l > AssignementExpression)
         then (
@@ -1103,11 +1096,7 @@ struct
           | { async = false; generator = true } -> "function*"
         in
         function_declaration f prefix ident (Some i) l b loc'
-    | Class_declaration (i, cl_decl) ->
-        PP.string f "class";
-        PP.space f;
-        ident f i;
-        class_declaration f cl_decl
+    | Class_declaration (i, cl_decl) -> class_declaration f (Some i) cl_decl
     | Empty_statement -> PP.string f ";"
     | Debugger_statement ->
         PP.string f "debugger";
@@ -1599,23 +1588,39 @@ struct
     PP.string f "}";
     PP.end_group f
 
-  and class_declaration f x =
+  and class_declaration f i x =
+    PP.start_group f 1;
+    PP.start_group f 0;
+    PP.start_group f 0;
+    PP.string f "class";
+    (match i with
+    | None -> ()
+    | Some i ->
+        PP.space f;
+        ident f i);
+    PP.end_group f;
     Option.iter x.extends ~f:(fun e ->
         PP.space f;
         PP.string f "extends";
         PP.space f;
-        expression Expression f e);
+        expression Expression f e;
+        PP.space f);
+    PP.end_group f;
+    PP.start_group f 2;
     PP.string f "{";
-    List.iter x.body ~f:(fun x ->
-        match x with
+    PP.break f;
+    List.iter_last x.body ~f:(fun last x ->
+        (match x with
         | CEMethod (static, n, m) ->
+            PP.start_group f 0;
             if static
             then (
               PP.string f "static";
               PP.space f);
             method_ f class_element_name n m;
-            PP.break f
+            PP.end_group f
         | CEField (static, n, i) ->
+            PP.start_group f 0;
             if static
             then (
               PP.string f "static";
@@ -1629,12 +1634,19 @@ struct
                 PP.space f;
                 output_debug_info f loc;
                 expression Expression f e);
-            PP.break f
+            PP.string f ";";
+            PP.end_group f
         | CEStaticBLock l ->
+            PP.start_group f 0;
             PP.string f "static";
+            PP.space f;
             block f l;
-            PP.break f);
-    PP.string f "}"
+            PP.end_group f);
+        if not last then PP.break f);
+    PP.end_group f;
+    PP.break f;
+    PP.string f "}";
+    PP.end_group f
 
   and class_element_name f x =
     match x with
diff --git a/compiler/tests-compiler/js_parser_printer.ml b/compiler/tests-compiler/js_parser_printer.ml
index 53014de09..e3e01d341 100644
--- a/compiler/tests-compiler/js_parser_printer.ml
+++ b/compiler/tests-compiler/js_parser_printer.ml
@@ -527,36 +527,24 @@ class x extends p {
 
   [%expect
     {|
-     /*<<fake:2:0>>*/ class
-    x
-    extends
-    p{constructor(){
-      /*<<fake:4:6>>*/  /*<<fake:4:6>>*/ super(a, b, c);
-     /*<<fake:3:4>>*/ }
-    foo(){
-      /*<<fake:8:6>>*/  /*<<fake:8:12>>*/ var s = super[d];
-      /*<<fake:9:6>>*/  /*<<fake:9:12>>*/ var s = super.d;
-     /*<<fake:6:4>>*/ }
-    static
-    bar(){
-      /*<<fake:14:6>>*/  /*<<fake:14:12>>*/ var s = super[d];
-      /*<<fake:15:6>>*/  /*<<fake:15:12>>*/ var s = super.d;
-     /*<<fake:12:11>>*/ }
-    x
-    =
-     /*<<fake:17:5>>*/ 3
-    static
-    y
-    =
-     /*<<fake:19:12>>*/ 5
-    #z
-    =
-     /*<<fake:21:6>>*/ 6
-    static
-    #t
-    =
-     /*<<fake:23:13>>*/ 2
-    static{ /*<<fake:25:12>>*/  /*<<fake:25:18>>*/ var x = 3;}
+    /*<<fake:2:0>>*/ class x extends p {
+      constructor(){
+        /*<<fake:4:6>>*/  /*<<fake:4:6>>*/ super(a, b, c);
+       /*<<fake:3:4>>*/ }
+      foo(){
+        /*<<fake:8:6>>*/  /*<<fake:8:12>>*/ var s = super[d];
+        /*<<fake:9:6>>*/  /*<<fake:9:12>>*/ var s = super.d;
+       /*<<fake:6:4>>*/ }
+      static
+      bar(){
+        /*<<fake:14:6>>*/  /*<<fake:14:12>>*/ var s = super[d];
+        /*<<fake:15:6>>*/  /*<<fake:15:12>>*/ var s = super.d;
+       /*<<fake:12:11>>*/ }
+      x =  /*<<fake:17:5>>*/ 3;
+      static y =  /*<<fake:19:12>>*/ 5;
+      #z =  /*<<fake:21:6>>*/ 6;
+      static #t =  /*<<fake:23:13>>*/ 2;
+      static { /*<<fake:25:12>>*/  /*<<fake:25:18>>*/ var x = 3;}
     } |}]
 
 let%expect_test "ite" =

From df89877efd10f9d8c49eb23b5dbd6ac3abe852e6 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sun, 17 Dec 2023 09:23:13 +0100
Subject: [PATCH 16/28] Compiler: js-parser: preserve consise body

---
 compiler/bin-wasm_of_ocaml/cmd_arg.ml |  4 ++--
 compiler/bin-wasm_of_ocaml/link.ml    |  2 +-
 compiler/lib/javascript.ml            |  2 +-
 compiler/lib/javascript.mli           |  2 +-
 compiler/lib/js_output.ml             |  8 ++++----
 compiler/lib/js_parser.mly            | 17 +++++++++++------
 compiler/lib/js_traverse.ml           | 18 +++++++++---------
 compiler/lib/wasm/wa_gc_target.ml     |  9 ++++++++-
 compiler/lib/wasm/wa_link.ml          |  6 +++++-
 compiler/tests-compiler/es6.ml        |  2 +-
 compiler/tests-compiler/util/util.ml  |  2 +-
 11 files changed, 44 insertions(+), 28 deletions(-)

diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml
index 59bd343d4..9579d7a1f 100644
--- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml
+++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml
@@ -145,7 +145,7 @@ let options =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ set_param
       $ include_dirs
       $ profile
@@ -226,7 +226,7 @@ let options_runtime_only =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ set_param
       $ include_dirs
       $ sourcemap
diff --git a/compiler/bin-wasm_of_ocaml/link.ml b/compiler/bin-wasm_of_ocaml/link.ml
index db36e305d..117212847 100644
--- a/compiler/bin-wasm_of_ocaml/link.ml
+++ b/compiler/bin-wasm_of_ocaml/link.ml
@@ -60,7 +60,7 @@ let options =
   let t =
     Term.(
       const build_t
-      $ Jsoo_cmdline.Arg.t
+      $ Lazy.force Jsoo_cmdline.Arg.t
       $ no_sourcemap
       $ sourcemap
       $ output_file
diff --git a/compiler/lib/javascript.ml b/compiler/lib/javascript.ml
index 256f3cc09..7825a535f 100644
--- a/compiler/lib/javascript.ml
+++ b/compiler/lib/javascript.ml
@@ -283,7 +283,7 @@ and expression =
   | EVar of ident
   | EFun of ident option * function_declaration
   | EClass of ident option * class_declaration
-  | EArrow of function_declaration * arrow_info
+  | EArrow of function_declaration * bool * arrow_info
   | EStr of Utf8_string.t
   | ETemplate of template
   | EArr of array_litteral
diff --git a/compiler/lib/javascript.mli b/compiler/lib/javascript.mli
index 69a87bea9..2910aca87 100644
--- a/compiler/lib/javascript.mli
+++ b/compiler/lib/javascript.mli
@@ -200,7 +200,7 @@ and expression =
   | EVar of ident
   | EFun of ident option * function_declaration
   | EClass of ident option * class_declaration
-  | EArrow of function_declaration * arrow_info
+  | EArrow of function_declaration * bool * arrow_info
   | EStr of Utf8_string.t
   (* A UTF-8 encoded string that may contain escape sequences. *)
   | ETemplate of template
diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml
index 247282fde..fb1646080 100644
--- a/compiler/lib/js_output.ml
+++ b/compiler/lib/js_output.ml
@@ -436,7 +436,7 @@ struct
         in
         function_declaration f prefix ident i l b pc
     | EClass (i, cl_decl) -> class_declaration f i cl_decl
-    | EArrow ((k, p, b, pc), _) ->
+    | EArrow ((k, p, b, pc), consise, _) ->
         if Prec.(l > AssignementExpression)
         then (
           PP.start_group f 1;
@@ -461,15 +461,15 @@ struct
             PP.string f ")=>";
             PP.end_group f);
         PP.end_group f;
-        (match b with
-        | [ (Return_statement (Some e), loc) ] ->
+        (match b, consise with
+        | [ (Return_statement (Some e), loc) ], true ->
             (* Should not starts with '{' *)
             PP.start_group f 1;
             PP.break1 f;
             output_debug_info f loc;
             parenthesized_expression ~obj:true AssignementExpression f e;
             PP.end_group f
-        | l ->
+        | l, _ ->
             let b =
               match l with
               | [ (Block l, _) ] -> l
diff --git a/compiler/lib/js_parser.mly b/compiler/lib/js_parser.mly
index 3f9588374..be6500232 100644
--- a/compiler/lib/js_parser.mly
+++ b/compiler/lib/js_parser.mly
@@ -1034,20 +1034,25 @@ encaps:
 (* TODO conflict with as then in indent_keyword_bis *)
 arrow_function:
   | i=ident T_ARROW b=arrow_body
-    { EArrow (({async = false; generator = false}, list [param' i],b, p $symbolstartpos), AUnknown) }
+    { let b,consise = b in
+      EArrow (({async = false; generator = false}, list [param' i],b, p $symbolstartpos), consise, AUnknown) }
   | T_LPAREN_ARROW a=formal_parameter_list_opt ")" T_ARROW b=arrow_body
-    { EArrow (({async = false; generator = false}, a,b, p $symbolstartpos), AUnknown) }
+    { let b,consise = b in
+      EArrow (({async = false; generator = false}, a,b, p $symbolstartpos), consise, AUnknown) }
 
 async_arrow_function:
-  | T_ASYNC i=ident T_ARROW b=arrow_body { EArrow(({async = true; generator = false}, list [param' i],b, p $symbolstartpos), AUnknown) }
+  | T_ASYNC i=ident T_ARROW b=arrow_body {
+      let b,consise = b in
+      EArrow(({async = true; generator = false}, list [param' i],b, p $symbolstartpos), consise, AUnknown) }
   | T_ASYNC T_LPAREN_ARROW a=formal_parameter_list_opt ")" T_ARROW b=arrow_body
-    { EArrow (({async = true; generator = false}, a,b, p $symbolstartpos), AUnknown) }
+    { let b,consise = b in
+      EArrow (({async = true; generator = false}, a,b, p $symbolstartpos), consise, AUnknown) }
 
 
 (* was called consise body in spec *)
 arrow_body:
- | "{" b=function_body "}" { b }
- | e=assignment_expr_for_consise_body { [(Return_statement (Some e), p $symbolstartpos)] }
+ | "{" b=function_body "}" { b, false }
+ | e=assignment_expr_for_consise_body { [(Return_statement (Some e), p $symbolstartpos)], true }
 
 (*----------------------------*)
 (* no in                    *)
diff --git a/compiler/lib/js_traverse.ml b/compiler/lib/js_traverse.ml
index e747f3aa7..96b098556 100644
--- a/compiler/lib/js_traverse.ml
+++ b/compiler/lib/js_traverse.ml
@@ -270,7 +270,7 @@ class map : mapper =
           let idopt = Option.map ~f:m#ident idopt in
           EFun (idopt, m#fun_decl fun_decl)
       | EClass (id, cl_decl) -> EClass (Option.map ~f:m#ident id, m#class_decl cl_decl)
-      | EArrow (fun_decl, x) -> EArrow (m#fun_decl fun_decl, x)
+      | EArrow (fun_decl, consise, x) -> EArrow (m#fun_decl fun_decl, consise, x)
       | EArr l ->
           EArr
             (List.map l ~f:(function
@@ -595,7 +595,7 @@ class iter : iterator =
       | EClass (i, cl_decl) ->
           Option.iter ~f:m#ident i;
           m#class_decl cl_decl
-      | EArrow (fun_decl, _) -> m#fun_decl fun_decl
+      | EArrow (fun_decl, _, _) -> m#fun_decl fun_decl
       | EArr l ->
           List.iter l ~f:(function
               | ElementHole -> ()
@@ -1590,9 +1590,9 @@ let use_fun_context l =
 
        method expression x =
          match x with
-         | EArrow (_, ANo_fun_context) -> ()
-         | EArrow (_, AUse_parent_fun_context) -> raise True
-         | EArrow (fun_decl, AUnknown) -> super#fun_decl fun_decl
+         | EArrow (_, _, ANo_fun_context) -> ()
+         | EArrow (_, _, AUse_parent_fun_context) -> raise True
+         | EArrow (fun_decl, _, AUnknown) -> super#fun_decl fun_decl
          | _ -> super#expression x
     end)
       #statements
@@ -1632,11 +1632,11 @@ class simpl =
       | EFun
           (None, (({ generator = false; async = true | false }, _, body, _) as fun_decl))
         when Config.Flag.es6 () && not (use_fun_context body) ->
-          EArrow (fun_decl, ANo_fun_context)
-      | EArrow (((_, _, body, _) as fun_decl), AUnknown) ->
+          EArrow (fun_decl, false, ANo_fun_context)
+      | EArrow (((_, _, body, _) as fun_decl), consise, AUnknown) ->
           if use_fun_context body
-          then EArrow (fun_decl, AUse_parent_fun_context)
-          else EArrow (fun_decl, ANo_fun_context)
+          then EArrow (fun_decl, consise, AUse_parent_fun_context)
+          else EArrow (fun_decl, consise, ANo_fun_context)
       | e -> e
 
     method statement s =
diff --git a/compiler/lib/wasm/wa_gc_target.ml b/compiler/lib/wasm/wa_gc_target.ml
index d0b85b737..4c0d714a1 100644
--- a/compiler/lib/wasm/wa_gc_target.ml
+++ b/compiler/lib/wasm/wa_gc_target.ml
@@ -1453,7 +1453,7 @@ let () =
               let name = Printf.sprintf "js_expr_%x" (String.hash str) in
               let* () =
                 register_fragment name (fun () ->
-                    EArrow (J.fun_ [] [ Return_statement (Some e), N ] N, AUnknown))
+                    EArrow (J.fun_ [] [ Return_statement (Some e), N ] N, true, AUnknown))
               in
               let* js_val = JavaScript.invoke_fragment name [] in
               return (W.Call (wrap, [ js_val ]))
@@ -1505,6 +1505,7 @@ let () =
                     , N )
                   ]
                   N
+              , true
               , AUnknown ))
       in
       let l = List.map ~f:transl_prim_arg l in
@@ -1531,6 +1532,7 @@ let () =
                     , N )
                   ]
                   N
+              , true
               , AUnknown ))
       in
       let l = List.map ~f:transl_prim_arg l in
@@ -1562,6 +1564,7 @@ let () =
                         , N )
                       ]
                       N
+                  , true
                   , AUnknown ))
           in
           let o = transl_prim_arg o in
@@ -1591,6 +1594,7 @@ let () =
                     , N )
                   ]
                   N
+              , true
               , AUnknown ))
       in
       let l = List.map ~f:transl_prim_arg l in
@@ -1610,6 +1614,7 @@ let () =
                       [ J.ident o ]
                       [ Return_statement (Some (J.dot (EVar (J.ident o)) prop)), N ]
                       N
+                  , true
                   , AUnknown ))
           in
           JavaScript.invoke_fragment name [ transl_prim_arg x ]
@@ -1636,6 +1641,7 @@ let () =
                         , N )
                       ]
                       N
+                  , true
                   , AUnknown ))
           in
           let l = List.map ~f:transl_prim_arg [ x; y ] in
@@ -1678,6 +1684,7 @@ let () =
                     , N )
                   ]
                   N
+              , true
               , AUnknown ))
       in
       let l = List.map ~f:transl_prim_arg vl in
diff --git a/compiler/lib/wasm/wa_link.ml b/compiler/lib/wasm/wa_link.ml
index f778f9b56..93aa9d82f 100644
--- a/compiler/lib/wasm/wa_link.ml
+++ b/compiler/lib/wasm/wa_link.ml
@@ -315,7 +315,9 @@ let output_js js =
       | S { name = Utf8 x; _ } -> Var_printer.add_reserved x)
     free;
   let js =
-    if Config.Flag.shortvar () then (new Js_traverse.rename_variable ~esm:false)#program js else js
+    if Config.Flag.shortvar ()
+    then (new Js_traverse.rename_variable ~esm:false)#program js
+    else js
   in
   let js = (new Js_traverse.simpl)#program js in
   let js = (new Js_traverse.clean)#program js in
@@ -400,6 +402,7 @@ let build_runtime_arguments
                          , N )
                        ]
                        N
+                   , false
                    , AUnknown ) ))
              missing_primitives) )
       :: generated_js
@@ -434,6 +437,7 @@ let build_runtime_arguments
                ; Return_statement (Some (obj generated_js)), N
                ]
                N
+           , true
            , AUnknown ))
         [ EVar (Javascript.ident Constant.global_object_) ]
         N
diff --git a/compiler/tests-compiler/es6.ml b/compiler/tests-compiler/es6.ml
index f6c57fcfd..da1a23a05 100644
--- a/compiler/tests-compiler/es6.ml
+++ b/compiler/tests-compiler/es6.ml
@@ -18,7 +18,7 @@ let f x =
        "use strict";
        var
         runtime = globalThis.jsoo_runtime,
-        f = x=>{var g = y=>(x + y | 0) + 7 | 0; return g;},
+        f = x=>{var g = y=>{return (x + y | 0) + 7 | 0;}; return g;},
         Test = [0, f];
        runtime.caml_register_global(0, Test, "Test");
        return;})
diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml
index 6ee690804..7606abf2d 100644
--- a/compiler/tests-compiler/util/util.ml
+++ b/compiler/tests-compiler/util/util.ml
@@ -465,7 +465,7 @@ class find_function_declaration r n =
           List.iter l ~f:(function
               | DeclIdent
                   ( (S { name = Utf8 name; _ } as id)
-                  , Some ((EFun (_, fun_decl) | EArrow (fun_decl, _)), _) ) -> (
+                  , Some ((EFun (_, fun_decl) | EArrow (fun_decl, _, _)), _) ) -> (
                   let fd = id, fun_decl in
                   match n with
                   | None -> r := fd :: !r

From d2b703a91b8003ecca699538df228771ad9b0f73 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 7 Dec 2023 10:54:28 +0100
Subject: [PATCH 17/28] Compiler: js-parser: fix assignment target

---
 compiler/lib/javascript.ml                   | 76 ++++++++++----------
 compiler/lib/javascript.mli                  | 20 +++++-
 compiler/lib/js_output.ml                    | 55 +++++++++++++-
 compiler/lib/js_parser.mly                   | 30 ++++----
 compiler/lib/js_traverse.ml                  | 47 +++++++++++-
 compiler/tests-compiler/js_parser_printer.ml | 46 +++++++-----
 6 files changed, 194 insertions(+), 80 deletions(-)

diff --git a/compiler/lib/javascript.ml b/compiler/lib/javascript.ml
index 7825a535f..633d96a86 100644
--- a/compiler/lib/javascript.ml
+++ b/compiler/lib/javascript.ml
@@ -272,7 +272,7 @@ and property_name =
 and expression =
   | ESeq of expression * expression
   | ECond of expression * expression * expression
-  | EAssignTarget of binding_pattern
+  | EAssignTarget of assignment_target
   | EBin of binop * expression * expression
   | EUn of unop * expression
   | ECall of expression * access_kind * arguments * location
@@ -414,6 +414,22 @@ and binding_pattern =
   | ObjectBinding of (binding_property, binding_ident) list_with_rest
   | ArrayBinding of (binding_element option, binding) list_with_rest
 
+and object_target_elt =
+  | TargetPropertyId of ident * initialiser option
+  | TargetProperty of property_name * expression
+  | TargetPropertySpread of expression
+  | TargetPropertyMethod of property_name * method_
+
+and array_target_elt =
+  | TargetElementId of ident * initialiser option
+  | TargetElementHole
+  | TargetElement of expression
+  | TargetElementSpread of expression
+
+and assignment_target =
+  | ObjectTarget of object_target_elt list
+  | ArrayTarget of array_target_elt list
+
 and binding_ident = ident
 
 and binding_property =
@@ -557,51 +573,33 @@ let fun_ params body loc =
   , body
   , loc )
 
-let rec assignment_pattern_of_expr x =
+let rec assignment_target_of_expr' x =
   match x with
   | EObj l ->
-      let rest, l =
-        match List.rev l with
-        | PropertySpread (EVar x) :: l -> Some x, List.rev l
-        | _ -> None, l
-      in
       let list =
         List.map l ~f:(function
-            | Property (PNI (Utf8 i), EVar (S { name = Utf8 i2; loc = N; _ } as ident))
-              when String.equal i i2 -> Prop_ident (ident, None)
-            | Property (n, e) -> Prop_binding (n, binding_element_of_expression e)
-            | CoverInitializedName (_, i, e) -> Prop_ident (i, Some e)
-            | _ -> raise Not_found)
+            | Property (PNI n, EVar (S { name = n'; _ } as id))
+              when Utf8_string.equal n n' -> TargetPropertyId (id, None)
+            | Property (n, e) -> TargetProperty (n, assignment_target_of_expr' e)
+            | CoverInitializedName (_, i, (e, loc)) ->
+                TargetPropertyId (i, Some (assignment_target_of_expr' e, loc))
+            | PropertySpread e -> TargetPropertySpread (assignment_target_of_expr' e)
+            | PropertyMethod (n, m) -> TargetPropertyMethod (n, m))
       in
-      ObjectBinding { list; rest }
+      EAssignTarget (ObjectTarget list)
   | EArr l ->
-      let rest, l =
-        match List.rev l with
-        | ElementSpread e :: l -> Some (binding_of_expression e), List.rev l
-        | _ -> None, l
-      in
       let list =
         List.map l ~f:(function
-            | ElementHole -> None
-            | Element e -> Some (binding_element_of_expression e)
-            | ElementSpread _ -> raise Not_found)
+            | ElementHole -> TargetElementHole
+            | Element (EVar x) -> TargetElementId (x, None)
+            | Element (EBin (Eq, EVar x, rhs)) -> TargetElementId (x, Some (rhs, N))
+            | Element e -> TargetElement (assignment_target_of_expr' e)
+            | ElementSpread e -> TargetElementSpread (assignment_target_of_expr' e))
       in
-      ArrayBinding { list; rest }
-  | _ -> raise Not_found
-
-and binding_element_of_expression e =
-  match e with
-  | EBin (Eq, e1, e2) -> binding_of_expression e1, Some (e2, N)
-  | e -> binding_of_expression e, None
-
-and binding_of_expression e =
-  match e with
-  | EVar x -> BindingIdent x
-  | EObj _ as x -> BindingPattern (assignment_pattern_of_expr x)
-  | EArr _ as x -> BindingPattern (assignment_pattern_of_expr x)
-  | _ -> raise Not_found
-
-let assignment_pattern_of_expr op x =
+      EAssignTarget (ArrayTarget list)
+  | _ -> x
+
+and assignment_target_of_expr op x =
   match op with
-  | None | Some Eq -> ( try Some (assignment_pattern_of_expr x) with Not_found -> None)
-  | _ -> None
+  | None | Some Eq -> assignment_target_of_expr' x
+  | _ -> x
diff --git a/compiler/lib/javascript.mli b/compiler/lib/javascript.mli
index 2910aca87..10716a427 100644
--- a/compiler/lib/javascript.mli
+++ b/compiler/lib/javascript.mli
@@ -185,7 +185,7 @@ and property_name =
 and expression =
   | ESeq of expression * expression
   | ECond of expression * expression * expression
-  | EAssignTarget of binding_pattern
+  | EAssignTarget of assignment_target
   (* EAssignTarget is used on the LHS of assignment and in for-loops.
      for({name} in o);
      for([fst] in o);
@@ -334,6 +334,22 @@ and binding_pattern =
   | ObjectBinding of (binding_property, binding_ident) list_with_rest
   | ArrayBinding of (binding_element option, binding) list_with_rest
 
+and object_target_elt =
+  | TargetPropertyId of ident * initialiser option
+  | TargetProperty of property_name * expression
+  | TargetPropertySpread of expression
+  | TargetPropertyMethod of property_name * method_
+
+and array_target_elt =
+  | TargetElementId of ident * initialiser option
+  | TargetElementHole
+  | TargetElement of expression
+  | TargetElementSpread of expression
+
+and assignment_target =
+  | ObjectTarget of object_target_elt list
+  | ArrayTarget of array_target_elt list
+
 and binding_ident = ident
 
 and binding_property =
@@ -424,4 +440,4 @@ val early_error : ?reason:string -> Parse_info.t -> early_error
 
 val fun_ : ident list -> statement_list -> location -> function_declaration
 
-val assignment_pattern_of_expr : binop option -> expression -> binding_pattern option
+val assignment_target_of_expr : binop option -> expression -> expression
diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml
index fb1646080..d1b3e3267 100644
--- a/compiler/lib/js_output.ml
+++ b/compiler/lib/js_output.ml
@@ -303,8 +303,8 @@ struct
       | ESeq (e, _) -> Prec.(l <= Expression) && traverse Expression e
       | ECond (e, _, _) ->
           Prec.(l <= ConditionalExpression) && traverse ShortCircuitExpression e
-      | EAssignTarget (ObjectBinding _) -> obj
-      | EAssignTarget (ArrayBinding _) -> false
+      | EAssignTarget (ObjectTarget _) -> obj
+      | EAssignTarget (ArrayTarget _) -> false
       | EBin (op, e, _) ->
           let out, lft, _rght = op_prec op in
           Prec.(l <= out) && traverse lft e
@@ -690,7 +690,56 @@ struct
         if Prec.(l > out) then PP.string f ")";
         PP.end_group f;
         PP.end_group f
-    | EAssignTarget p -> pattern f p
+    | EAssignTarget t -> (
+        let property f p =
+          match p with
+          | TargetPropertyId (id, None) -> ident f id
+          | TargetPropertyId (id, Some (e, _)) ->
+              ident f id;
+              PP.space f;
+              PP.string f "=";
+              PP.space f;
+              expression AssignementExpression f e
+          | TargetProperty (pn, e) ->
+              PP.start_group f 0;
+              property_name f pn;
+              PP.string f ":";
+              PP.space f;
+              expression AssignementExpression f e;
+              PP.end_group f
+          | TargetPropertySpread e ->
+              PP.string f "...";
+              expression AssignementExpression f e
+          | TargetPropertyMethod (n, m) -> method_ f property_name n m
+        in
+        let element f p =
+          match p with
+          | TargetElementHole -> ()
+          | TargetElementId (id, None) -> ident f id
+          | TargetElementId (id, Some (e, _)) ->
+              ident f id;
+              PP.space f;
+              PP.string f "=";
+              PP.space f;
+              expression AssignementExpression f e
+          | TargetElement e -> expression AssignementExpression f e
+          | TargetElementSpread e ->
+              PP.string f "...";
+              expression AssignementExpression f e
+        in
+        match t with
+        | ObjectTarget list ->
+            PP.start_group f 1;
+            PP.string f "{";
+            comma_list f property list;
+            PP.string f "}";
+            PP.end_group f
+        | ArrayTarget list ->
+            PP.start_group f 1;
+            PP.string f "[";
+            comma_list f element list;
+            PP.string f "]";
+            PP.end_group f)
     | EArr el ->
         PP.start_group f 1;
         PP.string f "[";
diff --git a/compiler/lib/js_parser.mly b/compiler/lib/js_parser.mly
index be6500232..8c31449a4 100644
--- a/compiler/lib/js_parser.mly
+++ b/compiler/lib/js_parser.mly
@@ -673,16 +673,14 @@ iteration_stmt:
    { For_statement (Right l, c, incr, st) }
 
  | T_FOR "(" left=left_hand_side_expr T_IN right=expr ")" body=stmt
-   { match assignment_pattern_of_expr None left with
-      | None -> ForIn_statement (Left left, right, body)
-      | Some b -> ForIn_statement (Left (EAssignTarget b), right, body) }
+   { let left = assignment_target_of_expr None left in
+     ForIn_statement (Left left, right, body) }
  | T_FOR "(" left=for_single_variable_decl T_IN right=expr ")" body=stmt
    { ForIn_statement (Right left, right, body) }
 
  | T_FOR "(" left=left_hand_side_expr T_OF right=assignment_expr ")" body=stmt
-    { match assignment_pattern_of_expr None left with
-      | None -> ForOf_statement (Left left, right, body)
-      | Some b -> ForOf_statement (Left (EAssignTarget b), right, body) }
+    { let left = assignment_target_of_expr None left in
+      ForOf_statement (Left left, right, body) }
  | T_FOR "(" left=for_single_variable_decl T_OF right=assignment_expr ")" body=stmt
    { ForOf_statement (Right left, right, body) }
 
@@ -751,9 +749,8 @@ assignment_expr:
  | conditional_expr(d1) { $1 }
  | e1=left_hand_side_expr_(d1) op=assignment_operator e2=assignment_expr
     {
-      match assignment_pattern_of_expr (Some op) e1 with
-        | None -> EBin (op, e1, e2)
-        | Some pat -> EBin (op, EAssignTarget pat, e2)
+      let e1 = assignment_target_of_expr (Some op) e1 in
+      EBin (op, e1, e2)
     }
  | arrow_function { $1 }
  | async_arrow_function { $1 }
@@ -1066,9 +1063,8 @@ assignment_expr_no_in:
  | conditional_expr_no_in { $1 }
  | e1=left_hand_side_expr_(d1) op=assignment_operator e2=assignment_expr_no_in
     {
-      match assignment_pattern_of_expr (Some op) e1 with
-        | None -> EBin (op, e1, e2)
-        | Some pat -> EBin (op, EAssignTarget pat, e2)
+      let e1 = assignment_target_of_expr (Some op) e1 in
+      EBin (op, e1, e2)
     }
 
 conditional_expr_no_in:
@@ -1109,9 +1105,8 @@ assignment_expr_no_stmt:
  | conditional_expr(primary_no_stmt) { $1 }
  | e1=left_hand_side_expr_(primary_no_stmt) op=assignment_operator e2=assignment_expr
     {
-      match assignment_pattern_of_expr (Some op) e1 with
-      | None -> EBin (op, e1, e2)
-      | Some pat -> EBin (op, EAssignTarget pat, e2)
+      let e1 = assignment_target_of_expr (Some op) e1 in
+      EBin (op, e1, e2)
     }
  (* es6: *)
  | arrow_function { $1 }
@@ -1134,9 +1129,8 @@ assignment_expr_for_consise_body:
  | conditional_expr(primary_for_consise_body) { $1 }
  | e1=left_hand_side_expr_(primary_for_consise_body) op=assignment_operator e2=assignment_expr
     {
-      match assignment_pattern_of_expr (Some op) e1 with
-      | None -> EBin (op, e1, e2)
-      | Some pat -> EBin (op, EAssignTarget pat, e2)
+      let e1 = assignment_target_of_expr (Some op) e1 in
+      EBin (op, e1, e2)
     }
  (* es6: *)
  | arrow_function { $1 }
diff --git a/compiler/lib/js_traverse.ml b/compiler/lib/js_traverse.ml
index 96b098556..34fddd54e 100644
--- a/compiler/lib/js_traverse.ml
+++ b/compiler/lib/js_traverse.ml
@@ -255,7 +255,29 @@ class map : mapper =
       | ESeq (e1, e2) -> ESeq (m#expression e1, m#expression e2)
       | ECond (e1, e2, e3) -> ECond (m#expression e1, m#expression e2, m#expression e3)
       | EBin (b, e1, e2) -> EBin (b, m#expression e1, m#expression e2)
-      | EAssignTarget p -> EAssignTarget (m#binding_pattern p)
+      | EAssignTarget x -> (
+          match x with
+          | ArrayTarget l ->
+              EAssignTarget
+                (ArrayTarget
+                   (List.map l ~f:(function
+                       | TargetElementHole -> TargetElementHole
+                       | TargetElementId (i, e) ->
+                           TargetElementId (m#ident i, m#initialiser_o e)
+                       | TargetElement e -> TargetElement (m#expression e)
+                       | TargetElementSpread e -> TargetElementSpread (m#expression e))))
+          | ObjectTarget l ->
+              EAssignTarget
+                (ObjectTarget
+                   (List.map l ~f:(function
+                       | TargetPropertyId (i, e) ->
+                           TargetPropertyId (m#ident i, m#initialiser_o e)
+                       | TargetProperty (i, e) ->
+                           TargetProperty (m#property_name i, m#expression e)
+                       | TargetPropertyMethod (n, x) ->
+                           TargetPropertyMethod (m#property_name n, m#method_ x)
+                       | TargetPropertySpread e -> TargetPropertySpread (m#expression e))))
+          )
       | EUn (b, e1) -> EUn (b, m#expression e1)
       | ECallTemplate (e1, t, loc) ->
           ECallTemplate (m#expression e1, m#template t, m#loc loc)
@@ -570,7 +592,28 @@ class iter : iterator =
       | EBin (_, e1, e2) ->
           m#expression e1;
           m#expression e2
-      | EAssignTarget p -> m#binding_pattern p
+      | EAssignTarget x -> (
+          match x with
+          | ArrayTarget l ->
+              List.iter l ~f:(function
+                  | TargetElementHole -> ()
+                  | TargetElementId (i, e) ->
+                      m#ident i;
+                      m#initialiser_o e
+                  | TargetElement e -> m#expression e
+                  | TargetElementSpread e -> m#expression e)
+          | ObjectTarget l ->
+              List.iter l ~f:(function
+                  | TargetPropertyId (i, e) ->
+                      m#ident i;
+                      m#initialiser_o e
+                  | TargetProperty (i, e) ->
+                      m#property_name i;
+                      m#expression e
+                  | TargetPropertyMethod (n, x) ->
+                      m#property_name n;
+                      m#method_ x
+                  | TargetPropertySpread e -> m#expression e))
       | EUn (_, e1) -> m#expression e1
       | ECall (e1, _ak, e2, _) ->
           m#expression e1;
diff --git a/compiler/tests-compiler/js_parser_printer.ml b/compiler/tests-compiler/js_parser_printer.ml
index e3e01d341..d049b811a 100644
--- a/compiler/tests-compiler/js_parser_printer.ml
+++ b/compiler/tests-compiler/js_parser_printer.ml
@@ -416,22 +416,20 @@ let%expect_test "assignment pattern" =
 
   [%expect
     {|
-     /*<<fake:2:4>>*/ var x, y, rest;
-     /*<<fake:3:4>>*/  /*<<fake:3:14>>*/ var [x, y] = [1, 2];
-     /*<<fake:4:4>>*/  /*<<fake:4:22>>*/ var [x, y, ...rest] = [1, 2, ...o];
-     /*<<fake:6:4>>*/  /*<<fake:6:14>>*/ var {x: x, y: y} = {x: 1, y: 2};
-     /*<<fake:7:4>>*/  /*<<fake:7:22>>*/ var
-     {x: x, y: y, ...rest} = {x: 1, y: 2, ...o};
-     /*<<fake:9:4>>*/ [x, y] = [1, 2];
-     /*<<fake:10:4>>*/ [x, y, ...rest] = [1, 2];
-     /*<<fake:12:4>>*/ ({x, y} = {x: 1, y: 2});
-     /*<<fake:13:4>>*/ ({x, y, ...rest} = {x: 1, y: 2});
-     /*<<fake:15:4>>*/ for
-    ([a, b, {c, d =  /*<<fake:15:17>>*/ e, [f]: [g, h, a, i, j]}] in 3)
-      /*<<fake:15:43>>*/ ;
-     /*<<fake:17:4>>*/ for
-    ([a, b, {c, d =  /*<<fake:17:17>>*/ e, [f]: [g, h, a, i, j]}] of 3)
-      /*<<fake:17:43>>*/ ; |}]
+    /*<<fake:2:4>>*/ var x, y, rest;
+    /*<<fake:3:4>>*/  /*<<fake:3:14>>*/ var [x, y] = [1, 2];
+    /*<<fake:4:4>>*/  /*<<fake:4:22>>*/ var [x, y, ...rest] = [1, 2, ...o];
+    /*<<fake:6:4>>*/  /*<<fake:6:14>>*/ var {x: x, y: y} = {x: 1, y: 2};
+    /*<<fake:7:4>>*/  /*<<fake:7:22>>*/ var
+    {x: x, y: y, ...rest} = {x: 1, y: 2, ...o};
+    /*<<fake:9:4>>*/ [x, y] = [1, 2];
+    /*<<fake:10:4>>*/ [x, y, ...rest] = [1, 2];
+    /*<<fake:12:4>>*/ ({x, y} = {x: 1, y: 2});
+    /*<<fake:13:4>>*/ ({x, y, ...rest} = {x: 1, y: 2});
+    /*<<fake:15:4>>*/ for([a, b, {c, d = e, [f]: [g, h, a, i, j]}] in 3)
+     /*<<fake:15:43>>*/ ;
+    /*<<fake:17:4>>*/ for([a, b, {c, d = e, [f]: [g, h, a, i, j]}] of 3)
+     /*<<fake:17:43>>*/ ; |}]
 
 let%expect_test "string template" =
   (* GH#1017 *)
@@ -630,6 +628,22 @@ var e = new (class f {})
     {|
     var e = new f; var e = new f(); var e = new class f{}; var e = new class f{}; |}]
 
+let%expect_test "assignment targets" =
+  print
+    ~debuginfo:false
+    ~compact:false
+    ~report:true
+    {|
+ [a,b,c, {a,b}] = [];
+ [[[x = 5]], {a,b}, ...rest] = [];
+ ({a: [a,b] = f(), b = 3, ...rest} = {});
+|};
+  [%expect
+    {|
+    [a, b, c, {a, b}] = [];
+    [[[x = 5]], {a, b}, ...rest] = [];
+    ({a: [a, b] = f(), b = 3, ...rest} = {}); |}]
+
 let%expect_test "error reporting" =
   (try
      print ~invalid:true ~compact:false {|

From ba117eefa2d6bbed9e22fced55ce530dbe235520 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= <jerome.vouillon@gmail.com>
Date: Mon, 11 Sep 2023 15:11:28 +0200
Subject: [PATCH 18/28] Compiler: Make it possible to link runtime JavaScript
 file together with OCaml libraries

Use: js_of_ocaml --toplevel --no-runtime runtime.js library.cma
---
 compiler/bin-js_of_ocaml/compile.ml | 30 ++++++++++++--
 compiler/lib/driver.ml              | 64 ++++++++++++++++++++++++-----
 compiler/lib/linker.ml              | 24 ++++++++---
 compiler/lib/linker.mli             |  9 +++-
 compiler/lib/unit_info.ml           |  9 ++++
 compiler/lib/unit_info.mli          |  2 +
 toplevel/examples/lwt_toplevel/dune |  7 +++-
 7 files changed, 122 insertions(+), 23 deletions(-)

diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml
index 926f39377..8ecc8fbbd 100644
--- a/compiler/bin-js_of_ocaml/compile.ml
+++ b/compiler/bin-js_of_ocaml/compile.ml
@@ -120,7 +120,7 @@ let run
         Some (Hashtbl.fold (fun cmi () acc -> cmi :: acc) t [])
   in
   let runtime_files =
-    if toplevel || dynlink
+    if (not no_runtime) && (toplevel || dynlink)
     then
       let add_if_absent x l = if List.mem x ~set:l then l else x :: l in
       runtime_files |> add_if_absent "+toplevel.js" |> add_if_absent "+dynlink.js"
@@ -247,9 +247,22 @@ let run
     Pretty_print.string fmt (Unit_info.to_string uinfo);
     output code ~source_map ~standalone ~linkall:false output_file
   in
+  let output_runtime ~standalone ~source_map ((_, fmt) as output_file) =
+    assert (not standalone);
+    let uinfo = Unit_info.of_primitives (Linker.list_all () |> StringSet.elements) in
+    Pretty_print.string fmt "\n";
+    Pretty_print.string fmt (Unit_info.to_string uinfo);
+    let code =
+      { Parse_bytecode.code = Code.empty
+      ; cmis = StringSet.empty
+      ; debug = Parse_bytecode.Debug.create ~include_cmis:false false
+      }
+    in
+    output code ~source_map ~standalone ~linkall:true output_file
+  in
   (if runtime_only
    then (
-     let prims = Primitive.get_external () |> StringSet.elements in
+     let prims = Linker.list_all () |> StringSet.elements in
      assert (List.length prims > 0);
      let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`JavaScript in
      let uinfo = { uinfo with primitives = uinfo.primitives @ prims } in
@@ -331,6 +344,7 @@ let run
              cmo
              ic
          in
+         let linkall = linkall || toplevel || dynlink in
          if times () then Format.eprintf "  parsing: %a@." Timer.print t1;
          output_gen
            ~standalone:false
@@ -338,7 +352,13 @@ let run
            ~build_info:(Build_info.create `Cmo)
            ~source_map
            output_file
-           (output_partial cmo code)
+           (fun ~standalone ~source_map output ->
+             let source_map =
+               if linkall
+               then output_runtime ~standalone ~source_map output
+               else source_map
+             in
+             output_partial cmo code ~standalone ~source_map output)
      | `Cma cma when keep_unit_names ->
          List.iter cma.lib_units ~f:(fun cmo ->
              let output_file =
@@ -376,7 +396,11 @@ let run
                (`Name output_file)
                (output_partial cmo code))
      | `Cma cma ->
+         let linkall = linkall || toplevel || dynlink in
          let f ~standalone ~source_map output =
+           let source_map =
+             if linkall then output_runtime ~standalone ~source_map output else source_map
+           in
            List.fold_left cma.lib_units ~init:source_map ~f:(fun source_map cmo ->
                let t1 = Timer.make () in
                let code =
diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml
index 889ef3623..89e6c1d19 100644
--- a/compiler/lib/driver.ml
+++ b/compiler/lib/driver.ml
@@ -276,7 +276,7 @@ let gen_missing js missing =
 let mark_start_of_generated_code = Debug.find ~even_if_quiet:true "mark-runtime-gen"
 
 let link ~standalone ~linkall (js : Javascript.statement_list) : Linker.output =
-  if not standalone
+  if not (linkall || standalone)
   then { runtime_code = js; always_required_codes = [] }
   else
     let t = Timer.make () in
@@ -313,7 +313,7 @@ let link ~standalone ~linkall (js : Javascript.statement_list) : Linker.output =
     let all_external = StringSet.union prim prov in
     let used = StringSet.inter free all_external in
     let linkinfos = Linker.init () in
-    let linkinfos, missing = Linker.resolve_deps ~linkall linkinfos used in
+    let linkinfos, missing = Linker.resolve_deps ~standalone ~linkall linkinfos used in
     (* gen_missing may use caml_failwith *)
     let linkinfos, missing =
       if (not (StringSet.is_empty missing)) && Config.Flag.genprim ()
@@ -336,18 +336,60 @@ let link ~standalone ~linkall (js : Javascript.statement_list) : Linker.output =
               let name = Utf8_string.of_string_exn name in
               Property (PNI name, EVar (ident name)))
         in
-        ( Expression_statement
-            (EBin
-               ( Eq
-               , dot
-                   (EVar (ident Constant.global_object_))
-                   (Utf8_string.of_string_exn "jsoo_runtime")
-               , EObj all ))
-        , N )
+        (if standalone
+         then
+           ( Expression_statement
+               (EBin
+                  ( Eq
+                  , dot
+                      (EVar (ident Constant.global_object_))
+                      (Utf8_string.of_string_exn "jsoo_runtime")
+                  , EObj all ))
+           , N )
+         else
+           ( Expression_statement
+               (call
+                  (dot
+                     (EVar (ident (Utf8_string.of_string_exn "Object")))
+                     (Utf8_string.of_string_exn "assign"))
+                  [ dot
+                      (EVar (ident Constant.global_object_))
+                      (Utf8_string.of_string_exn "jsoo_runtime")
+                  ; EObj all
+                  ]
+                  N)
+           , N ))
         :: js
       else js
     in
-    Linker.link js linkinfos
+    let missing = Linker.missing linkinfos in
+    let output = Linker.link ~standalone js linkinfos in
+    if not (List.is_empty missing)
+    then
+      { output with
+        runtime_code =
+          (let open Javascript in
+           ( Variable_statement
+               ( Var
+               , [ DeclPattern
+                     ( ObjectBinding
+                         { list =
+                             List.map
+                               ~f:(fun name ->
+                                 let name = Utf8_string.of_string_exn name in
+                                 Prop_ident (ident name, None))
+                               missing
+                         ; rest = None
+                         }
+                     , ( dot
+                           (EVar (ident Constant.global_object_))
+                           (Utf8_string.of_string_exn "jsoo_runtime")
+                       , N ) )
+                 ] )
+           , N )
+           :: output.runtime_code)
+      }
+    else output
 
 let check_js js =
   let t = Timer.make () in
diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml
index 76808e78f..76ff4972d 100644
--- a/compiler/lib/linker.ml
+++ b/compiler/lib/linker.ml
@@ -393,6 +393,7 @@ type state =
   { ids : IntSet.t
   ; always_required_codes : always_required list
   ; codes : (Javascript.program pack * bool) list
+  ; missing : StringSet.t
   }
 
 type output =
@@ -596,10 +597,9 @@ let load_files ?(ignore_always_annotation = false) ~target_env l =
 
 (* resolve *)
 let rec resolve_dep_name_rev visited path nm =
-  let x =
-    try Hashtbl.find provided nm with Not_found -> error "missing dependency '%s'@." nm
-  in
-  resolve_dep_id_rev visited path x.id
+  match Hashtbl.find provided nm with
+  | x -> resolve_dep_id_rev visited path x.id
+  | exception Not_found -> { visited with missing = StringSet.add nm visited.missing }
 
 and resolve_dep_id_rev visited path id =
   if IntSet.mem id visited.ids
@@ -630,9 +630,17 @@ let init () =
   { ids = IntSet.empty
   ; always_required_codes = List.rev_map !always_included ~f:proj_always_required
   ; codes = []
+  ; missing = StringSet.empty
   }
 
-let resolve_deps ?(linkall = false) visited_rev used =
+let list_all () =
+  Hashtbl.fold (fun nm _ set -> StringSet.add nm set) provided StringSet.empty
+
+let check_missing state =
+  if not (StringSet.is_empty state.missing)
+  then error "missing dependency '%s'@." (StringSet.choose state.missing)
+
+let resolve_deps ?(standalone = true) ?(linkall = false) visited_rev used =
   (* link the special files *)
   let missing, visited_rev =
     if linkall
@@ -657,9 +665,10 @@ let resolve_deps ?(linkall = false) visited_rev used =
         used
         (StringSet.empty, visited_rev)
   in
+  if standalone then check_missing visited_rev;
   visited_rev, missing
 
-let link program (state : state) =
+let link ?(standalone = true) program (state : state) =
   let always, always_required =
     List.partition
       ~f:(function
@@ -676,6 +685,7 @@ let link program (state : state) =
         in
         { state with codes = (Ok always.program, false) :: state.codes })
   in
+  if standalone then check_missing state;
   let codes =
     List.map state.codes ~f:(fun (x, has_macro) ->
         let c = unpack x in
@@ -698,6 +708,8 @@ let all state =
     state.ids
     []
 
+let missing state = StringSet.elements state.missing
+
 let origin ~name =
   try
     let x = Hashtbl.find provided name in
diff --git a/compiler/lib/linker.mli b/compiler/lib/linker.mli
index cc13208df..9577a99ff 100644
--- a/compiler/lib/linker.mli
+++ b/compiler/lib/linker.mli
@@ -61,14 +61,19 @@ type output =
   ; always_required_codes : always_required list
   }
 
+val list_all : unit -> StringSet.t
+
 val init : unit -> state
 
-val resolve_deps : ?linkall:bool -> state -> StringSet.t -> state * StringSet.t
+val resolve_deps :
+  ?standalone:bool -> ?linkall:bool -> state -> StringSet.t -> state * StringSet.t
 
-val link : Javascript.program -> state -> output
+val link : ?standalone:bool -> Javascript.program -> state -> output
 
 val get_provided : unit -> StringSet.t
 
 val all : state -> string list
 
+val missing : state -> string list
+
 val origin : name:string -> string option
diff --git a/compiler/lib/unit_info.ml b/compiler/lib/unit_info.ml
index e99acd6d6..6daa29e73 100644
--- a/compiler/lib/unit_info.ml
+++ b/compiler/lib/unit_info.ml
@@ -37,6 +37,15 @@ let empty =
   ; effects_without_cps = false
   }
 
+let of_primitives l =
+  { provides = StringSet.empty
+  ; requires = StringSet.empty
+  ; primitives = l
+  ; crcs = StringMap.empty
+  ; force_link = true
+  ; effects_without_cps = false
+  }
+
 let of_cmo (cmo : Cmo_format.compilation_unit) =
   let open Ocaml_compiler in
   let provides = StringSet.singleton (Cmo_format.name cmo) in
diff --git a/compiler/lib/unit_info.mli b/compiler/lib/unit_info.mli
index 8e93e0e5a..cd0895fa9 100644
--- a/compiler/lib/unit_info.mli
+++ b/compiler/lib/unit_info.mli
@@ -30,6 +30,8 @@ type t =
 
 val of_cmo : Cmo_format.compilation_unit -> t
 
+val of_primitives : string list -> t
+
 val union : t -> t -> t
 
 val empty : t
diff --git a/toplevel/examples/lwt_toplevel/dune b/toplevel/examples/lwt_toplevel/dune
index 775b7b0c2..81ca33c23 100644
--- a/toplevel/examples/lwt_toplevel/dune
+++ b/toplevel/examples/lwt_toplevel/dune
@@ -71,7 +71,12 @@
 (rule
  (targets test_dynlink.js)
  (action
-  (run %{bin:js_of_ocaml} --pretty --toplevel %{dep:test_dynlink.cmo})))
+  (run
+   %{bin:js_of_ocaml}
+   --pretty
+   --toplevel
+   %{read-strings:effects_flags.txt}
+   %{dep:test_dynlink.cmo})))
 
 (rule
  (targets export.txt)

From fa2742af1e7d93441ce563390c541e0d191fb2cb Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 27 Apr 2024 09:39:11 +0200
Subject: [PATCH 19/28] Compiler: small refactoring

---
 compiler/lib/driver.ml | 22 ++++++++++++----------
 1 file changed, 12 insertions(+), 10 deletions(-)

diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml
index 89e6c1d19..fa537fff1 100644
--- a/compiler/lib/driver.ml
+++ b/compiler/lib/driver.ml
@@ -275,8 +275,9 @@ let gen_missing js missing =
 
 let mark_start_of_generated_code = Debug.find ~even_if_quiet:true "mark-runtime-gen"
 
-let link ~standalone ~linkall (js : Javascript.statement_list) : Linker.output =
-  if not (linkall || standalone)
+let link ~export_runtime ~standalone ~linkall (js : Javascript.statement_list) :
+    Linker.output =
+  if (not export_runtime) && not standalone
   then { runtime_code = js; always_required_codes = [] }
   else
     let t = Timer.make () in
@@ -313,21 +314,21 @@ let link ~standalone ~linkall (js : Javascript.statement_list) : Linker.output =
     let all_external = StringSet.union prim prov in
     let used = StringSet.inter free all_external in
     let linkinfos = Linker.init () in
-    let linkinfos, missing = Linker.resolve_deps ~standalone ~linkall linkinfos used in
-    (* gen_missing may use caml_failwith *)
-    let linkinfos, missing =
+    let linkinfos, js =
+      let linkinfos, missing = Linker.resolve_deps ~standalone ~linkall linkinfos used in
+      (* gen_missing may use caml_failwith *)
       if (not (StringSet.is_empty missing)) && Config.Flag.genprim ()
       then
         let linkinfos, missing2 =
           Linker.resolve_deps linkinfos (StringSet.singleton "caml_failwith")
         in
-        linkinfos, StringSet.union missing missing2
-      else linkinfos, missing
+        let missing = StringSet.union missing missing2 in
+        linkinfos, gen_missing js missing
+      else linkinfos, js
     in
-    let js = if Config.Flag.genprim () then gen_missing js missing else js in
     if times () then Format.eprintf "  linking: %a@." Timer.print t;
     let js =
-      if linkall
+      if export_runtime
       then
         let open Javascript in
         let all = Linker.all linkinfos in
@@ -628,8 +629,9 @@ let target_flag (type a) (t : a target) =
   | Wasm -> `Wasm
 
 let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(linkall = false) p =
+  let export_runtime = linkall in
   p
-  |> link ~standalone ~linkall
+  |> link ~export_runtime ~standalone ~linkall
   |> pack ~wrap_with_fun ~standalone
   |> coloring
   |> check_js

From 4f541b992351afeeb76359c51946dd88ad9c7747 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 29 Apr 2024 14:53:44 +0200
Subject: [PATCH 20/28] Compiler: refactoring

---
 compiler/bin-js_of_ocaml/check_runtime.ml |  2 +-
 compiler/lib-runtime-files/gen/gen.ml     |  4 +--
 compiler/lib/driver.ml                    | 43 +++++++++++++----------
 compiler/lib/linker.ml                    | 41 +++++++--------------
 compiler/lib/linker.mli                   |  5 +--
 compiler/lib/wasm/wa_binaryen.ml          |  2 +-
 6 files changed, 41 insertions(+), 56 deletions(-)

diff --git a/compiler/bin-js_of_ocaml/check_runtime.ml b/compiler/bin-js_of_ocaml/check_runtime.ml
index 41b9495b6..14bca57e0 100644
--- a/compiler/bin-js_of_ocaml/check_runtime.ml
+++ b/compiler/bin-js_of_ocaml/check_runtime.ml
@@ -88,7 +88,7 @@ let f (runtime_files, bytecode, target_env) =
       needed
   in
   let needed = StringSet.of_list (List.map ~f:fst needed) in
-  let from_runtime1 = Linker.get_provided () in
+  let from_runtime1 = Linker.list_all () in
   let from_runtime2 = Primitive.get_external () in
   (* [from_runtime2] is a superset of [from_runtime1].
      Extra primitives are registered on the ocaml side (e.g. generate.ml) *)
diff --git a/compiler/lib-runtime-files/gen/gen.ml b/compiler/lib-runtime-files/gen/gen.ml
index 0acc8b282..3f0147357 100644
--- a/compiler/lib-runtime-files/gen/gen.ml
+++ b/compiler/lib-runtime-files/gen/gen.ml
@@ -65,9 +65,9 @@ let () =
               List.iter fragments ~f:(fun (filename, frags) ->
                   Js_of_ocaml_compiler.Linker.load_fragments ~target_env ~filename frags);
               let linkinfos = Js_of_ocaml_compiler.Linker.init () in
-              let prov = Js_of_ocaml_compiler.Linker.get_provided () in
+              let prov = Js_of_ocaml_compiler.Linker.list_all () in
               let _linkinfos, missing =
-                Js_of_ocaml_compiler.Linker.resolve_deps ~linkall:true linkinfos prov
+                Js_of_ocaml_compiler.Linker.resolve_deps linkinfos prov
               in
               Js_of_ocaml_compiler.Linker.check_deps ();
               assert (StringSet.is_empty missing)));
diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml
index fa537fff1..e82d72283 100644
--- a/compiler/lib/driver.ml
+++ b/compiler/lib/driver.ml
@@ -295,27 +295,32 @@ let link ~export_runtime ~standalone ~linkall (js : Javascript.statement_list) :
         :: js
       else js
     in
-    let free = traverse#get_free in
-    let free : StringSet.t =
-      Javascript.IdentSet.fold
-        (fun x acc ->
-          match x with
-          | V _ ->
-              (* This is an error. We don't complain here as we want
-                 to be able to name other variable to make it
-                 easier to spot the problematic ones *)
-              acc
-          | S { name = Utf8 x; _ } -> StringSet.add x acc)
-        free
-        StringSet.empty
+    let used =
+      let all_provided = Linker.list_all () in
+      if linkall
+      then all_provided
+      else
+        let free = traverse#get_free in
+        let free : StringSet.t =
+          Javascript.IdentSet.fold
+            (fun x acc ->
+              match x with
+              | V _ ->
+                  (* This is an error. We don't complain here as we want
+                     to be able to name other variable to make it
+                     easier to spot the problematic ones *)
+                  acc
+              | S { name = Utf8 x; _ } -> StringSet.add x acc)
+            free
+            StringSet.empty
+        in
+        let prim = Primitive.get_external () in
+        let all_external = StringSet.union prim all_provided in
+        StringSet.inter free all_external
     in
-    let prim = Primitive.get_external () in
-    let prov = Linker.get_provided () in
-    let all_external = StringSet.union prim prov in
-    let used = StringSet.inter free all_external in
     let linkinfos = Linker.init () in
     let linkinfos, js =
-      let linkinfos, missing = Linker.resolve_deps ~standalone ~linkall linkinfos used in
+      let linkinfos, missing = Linker.resolve_deps ~standalone linkinfos used in
       (* gen_missing may use caml_failwith *)
       if (not (StringSet.is_empty missing)) && Config.Flag.genprim ()
       then
@@ -408,7 +413,7 @@ let check_js js =
       StringSet.empty
   in
   let prim = Primitive.get_external () in
-  let prov = Linker.get_provided () in
+  let prov = Linker.list_all () in
   let all_external = StringSet.union prim prov in
   let missing = StringSet.inter free all_external in
   let missing = StringSet.diff missing Reserved.provided in
diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml
index 76ff4972d..5ed9b53e9 100644
--- a/compiler/lib/linker.ml
+++ b/compiler/lib/linker.ml
@@ -424,6 +424,9 @@ let reset () =
   Primitive.reset ();
   Generate.init ()
 
+let list_all () =
+  Hashtbl.fold (fun nm _ set -> StringSet.add nm set) provided StringSet.empty
+
 let load_fragment ~ignore_always_annotation ~target_env ~filename (f : Fragment.t) =
   match f with
   | Always_include code ->
@@ -539,11 +542,8 @@ let load_fragment ~ignore_always_annotation ~target_env ~filename (f : Fragment.
               StringSet.iter (fun alias -> Primitive.alias alias name) aliases;
               `Ok)
 
-let get_provided () =
-  Hashtbl.fold (fun k _ acc -> StringSet.add k acc) provided StringSet.empty
-
 let check_deps () =
-  let provided = get_provided () in
+  let provided = list_all () in
   Hashtbl.iter
     (fun id (code, _has_macro, requires) ->
       match code with
@@ -633,37 +633,20 @@ let init () =
   ; missing = StringSet.empty
   }
 
-let list_all () =
-  Hashtbl.fold (fun nm _ set -> StringSet.add nm set) provided StringSet.empty
-
 let check_missing state =
   if not (StringSet.is_empty state.missing)
   then error "missing dependency '%s'@." (StringSet.choose state.missing)
 
-let resolve_deps ?(standalone = true) ?(linkall = false) visited_rev used =
+let resolve_deps ?(standalone = true) visited_rev used =
   (* link the special files *)
   let missing, visited_rev =
-    if linkall
-    then
-      (* link all primitives *)
-      let prog, set =
-        Hashtbl.fold
-          (fun nm _ (visited, set) ->
-            resolve_dep_name_rev visited [] nm, StringSet.add nm set)
-          provided
-          (visited_rev, StringSet.empty)
-      in
-      let missing = StringSet.diff used set in
-      missing, prog
-    else
-      (* link used primitives *)
-      StringSet.fold
-        (fun nm (missing, visited) ->
-          if Hashtbl.mem provided nm
-          then missing, resolve_dep_name_rev visited [] nm
-          else StringSet.add nm missing, visited)
-        used
-        (StringSet.empty, visited_rev)
+    StringSet.fold
+      (fun nm (missing, visited) ->
+        if Hashtbl.mem provided nm
+        then missing, resolve_dep_name_rev visited [] nm
+        else StringSet.add nm missing, visited)
+      used
+      (StringSet.empty, visited_rev)
   in
   if standalone then check_missing visited_rev;
   visited_rev, missing
diff --git a/compiler/lib/linker.mli b/compiler/lib/linker.mli
index 9577a99ff..f0822054a 100644
--- a/compiler/lib/linker.mli
+++ b/compiler/lib/linker.mli
@@ -65,13 +65,10 @@ val list_all : unit -> StringSet.t
 
 val init : unit -> state
 
-val resolve_deps :
-  ?standalone:bool -> ?linkall:bool -> state -> StringSet.t -> state * StringSet.t
+val resolve_deps : ?standalone:bool -> state -> StringSet.t -> state * StringSet.t
 
 val link : ?standalone:bool -> Javascript.program -> state -> output
 
-val get_provided : unit -> StringSet.t
-
 val all : state -> string list
 
 val missing : state -> string list
diff --git a/compiler/lib/wasm/wa_binaryen.ml b/compiler/lib/wasm/wa_binaryen.ml
index 551c3a11b..d7335f272 100644
--- a/compiler/lib/wasm/wa_binaryen.ml
+++ b/compiler/lib/wasm/wa_binaryen.ml
@@ -96,7 +96,7 @@ let dead_code_elimination
   @@ fun deps_file ->
   Fs.with_intermediate_file (Filename.temp_file "usage" ".txt")
   @@ fun usage_file ->
-  let primitives = Linker.get_provided () in
+  let primitives = Linker.list_all () in
   Fs.write_file ~name:deps_file ~contents:(generate_dependencies ~dependencies primitives);
   command
     ("wasm-metadce"

From 3694f146912e38a0c2d6197c1defaed9c01c7a6e Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 20 Apr 2024 15:09:42 +0200
Subject: [PATCH 21/28] Compiler: remove deprecated cmdline runtime-only flag

---
 compiler/bin-js_of_ocaml/cmd_arg.ml | 24 +++++-------------------
 1 file changed, 5 insertions(+), 19 deletions(-)

diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml
index 2077da267..38c660967 100644
--- a/compiler/bin-js_of_ocaml/cmd_arg.ml
+++ b/compiler/bin-js_of_ocaml/cmd_arg.ml
@@ -122,13 +122,6 @@ let options =
     let doc = "Do not include the standard runtime." in
     Arg.(value & flag & info [ "noruntime"; "no-runtime" ] ~doc)
   in
-  let runtime_only =
-    let doc =
-      "[DEPRECATED: use js_of_ocaml build-runtime instead]. Generate a JavaScript file \
-       containing/exporting the runtime only."
-    in
-    Arg.(value & flag & info [ "runtime-only" ] ~doc)
-  in
   let no_sourcemap =
     let doc =
       "Don't generate source map. All other source map related flags will be be ignored."
@@ -270,7 +263,6 @@ let options =
       no_cmis
       profile
       no_runtime
-      runtime_only
       no_sourcemap
       sourcemap
       sourcemap_inline_in_js
@@ -283,16 +275,11 @@ let options =
       keep_unit_names =
     let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in
     let runtime_files = js_files in
-    let runtime_files =
-      if runtime_only && Filename.check_suffix input_file ".js"
-      then runtime_files @ [ input_file ]
-      else runtime_files
-    in
-    let fs_external = fs_external || (toplevel && no_cmis) || runtime_only in
+    let fs_external = fs_external || (toplevel && no_cmis) in
     let input_file =
-      match input_file, runtime_only with
-      | "-", _ | _, true -> None
-      | x, false -> Some x
+      match input_file with
+      | "-" -> None
+      | x -> Some x
     in
     let output_file =
       match output_file with
@@ -351,7 +338,7 @@ let options =
       ; include_dirs
       ; runtime_files
       ; no_runtime
-      ; runtime_only
+      ; runtime_only = false
       ; fs_files
       ; fs_output
       ; fs_external
@@ -380,7 +367,6 @@ let options =
       $ no_cmis
       $ profile
       $ noruntime
-      $ runtime_only
       $ no_sourcemap
       $ sourcemap
       $ sourcemap_inline_in_js

From efbe91a576b377b111c002922e6400d023fe8bcb Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 29 Apr 2024 15:02:28 +0200
Subject: [PATCH 22/28] Compiler: refactoring

---
 compiler/lib/driver.ml  | 10 +++++++---
 compiler/lib/linker.ml  | 10 +++++-----
 compiler/lib/linker.mli |  4 ++--
 3 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml
index e82d72283..63d53aa07 100644
--- a/compiler/lib/driver.ml
+++ b/compiler/lib/driver.ml
@@ -280,6 +280,7 @@ let link ~export_runtime ~standalone ~linkall (js : Javascript.statement_list) :
   if (not export_runtime) && not standalone
   then { runtime_code = js; always_required_codes = [] }
   else
+    let check_missing = standalone in
     let t = Timer.make () in
     if times () then Format.eprintf "Start Linking...@.";
     let traverse = new Js_traverse.free in
@@ -320,12 +321,15 @@ let link ~export_runtime ~standalone ~linkall (js : Javascript.statement_list) :
     in
     let linkinfos = Linker.init () in
     let linkinfos, js =
-      let linkinfos, missing = Linker.resolve_deps ~standalone linkinfos used in
+      let linkinfos, missing = Linker.resolve_deps ~check_missing linkinfos used in
       (* gen_missing may use caml_failwith *)
       if (not (StringSet.is_empty missing)) && Config.Flag.genprim ()
       then
         let linkinfos, missing2 =
-          Linker.resolve_deps linkinfos (StringSet.singleton "caml_failwith")
+          Linker.resolve_deps
+            ~check_missing
+            linkinfos
+            (StringSet.singleton "caml_failwith")
         in
         let missing = StringSet.union missing missing2 in
         linkinfos, gen_missing js missing
@@ -369,7 +373,7 @@ let link ~export_runtime ~standalone ~linkall (js : Javascript.statement_list) :
       else js
     in
     let missing = Linker.missing linkinfos in
-    let output = Linker.link ~standalone js linkinfos in
+    let output = Linker.link ~check_missing js linkinfos in
     if not (List.is_empty missing)
     then
       { output with
diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml
index 5ed9b53e9..eb76f9b70 100644
--- a/compiler/lib/linker.ml
+++ b/compiler/lib/linker.ml
@@ -633,11 +633,11 @@ let init () =
   ; missing = StringSet.empty
   }
 
-let check_missing state =
+let do_check_missing state =
   if not (StringSet.is_empty state.missing)
   then error "missing dependency '%s'@." (StringSet.choose state.missing)
 
-let resolve_deps ?(standalone = true) visited_rev used =
+let resolve_deps ?(check_missing = true) visited_rev used =
   (* link the special files *)
   let missing, visited_rev =
     StringSet.fold
@@ -648,10 +648,10 @@ let resolve_deps ?(standalone = true) visited_rev used =
       used
       (StringSet.empty, visited_rev)
   in
-  if standalone then check_missing visited_rev;
+  if check_missing then do_check_missing visited_rev;
   visited_rev, missing
 
-let link ?(standalone = true) program (state : state) =
+let link ?(check_missing = true) program (state : state) =
   let always, always_required =
     List.partition
       ~f:(function
@@ -668,7 +668,7 @@ let link ?(standalone = true) program (state : state) =
         in
         { state with codes = (Ok always.program, false) :: state.codes })
   in
-  if standalone then check_missing state;
+  if check_missing then do_check_missing state;
   let codes =
     List.map state.codes ~f:(fun (x, has_macro) ->
         let c = unpack x in
diff --git a/compiler/lib/linker.mli b/compiler/lib/linker.mli
index f0822054a..1f8765397 100644
--- a/compiler/lib/linker.mli
+++ b/compiler/lib/linker.mli
@@ -65,9 +65,9 @@ val list_all : unit -> StringSet.t
 
 val init : unit -> state
 
-val resolve_deps : ?standalone:bool -> state -> StringSet.t -> state * StringSet.t
+val resolve_deps : ?check_missing:bool -> state -> StringSet.t -> state * StringSet.t
 
-val link : ?standalone:bool -> Javascript.program -> state -> output
+val link : ?check_missing:bool -> Javascript.program -> state -> output
 
 val all : state -> string list
 

From 0c714443a7fca09ff18f228b78d86e87b722bf64 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Fri, 3 May 2024 13:15:44 +0200
Subject: [PATCH 23/28] Compiler: new include-partial-runtime flag

---
 compiler/bin-js_of_ocaml/build_fs.ml  |  1 +
 compiler/bin-js_of_ocaml/cmd_arg.ml   | 11 ++++
 compiler/bin-js_of_ocaml/cmd_arg.mli  |  1 +
 compiler/bin-js_of_ocaml/compile.ml   | 77 +++++++++++++++++------
 compiler/bin-wasm_of_ocaml/compile.ml | 12 +++-
 compiler/lib/driver.ml                | 88 ++++++++++++++-------------
 compiler/lib/driver.mli               |  6 +-
 compiler/lib/link_js.ml               |  2 +-
 compiler/lib/linker.ml                | 71 ++++++++++++++-------
 compiler/lib/linker.mli               |  4 +-
 toplevel/bin/jsoo_mkcmis.ml           |  1 +
 11 files changed, 182 insertions(+), 92 deletions(-)

diff --git a/compiler/bin-js_of_ocaml/build_fs.ml b/compiler/bin-js_of_ocaml/build_fs.ml
index 1b5931aef..84ed7fb55 100644
--- a/compiler/bin-js_of_ocaml/build_fs.ml
+++ b/compiler/bin-js_of_ocaml/build_fs.ml
@@ -78,6 +78,7 @@ function jsoo_create_file_extern(name,content){
           ~target:(JavaScript pfs_fmt)
           ~standalone:true
           ~wrap_with_fun:`Iife
+          ~link:`Needed
           (Parse_bytecode.Debug.create ~include_cmis:false false)
           code
       in
diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml
index 38c660967..e8083a221 100644
--- a/compiler/bin-js_of_ocaml/cmd_arg.ml
+++ b/compiler/bin-js_of_ocaml/cmd_arg.ml
@@ -46,6 +46,7 @@ type t =
   ; source_map : (string option * Source_map.t) option
   ; runtime_files : string list
   ; no_runtime : bool
+  ; include_partial_runtime : bool
   ; runtime_only : bool
   ; output_file : [ `Name of string | `Stdout ] * bool
   ; input_file : string option
@@ -122,6 +123,12 @@ let options =
     let doc = "Do not include the standard runtime." in
     Arg.(value & flag & info [ "noruntime"; "no-runtime" ] ~doc)
   in
+  let include_partial_runtime =
+    let doc =
+      "Include (partial) runtime when compiling cmo and cma files to JavaScript."
+    in
+    Arg.(value & flag & info [ "include-partial-runtime" ] ~doc)
+  in
   let no_sourcemap =
     let doc =
       "Don't generate source map. All other source map related flags will be be ignored."
@@ -263,6 +270,7 @@ let options =
       no_cmis
       profile
       no_runtime
+      include_partial_runtime
       no_sourcemap
       sourcemap
       sourcemap_inline_in_js
@@ -338,6 +346,7 @@ let options =
       ; include_dirs
       ; runtime_files
       ; no_runtime
+      ; include_partial_runtime
       ; runtime_only = false
       ; fs_files
       ; fs_output
@@ -367,6 +376,7 @@ let options =
       $ no_cmis
       $ profile
       $ noruntime
+      $ include_partial_runtime
       $ no_sourcemap
       $ sourcemap
       $ sourcemap_inline_in_js
@@ -576,6 +586,7 @@ let options_runtime_only =
       ; include_dirs
       ; runtime_files
       ; no_runtime
+      ; include_partial_runtime = false
       ; runtime_only = true
       ; fs_files
       ; fs_output
diff --git a/compiler/bin-js_of_ocaml/cmd_arg.mli b/compiler/bin-js_of_ocaml/cmd_arg.mli
index ee65275cc..9bd5996a2 100644
--- a/compiler/bin-js_of_ocaml/cmd_arg.mli
+++ b/compiler/bin-js_of_ocaml/cmd_arg.mli
@@ -26,6 +26,7 @@ type t =
   ; source_map : (string option * Source_map.t) option
   ; runtime_files : string list
   ; no_runtime : bool
+  ; include_partial_runtime : bool
   ; runtime_only : bool
   ; output_file : [ `Name of string | `Stdout ] * bool
   ; input_file : string option
diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml
index 8ecc8fbbd..6c16a5f2d 100644
--- a/compiler/bin-js_of_ocaml/compile.ml
+++ b/compiler/bin-js_of_ocaml/compile.ml
@@ -68,7 +68,7 @@ let run
     { Cmd_arg.common
     ; profile
     ; source_map
-    ; runtime_files
+    ; runtime_files = runtime_files_from_cmdline
     ; no_runtime
     ; input_file
     ; output_file
@@ -87,6 +87,7 @@ let run
     ; fs_external
     ; export_file
     ; keep_unit_names
+    ; include_partial_runtime
     } =
   let include_cmis = toplevel && not no_cmis in
   let custom_header = common.Jsoo_cmdline.Arg.custom_header in
@@ -123,8 +124,10 @@ let run
     if (not no_runtime) && (toplevel || dynlink)
     then
       let add_if_absent x l = if List.mem x ~set:l then l else x :: l in
-      runtime_files |> add_if_absent "+toplevel.js" |> add_if_absent "+dynlink.js"
-    else runtime_files
+      runtime_files_from_cmdline
+      |> add_if_absent "+toplevel.js"
+      |> add_if_absent "+dynlink.js"
+    else runtime_files_from_cmdline
   in
   let runtime_files, builtin =
     List.partition_map runtime_files ~f:(fun name ->
@@ -176,7 +179,7 @@ let run
             , noloc )
           ])
   in
-  let output (one : Parse_bytecode.one) ~standalone ~source_map ~linkall output_file =
+  let output (one : Parse_bytecode.one) ~standalone ~source_map ~link output_file =
     check_debug one;
     let init_pseudo_fs = fs_external && standalone in
     let sm =
@@ -194,7 +197,7 @@ let run
             ~target:(JavaScript fmt)
             ~standalone
             ?profile
-            ~linkall
+            ~link
             ~wrap_with_fun
             ?source_map
             one.debug
@@ -218,7 +221,7 @@ let run
               ~target:(JavaScript fmt)
               ~standalone
               ?profile
-              ~linkall
+              ~link
               ~wrap_with_fun
               ?source_map
               one.debug
@@ -229,7 +232,14 @@ let run
                   let instr = fs_instr2 in
                   let code = Code.prepend Code.empty instr in
                   let pfs_fmt = Pretty_print.to_out_channel chan in
-                  Driver.f' ~standalone ?profile ~wrap_with_fun pfs_fmt one.debug code));
+                  Driver.f'
+                    ~standalone
+                    ~link:`Needed
+                    ?profile
+                    ~wrap_with_fun
+                    pfs_fmt
+                    one.debug
+                    code));
           res
     in
     if times () then Format.eprintf "compilation: %a@." Timer.print t;
@@ -245,11 +255,14 @@ let run
     let uinfo = Unit_info.of_cmo cmo in
     Pretty_print.string fmt "\n";
     Pretty_print.string fmt (Unit_info.to_string uinfo);
-    output code ~source_map ~standalone ~linkall:false output_file
+    output code ~source_map ~standalone ~link:`No output_file
   in
-  let output_runtime ~standalone ~source_map ((_, fmt) as output_file) =
+  let output_partial_runtime ~standalone ~source_map ((_, fmt) as output_file) =
     assert (not standalone);
-    let uinfo = Unit_info.of_primitives (Linker.list_all () |> StringSet.elements) in
+    let uinfo =
+      Unit_info.of_primitives
+        (Linker.list_all ~from:runtime_files_from_cmdline () |> StringSet.elements)
+    in
     Pretty_print.string fmt "\n";
     Pretty_print.string fmt (Unit_info.to_string uinfo);
     let code =
@@ -258,7 +271,12 @@ let run
       ; debug = Parse_bytecode.Debug.create ~include_cmis:false false
       }
     in
-    output code ~source_map ~standalone ~linkall:true output_file
+    output
+      code
+      ~source_map
+      ~standalone
+      ~link:(`All_from runtime_files_from_cmdline)
+      output_file
   in
   (if runtime_only
    then (
@@ -281,7 +299,7 @@ let run
        (fun ~standalone ~source_map ((_, fmt) as output_file) ->
          Pretty_print.string fmt "\n";
          Pretty_print.string fmt (Unit_info.to_string uinfo);
-         output code ~source_map ~standalone ~linkall:true output_file))
+         output code ~source_map ~standalone ~link:`All output_file))
    else
      let kind, ic, close_ic, include_dirs =
        match input_file with
@@ -320,7 +338,7 @@ let run
            ~build_info:(Build_info.create `Exe)
            ~source_map
            (fst output_file)
-           (output code ~linkall)
+           (output code ~link:(if linkall then `All else `Needed))
      | `Cmo cmo ->
          let output_file =
            match output_file, keep_unit_names with
@@ -344,7 +362,6 @@ let run
              cmo
              ic
          in
-         let linkall = linkall || toplevel || dynlink in
          if times () then Format.eprintf "  parsing: %a@." Timer.print t1;
          output_gen
            ~standalone:false
@@ -354,12 +371,33 @@ let run
            output_file
            (fun ~standalone ~source_map output ->
              let source_map =
-               if linkall
-               then output_runtime ~standalone ~source_map output
-               else source_map
+               if not include_partial_runtime
+               then source_map
+               else output_partial_runtime ~standalone ~source_map output
              in
              output_partial cmo code ~standalone ~source_map output)
      | `Cma cma when keep_unit_names ->
+         (if include_partial_runtime
+          then
+            let output_file =
+              let gen dir = Filename.concat dir "runtime.js" in
+              match output_file with
+              | `Stdout, false -> gen "./"
+              | `Name x, false -> gen (Filename.dirname x)
+              | `Name x, true
+                when String.length x > 0 && Char.equal x.[String.length x - 1] '/' ->
+                  gen x
+              | `Stdout, true | `Name _, true ->
+                  failwith "use [-o dirname/] or remove [--keep-unit-names]"
+            in
+            output_gen
+              ~standalone:false
+              ~custom_header
+              ~build_info:(Build_info.create `Runtime)
+              ~source_map
+              (`Name output_file)
+              (fun ~standalone ~source_map output ->
+                output_partial_runtime ~standalone ~source_map output));
          List.iter cma.lib_units ~f:(fun cmo ->
              let output_file =
                match output_file with
@@ -396,10 +434,11 @@ let run
                (`Name output_file)
                (output_partial cmo code))
      | `Cma cma ->
-         let linkall = linkall || toplevel || dynlink in
          let f ~standalone ~source_map output =
            let source_map =
-             if linkall then output_runtime ~standalone ~source_map output else source_map
+             if not include_partial_runtime
+             then source_map
+             else output_partial_runtime ~standalone ~source_map output
            in
            List.fold_left cma.lib_units ~init:source_map ~f:(fun source_map cmo ->
                let t1 = Timer.make () in
diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml
index a76ec7df3..cfddd79c6 100644
--- a/compiler/bin-wasm_of_ocaml/compile.ml
+++ b/compiler/bin-wasm_of_ocaml/compile.ml
@@ -145,7 +145,11 @@ let generate_prelude ~out_file =
   @@ fun ch ->
   let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`Wasm in
   let live_vars, in_cps, p, debug =
-    Driver.f ~target:Wasm (Parse_bytecode.Debug.create ~include_cmis:false false) code
+    Driver.f
+      ~target:Wasm
+      ~link:`Needed
+      (Parse_bytecode.Debug.create ~include_cmis:false false)
+      code
   in
   let context = Wa_generate.start () in
   let _ = Wa_generate.f ~context ~unit_name:(Some "prelude") ~live_vars ~in_cps p in
@@ -180,7 +184,9 @@ let build_js_runtime ~primitives ?runtime_arguments () =
     in
     match
       List.split_last
-      @@ Driver.link_and_pack [ Javascript.Return_statement (Some (EObj l)), N ]
+      @@ Driver.link_and_pack
+           ~link:`Needed
+           [ Javascript.Return_statement (Some (EObj l)), N ]
     with
     | Some x -> x
     | None -> assert false
@@ -279,7 +285,7 @@ let run
     let code = one.code in
     let standalone = Option.is_none unit_name in
     let live_vars, in_cps, p, debug =
-      Driver.f ~target:Wasm ~standalone ?profile one.debug code
+      Driver.f ~target:Wasm ~standalone ?profile ~link:`No one.debug code
     in
     let context = Wa_generate.start () in
     let toplevel_name, generated_js =
diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml
index 63d53aa07..0694e8370 100644
--- a/compiler/lib/driver.ml
+++ b/compiler/lib/driver.ml
@@ -275,7 +275,7 @@ let gen_missing js missing =
 
 let mark_start_of_generated_code = Debug.find ~even_if_quiet:true "mark-runtime-gen"
 
-let link ~export_runtime ~standalone ~linkall (js : Javascript.statement_list) :
+let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
     Linker.output =
   if (not export_runtime) && not standalone
   then { runtime_code = js; always_required_codes = [] }
@@ -298,28 +298,37 @@ let link ~export_runtime ~standalone ~linkall (js : Javascript.statement_list) :
     in
     let used =
       let all_provided = Linker.list_all () in
-      if linkall
-      then all_provided
-      else
-        let free = traverse#get_free in
-        let free : StringSet.t =
-          Javascript.IdentSet.fold
-            (fun x acc ->
-              match x with
-              | V _ ->
-                  (* This is an error. We don't complain here as we want
-                     to be able to name other variable to make it
-                     easier to spot the problematic ones *)
-                  acc
-              | S { name = Utf8 x; _ } -> StringSet.add x acc)
-            free
-            StringSet.empty
-        in
-        let prim = Primitive.get_external () in
-        let all_external = StringSet.union prim all_provided in
-        StringSet.inter free all_external
+      match link with
+      | `All -> all_provided
+      | `All_from from -> Linker.list_all ~from ()
+      | `No -> StringSet.empty
+      | `Needed ->
+          let free = traverse#get_free in
+          let free : StringSet.t =
+            Javascript.IdentSet.fold
+              (fun x acc ->
+                match x with
+                | V _ ->
+                    (* This is an error. We don't complain here as we want
+                       to be able to name other variable to make it
+                       easier to spot the problematic ones *)
+                    acc
+                | S { name = Utf8 x; _ } -> StringSet.add x acc)
+              free
+              StringSet.empty
+          in
+          let prim = Primitive.get_external () in
+          let all_external = StringSet.union prim all_provided in
+          StringSet.inter free all_external
+    in
+    let linkinfos =
+      let from =
+        match link with
+        | `All_from l -> Some l
+        | `All | `No | `Needed -> None
+      in
+      Linker.init ?from ()
     in
-    let linkinfos = Linker.init () in
     let linkinfos, js =
       let linkinfos, missing = Linker.resolve_deps ~check_missing linkinfos used in
       (* gen_missing may use caml_failwith *)
@@ -637,10 +646,14 @@ let target_flag (type a) (t : a target) =
   | JavaScript _ -> `JavaScript
   | Wasm -> `Wasm
 
-let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(linkall = false) p =
-  let export_runtime = linkall in
+let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ~link p =
+  let export_runtime =
+    match link with
+    | `All | `All_from _ -> true
+    | `Needed | `No -> false
+  in
   p
-  |> link ~export_runtime ~standalone ~linkall
+  |> link' ~export_runtime ~standalone ~link
   |> pack ~wrap_with_fun ~standalone
   |> coloring
   |> check_js
@@ -651,7 +664,7 @@ let full
     ~standalone
     ~wrap_with_fun
     ~profile
-    ~linkall
+    ~link
     ~source_map
     d
     p : result =
@@ -679,7 +692,7 @@ let full
       let exported_runtime = not standalone in
       let emit formatter =
         generate d ~exported_runtime ~wrap_with_fun ~warn_on_unhandled_effect:standalone
-        +> link_and_pack ~standalone ~wrap_with_fun ~linkall
+        +> link_and_pack ~standalone ~wrap_with_fun ~link
         +> output formatter ~source_map ()
       in
       let source_map = emit formatter r in
@@ -688,14 +701,14 @@ let full
       let (p, live_vars), _, in_cps = r in
       live_vars, in_cps, p, d
 
-let full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~linkall d p =
+let full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p =
   let (_ : Source_map.t option) =
     full
       ~target:(JavaScript formatter)
       ~standalone
       ~wrap_with_fun
       ~profile
-      ~linkall
+      ~link
       ~source_map:None
       d
       p
@@ -707,21 +720,14 @@ let f
     ?(standalone = true)
     ?(wrap_with_fun = `Iife)
     ?(profile = O1)
-    ?(linkall = false)
+    ~link
     ?source_map
     d
     p =
-  full ~target ~standalone ~wrap_with_fun ~profile ~linkall ~source_map d p
+  full ~target ~standalone ~wrap_with_fun ~profile ~link ~source_map d p
 
-let f'
-    ?(standalone = true)
-    ?(wrap_with_fun = `Iife)
-    ?(profile = O1)
-    ?(linkall = false)
-    formatter
-    d
-    p =
-  full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~linkall d p
+let f' ?(standalone = true) ?(wrap_with_fun = `Iife) ?(profile = O1) ~link formatter d p =
+  full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p
 
 let from_string ~prims ~debug s formatter =
   let p, d = Parse_bytecode.from_string ~prims ~debug s in
@@ -730,7 +736,7 @@ let from_string ~prims ~debug s formatter =
     ~standalone:false
     ~wrap_with_fun:`Anonymous
     ~profile:O1
-    ~linkall:false
+    ~link:`No
     d
     p
 
diff --git a/compiler/lib/driver.mli b/compiler/lib/driver.mli
index 58c3c19c0..8e8d0c97e 100644
--- a/compiler/lib/driver.mli
+++ b/compiler/lib/driver.mli
@@ -31,7 +31,7 @@ val f :
   -> ?standalone:bool
   -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ]
   -> ?profile:profile
-  -> ?linkall:bool
+  -> link:[ `All | `All_from of string list | `Needed | `No ]
   -> ?source_map:Source_map.t
   -> Parse_bytecode.Debug.t
   -> Code.program
@@ -41,7 +41,7 @@ val f' :
      ?standalone:bool
   -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ]
   -> ?profile:profile
-  -> ?linkall:bool
+  -> link:[ `All | `All_from of string list | `Needed | `No ]
   -> Pretty_print.t
   -> Parse_bytecode.Debug.t
   -> Code.program
@@ -57,7 +57,7 @@ val from_string :
 val link_and_pack :
      ?standalone:bool
   -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ]
-  -> ?linkall:bool
+  -> link:[ `All | `All_from of string list | `Needed | `No ]
   -> Javascript.statement_list
   -> Javascript.statement_list
 
diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml
index 65418e2df..23932e75f 100644
--- a/compiler/lib/link_js.ml
+++ b/compiler/lib/link_js.ml
@@ -424,7 +424,7 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source
           Driver.configure fmt;
           Driver.f'
             ~standalone:false
-            ~linkall:false
+            ~link:`No
             ~wrap_with_fun:`Iife
             fmt
             (Parse_bytecode.Debug.create ~include_cmis:false false)
diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml
index eb76f9b70..d0a610d90 100644
--- a/compiler/lib/linker.ml
+++ b/compiler/lib/linker.ml
@@ -394,6 +394,7 @@ type state =
   ; always_required_codes : always_required list
   ; codes : (Javascript.program pack * bool) list
   ; missing : StringSet.t
+  ; include_ : string -> bool
   }
 
 type output =
@@ -404,6 +405,7 @@ type output =
 type provided =
   { id : int
   ; pi : Parse_info.t
+  ; filename : string
   ; weakdef : bool
   ; target_env : Target_env.t
   }
@@ -424,8 +426,16 @@ let reset () =
   Primitive.reset ();
   Generate.init ()
 
-let list_all () =
-  Hashtbl.fold (fun nm _ set -> StringSet.add nm set) provided StringSet.empty
+let list_all ?from () =
+  let include_ =
+    match from with
+    | None -> fun _ _ -> true
+    | Some l -> fun fn _nm -> List.mem fn ~set:l
+  in
+  Hashtbl.fold
+    (fun nm p set -> if include_ p.filename nm then StringSet.add nm set else set)
+    provided
+    StringSet.empty
 
 let load_fragment ~ignore_always_annotation ~target_env ~filename (f : Fragment.t) =
   match f with
@@ -536,7 +546,10 @@ let load_fragment ~ignore_always_annotation ~target_env ~filename (f : Fragment.
               let id = Hashtbl.length provided in
               Primitive.register name kind ka arity;
               StringSet.iter Primitive.register_named_value named_values;
-              Hashtbl.add provided name { id; pi; weakdef; target_env = fragment_target };
+              Hashtbl.add
+                provided
+                name
+                { id; pi; filename; weakdef; target_env = fragment_target };
               Hashtbl.add provided_rev id (name, pi);
               Hashtbl.add code_pieces id (code, has_macro, requires);
               StringSet.iter (fun alias -> Primitive.alias alias name) aliases;
@@ -596,13 +609,16 @@ let load_files ?(ignore_always_annotation = false) ~target_env l =
   check_deps ()
 
 (* resolve *)
-let rec resolve_dep_name_rev visited path nm =
+let rec resolve_dep_name_rev state path nm =
   match Hashtbl.find provided nm with
-  | x -> resolve_dep_id_rev visited path x.id
-  | exception Not_found -> { visited with missing = StringSet.add nm visited.missing }
-
-and resolve_dep_id_rev visited path id =
-  if IntSet.mem id visited.ids
+  | x ->
+      if state.include_ x.filename
+      then resolve_dep_id_rev state path x.id
+      else { state with missing = StringSet.add nm state.missing }
+  | exception Not_found -> { state with missing = StringSet.add nm state.missing }
+
+and resolve_dep_id_rev state path id =
+  if IntSet.mem id state.ids
   then (
     if List.memq id ~set:path
     then
@@ -611,25 +627,34 @@ and resolve_dep_id_rev visited path id =
         (String.concat
            ~sep:", "
            (List.map path ~f:(fun id -> fst (Hashtbl.find provided_rev id))));
-    visited)
+    state)
   else
     let path = id :: path in
     let code, has_macro, req = Hashtbl.find code_pieces id in
-    let visited = { visited with ids = IntSet.add id visited.ids } in
-    let visited =
-      List.fold_left req ~init:visited ~f:(fun visited nm ->
-          resolve_dep_name_rev visited path nm)
+    let state = { state with ids = IntSet.add id state.ids } in
+    let state =
+      List.fold_left req ~init:state ~f:(fun state nm ->
+          resolve_dep_name_rev state path nm)
     in
-    let visited = { visited with codes = (code, has_macro) :: visited.codes } in
-    visited
+    let state = { state with codes = (code, has_macro) :: state.codes } in
+    state
 
 let proj_always_required { ar_filename; ar_requires; ar_program } =
   { filename = ar_filename; requires = ar_requires; program = unpack ar_program }
 
-let init () =
+let init ?from () =
+  let include_ =
+    match from with
+    | None -> fun _ -> true
+    | Some l -> fun fn -> List.mem fn ~set:l
+  in
   { ids = IntSet.empty
-  ; always_required_codes = List.rev_map !always_included ~f:proj_always_required
+  ; always_required_codes =
+      List.rev
+        (List.filter_map !always_included ~f:(fun x ->
+             if include_ x.ar_filename then Some (proj_always_required x) else None))
   ; codes = []
+  ; include_
   ; missing = StringSet.empty
   }
 
@@ -637,19 +662,19 @@ let do_check_missing state =
   if not (StringSet.is_empty state.missing)
   then error "missing dependency '%s'@." (StringSet.choose state.missing)
 
-let resolve_deps ?(check_missing = true) visited_rev used =
+let resolve_deps ?(check_missing = true) state used =
   (* link the special files *)
-  let missing, visited_rev =
+  let missing, state =
     StringSet.fold
       (fun nm (missing, visited) ->
         if Hashtbl.mem provided nm
         then missing, resolve_dep_name_rev visited [] nm
         else StringSet.add nm missing, visited)
       used
-      (StringSet.empty, visited_rev)
+      (StringSet.empty, state)
   in
-  if check_missing then do_check_missing visited_rev;
-  visited_rev, missing
+  if check_missing then do_check_missing state;
+  state, missing
 
 let link ?(check_missing = true) program (state : state) =
   let always, always_required =
diff --git a/compiler/lib/linker.mli b/compiler/lib/linker.mli
index 1f8765397..246b95940 100644
--- a/compiler/lib/linker.mli
+++ b/compiler/lib/linker.mli
@@ -61,9 +61,9 @@ type output =
   ; always_required_codes : always_required list
   }
 
-val list_all : unit -> StringSet.t
+val list_all : ?from:string list -> unit -> StringSet.t
 
-val init : unit -> state
+val init : ?from:string list -> unit -> state
 
 val resolve_deps : ?check_missing:bool -> state -> StringSet.t -> state * StringSet.t
 
diff --git a/toplevel/bin/jsoo_mkcmis.ml b/toplevel/bin/jsoo_mkcmis.ml
index f87133cf6..0c64fb785 100644
--- a/toplevel/bin/jsoo_mkcmis.ml
+++ b/toplevel/bin/jsoo_mkcmis.ml
@@ -96,5 +96,6 @@ let () =
   Js_of_ocaml_compiler.Config.Flag.enable "pretty";
   Js_of_ocaml_compiler.Driver.f'
     pfs_fmt
+    ~link:`Needed
     (Js_of_ocaml_compiler.Parse_bytecode.Debug.create ~include_cmis:false false)
     program

From b4be1132223c9a2c2a06eab365453374a7cbd550 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 22 Feb 2024 00:13:37 +0100
Subject: [PATCH 24/28] Tests: add test for compact option

---
 compiler/tests-compiler/compact.ml    | 53 +++++++++++++++++++++++++++
 compiler/tests-compiler/dune.inc      | 15 ++++++++
 compiler/tests-compiler/util/util.ml  | 28 +++++++-------
 compiler/tests-compiler/util/util.mli |  3 ++
 4 files changed, 84 insertions(+), 15 deletions(-)
 create mode 100644 compiler/tests-compiler/compact.ml

diff --git a/compiler/tests-compiler/compact.ml b/compiler/tests-compiler/compact.ml
new file mode 100644
index 000000000..151db3f39
--- /dev/null
+++ b/compiler/tests-compiler/compact.ml
@@ -0,0 +1,53 @@
+(* Js_of_ocaml tests
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2024 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.
+ *)
+
+(* Testing renaming for backward edges with the default [--enable compact] *)
+
+let%expect_test _ =
+  let prog =
+    {|
+let rec f x y z =
+  match x,y,z with
+  | 0, 0, 0 -> true
+  | _       -> f (x + z) (y - z) (z + x + y)
+
+|}
+  in
+  let program = Util.compile_and_parse ~pretty:false prog in
+  Util.print_program program;
+  [%expect
+    {|
+    (function(a){
+       "use strict";
+       var b = a.jsoo_runtime;
+       b.caml_register_global
+        (0,
+         [0,
+          function(a, b, c){
+           var f = a, e = b, d = c;
+           for(;;){
+            if(0 === f && 0 === e && 0 === d) return 1;
+            var g = (d + f | 0) + e | 0, f = f + d | 0, e = e - d | 0, d = g;
+           }
+          }],
+         "Test");
+       return;
+      }
+      (globalThis));
+    //end |}]
diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc
index a049c39a1..5ab5836bf 100644
--- a/compiler/tests-compiler/dune.inc
+++ b/compiler/tests-compiler/dune.inc
@@ -44,6 +44,21 @@
  (preprocess
   (pps ppx_expect)))
 
+(library
+ ;; compiler/tests-compiler/compact.ml
+ (name compact_15)
+ (enabled_if (and (<> %{profile} wasm) (<> %{profile} wasm-effects)))
+ (modules compact)
+ (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper)
+ (inline_tests
+  (enabled_if (and (<> %{profile} wasm) (<> %{profile} wasm-effects)))
+  (deps
+   (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe)
+   (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe)))
+ (flags (:standard -open Jsoo_compiler_expect_tests_helper))
+ (preprocess
+  (pps ppx_expect)))
+
 (library
  ;; compiler/tests-compiler/cond.ml
  (name cond_15)
diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml
index 7606abf2d..8f6e4330f 100644
--- a/compiler/tests-compiler/util/util.ml
+++ b/compiler/tests-compiler/util/util.ml
@@ -505,6 +505,7 @@ let compile_and_run_bytecode ?unix s =
 
 let compile_and_run
     ?debug
+    ?pretty
     ?(skip_modern = false)
     ?(flags = [])
     ?effects
@@ -520,6 +521,7 @@ let compile_and_run
       in
       let output_without_stdlib_modern =
         compile_bc_to_javascript
+          ?pretty
           ~flags
           ?effects
           ?use_js_string
@@ -546,33 +548,29 @@ let compile_and_run
           print_string output_with_stdlib_modern;
           print_endline "==========================================="))
 
-let compile_and_parse_whole_program ?(debug = true) ?flags ?effects ?use_js_string ?unix s
-    =
+let compile_and_parse_whole_program
+    ?(debug = true)
+    ?pretty
+    ?flags
+    ?effects
+    ?use_js_string
+    ?unix
+    s =
   with_temp_dir ~f:(fun () ->
       s
       |> Filetype.ocaml_text_of_string
       |> Filetype.write_ocaml ~name:"test.ml"
       |> compile_ocaml_to_bc ?unix ~debug
-      |> compile_bc_to_javascript
-           ?flags
-           ?effects
-           ?use_js_string
-           ~pretty:true
-           ~sourcemap:debug
+      |> compile_bc_to_javascript ?pretty ?flags ?effects ?use_js_string ~sourcemap:debug
       |> parse_js)
 
-let compile_and_parse ?(debug = true) ?flags ?effects ?use_js_string s =
+let compile_and_parse ?(debug = true) ?pretty ?flags ?effects ?use_js_string s =
   with_temp_dir ~f:(fun () ->
       s
       |> Filetype.ocaml_text_of_string
       |> Filetype.write_ocaml ~name:"test.ml"
       |> compile_ocaml_to_cmo ~debug
-      |> compile_cmo_to_javascript
-           ?flags
-           ?effects
-           ?use_js_string
-           ~pretty:true
-           ~sourcemap:debug
+      |> compile_cmo_to_javascript ?pretty ?flags ?effects ?use_js_string ~sourcemap:debug
       |> parse_js)
 
 let normalize_path s =
diff --git a/compiler/tests-compiler/util/util.mli b/compiler/tests-compiler/util/util.mli
index 5cdf48839..a7f5de2c7 100644
--- a/compiler/tests-compiler/util/util.mli
+++ b/compiler/tests-compiler/util/util.mli
@@ -73,6 +73,7 @@ val print_fun_decl : Javascript.program -> string option -> unit
 
 val compile_and_run :
      ?debug:bool
+  -> ?pretty:bool
   -> ?skip_modern:bool
   -> ?flags:string list
   -> ?effects:bool
@@ -85,6 +86,7 @@ val compile_and_run_bytecode : ?unix:bool -> string -> unit
 
 val compile_and_parse :
      ?debug:bool
+  -> ?pretty:bool
   -> ?flags:string list
   -> ?effects:bool
   -> ?use_js_string:bool
@@ -93,6 +95,7 @@ val compile_and_parse :
 
 val compile_and_parse_whole_program :
      ?debug:bool
+  -> ?pretty:bool
   -> ?flags:string list
   -> ?effects:bool
   -> ?use_js_string:bool

From 7eee7ed4cb52786973c8ee55114fcd0aecb6a02b Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Fri, 8 Mar 2024 16:29:43 +0100
Subject: [PATCH 25/28] Compiler: use consise body in arrow when es6 is enabled

---
 compiler/lib/js_traverse.ml    |  7 ++++++-
 compiler/tests-compiler/es6.ml | 15 +++++++++++++--
 2 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/compiler/lib/js_traverse.ml b/compiler/lib/js_traverse.ml
index 34fddd54e..fdf631616 100644
--- a/compiler/lib/js_traverse.ml
+++ b/compiler/lib/js_traverse.ml
@@ -1675,7 +1675,12 @@ class simpl =
       | EFun
           (None, (({ generator = false; async = true | false }, _, body, _) as fun_decl))
         when Config.Flag.es6 () && not (use_fun_context body) ->
-          EArrow (fun_decl, false, ANo_fun_context)
+          let consise =
+            match body with
+            | [ (Return_statement _, _) ] -> true
+            | _ -> false
+          in
+          EArrow (fun_decl, consise, ANo_fun_context)
       | EArrow (((_, _, body, _) as fun_decl), consise, AUnknown) ->
           if use_fun_context body
           then EArrow (fun_decl, consise, AUse_parent_fun_context)
diff --git a/compiler/tests-compiler/es6.ml b/compiler/tests-compiler/es6.ml
index da1a23a05..9b64c1d5d 100644
--- a/compiler/tests-compiler/es6.ml
+++ b/compiler/tests-compiler/es6.ml
@@ -10,7 +10,7 @@ let f x =
     |}
   in
   let flags = [ "--enable"; "es6" ] in
-  let program = Util.compile_and_parse ~effects:false ~flags prog in
+  let program = Util.compile_and_parse ~effects:false ~pretty:true ~flags prog in
   Util.print_program program;
   [%expect
     {|
@@ -18,9 +18,20 @@ let f x =
        "use strict";
        var
         runtime = globalThis.jsoo_runtime,
-        f = x=>{var g = y=>{return (x + y | 0) + 7 | 0;}; return g;},
+        f = x=>{var g = y=>(x + y | 0) + 7 | 0; return g;},
         Test = [0, f];
        runtime.caml_register_global(0, Test, "Test");
        return;})
      (globalThis);
+    //end |}];
+  let program = Util.compile_and_parse ~effects:false ~pretty:false ~flags prog in
+  Util.print_program program;
+  [%expect
+    {|
+    (a=>{
+       "use strict";
+       var b = a.jsoo_runtime;
+       b.caml_register_global(0, [0, b=>a=>(b + a | 0) + 7 | 0], "Test");
+       return;})
+     (globalThis);
     //end |}]

From 7721b1656d1f2361b61c169fb816b95371f223f8 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 13 May 2024 23:14:11 +0200
Subject: [PATCH 26/28] Misc: disable some test on older ocaml

---
 compiler/tests-toplevel/dune | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/compiler/tests-toplevel/dune b/compiler/tests-toplevel/dune
index be8e3b304..ba0474819 100644
--- a/compiler/tests-toplevel/dune
+++ b/compiler/tests-toplevel/dune
@@ -20,11 +20,12 @@
 
 (rule
  (target test_toplevel.referencejs)
+ (deps test_toplevel.js)
  (enabled_if
   (and
    (<> %{profile} wasm)
-   (<> %{profile} wasm-effects)))
- (deps test_toplevel.js)
+   (<> %{profile} wasm-effects)
+   (>= %{ocaml_version} 5.2)))
  (action
   (with-stdout-to
    %{target}
@@ -35,7 +36,8 @@
  (enabled_if
   (and
    (<> %{profile} wasm)
-   (<> %{profile} wasm-effects)))
+   (<> %{profile} wasm-effects)
+   (>= %{ocaml_version} 5.2)))
  (deps test_toplevel.reference test_toplevel.referencejs)
  (action
   (diff test_toplevel.reference test_toplevel.referencejs)))

From 6e90b4e326e2e55f29312005b59d5402b54ce1a9 Mon Sep 17 00:00:00 2001
From: Olivier Nicole <olivier@chnik.fr>
Date: Thu, 1 Aug 2024 12:05:11 +0200
Subject: [PATCH 27/28] Move Sexp functions to wasm/ subdirectory

This was made necessary by the changes requested in
ocsigen/js_of_ocaml#1657.
---
 compiler/lib/build_info.ml       | 16 ++-----
 compiler/lib/build_info.mli      |  4 +-
 compiler/lib/unit_info.ml        | 40 -----------------
 compiler/lib/unit_info.mli       |  4 --
 compiler/lib/{ => wasm}/sexp.ml  |  0
 compiler/lib/{ => wasm}/sexp.mli |  0
 compiler/lib/wasm/wa_link.ml     | 76 ++++++++++++++++++++++++++++++++
 7 files changed, 81 insertions(+), 59 deletions(-)
 rename compiler/lib/{ => wasm}/sexp.ml (100%)
 rename compiler/lib/{ => wasm}/sexp.mli (100%)

diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml
index df09835ca..3d723a5c3 100644
--- a/compiler/lib/build_info.ml
+++ b/compiler/lib/build_info.ml
@@ -90,19 +90,9 @@ let parse s =
       in
       Some t
 
-let to_sexp info =
-  Sexp.List
-    (info
-    |> StringMap.bindings
-    |> List.map ~f:(fun (k, v) -> Sexp.List [ Atom k; Atom v ]))
-
-let from_sexp info =
-  let open Sexp.Util in
-  info
-  |> assoc
-  |> List.fold_left
-       ~f:(fun m (k, v) -> StringMap.add k (single string v) m)
-       ~init:StringMap.empty
+let to_map : t -> string StringMap.t = Fun.id
+
+let of_map : string StringMap.t -> t = Fun.id
 
 exception
   Incompatible_build_info of
diff --git a/compiler/lib/build_info.mli b/compiler/lib/build_info.mli
index 34c72abbc..f80eee164 100644
--- a/compiler/lib/build_info.mli
+++ b/compiler/lib/build_info.mli
@@ -34,9 +34,9 @@ val to_string : t -> string
 
 val parse : string -> t option
 
-val to_sexp : t -> Sexp.t
+val to_map : t -> string StringMap.t
 
-val from_sexp : Sexp.t -> t
+val of_map : string StringMap.t -> t
 
 val with_kind : t -> kind -> t
 
diff --git a/compiler/lib/unit_info.ml b/compiler/lib/unit_info.ml
index 6daa29e73..bcc168a56 100644
--- a/compiler/lib/unit_info.ml
+++ b/compiler/lib/unit_info.ml
@@ -149,43 +149,3 @@ let parse acc s =
       | Some ("Effects_without_cps", b) ->
           Some { acc with effects_without_cps = bool_of_string (String.trim b) }
       | Some (_, _) -> None)
-
-let to_sexp t =
-  let add nm skip v rem = if skip then rem else Sexp.List (Atom nm :: v) :: rem in
-  let set nm f rem =
-    add
-      nm
-      (List.equal ~eq:String.equal (f empty) (f t))
-      (List.map ~f:(fun x -> Sexp.Atom x) (f t))
-      rem
-  in
-  let bool nm f rem =
-    add
-      nm
-      (Bool.equal (f empty) (f t))
-      (if f t then [ Atom "true" ] else [ Atom "false" ])
-      rem
-  in
-  []
-  |> bool "effects_without_cps" (fun t -> t.effects_without_cps)
-  |> set "primitives" (fun t -> t.primitives)
-  |> bool "force_link" (fun t -> t.force_link)
-  |> set "requires" (fun t -> StringSet.elements t.requires)
-  |> add "provides" false [ Atom (StringSet.choose t.provides) ]
-
-let from_sexp t =
-  let open Sexp.Util in
-  let opt_list l = l |> Option.map ~f:(List.map ~f:string) in
-  let list default l = Option.value ~default (opt_list l) in
-  let set default l =
-    Option.value ~default (Option.map ~f:StringSet.of_list (opt_list l))
-  in
-  let bool default v = Option.value ~default (Option.map ~f:(single bool) v) in
-  { provides = t |> member "provides" |> mandatory (single string) |> StringSet.singleton
-  ; requires = t |> member "requires" |> set empty.requires
-  ; primitives = t |> member "primitives" |> list empty.primitives
-  ; force_link = t |> member "force_link" |> bool empty.force_link
-  ; effects_without_cps =
-      t |> member "effects_without_cps" |> bool empty.effects_without_cps
-  ; crcs = StringMap.empty
-  }
diff --git a/compiler/lib/unit_info.mli b/compiler/lib/unit_info.mli
index cd0895fa9..1899b5657 100644
--- a/compiler/lib/unit_info.mli
+++ b/compiler/lib/unit_info.mli
@@ -41,7 +41,3 @@ val prefix : string
 val to_string : t -> string
 
 val parse : t -> string -> t option
-
-val to_sexp : t -> Sexp.t list
-
-val from_sexp : Sexp.t -> t
diff --git a/compiler/lib/sexp.ml b/compiler/lib/wasm/sexp.ml
similarity index 100%
rename from compiler/lib/sexp.ml
rename to compiler/lib/wasm/sexp.ml
diff --git a/compiler/lib/sexp.mli b/compiler/lib/wasm/sexp.mli
similarity index 100%
rename from compiler/lib/sexp.mli
rename to compiler/lib/wasm/sexp.mli
diff --git a/compiler/lib/wasm/wa_link.ml b/compiler/lib/wasm/wa_link.ml
index 93aa9d82f..453c65858 100644
--- a/compiler/lib/wasm/wa_link.ml
+++ b/compiler/lib/wasm/wa_link.ml
@@ -20,6 +20,82 @@ open Stdlib
 
 let times = Debug.find "times"
 
+module Build_info : sig
+  include module type of Build_info
+
+  val to_sexp : t -> Sexp.t
+
+  val from_sexp : Sexp.t -> t
+end = struct
+  include Build_info
+
+  let to_sexp info =
+    Sexp.List
+      (info
+      |> to_map
+      |> StringMap.bindings
+      |> List.map ~f:(fun (k, v) -> Sexp.List [ Atom k; Atom v ]))
+
+  let from_sexp info =
+    let open Sexp.Util in
+    info
+    |> assoc
+    |> List.fold_left
+         ~f:(fun m (k, v) -> StringMap.add k (single string v) m)
+         ~init:StringMap.empty
+    |> of_map
+end
+
+module Unit_info : sig
+  include module type of Unit_info
+
+  val to_sexp : t -> Sexp.t list
+
+  val from_sexp : Sexp.t -> t
+end = struct
+  include Unit_info
+
+  let to_sexp t =
+    let add nm skip v rem = if skip then rem else Sexp.List (Atom nm :: v) :: rem in
+    let set nm f rem =
+      add
+        nm
+        (List.equal ~eq:String.equal (f empty) (f t))
+        (List.map ~f:(fun x -> Sexp.Atom x) (f t))
+        rem
+    in
+    let bool nm f rem =
+      add
+        nm
+        (Bool.equal (f empty) (f t))
+        (if f t then [ Atom "true" ] else [ Atom "false" ])
+        rem
+    in
+    []
+    |> bool "effects_without_cps" (fun t -> t.effects_without_cps)
+    |> set "primitives" (fun t -> t.primitives)
+    |> bool "force_link" (fun t -> t.force_link)
+    |> set "requires" (fun t -> StringSet.elements t.requires)
+    |> add "provides" false [ Atom (StringSet.choose t.provides) ]
+
+  let from_sexp t =
+    let open Sexp.Util in
+    let opt_list l = l |> Option.map ~f:(List.map ~f:string) in
+    let list default l = Option.value ~default (opt_list l) in
+    let set default l =
+      Option.value ~default (Option.map ~f:StringSet.of_list (opt_list l))
+    in
+    let bool default v = Option.value ~default (Option.map ~f:(single bool) v) in
+    { provides = t |> member "provides" |> mandatory (single string) |> StringSet.singleton
+    ; requires = t |> member "requires" |> set empty.requires
+    ; primitives = t |> member "primitives" |> list empty.primitives
+    ; force_link = t |> member "force_link" |> bool empty.force_link
+    ; effects_without_cps =
+        t |> member "effects_without_cps" |> bool empty.effects_without_cps
+    ; crcs = StringMap.empty
+    }
+end
+
 module Wasm_binary = struct
   let header = "\000asm\001\000\000\000"
 

From 929eed28f055d21dc16c81b251c75c8739769b22 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Fri, 28 Jun 2024 08:50:08 +0200
Subject: [PATCH 28/28] Compiler: fix toplevel

---
 compiler/lib/link_js.ml                       |  4 ++--
 compiler/lib/parse_bytecode.ml                |  4 ++++
 compiler/lib/parse_bytecode.mli               |  2 +-
 compiler/tests-toplevel/dune                  | 21 +++++++++++++++++--
 compiler/tests-toplevel/test_toplevel.ml      |  8 +++++--
 .../tests-toplevel/test_toplevel.reference    |  8 ++++---
 6 files changed, 37 insertions(+), 10 deletions(-)

diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml
index 23932e75f..4f41268fd 100644
--- a/compiler/lib/link_js.ml
+++ b/compiler/lib/link_js.ml
@@ -409,8 +409,8 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source
       | Some bi ->
           Build_info.configure bi;
           let primitives =
-            List.fold_left units ~init:[] ~f:(fun acc (u : Unit_info.t) ->
-                acc @ u.primitives)
+            List.fold_left units ~init:StringSet.empty ~f:(fun acc (u : Unit_info.t) ->
+                StringSet.union acc (StringSet.of_list u.primitives))
           in
           let code =
             Parse_bytecode.link_info
diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml
index 9ed5bf484..1caac8caf 100644
--- a/compiler/lib/parse_bytecode.ml
+++ b/compiler/lib/parse_bytecode.ml
@@ -3161,6 +3161,10 @@ let link_info ~target ~symtable ~primitives ~crcs =
       []
     |> Array.of_list
   in
+  let primitives =
+    (* Add the externals translated by jsoo directly (in generate.ml) *)
+    StringSet.union (Primitive.get_external ()) primitives |> StringSet.elements
+  in
   let body = [] in
   let body =
     (* Include linking information *)
diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli
index 5500e4f4a..244472cd4 100644
--- a/compiler/lib/parse_bytecode.mli
+++ b/compiler/lib/parse_bytecode.mli
@@ -95,6 +95,6 @@ val predefined_exceptions : target:[ `JavaScript | `Wasm ] -> Code.program * Uni
 val link_info :
      target:[ `JavaScript | `Wasm ]
   -> symtable:Ocaml_compiler.Symtable.GlobalMap.t
-  -> primitives:string list
+  -> primitives:StringSet.t
   -> crcs:(string * Digest.t option) list
   -> Code.program
diff --git a/compiler/tests-toplevel/dune b/compiler/tests-toplevel/dune
index ba0474819..2e541eec6 100644
--- a/compiler/tests-toplevel/dune
+++ b/compiler/tests-toplevel/dune
@@ -7,7 +7,9 @@
  (libraries js_of_ocaml-compiler.dynlink compiler-libs.toplevel)
  (flags
   (:standard -linkall))
- (modes byte))
+ (js_of_ocaml
+  (flags :standard --toplevel))
+ (modes byte js))
 
 (rule
  (targets test_toplevel.js)
@@ -31,6 +33,19 @@
    %{target}
    (run node ./test_toplevel.js))))
 
+(rule
+ (target test_toplevel.referencebcjs)
+ (deps test_toplevel.bc.js)
+ (enabled_if
+  (and
+   (<> %{profile} wasm)
+   (<> %{profile} wasm-effects)
+   (>= %{ocaml_version} 5.2)))
+ (action
+  (with-stdout-to
+   %{target}
+   (run node ./test_toplevel.bc.js))))
+
 (rule
  (alias runtest)
  (enabled_if
@@ -40,4 +55,6 @@
    (>= %{ocaml_version} 5.2)))
  (deps test_toplevel.reference test_toplevel.referencejs)
  (action
-  (diff test_toplevel.reference test_toplevel.referencejs)))
+  (progn
+   (diff test_toplevel.reference test_toplevel.referencebcjs)
+   (diff test_toplevel.reference test_toplevel.referencejs))))
diff --git a/compiler/tests-toplevel/test_toplevel.ml b/compiler/tests-toplevel/test_toplevel.ml
index fde3c4579..e35a3ea90 100644
--- a/compiler/tests-toplevel/test_toplevel.ml
+++ b/compiler/tests-toplevel/test_toplevel.ml
@@ -1,9 +1,13 @@
 let () =
-  let content = {|
+  let content =
+    {|
 let () = print_endline "hello";;
+1+1;;
 1+;;
 Missing_module.f;;
-|} in
+let y = float 1 /. float 3;;
+|}
+  in
   Topdirs.dir_directory "/static/cmis";
   Toploop.initialize_toplevel_env ();
   Toploop.input_name := "//toplevel//";
diff --git a/compiler/tests-toplevel/test_toplevel.reference b/compiler/tests-toplevel/test_toplevel.reference
index 3ab394a97..81e85b344 100644
--- a/compiler/tests-toplevel/test_toplevel.reference
+++ b/compiler/tests-toplevel/test_toplevel.reference
@@ -1,5 +1,7 @@
 hello
-Line 3, characters 2-4:
+- : int = 2
+Line 4, characters 2-4:
 Error: Syntax error
-Line 4, characters 0-16:
-Error: Unbound module Missing_module
+Line 5, characters 0-16:
+Error: Unbound module "Missing_module"
+val y : float = 0.333333333333333315