[Not for merge] Optim effects optional

.git-blame-ignore-revs

@@ -1,2 +1,4 @@
 # ocamlformat bump
-3c98cd3e0c4e1191983b602a8e38a1c92d259891
+3c98cd3e0c4e1191983b602a8e38a1c92d259891
+# Upgrade to OCamlformat 0.26.0
+7de742a776fcdad4b098695617b9e7afab822c82

.github/workflows/build.yml

@@ -23,6 +23,7 @@ jobs:
           - 4.11.x
           - 4.12.x
           - 4.13.x
+          - 5.0.x
         skip-test:
           - true
         skip-doc:
@@ -46,17 +47,17 @@ jobs:
             skip-test: false
             skip-doc: true
           - os: ubuntu-latest
-            ocaml-compiler: 5.0.x
+            ocaml-compiler: 5.1.x
             skip-effects: false
             skip-test: false
             skip-doc: false
           - os: macos-latest
-            ocaml-compiler: 5.0.x
+            ocaml-compiler: 5.1.x
             skip-effects: true
             skip-test: false
             skip-doc: true
           - os: windows-latest
-            ocaml-compiler: ocaml.5.0.0,ocaml-option-mingw
+            ocaml-compiler: ocaml.5.1.0,ocaml-option-mingw
             skip-effects: false
             skip-test: false
             skip-doc: true
@@ -85,7 +86,7 @@ jobs:
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
           opam-repositories: |
-            dra27: https://github.com/dra27/opam-repository.git#windows-5.0
+            dra27: https://github.com/hhugo/opam-repository.git#for-jsoo-ci-windows
             default: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset
             opam: https://github.com/ocaml/opam-repository.git
           dune-cache: true
@@ -97,13 +98,10 @@ jobs:
         uses: ocaml/setup-ocaml@v2
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
-          dune-cache: ${{ matrix.os != 'macos-latest' }}
+          dune-cache: true
           opam-depext: ${{ !matrix.skip-test }}
           opam-depext-flags: --with-test
 
-      - run: opam pin add zarith git+https://github.com/hhugo/Zarith.git#win-fix
-        if: runner.os == 'Windows'
-
       - run: opam install . --best-effort
         if: ${{ matrix.skip-test }}
 

.ocamlformat

@@ -10,5 +10,5 @@ break-separators=before
 dock-collection-brackets=false
 margin=90
 module-item-spacing=sparse
-version=0.25.1
+version=0.26.0
 ocaml-version=4.08.0

CHANGES.md

