Compiler: remove --write-shape flag

Author: hhugo

compiler/bin-js_of_ocaml/cmd_arg.ml

@@ -65,7 +65,6 @@ type t =
   ; wrap_with_fun : [ `Iife | `Named of string | `Anonymous ]
   ; target_env : Target_env.t
   ; shape_files : string list
-  ; write_shape : bool
   ; (* toplevel *)
     dynlink : bool
   ; linkall : bool
@@ -120,10 +119,6 @@ let options =
     let doc = "load shape file [$(docv)]." in
     Arg.(value & opt_all string [] & info [ "load-shape" ] ~docv:"FILE" ~doc)
   in
-  let write_shape =
-    let doc = "Emit shape files" in
-    Arg.(value & flag & info [ "write-shape" ] ~doc)
-  in
   let input_file =
     let doc =
       "Compile the bytecode program [$(docv)]. "
@@ -328,8 +323,7 @@ let options =
       js_files
       keep_unit_names
       effects
-      shape_files
-      write_shape =
+      shape_files =
     let inline_source_content = not sourcemap_don't_inline_content in
     let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in
     let runtime_files = js_files in
@@ -401,7 +395,6 @@ let options =
       ; keep_unit_names
       ; effects
       ; shape_files
-      ; write_shape
       }
   in
   let t =
@@ -435,8 +428,7 @@ let options =
       $ js_files
       $ keep_unit_names
       $ effects
-      $ shape_files
-      $ write_shape)
+      $ shape_files)
   in
   Term.ret t
 
@@ -666,7 +658,6 @@ let options_runtime_only =
       ; keep_unit_names = false
       ; effects
       ; shape_files = []
-      ; write_shape = false
       }
   in
   let t =

compiler/bin-js_of_ocaml/cmd_arg.mli

@@ -38,7 +38,6 @@ type t =
       ]
   ; target_env : Target_env.t
   ; shape_files : string list
-  ; write_shape : bool
   ; (* toplevel *)
     dynlink : bool
   ; linkall : bool

compiler/bin-js_of_ocaml/compile.ml

@@ -54,15 +54,7 @@ let output_gen
     Driver.configure fmt;
     if standalone then header ~custom_header fmt;
     if Config.Flag.header () then jsoo_header fmt build_info;
-    let sm, shapes = f ~standalone ~shapes:write_shape ~source_map (k, fmt) in
-    (if write_shape
-     then
-       match output_file with
-       | `Stdout -> ()
-       | `Name name ->
-           Shape.Store.save'
-             (Filename.remove_extension name ^ Shape.Store.ext)
-             (StringMap.bindings shapes));
+    let sm = f ~standalone ~shapes:write_shape ~source_map (k, fmt) in
     match source_map, sm with
     | None, _ | _, None -> ()
     | Some { output_file = output; source_map; keep_empty }, Some sm ->
@@ -140,11 +132,6 @@ let sourcemap_of_infos ~base l =
 
 let sourcemap_of_info ~base info = sourcemap_of_infos ~base [ info ]
 
-let map_fst f (x, y) = f x, y
-
-let merge_shape a b =
-  StringMap.union (fun _name s1 s2 -> if Shape.equal s1 s2 then Some s1 else None) a b
-
 let run
     { Cmd_arg.common
     ; profile
@@ -170,7 +157,6 @@ let run
     ; include_runtime
     ; effects
     ; shape_files
-    ; write_shape
     } =
   let source_map_base =
     Option.map ~f:(fun spec -> spec.Source_map.Encoding_spec.source_map) source_map
@@ -273,7 +259,7 @@ let run
       output_file =
     if check_sourcemap then check_debug one;
     let init_pseudo_fs = fs_external && standalone in
-    let sm =
+    let sm, shapes =
       match output_file with
       | `Stdout, formatter ->
           let instr =
@@ -326,6 +312,7 @@ let run
                   Driver.f' ~standalone ~link:`Needed ?profile ~wrap_with_fun pfs_fmt code));
           res
     in
+    StringMap.iter (fun name shape -> Shape.Store.set ~name shape) shapes;
     if times () then Format.eprintf "compilation: %a@." Timer.print t;
     sm
   in
@@ -398,7 +385,7 @@ let run
         { code; cmis = StringSet.empty; debug = Parse_bytecode.Debug.default_summary }
       in
       output_gen
-        ~write_shape
+        ~write_shape:false
         ~standalone:true
         ~custom_header
         ~build_info:(Build_info.create `Runtime)
@@ -415,7 +402,7 @@ let run
             ~shapes
             ~link:`All
             output_file
-          |> map_fst (sourcemap_of_info ~base:source_map_base))
+          |> sourcemap_of_info ~base:source_map_base)
   | (`Stdin | `File _) as bytecode ->
       let kind, ic, close_ic, include_dirs =
         match bytecode with
