Compiler: add js_of_ocaml-check-runtime tool (#1121)

hhugo · web-flow · commit 2ef64a2ae388 · 2021-08-20T15:39:27.000+02:00
* Compiler: add js_of_ocaml-check-primitives tool

* Compiler: compat for List.concat_map

* Changes
diff --git a/CHANGES.md b/CHANGES.md
@@ -1,6 +1,7 @@
 # ??? (??) - ??
 ## Features/Changes
 * Compiler: add support for OCaml 4.13
+* Compiler: new tool to check for missing primitives
 * Lib: add offsetX and offsetY to Dom_html.mouseEvent
 * Lib: add innerText property for Dom_html
 * Runtime: add dummy implementation for many dummy primitives
diff --git a/compiler/bin-js_of_ocaml/check_runtime.ml b/compiler/bin-js_of_ocaml/check_runtime.ml
@@ -0,0 +1,148 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2021 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.
+ *)
+
+open! Js_of_ocaml_compiler.Stdlib
+open Js_of_ocaml_compiler
+
+let group_by_snd l =
+  l
+  |> List.sort_uniq ~compare:(fun (n1, l1) (n2, l2) ->
+         match Poly.compare l1 l2 with
+         | 0 -> String.compare n1 n2
+         | c -> c)
+  |> List.group ~f:(fun (_, g1) (_, g2) -> Poly.equal g1 g2)
+
+let print_groups output l =
+  List.iter l ~f:(fun group ->
+      match group with
+      | [] -> assert false
+      | (_, loc) :: _ ->
+          (match loc with
+          | [] -> ()
+          | loc ->
+              output_string
+                output
+                (Printf.sprintf "\nFrom %s:\n" (String.concat ~sep:"," loc)));
+          List.iter group ~f:(fun (name, _) ->
+              output_string output (Printf.sprintf "%s\n" name)))
+
+let f (runtime_files, bytecode) =
+  let runtime_files, builtin =
+    List.partition_map runtime_files ~f:(fun name ->
+        match Builtins.find name with
+        | Some t -> `Snd t
+        | None -> `Fst name)
+  in
+  let builtin = if false then builtin else Jsoo_runtime.runtime @ builtin in
+  List.iter builtin ~f:(fun t ->
+      let filename = Builtins.File.name t in
+      let runtimes = Linker.parse_builtin t in
+      List.iter runtimes ~f:(Linker.load_fragment ~filename));
+  Linker.load_files runtime_files;
+  let all_prims =
+    List.concat_map bytecode ~f:(fun f ->
+        let ic = open_in_bin f in
+        let prims =
+          match Parse_bytecode.from_channel ic with
+          | `Cmo x -> x.Cmo_format.cu_primitives
+          | `Cma x ->
+              List.concat_map
+                ~f:(fun x -> x.Cmo_format.cu_primitives)
+                x.Cmo_format.lib_units
+          | `Exe ->
+              let toc = Parse_bytecode.Toc.read ic in
+              Parse_bytecode.read_primitives toc ic
+        in
+        close_in ic;
+        List.map ~f:(fun p -> p, f) prims)
+  in
+  let _percent_prim, needed =
+    List.partition all_prims ~f:(fun (x, _) -> Char.equal (String.get x 0) '%')
+  in
+  let origin =
+    List.fold_left
+      ~f:(fun acc (x, y) ->
+        let l = try StringMap.find x acc with Not_found -> [] in
+        StringMap.add x (y :: l) acc)
+      ~init:StringMap.empty
+      needed
+  in
+  let needed = StringSet.of_list (List.map ~f:fst needed) in
+  let from_runtime1 = Linker.get_provided () 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) *)
+  assert (StringSet.is_empty (StringSet.diff from_runtime1 from_runtime2));
+  let missing' = StringSet.diff needed from_runtime1 in
+  let all_used, missing =
+    let state = Linker.init () in
+    let state, missing = Linker.resolve_deps state needed in
+    StringSet.of_list (Linker.all state), missing
+  in
+  assert (StringSet.equal missing missing');
+  let extra =
+    StringSet.diff from_runtime1 all_used
+    |> StringSet.elements
+    |> List.map ~f:(fun name ->
+           ( name
+           , match Linker.origin ~name with
+             | None -> []
+             | Some x -> [ x ] ))
+    |> group_by_snd
+  in
+
+  let missing_for_real =
+    StringSet.diff missing from_runtime2
+    |> StringSet.elements
+    |> List.map ~f:(fun x -> x, StringMap.find x origin)
+    |> group_by_snd
+  in
+
+  let output = stdout in
+  output_string output "Missing\n";
+  output_string output "-------\n";
+  print_groups output missing_for_real;
+  output_string output "\n";
+  output_string output "Unused\n";
+  output_string output "-------\n";
+  print_groups output extra;
+  output_string output "\n";
+  ()
+
+let options =
+  let open Cmdliner in
+  (* TODO: add flags to only display missing or extra primitives *)
+  let files =
+    let doc = "Bytecode and JavaScript files [$(docv)]. " in
+    Arg.(value & pos_all string [] & info [] ~docv:"FILES" ~doc)
+  in
+  let build_t files =
+    let files = List.partition files ~f:(fun file -> Filename.check_suffix file ".js") in
+    `Ok files
+  in
+  let t = Term.(pure build_t $ files) in
+  Term.ret t
+
+let info =
+  Info.make
+    ~name:"check-runtime"
+    ~doc:"Check runtime"
+    ~description:"js_of_ocaml-check-runtime checks the runtime."
+
+let command = Cmdliner.Term.(pure f $ options), info
diff --git a/compiler/bin-js_of_ocaml/js_of_ocaml.ml b/compiler/bin-js_of_ocaml/js_of_ocaml.ml
@@ -53,6 +53,7 @@ let _ =
       ; Build_fs.command
       ; Build_runtime.command
       ; Print_runtime.command
+      ; Check_runtime.command
       ; Compile.command
       ]
   with
diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml
@@ -490,3 +490,9 @@ let all state =
       with Not_found -> acc)
     state.ids
     []
+
+let origin ~name =
+  try
+    let _, ploc, _ = Hashtbl.find provided name in
+    Option.bind ploc ~f:(fun ploc -> ploc.Parse_info.src)
+  with Not_found -> None
diff --git a/compiler/lib/linker.mli b/compiler/lib/linker.mli
@@ -62,3 +62,5 @@ val link : Javascript.program -> state -> output
 val get_provided : unit -> StringSet.t
 
 val all : state -> string list
+
+val origin : name:string -> string option
diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml
@@ -2142,30 +2142,78 @@ let override_global =
 
 (* HACK END *)
 
-let seek_section toc ic name =
-  let rec seek_sec curr_ofs = function
-    | [] -> raise Not_found
-    | (n, len) :: rem ->
-        if String.equal n name
-        then (
-          seek_in ic (curr_ofs - len);
-          len)
-        else seek_sec (curr_ofs - len) rem
-  in
-  seek_sec (in_channel_length ic - 16 - (8 * List.length toc)) toc
-
-let read_toc ic =
-  let pos_trailer = in_channel_length ic - 16 in
-  seek_in ic pos_trailer;
-  let num_sections = input_binary_int ic in
-  seek_in ic (pos_trailer - (8 * num_sections));
-  let section_table = ref [] in
-  for _i = 1 to num_sections do
-    let name = really_input_string ic 4 in
-    let len = input_binary_int ic in
-    section_table := (name, len) :: !section_table
-  done;
-  !section_table
+module Toc : sig
+  type t
+
+  val read : in_channel -> t
+
+  val seek_section : t -> in_channel -> string -> int
+
+  val read_code : t -> in_channel -> string
+
+  val read_data : t -> in_channel -> Obj.t array
+
+  val read_crcs : t -> in_channel -> (string * Digest.t option) list
+
+  val read_prim : t -> in_channel -> string
+
+  val read_symb : t -> in_channel -> Ocaml_compiler.Symtable.GlobalMap.t
+end = struct
+  type t = (string * int) list
+
+  let seek_section toc ic name =
+    let rec seek_sec curr_ofs = function
+      | [] -> raise Not_found
+      | (n, len) :: rem ->
+          if String.equal n name
+          then (
+            seek_in ic (curr_ofs - len);
+            len)
+          else seek_sec (curr_ofs - len) rem
+    in
+    seek_sec (in_channel_length ic - 16 - (8 * List.length toc)) toc
+
+  let read ic =
+    let pos_trailer = in_channel_length ic - 16 in
+    seek_in ic pos_trailer;
+    let num_sections = input_binary_int ic in
+    seek_in ic (pos_trailer - (8 * num_sections));
+    let section_table = ref [] in
+    for _i = 1 to num_sections do
+      let name = really_input_string ic 4 in
+      let len = input_binary_int ic in
+      section_table := (name, len) :: !section_table
+    done;
+    !section_table
+
+  let read_code toc ic =
+    let code_size = seek_section toc ic "CODE" in
+    really_input_string ic code_size
+
+  let read_data toc ic =
+    ignore (seek_section toc ic "DATA");
+    let init_data : Obj.t array = input_value ic in
+    init_data
+
+  let read_symb toc ic =
+    ignore (seek_section toc ic "SYMB");
+    let orig_symbols : Ocaml_compiler.Symtable.GlobalMap.t = input_value ic in
+    orig_symbols
+
+  let read_crcs toc ic =
+    ignore (seek_section toc ic "CRCS");
+    let orig_crcs : (string * Digest.t option) list = input_value ic in
+    orig_crcs
+
+  let read_prim toc ic =
+    let prim_size = seek_section toc ic "PRIM" in
+    let prim = really_input_string ic prim_size in
+    prim
+end
+
+let read_primitives toc ic =
+  let prim = Toc.read_prim toc ic in
+  String.split_char ~sep:'\000' prim
 
 let from_exe
     ?(includes = [])
