Merge pull request #108 from ocaml-wasm/dead-code-fix

Fix bad interaction of deadcode elimination and unboxed float records

Author: vouillon

compiler/bin-wasm_of_ocaml/compile.ml

@@ -146,7 +146,9 @@ let generate_prelude ~out_file =
     | Some p -> p
     | None -> assert false
   in
-  let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize ~profile code in
+  let Driver.{ program; variable_uses; in_cps; deadcode_sentinal; _ } =
+    Driver.optimize ~profile code
+  in
   let context = Wa_generate.start () in
   let debug = Parse_bytecode.Debug.create ~include_cmis:false false in
   let _ =
@@ -155,6 +157,7 @@ let generate_prelude ~out_file =
       ~unit_name:(Some "prelude")
       ~live_vars:variable_uses
       ~in_cps
+      ~deadcode_sentinal
       ~debug
       program
   in
@@ -305,11 +308,20 @@ let run
       | None, Some p -> p
       | None, None -> assert false
     in
-    let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize ~profile code in
+    let Driver.{ program; variable_uses; in_cps; deadcode_sentinal; _ } =
+      Driver.optimize ~profile code
+    in
     let context = Wa_generate.start () in
     let debug = one.debug in
     let toplevel_name, generated_js =
-      Wa_generate.f ~context ~unit_name ~live_vars:variable_uses ~in_cps ~debug program
+      Wa_generate.f
+        ~context
+        ~unit_name
+        ~live_vars:variable_uses
+        ~in_cps
+        ~deadcode_sentinal
+        ~debug
+        program
     in
     if standalone then Wa_generate.add_start_function ~context toplevel_name;
     Wa_generate.output ch ~context ~debug;

compiler/lib/wasm/wa_curry.ml

@@ -257,7 +257,13 @@ module Make (Target : Wa_target_sig.S) = struct
         (fun ~typ closure ->
           let* l = expression_list load l in
           call ?typ ~cps:true ~arity closure l)
-        (let* args = Memory.allocate ~tag:0 (List.map ~f:(fun x -> `Var x) (List.tl l)) in
+        (let* args =
+           (* We don't need the deadcode sentinal when the tag is 0 *)
+           Memory.allocate
+             ~tag:0
+             ~deadcode_sentinal:(Code.Var.fresh ())
+             (List.map ~f:(fun x -> `Var x) (List.tl l))
+         in
          let* make_iterator =
            register_import ~name:"caml_apply_continuation" (Fun (func_type 0))
          in

compiler/lib/wasm/wa_gc_target.ml

@@ -656,16 +656,18 @@ module Memory = struct
     let* ty = Type.float_type in
     wasm_struct_get ty (wasm_cast ty e) 0
 
-  let allocate ~tag l =
+  let allocate ~tag ~deadcode_sentinal l =
     if tag = 254
     then
       let* l =
         expression_list
           (fun v ->
-            unbox_float
-              (match v with
-              | `Var y -> load y
-              | `Expr e -> return e))
+            match v with
+            | `Var y ->
+                if Code.Var.equal y deadcode_sentinal
+                then return (W.Const (F64 0.))
+                else unbox_float (load y)
+            | `Expr e -> unbox_float (return e))
           l
       in
       let* ty = Type.float_array_type in

compiler/lib/wasm/wa_generate.ml

