Compiler: better handling of empty libs (#1169)

Author: hhugo

CHANGES.md

@@ -1,3 +1,8 @@
+# dev (2021-??-??) - ??
+
+## Bug fixes
+* Compiler: fix sourcemap warning for empty cma
+
 # 3.11.0 (2021-10-06) - Lille
 
 ## Features/Changes

compiler/bin-js_of_ocaml/compile.ml

@@ -116,10 +116,11 @@ let run
   in
   if times () then Format.eprintf "Start parsing...@.";
   let need_debug = Option.is_some source_map || Config.Flag.debuginfo () in
-  let check_debug debug =
+  let check_debug (one : Parse_bytecode.one) =
     if (not runtime_only)
        && Option.is_some source_map
-       && Parse_bytecode.Debug.is_empty debug
+       && Parse_bytecode.Debug.is_empty one.debug
+       && not (Code.is_empty one.code)
     then
       warn
         "Warning: '--source-map' is enabled but the bytecode program was compiled with \
@@ -141,7 +142,7 @@ let run
         Code.(Let (Var.fresh (), Prim (Extern "caml_set_static_env", args))))
   in
   let output (one : Parse_bytecode.one) ~standalone output_file =
-    check_debug one.debug;
+    check_debug one;
     let init_pseudo_fs = fs_external && standalone in
     (match output_file with
     | `Stdout ->

compiler/lib/code.ml

@@ -531,13 +531,25 @@ let prepend ({ start; blocks; free_pc } as p) body =
       let free_pc = free_pc + 1 in
       { start = new_start; blocks; free_pc }
 
+let empty_block = { params = []; handler = None; body = []; branch = Stop }
+
 let empty =
   let start = 0 in
-  let free_pc = 1 in
-  let blocks =
-    Addr.Map.singleton start { params = []; handler = None; body = []; branch = Stop }
-  in
-  { start; blocks; free_pc }
+  let blocks = Addr.Map.singleton start empty_block in
+  { start; blocks; free_pc = start + 1 }
+
+let is_empty p =
+  match Addr.Map.cardinal p.blocks with
+  | 0 -> true
+  | 1 -> (
+      let _, v = Addr.Map.choose p.blocks in
+      match v with
+      | { handler = None; body; branch = Stop; params = _ } -> (
+          match body with
+          | ([] | [ Let (_, Prim (Extern "caml_get_global_data", _)) ]) when true -> true
+          | _ -> false)
+      | _ -> false)
+  | _ -> false
 
 let fold_children blocks pc f accu =
   let block = Addr.Map.find pc blocks in
@@ -601,9 +613,10 @@ let with_invariant = Debug.find "invariant"
 
 let check_defs = false
 
-let invariant { blocks; _ } =
+let invariant { blocks; start; _ } =
   if with_invariant ()
-  then
+  then (
+    assert (Addr.Map.mem start blocks);
     let defs = Array.make (Var.count ()) false in
     let check_cont (cont, args) =
       let b = Addr.Map.find cont blocks in
@@ -655,4 +668,4 @@ let invariant { blocks; _ } =
         Option.iter block.handler ~f:(fun (_, cont) -> check_cont cont);
         List.iter block.body ~f:check_instr;
         check_last block.branch)
-      blocks
+      blocks)

compiler/lib/code.mli

@@ -227,6 +227,8 @@ val prepend : program -> instr list -> program
 
 val empty : program
 
+val is_empty : program -> bool
+
 val eq : program -> program -> bool
 
 val invariant : program -> unit

compiler/lib/generate.ml

@@ -222,7 +222,7 @@ module Ctx = struct
     ; live : int array
     ; share : Share.t
     ; debug : Parse_bytecode.Debug.t
-    ; exported_runtime : Code.Var.t option
+    ; exported_runtime : (Code.Var.t * bool ref) option
     }
 
   let initial ~exported_runtime blocks live share debug =
@@ -275,7 +275,9 @@ let s_var name = J.EVar (J.ident name)
 
 let runtime_fun ctx name =
   match ctx.Ctx.exported_runtime with
-  | Some runtime -> J.EDot (J.EVar (J.V runtime), name)
+  | Some (runtime, runtime_needed) ->
+      runtime_needed := true;
+      J.EDot (J.EVar (J.V runtime), name)
   | None -> s_var name
 
 let str_js s = J.EStr (s, `Bytes)