@@ -2175,19 +2223,14 @@ let from_exe
     ?(debug = false)
     ic =
   let debug_data = Debug.create ~toplevel debug in
-  let toc = read_toc ic in
-  let prim_size = seek_section toc ic "PRIM" in
-  let prim = really_input_string ic prim_size in
-  let primitive_table = Array.of_list (String.split_char ~sep:'\000' prim) in
-  let code_size = seek_section toc ic "CODE" in
-  let code = really_input_string ic code_size in
-  ignore (seek_section toc ic "DATA");
-  let init_data : Obj.t array = input_value ic in
+  let toc = Toc.read ic in
+  let primitives = read_primitives toc ic in
+  let primitive_table = Array.of_list primitives in
+  let code = Toc.read_code toc ic in
+  let init_data = Toc.read_data toc ic in
   let init_data = Array.map ~f:Constants.parse init_data in
-  ignore (seek_section toc ic "SYMB");
-  let orig_symbols : Ocaml_compiler.Symtable.GlobalMap.t = input_value ic in
-  ignore (seek_section toc ic "CRCS");
-  let orig_crcs : (string * Digest.t option) list = input_value ic in
+  let orig_symbols = Toc.read_symb toc ic in
+  let orig_crcs = Toc.read_crcs toc ic in
   let keeps =
     let t = Hashtbl.create 17 in
     List.iter ~f:(fun (_, s) -> Hashtbl.add t s ()) predefined_exceptions;
@@ -2213,7 +2256,7 @@ let from_exe
   then ()
   else
     try
-      ignore (seek_section toc ic "DBUG");
+      ignore (Toc.seek_section toc ic "DBUG");
       Debug.read debug_data ~crcs ~includes ic
     with Not_found ->
       if Debug.enabled debug_data || Debug.toplevel debug_data
@@ -2268,7 +2311,10 @@ let from_exe
     then
       (* Include linking information *)
       let toc =
-        [ "SYMB", Obj.repr symbols; "CRCS", Obj.repr crcs; "PRIM", Obj.repr prim ]
+        [ "SYMB", Obj.repr symbols
+        ; "CRCS", Obj.repr crcs
+        ; "PRIM", Obj.repr (String.concat ~sep:"\000" primitives)
+        ]
       in
       let gdata = Var.fresh () in
       let infos =
diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli
@@ -38,6 +38,14 @@ type one =
   ; debug : Debug.t
   }
 
+module Toc : sig
+  type t
+
+  val read : in_channel -> t
+end
+
+val read_primitives : Toc.t -> in_channel -> string list
+
 val from_exe :
      ?includes:string list
   -> ?toplevel:bool
diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml
@@ -205,6 +205,30 @@ module List = struct
             else count_append tl l2 (count + 1)))
 
   let append l1 l2 = count_append l1 l2 0
+
+  let group l ~f =
+    let rec loop (l : 'a list) (this_group : 'a list) (acc : 'a list list) : 'a list list
+        =
+      match l with
+      | [] -> List.rev (List.rev this_group :: acc)
+      | x :: xs ->
+          let pred = List.hd this_group in
+          if f x pred
+          then loop xs (x :: this_group) acc
+          else loop xs [ x ] (List.rev this_group :: acc)
+    in
+    match l with
+    | [] -> []
+    | x :: xs -> loop xs [ x ] []
+
+  let concat_map ~f l =
+    let rec aux f acc = function
+      | [] -> rev acc
+      | x :: l ->
+          let xs = f x in
+          aux f (rev_append xs acc) l
+    in
+    aux f [] l
 end
 
 let ( @ ) = List.append
@@ -274,6 +298,11 @@ module Option = struct
     | None -> None
     | Some v -> Some (f v)
 
+  let bind ~f x =
+    match x with
+    | None -> None
+    | Some v -> f v
+
   let iter ~f x =
     match x with
     | None -> ()
diff --git a/compiler/tests-check-prim/dune b/compiler/tests-check-prim/dune
diff --git a/compiler/tests-check-prim/main.ml b/compiler/tests-check-prim/main.ml
diff --git a/compiler/tests-check-prim/output b/compiler/tests-check-prim/output
diff --git a/runtime/internalMod.js b/runtime/internalMod.js

Original file line number	Diff line number	Diff line change
`@@ -53,6 +53,7 @@ let _ =`
`53`	`53`	`; Build_fs.command`
`54`	`54`	`; Build_runtime.command`
`55`	`55`	`; Print_runtime.command`
	`56`	`+ ; Check_runtime.command`
`56`	`57`	`; Compile.command`
`57`	`58`	`]`
`58`	`59`	`with`