@@ -1,3 +1,18 @@
+# Dev (2023-??-??) - ??
+
+## Features/Changes
+* Compiler: change control-flow compilation strategy (#1496)
+* Lib: add download attribute to anchor element
+* Dead code elimination of unused references (#2076)
+* Misc: switch CI to OCaml 5.1
+* Misc: preliminary support for OCaml 5.2
+* Effects: add an optional feature of "dynamic switching" between CPS and direct style, resulting in much better performance when no effect handler is installed
+
+## Bug fixes
+* Runtime: fix Dom_html.onIE (#1493)
+* Compiler: fix global flow analysis (#1494)
+* Runtime: add conversion functions + strict equality for compatibility with Wasm_of_ocaml (#1492)
+
 # 5.4.0 (2023-07-06) - Lille
 
 ## Bug fixes

compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml

@@ -20,9 +20,8 @@ let () =
   Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.Config.use_js_string ());
   Config.Flag.set "effects" (Jsoo_runtime.Sys.Config.effects ());
   (* this needs to stay synchronized with toplevel.js *)
-  let toplevel_compile (s : bytes array) (debug : Instruct.debug_event list array) :
+  let toplevel_compile (s : string) (debug : Instruct.debug_event list array) :
       unit -> J.t =
-    let s = String.concat ~sep:"" (List.map ~f:Bytes.to_string (Array.to_list s)) in
     let prims = split_primitives (Symtable.data_primitive_names ()) in
     let b = Buffer.create 100 in
     let fmt = Pretty_print.to_buffer b in

compiler/lib-runtime-files/gen/gen.ml

@@ -88,7 +88,7 @@ let () =
 let %s = Js_of_ocaml_compiler.Builtins.register
   ~name:%S
   ~content:{frag|%s|frag}
-  ~fragments:(Some {frag|%s|frag})
+  ~fragments:(Some %S)
 |}
             (to_ident (Filename.chop_extension name))
             name

compiler/lib/base64.ml

@@ -39,7 +39,7 @@ let unsafe_get_uint8 t off = Char.code (String.unsafe_get t off)
 let unsafe_set_uint8 t off v = Bytes.unsafe_set t off (Char.chr v)
 
 external unsafe_set_uint16 : bytes -> int -> int -> unit = "%caml_bytes_set16u"
-  [@@noalloc]
+[@@noalloc]
 
 external unsafe_get_uint16 : string -> int -> int = "%caml_string_get16u" [@@noalloc]
 

compiler/lib/code.ml

@@ -106,6 +106,8 @@ module Var : sig
 
     val set : 'a t -> key -> 'a -> unit
 
+    val length : 'a t -> int
+
     val make : size -> 'a -> 'a t
 
     val iter : (key -> 'a -> unit) -> 'a t -> unit
@@ -212,6 +214,8 @@ end = struct
 
     let set t x v = t.(x) <- v
 
+    let length t = Array.length t
+
     let make () v = Array.make (count ()) v
 
     let iter f t =
@@ -354,7 +358,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 * Addr.Set.t
   | Poptrap of cont
 
@@ -499,10 +503,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, pcs) ->
         Format.fprintf
@@ -598,9 +601,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
 
 type 'c fold_blocs = block Addr.Map.t -> Addr.t -> (Addr.t -> 'c -> 'c) -> 'c -> 'c
@@ -726,9 +728,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, _pcs) ->
           check_cont cont1;
           check_cont cont2

compiler/lib/code.mli

@@ -99,6 +99,8 @@ module Var : sig
 
     val set : 'a t -> key -> 'a -> unit
 
+    val length : 'a t -> int
+
     val make : size -> 'a -> 'a t
 
     val iter : (key -> 'a -> unit) -> 'a t -> unit
@@ -201,7 +203,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 * Addr.Set.t
   | Poptrap of cont
 

compiler/lib/config.ml

@@ -68,6 +68,8 @@ module Flag = struct
 
   let effects = o ~name:"effects" ~default:false
 
+  let double_translation = o ~name:"doubletranslate" ~default:false
+
   let staticeval = o ~name:"staticeval" ~default:true
 
   let share_constant = o ~name:"share" ~default:true

compiler/lib/config.mli

@@ -39,6 +39,8 @@ module Flag : sig
 
   val effects : unit -> bool
 
+  val double_translation : unit -> bool
+
   val genprim : unit -> bool
 
   val strictmode : unit -> bool

compiler/lib/deadcode.ml

@@ -28,6 +28,11 @@ open Code
 type def =
   | Expr of expr
   | Var of Var.t
+  | Field_update of Var.t
+
+let add_def defs x i =
+  let idx = Var.idx x in
+  defs.(idx) <- i :: defs.(idx)
 
 type variable_uses = int array
 
@@ -48,11 +53,15 @@ let pure_expr pure_funs e = Pure_fun.pure_expr pure_funs e && Config.Flag.deadco
 let rec mark_var st x =
   let x = Var.idx x in
   st.live.(x) <- st.live.(x) + 1;
-  if st.live.(x) = 1 then List.iter st.defs.(x) ~f:(fun e -> mark_def st e)
+  if st.live.(x) = 1 then List.iter st.defs.(x) ~f:(fun e -> mark_def st x e)
 
-and mark_def st d =
+and mark_def st x d =
   match d with
-  | Var x -> mark_var st x
+  | Var y -> mark_var st y
+  | Field_update y ->
+      (* A [Set_field (x, _, y)] becomes live *)
+      st.live.(x) <- st.live.(x) + 1;
+      mark_var st y
   | Expr e -> if pure_expr st.pure_funs e then mark_expr st e
 
 and mark_expr st e =
@@ -81,9 +90,14 @@ and mark_reachable st pc =
         match i with
         | Let (_, e) -> if not (pure_expr st.pure_funs e) then mark_expr st e
         | Assign _ -> ()
-        | Set_field (x, _, y) ->
-            mark_var st x;
-            mark_var st y
+        | Set_field (x, _, y) -> (
+            match st.defs.(Var.idx x) with
+            | [ Expr (Block _) ] when st.live.(Var.idx x) = 0 ->
+                (* We will keep this instruction only if x is live *)
+                add_def st.defs x (Field_update y)
+            | _ ->
+                mark_var st x;
+                mark_var st y)
         | Array_set (x, y, z) ->
             mark_var st x;
             mark_var st y;
@@ -97,10 +111,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)
@@ -110,8 +123,8 @@ and mark_reachable st pc =
 let live_instr st i =
   match i with
   | Let (x, e) -> st.live.(Var.idx x) > 0 || not (pure_expr st.pure_funs e)
-  | Assign (x, _) -> st.live.(Var.idx x) > 0
-  | Set_field _ | Offset_ref _ | Array_set _ -> true
+  | Assign (x, _) | Set_field (x, _, _) -> st.live.(Var.idx x) > 0
+  | Offset_ref _ | Array_set _ -> true
 
 let rec filter_args st pl al =
   match pl, al with
@@ -136,11 +149,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, pcs) ->
         Pushtrap
           ( filter_cont blocks st cont1
@@ -169,10 +179,6 @@ let annot st pc xi =
 
 (****)
 
-let add_def defs x i =
-  let idx = Var.idx x in
-  defs.(idx) <- i :: defs.(idx)
-
 let rec add_arg_dep defs params args =
   match params, args with
   | x :: params, y :: args ->
@@ -204,9 +210,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

compiler/lib/dgraph.ml

@@ -19,11 +19,12 @@
  *)
 open! Stdlib
 
-module Make (N : sig
-  type t
-end)
-(NSet : Set.S with type elt = N.t)
-(NMap : Map.S with type key = N.t) =
+module Make
+    (N : sig
+      type t
+    end)
+    (NSet : Set.S with type elt = N.t)
+    (NMap : Map.S with type key = N.t) =
 struct
   type t =
     { domain : NSet.t
@@ -175,11 +176,12 @@ module type Tbl = sig
   val make : size -> 'a -> 'a t
 end
 
-module Make_Imperative (N : sig
-  type t
-end)
-(NSet : ISet with type elt = N.t)
-(NTbl : Tbl with type key = N.t) =
+module Make_Imperative
+    (N : sig
+      type t
+    end)
+    (NSet : ISet with type elt = N.t)
+    (NTbl : Tbl with type key = N.t) =
 struct
   type t =
     { domain : NSet.t

compiler/lib/dgraph.mli

@@ -17,11 +17,12 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
-module Make (N : sig
-  type t
-end)
-(NSet : Set.S with type elt = N.t)
-(NMap : Map.S with type key = N.t) : sig
+module Make
+    (N : sig
+      type t
+    end)
+    (NSet : Set.S with type elt = N.t)
+    (NMap : Map.S with type key = N.t) : sig
   type t =
     { domain : NSet.t
     ; fold_children : 'a. (N.t -> 'a -> 'a) -> N.t -> 'a -> 'a
@@ -72,11 +73,12 @@ module type Tbl = sig
   val make : size -> 'a -> 'a t
 end
 
-module Make_Imperative (N : sig
-  type t
-end)
-(NSet : ISet with type elt = N.t)
-(NTbl : Tbl with type key = N.t) : sig
+module Make_Imperative
+    (N : sig
+      type t
+    end)
+    (NSet : ISet with type elt = N.t)
+    (NTbl : Tbl with type key = N.t) : sig
   type t =
     { domain : NSet.t
     ; iter_children : (N.t -> unit) -> N.t -> unit