Effect handlers

.github/workflows/build.yml

@@ -31,25 +31,32 @@ jobs:
           - true
         skip-doc:
           - true
+        skip-effects:
+          - true
         include:
           - os: ubuntu-latest
             ocaml-compiler: 4.14.x
+            skip-effects: true
             skip-test: false
             skip-doc: false
           - os: macos-latest
             ocaml-compiler: 4.14.x
+            skip-effects: true
             skip-test: false
             skip-doc: true
           - os: windows-latest
             ocaml-compiler: 4.14.x
+            skip-effects: true
             skip-test: false
             skip-doc: true
           - os: ubuntu-latest
             ocaml-compiler: ocaml-variants.5.0.0+trunk
+            skip-effects: false
             skip-test: false
             skip-doc: true
           - os: macos-latest
             ocaml-compiler: ocaml-variants.5.0.0+trunk
+            skip-effects: true
             skip-test: false
             skip-doc: true
 
@@ -90,6 +97,9 @@ jobs:
       - run: opam exec -- make tests
         if: ${{ !matrix.skip-test }}
 
+      - run: opam exec -- dune build @all @runtest --profile using-effects
+        if: ${{ !matrix.skip-effects }}
+
       - run: opam exec -- git diff --exit-code
         if: ${{ !matrix.skip-test }}
 

CHANGES.md

@@ -1,5 +1,6 @@
 # dev (202?-??) - ??
 ## Features/Changes
+* Compiler: add support for effect handlers (--enable=effects)
 * Compiler: small refactoring in code generation
 * Compiler: check build info compatibility when linking js file.
 * Misc: fix and update benchmarks

README.md