@@ -1891,7 +1893,8 @@ let generate_shared_value ctx =
         (J.Variable_statement
            ((match ctx.Ctx.exported_runtime with
             | None -> []
-            | Some v ->
+            | Some (_, { contents = false }) -> []
+            | Some (v, _) ->
                 [ J.V v, Some (J.EDot (s_var Constant.global_object, "jsoo_runtime"), J.N)
                 ])
            @ List.map
@@ -1924,7 +1927,7 @@ let f (p : Code.program) ~exported_runtime ~live_vars debug =
   let t' = Timer.make () in
   let share = Share.get ~alias_prims:exported_runtime p in
   let exported_runtime =
-    if exported_runtime then Some (Code.Var.fresh_n "runtime") else None
+    if exported_runtime then Some (Code.Var.fresh_n "runtime", ref false) else None
   in
   let ctx = Ctx.initial ~exported_runtime p.blocks live_vars share debug in
   let p = compile_program ctx p.start in

compiler/lib/parse_bytecode.ml

@@ -2101,22 +2101,29 @@ let parse_bytecode code globals debug_data =
     else blocks
   in
   let blocks' = Blocks.finish_analysis blocks in
-  if not (Blocks.is_empty blocks') then compile_block blocks' debug_data code 0 state;
-  let blocks =
-    Addr.Map.mapi
-      (fun _ (state, instr, last) ->
-        { params = State.stack_vars state
-        ; handler = State.current_handler state
-        ; body = instr
-        ; branch = last
-        })
-      !compiled_blocks
+  let p =
+    if not (Blocks.is_empty blocks')
+    then (
+      let start = 0 in
+      compile_block blocks' debug_data code start state;
+      let blocks =
+        Addr.Map.mapi
+          (fun _ (state, instr, last) ->
+            { params = State.stack_vars state
+            ; handler = State.current_handler 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
   compiled_blocks := Addr.Map.empty;
   tagged_blocks := Addr.Set.empty;
-  let free_pc = String.length code / 4 in
-  let blocks = match_exn_traps blocks in
-  { start = 0; blocks; free_pc }
+  p
 
 (* HACK - override module *)
 
@@ -2317,21 +2324,25 @@ let from_exe
         ]
       in
       let gdata = Var.fresh () in
+      let need_gdata = ref false in
       let infos =
         [ "toc", Constants.parse (Obj.repr toc)
         ; "prim_count", Int (Int32.of_int (Array.length globals.primitives))
         ]
       in
       let body =
         List.fold_left infos ~init:body ~f:(fun rem (name, const) ->
+            need_gdata := true;
             let c = Var.fresh () in
             Let (c, Constant const)
             :: Let
                  ( Var.fresh ()
                  , Prim (Extern "caml_js_set", [ Pv gdata; Pc (String name); Pv c ]) )
             :: rem)
       in
-      Let (gdata, Prim (Extern "caml_get_global_data", [])) :: body
+      if !need_gdata
+      then Let (gdata, Prim (Extern "caml_get_global_data", [])) :: body
+      else body
     else body
   in
   (* List interface files *)
@@ -2387,13 +2398,20 @@ let from_bytes primitives (code : bytecode) =
   let globals = make_globals 0 [||] primitives in
   let p = parse_bytecode code globals debug_data in
   let gdata = Var.fresh () in
+  let need_gdata = ref false in
   let body =
     Array.fold_right_i globals.vars ~init:[] ~f:(fun i var l ->
         match var with
-        | Some x when globals.is_const.(i) -> Let (x, Field (gdata, i)) :: l
+        | Some x when globals.is_const.(i) ->
+            need_gdata := true;
+            Let (x, Field (gdata, i)) :: l
         | _ -> l)
   in
-  let body = Let (gdata, Prim (Extern "caml_get_global_data", [])) :: body in
+  let body =
+    if !need_gdata
+    then Let (gdata, Prim (Extern "caml_get_global_data", [])) :: body
+    else body
+  in
   prepend p body, debug_data
 
 let from_string primitives (code : string) = from_bytes primitives code
@@ -2500,6 +2518,7 @@ let from_compilation_units ~includes:_ ~toplevel ~debug_data l =
   in
   let prog = parse_bytecode code globals debug_data in
   let gdata = Var.fresh_n "global_data" in
+  let need_gdata = ref false in
   let body =
     Array.fold_right_i globals.vars ~init:[] ~f:(fun i var l ->
         match var with
@@ -2515,11 +2534,16 @@ let from_compilation_units ~includes:_ ~toplevel ~debug_data l =
                 Let (x, Constant cst) :: l
             | Some name ->
                 Var.name x name;
+                need_gdata := true;
                 Let (x, Prim (Extern "caml_js_get", [ Pv gdata; Pc (IString name) ])) :: l
             )
         | _ -> l)
   in
-  let body = Let (gdata, Prim (Extern "caml_get_global_data", [])) :: body in
+  let body =
+    if !need_gdata
+    then Let (gdata, Prim (Extern "caml_get_global_data", [])) :: body
+    else body
+  in
   let cmis =
     if toplevel && Config.Flag.include_cmis ()
     then

compiler/tests-compiler/empty_cma.ml

@@ -21,15 +21,15 @@ open Util
 
 let%expect_test _ =
   compile_lib [] "empty"
-  |> compile_cmo_to_javascript ~sourcemap:false
+  |> compile_cmo_to_javascript ~sourcemap:true
   |> Filetype.read_js
   |> Filetype.string_of_js_text
   |> print_endline;
   Sys.remove "empty.cma";
   Sys.remove "empty.js";
   [%expect
     {|
-      (function(joo_global_object)
-         {"use strict";var runtime=joo_global_object.jsoo_runtime;return}
-        (function(){return this}()));
+      (function(joo_global_object){"use strict";return}(function(){return this}()));
+
+      //# sourceMappingURL=empty.map
     |}]