@@ -448,7 +435,7 @@ let run
           in
           if times () then Format.eprintf "  parsing: %a@." Timer.print t1;
           output_gen
-            ~write_shape
+            ~write_shape:false
             ~standalone:true
             ~custom_header
             ~build_info:(Build_info.create `Exe)
@@ -463,7 +450,7 @@ let run
                 ~source_map
                 ~link:(if linkall then `All else `Needed)
                 output_file
-              |> map_fst (sourcemap_of_info ~base:source_map_base))
+              |> sourcemap_of_info ~base:source_map_base)
       | `Cmo cmo ->
           let output_file =
             match output_file, keep_unit_names with
@@ -488,7 +475,7 @@ let run
           in
           if times () then Format.eprintf "  parsing: %a@." Timer.print t1;
           output_gen
-            ~write_shape
+            ~write_shape:true
             ~standalone:false
             ~custom_header
             ~build_info:(Build_info.create `Cmo)
@@ -497,17 +484,16 @@ let run
             (fun ~standalone ~shapes ~source_map output ->
               match include_runtime with
               | true ->
-                  let sm1, sh1 =
+                  let sm1 =
                     output_partial_runtime ~standalone ~shapes ~source_map output
                   in
-                  let sm2, sh2 =
+                  let sm2 =
                     output_partial cmo code ~standalone ~shapes ~source_map output
                   in
-                  ( sourcemap_of_infos ~base:source_map_base [ sm1; sm2 ]
-                  , merge_shape sh1 sh2 )
+                  sourcemap_of_infos ~base:source_map_base [ sm1; sm2 ]
               | false ->
                   output_partial cmo code ~standalone ~shapes ~source_map output
-                  |> map_fst (sourcemap_of_info ~base:source_map_base))
+                  |> sourcemap_of_info ~base:source_map_base)
       | `Cma cma when keep_unit_names ->
           (if include_runtime
            then
@@ -523,15 +509,15 @@ let run
                    failwith "use [-o dirname/] or remove [--keep-unit-names]"
              in
              output_gen
-               ~write_shape
+               ~write_shape:false
                ~standalone:false
                ~custom_header
                ~build_info:(Build_info.create `Runtime)
                ~source_map
                (`Name output_file)
                (fun ~standalone ~shapes ~source_map output ->
                  output_partial_runtime ~standalone ~shapes ~source_map output
-                 |> map_fst (sourcemap_of_info ~base:source_map_base)));
+                 |> sourcemap_of_info ~base:source_map_base));
           List.iter cma.lib_units ~f:(fun cmo ->
               let output_file =
                 match output_file with
@@ -560,15 +546,15 @@ let run
                   t1
                   (Ocaml_compiler.Cmo_format.name cmo);
               output_gen
-                ~write_shape
+                ~write_shape:true
                 ~standalone:false
                 ~custom_header
                 ~build_info:(Build_info.create `Cma)
                 ~source_map
                 (`Name output_file)
                 (fun ~standalone ~shapes ~source_map output ->
                   output_partial ~standalone ~shapes ~source_map cmo code output
-                  |> map_fst (sourcemap_of_info ~base:source_map_base)))
+                  |> sourcemap_of_info ~base:source_map_base))
       | `Cma cma ->
           let f ~standalone ~shapes ~source_map output =
             (* Always compute shapes because it can be used by other units of the cma *)
@@ -599,20 +585,15 @@ let run
                       (Ocaml_compiler.Cmo_format.name cmo);
                   output_partial ~standalone ~shapes ~source_map cmo code output)
             in
-            let sm_and_shapes =
+            let sm =
               match runtime with
               | None -> units
               | Some x -> x :: units
             in
-            let shapes =
-              List.fold_left sm_and_shapes ~init:StringMap.empty ~f:(fun acc (_, s) ->
-                  merge_shape s acc)
-            in
-            ( sourcemap_of_infos ~base:source_map_base (List.map sm_and_shapes ~f:fst)
-            , shapes )
+            sourcemap_of_infos ~base:source_map_base sm
           in
           output_gen
-            ~write_shape
+            ~write_shape:true
             ~standalone:false
             ~custom_header
             ~build_info:(Build_info.create `Cma)