@@ -32,6 +32,7 @@ module Generate (Target : Wa_target_sig.S) = struct
   type ctx =
     { live : int array
     ; in_cps : Effects.in_cps
+    ; deadcode_sentinal : Var.t
     ; blocks : block Addr.Map.t
     ; closures : Wa_closure_conversion.closure Var.Map.t
     ; global_context : Wa_code_generation.context
@@ -209,7 +210,10 @@ module Generate (Target : Wa_target_sig.S) = struct
         let* closure = load f in
         return (W.Call (apply, args @ [ closure ]))
     | Block (tag, a, _, _) ->
-        Memory.allocate ~tag (List.map ~f:(fun x -> `Var x) (Array.to_list a))
+        Memory.allocate
+          ~deadcode_sentinal:ctx.deadcode_sentinal
+          ~tag
+          (List.map ~f:(fun x -> `Var x) (Array.to_list a))
     | Field (x, n, Non_float) -> Memory.field (load x) n
     | Field (x, n, Float) ->
         Memory.float_array_get
@@ -633,7 +637,7 @@ module Generate (Target : Wa_target_sig.S) = struct
                     l
                     ~init:(return [])
                 in
-                Memory.allocate ~tag:0 l
+                Memory.allocate ~tag:0 ~deadcode_sentinal:ctx.deadcode_sentinal l
             | Extern name, l -> (
                 let name = Primitive.resolve name in
                 try
@@ -1088,14 +1092,22 @@ module Generate (Target : Wa_target_sig.S) = struct
     ~should_export
     ~warn_on_unhandled_effect
 *)
+      ~deadcode_sentinal
       ~debug =
     global_context.unit_name <- unit_name;
     let p, closures = Wa_closure_conversion.f p in
     (*
   Code.Print.program (fun _ _ -> "") p;
 *)
     let ctx =
-      { live = live_vars; in_cps; blocks = p.blocks; closures; global_context; debug }
+      { live = live_vars
+      ; in_cps
+      ; deadcode_sentinal
+      ; blocks = p.blocks
+      ; closures
+      ; global_context
+      ; debug
+      }
     in
     let toplevel_name = Var.fresh_n "toplevel" in
     let functions =
@@ -1198,10 +1210,10 @@ let fix_switch_branches p =
 
 let start () = make_context ~value_type:Wa_gc_target.Value.value
 
-let f ~context ~unit_name p ~live_vars ~in_cps ~debug =
+let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~debug =
   let p = if Config.Flag.effects () then fix_switch_branches p else p in
   let module G = Generate (Wa_gc_target) in
-  G.f ~context ~unit_name ~live_vars ~in_cps ~debug p
+  G.f ~context ~unit_name ~live_vars ~in_cps ~deadcode_sentinal ~debug p
 
 let add_start_function =
   let module G = Generate (Wa_gc_target) in

compiler/lib/wasm/wa_generate.mli

@@ -26,6 +26,7 @@ val f :
   -> Code.program
   -> live_vars:int array
   -> in_cps:Effects.in_cps
+  -> deadcode_sentinal:Code.Var.t
   -> debug:Parse_bytecode.Debug.t
   -> Wa_ast.var * (string list * (string * Javascript.expression) list)
 

compiler/lib/wasm/wa_target_sig.ml

@@ -21,7 +21,10 @@ module type S = sig
 
   module Memory : sig
     val allocate :
-      tag:int -> [ `Expr of Wa_ast.expression | `Var of Wa_ast.var ] list -> expression
+         tag:int
+      -> deadcode_sentinal:Code.Var.t
+      -> [ `Expr of Wa_ast.expression | `Var of Wa_ast.var ] list
+      -> expression
 
     val load_function_pointer :
          cps:bool

compiler/tests-wasm_of_ocaml/dune

@@ -1,8 +1,8 @@
 (executables
- (names gh38 gh46)
+ (names gh38 gh46 gh107)
  (modes js)
  (js_of_ocaml
-  (flags :standard --disable optcall)))
+  (flags :standard --disable optcall --no-inline)))
 
 (rule
  (target gh38.actual)
@@ -23,3 +23,13 @@
   (with-outputs-to
    %{target}
    (run node %{dep:gh46.bc.js}))))
+
+(rule
+ (target gh107.actual)
+ (enabled_if
+  (= %{profile} wasm))
+ (alias runtest)
+ (action
+  (with-outputs-to
+   %{target}
+   (run node %{dep:gh107.bc.js}))))

compiler/tests-wasm_of_ocaml/gh107.ml

@@ -0,0 +1,11 @@
+[@@@warning "-69"]
+
+type t =
+  { x : float
+  ; y : float
+  }
+
+let () =
+  let f x = { x; y = 2. } in
+  let x = f 1. in
+  Format.eprintf "%f@." x.y