@@ -94,6 +94,8 @@ optimized:
   [More](http://ocsigen.org/js_of_ocaml/dev/manual/tailcall) about tail call
   optimization.
 
+Effect handlers are supported with the `--enable=effects` flag.
+
 ## Data representation
 
 Data representation differs from the usual one. Most notably, integers are 32

benchmarks/Makefile

@@ -4,13 +4,18 @@ GRAPHSNOPR = time.pdf time-optim.pdf nativejs.pdf
 # graphs with precompiled programs:
 GRAPHSPR = size.pdf size-optim.pdf compiletime.pdf
 
+# graphs showing the impact of supporting effects
+GRAPHSEFF = time-effects.pdf size-effects.pdf
+
 # For full benchs:
-all: _perf graphsnopr graphspr _noperf
+all: _perf graphsnopr graphspr graphseff _noperf
 
 graphsnopr: _noprecomp $(GRAPHSNOPR)
 
 graphspr: __precomp $(GRAPHSPR)
 
+graphseff: $(GRAPHSEFF)
+
 # For fast benchs:
 test: _perf fastrun $(GRAPHS) _noperf
 
@@ -42,6 +47,11 @@ __run:
 	$(RUN) -all
 	touch __run
 
+__run_effects:
+	make _noprecomp
+	$(RUN) -fast -nobyteopt -effects
+	touch __run_effects
+
 fastrun:
 	make _noprecomp
 	echo "======================== WARNING: fast benchs!"
@@ -138,6 +148,26 @@ size-optim.svg: __run __missingsizes
 	 -max 2.5 -svg 7 650 150 -edgecaption -ylabel Size \
 	 > $@
 
+time-effects.svg: __run_effects
+	$(REPORT) -config report-time-effects.config \
+	 -omit binary_trees \
+	 -omit fannkuch_redux \
+	 -omit fannkuch_redux_2 \
+	 -omit loop \
+	 -max 5 -svg 7 400 150 -edgecaption -ylabel "Execution time" \
+	 > $@
+
+size-effects.svg: __run_effects
+	$(REPORT) -config report-size-effects.config \
+	 -omit binary_trees \
+	 -omit fannkuch_redux \
+	 -omit fannkuch_redux_2 \
+	 -omit boyer_no_exc \
+	 -omit kb_no_exc \
+	 -omit loop \
+	 -max 2.5 -svg 7 650 150 -edgecaption -ylabel Size \
+	 > $@
+
 compiletime.svg: __run __precomp __missingcompiletimes
 	$(REPORT) -config report-compiletime.config \
 	 -omit binary_trees \

benchmarks/common.ml

@@ -160,6 +160,8 @@ module Spec : sig
   val js_of_ocaml_compact : t
 
   val js_of_ocaml_call : t
+
+  val js_of_ocaml_effects : t
 end = struct
   type t =
     { dir : string
@@ -221,6 +223,8 @@ end = struct
   let js_of_ocaml_compact = create "notcompact" ".js"
 
   let js_of_ocaml_call = create "nooptcall" ".js"
+
+  let js_of_ocaml_effects = create "effects" ".js"
 end
 
 let rec mkdir d =

benchmarks/report-size-effects.config

@@ -0,0 +1,2 @@
+histogramref sizes "" js_of_ocaml/generated #fbaf4f direct
+histogram sizes "" effects #fb4f4f effects

benchmarks/report-time-effects.config

@@ -0,0 +1,2 @@
+histogramref times node js_of_ocaml #fbaf4f default
+histogram times node effects #fb4f4f --enable=effects

benchmarks/run.ml

@@ -34,7 +34,7 @@ module Param = struct
     { warm_up_time = 1.0
     ; min_measures = 10
     ; max_confidence = 0.03
-    ; max_duration = 5.
+    ; max_duration = 20.
     ; verbose = false
     }
 
@@ -207,6 +207,7 @@ let read_config file =
 let _ =
   let compile_only = ref false in
   let full = ref false in
+  let effects = ref false in
   let conf_file = ref "run.config" in
   let nobyteopt = ref false in
   let param = ref Param.default in
@@ -216,6 +217,7 @@ let _ =
   let options =
     [ "-compile", Arg.Set compile_only, " only compiles"
     ; "-all", Arg.Set full, " run all benchmarks"
+    ; "-effects", Arg.Set effects, " only run with and without effect handler support"
     ; "-config", Arg.Set_string conf_file, "<file> use <file> as a config file"
     ; "-fast", Arg.Unit fast_run, " perform less iterations"
     ; "-ffast", Arg.Unit ffast_run, " perform very few iterations"
@@ -233,14 +235,16 @@ let _ =
   let compile_only = !compile_only in
   let nobyteopt = !nobyteopt in
   let full = !full in
+  let effects = !effects in
   let param = !param in
   let interpreters = read_config conf_file in
   let compile = compile param ~comptime:true in
-  let compile_jsoo opts =
+  let compile_jsoo ?(effects = false) opts =
     compile
       (Format.sprintf
-         "js_of_ocaml -q --target-env browser --debug mark-runtime-gen %s"
-         opts)
+         "js_of_ocaml -q --target-env browser --debug mark-runtime-gen %s %s"
+         opts
+         (if effects then "--enable=effects" else "--disable=effects"))
   in
   Format.eprintf "Compile@.";
   compile "ocamlc" src Spec.ml code Spec.byte;
@@ -252,6 +256,7 @@ let _ =
   compile_jsoo "--disable deadcode" code Spec.byte code Spec.js_of_ocaml_deadcode;
   compile_jsoo "--disable compact" code Spec.byte code Spec.js_of_ocaml_compact;
   compile_jsoo "--disable optcall" code Spec.byte code Spec.js_of_ocaml_call;
+  compile_jsoo ~effects:true "" code Spec.byte code Spec.js_of_ocaml_effects;
   compile "ocamlc -unsafe" src Spec.ml code Spec.byte_unsafe;
   compile "ocamlopt" src Spec.ml code Spec.opt_unsafe;
   compile_jsoo "" code Spec.byte_unsafe code Spec.js_of_ocaml_unsafe;
@@ -278,6 +283,7 @@ let _ =
   gen_size param code Spec.js_of_ocaml_deadcode sizes Spec.js_of_ocaml_deadcode;
   gen_size param code Spec.js_of_ocaml_compact sizes Spec.js_of_ocaml_compact;
   gen_size param code Spec.js_of_ocaml_call sizes Spec.js_of_ocaml_call;
+  gen_size param code Spec.js_of_ocaml_effects sizes Spec.js_of_ocaml_effects;
   if compile_only then exit 0;
   Format.eprintf "Measure@.";
   if not nobyteopt
@@ -296,7 +302,14 @@ let _ =
         ; Some Spec.js_of_ocaml_deadcode
         ; Some Spec.js_of_ocaml_compact
         ; Some Spec.js_of_ocaml_call
+        ; Some Spec.js_of_ocaml_effects
         ] )
+    else if effects
+    then
+      ( (match interpreters with
+        | i :: _ -> [ i ]
+        | [] -> [])
+      , [ Some Spec.js_of_ocaml; Some Spec.js_of_ocaml_effects ] )
     else
       ( (match interpreters with
         | i :: _ -> [ i ]

compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml

@@ -15,7 +15,8 @@ let split_primitives p =
 
 let () =
   let global = J.pure_js_expr "globalThis" in
-  Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.use_js_string ());
+  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) :
       unit -> J.t =
@@ -35,9 +36,9 @@ let () =
     res (js : string)
   in
   let toplevel_eval (x : string) : unit -> J.t =
-    let f : J.t -> J.t = J.eval_string x in
+    let f : J.t = J.eval_string x in
     fun () ->
-      let res = f global in
+      let res = J.fun_call f [| global |] in
       Format.(pp_print_flush std_formatter ());
       Format.(pp_print_flush err_formatter ());
       flush stdout;

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

@@ -37,6 +37,15 @@ let to_ident s =
       | '0' .. '9' as c -> c
       | _ -> '_')
 
+let rec list_product l =
+  match l with
+  | [] -> [ [] ]
+  | (key, values) :: xs ->
+      let tail = list_product xs in
+      List.concat_map values ~f:(fun v -> List.map tail ~f:(fun l -> (key, v) :: l))
+
+let bool = [ true; false ]
+
 let () =
   match Array.to_list Sys.argv with
   | [] -> assert false