compiler/lib/driver.ml

@@ -730,7 +730,6 @@ let full ~standalone ~wrap_with_fun ~shapes ~profile ~link ~source_map ~formatte
   let shapes_v = optimized_code.shapes in
   StringMap.iter
     (fun name shape ->
-      Shape.Store.set ~name shape;
       if shapes
       then
         Pretty_print.string

compiler/lib/parse_bytecode.ml

@@ -587,7 +587,6 @@ module State = struct
     ; globals : globals
     ; immutable : unit Code.Var.Hashtbl.t
     ; module_or_not : Ocaml_compiler.module_or_not Ident.Tbl.t
-    ; includes : string list
     }
 
   let fresh_var state =
@@ -672,7 +671,7 @@ module State = struct
 
   let pop_handler state = { state with handlers = List.tl state.handlers }
 
-  let initial includes g immutable =
+  let initial g immutable =
     { accu = Unset
     ; stack = []
     ; env = [||]
@@ -681,7 +680,6 @@ module State = struct
     ; globals = g
     ; immutable
     ; module_or_not = Ident.Tbl.create 0
-    ; includes
     }
 
   let rec print_stack f l =
@@ -831,7 +829,7 @@ let get_global state instrs i =
             (match g.named_value.(i) with
             | None -> ()
             | Some name -> (
-                match Shape.Store.load ~name ~paths:state.includes with
+                match Shape.Store.load ~name with
                 | None -> ()
                 | Some shape -> Shape.State.assign x shape));
             x, state, instrs
@@ -2538,9 +2536,9 @@ type one =
   ; debug : Debug.summary
   }
 
-let parse_bytecode ~includes code globals debug_data =
+let parse_bytecode code globals debug_data =
   let immutable = Code.Var.Hashtbl.create 0 in
-  let state = State.initial includes globals immutable in
+  let state = State.initial globals immutable in
   Code.Var.reset ();
   let blocks', joins = Blocks.analyse code in
   Shape.State.reset ();
@@ -2725,7 +2723,7 @@ let from_exe
     Ocaml_compiler.Symtable.GlobalMap.iter symbols ~f:(fun id n ->
         globals.named_value.(n) <- Some (Ocaml_compiler.Symtable.Global.name id);
         globals.is_exported.(n) <- true);
-  let p = parse_bytecode ~includes code globals debug_data in
+  let p = parse_bytecode code globals debug_data in
   (* register predefined exception *)
   let body =
     List.fold_left predefined_exceptions ~init:[] ~f:(fun body (i, name) ->
@@ -2855,7 +2853,7 @@ let from_bytes ~prims ~debug (code : bytecode) =
     t
   in
   let globals = make_globals 0 [||] prims in
-  let p = parse_bytecode ~includes:[] code globals debug_data in
+  let p = parse_bytecode code globals debug_data in
   let gdata = Var.fresh_n "global_data" in
   let need_gdata = ref false in
   let find_name i =
@@ -2987,7 +2985,7 @@ module Reloc = struct
     globals
 end
 
-let from_compilation_units ~includes ~include_cmis ~debug_data l =
+let from_compilation_units ~includes:_ ~include_cmis ~debug_data l =
   let reloc = Reloc.create () in
   List.iter l ~f:(fun (compunit, code) -> Reloc.step1 reloc compunit code);
   List.iter l ~f:(fun (compunit, code) -> Reloc.step2 reloc compunit code);
@@ -2996,7 +2994,7 @@ let from_compilation_units ~includes ~include_cmis ~debug_data l =
     let l = List.map l ~f:(fun (_, c) -> Bytes.to_string c) in
     String.concat ~sep:"" l
   in
-  let prog = parse_bytecode ~includes code globals debug_data 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 =