@@ -45,12 +54,11 @@ let () =
       let fragments =
         List.map rest ~f:(fun f -> f, Js_of_ocaml_compiler.Linker.Fragment.parse_file f)
       in
+      let variants = list_product [ "use-js-string", bool; "effects", bool ] in
       (* load all files to make sure they are valid *)
-      List.iter [ true; false ] ~f:(fun js_string ->
-          (if js_string
-          then Js_of_ocaml_compiler.Config.Flag.enable
-          else Js_of_ocaml_compiler.Config.Flag.disable)
-            "use-js-string";
+      List.iter variants ~f:(fun setup ->
+          List.iter setup ~f:(fun (name, b) ->
+              Js_of_ocaml_compiler.Config.Flag.set name b);
           List.iter Js_of_ocaml_compiler.Target_env.all ~f:(fun target_env ->
               Js_of_ocaml_compiler.Linker.reset ();
               List.iter fragments ~f:(fun (filename, frags) ->

compiler/lib/build_info.ml

@@ -29,7 +29,7 @@ let create () =
   in
 
   [ "use-js-string", string_of_bool (Config.Flag.use_js_string ())
-  ; "effects", "false"
+  ; "effects", string_of_bool (Config.Flag.effects ())
   ; "version", version
   ]
   |> List.fold_left ~init:StringMap.empty ~f:(fun acc (k, v) -> StringMap.add k v acc)

compiler/lib/code.ml

@@ -308,7 +308,11 @@ type prim_arg =
   | Pc of constant
 
 type expr =
-  | Apply of Var.t * Var.t list * bool
+  | Apply of
+      { f : Var.t
+      ; args : Var.t list
+      ; exact : bool
+      }
   | Block of int * Var.t array * array_or_not
   | Field of Var.t * int
   | Closure of Var.t list * cont
@@ -435,10 +439,10 @@ module Print = struct
 
   let expr f e =
     match e with
-    | Apply (g, l, exact) ->
+    | Apply { f = g; args; exact } ->
         if exact
-        then Format.fprintf f "%a!(%a)" Var.print g var_list l
-        else Format.fprintf f "%a(%a)" Var.print g var_list l
+        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;
         for i = 0 to Array.length a - 1 do
@@ -588,6 +592,23 @@ let rec traverse' { fold } f pc visited blocks acc =
 
 let traverse fold f pc blocks acc = snd (traverse' fold f pc Addr.Set.empty blocks acc)
 
+let rec preorder_traverse' { fold } f pc visited blocks acc =
+  if not (Addr.Set.mem pc visited)
+  then
+    let visited = Addr.Set.add pc visited in
+    let acc = f pc acc in
+    fold
+      blocks
+      pc
+      (fun pc (visited, acc) ->
+        let visited, acc = preorder_traverse' { fold } f pc visited blocks acc in
+        visited, acc)
+      (visited, acc)
+  else visited, acc
+
+let preorder_traverse fold f pc blocks acc =
+  snd (preorder_traverse' fold f pc Addr.Set.empty blocks acc)
+
 let eq p1 p2 =
   p1.start = p2.start
   && Addr.Map.cardinal p1.blocks = Addr.Map.cardinal p2.blocks
@@ -624,7 +645,7 @@ let invariant { blocks; start; _ } =
         defs.(Var.idx x) <- true)
     in
     let check_expr = function
-      | Apply (_, _, _) -> ()
+      | Apply _ -> ()
       | Block (_, _, _) -> ()
       | Field (_, _) -> ()
       | Closure (l, cont) ->

compiler/lib/code.mli

@@ -156,8 +156,11 @@ type prim_arg =
   | Pc of constant
 
 type expr =
-  | Apply of Var.t * Var.t list * bool
-  (* if true, then # of arguments = # of parameters *)
+  | 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
   | Field of Var.t * int
   | Closure of Var.t list * cont
@@ -223,6 +226,9 @@ val fold_children : 'c fold_blocs
 val traverse :
   fold_blocs_poly -> (Addr.t -> 'c -> 'c) -> Addr.t -> block Addr.Map.t -> 'c -> 'c
 
+val preorder_traverse :
+  fold_blocs_poly -> (Addr.t -> 'c -> 'c) -> Addr.t -> block Addr.Map.t -> 'c -> 'c
+
 val prepend : program -> instr list -> program
 
 val empty : program

compiler/lib/config.ml

@@ -66,6 +66,8 @@ module Flag = struct
 
   let inline = o ~name:"inline" ~default:true
 
+  let effects = o ~name:"effects" ~default:false
+
   let staticeval = o ~name:"staticeval" ~default:true
 
   let share_constant = o ~name:"share" ~default:true
@@ -157,4 +159,11 @@ module Param = struct
       ~name:"tc"
       ~desc:"Set tailcall optimisation"
       (enum [ "trampoline", TcTrampoline; (* default *) "none", TcNone ])
+
+  let lambda_lifting_threshold =
+    (* When we reach this depth, we start looking for functions to be lifted *)
+    p
+      ~name:"lifting-threshold"
+      ~desc:"Set threshold for lifting deeply nested functions"
+      (int 50)
 end