Merge branch 'master' into label-parsing

Author: hhugo

CHANGES.md

@@ -4,6 +4,7 @@
 
 ## Bug fixes
 * Compiler (js parser): fix parsing of js labels (fix #1440)
+* Compiler: put custom header at the top of the output file (fix #1441)
 
 # 5.1.1 (2023-03-15) - Lille
 ## Bug fixes

compiler/bin-js_of_ocaml/compile.ml

@@ -28,16 +28,22 @@ let () = Sys.catch_break true
 let gen_unit_filename dir u =
   Filename.concat dir (Printf.sprintf "%s.js" u.Cmo_format.cu_name)
 
+let header formatter ~custom_header =
+  match custom_header with
+  | None -> ()
+  | Some c -> Pretty_print.string formatter (c ^ "\n")
+
 let jsoo_header formatter build_info =
   Pretty_print.string formatter "// Generated by js_of_ocaml\n";
   Pretty_print.string formatter (Build_info.to_string build_info)
 
-let output_gen ~build_info ~source_map output_file f =
+let output_gen ~standalone ~custom_header ~build_info ~source_map output_file f =
   let f chan k =
     let fmt = Pretty_print.to_out_channel chan in
     Driver.configure fmt;
+    if standalone then header ~custom_header fmt;
     if Config.Flag.header () then jsoo_header fmt build_info;
-    let sm = f ~source_map:(Option.map ~f:snd source_map) (k, fmt) in
+    let sm = f ~standalone ~source_map:(Option.map ~f:snd source_map) (k, fmt) in
     match source_map, sm with
     | None, _ | _, None -> ()
     | Some (output_file, _), Some sm ->
@@ -169,7 +175,7 @@ let run
             , noloc )
           ])
   in
-  let output (one : Parse_bytecode.one) ~source_map ~linkall ~standalone output_file =
+  let output (one : Parse_bytecode.one) ~standalone ~source_map ~linkall output_file =
     check_debug one;
     let init_pseudo_fs = fs_external && standalone in
     let sm =
@@ -189,7 +195,6 @@ let run
             ~linkall
             ~wrap_with_fun
             ?source_map
-            ?custom_header
             fmt
             one.debug
             code
@@ -214,7 +219,6 @@ let run
               ~linkall
               ~wrap_with_fun
               ?source_map
-              ?custom_header
               fmt
               one.debug
               code
@@ -224,28 +228,23 @@ let run
                   let instr = fs_instr2 in
                   let code = Code.prepend Code.empty instr in
                   let pfs_fmt = Pretty_print.to_out_channel chan in
-                  Driver.f'
-                    ~standalone
-                    ?profile
-                    ?custom_header
-                    ~wrap_with_fun
-                    pfs_fmt
-                    one.debug
-                    code));
+                  Driver.f' ~standalone ?profile ~wrap_with_fun pfs_fmt one.debug code));
           res
     in
     if times () then Format.eprintf "compilation: %a@." Timer.print t;
     sm
   in
   let output_partial
       (cmo : Cmo_format.compilation_unit)
+      ~standalone
       ~source_map
       code
       ((_, fmt) as output_file) =
+    assert (not standalone);
     let uinfo = Unit_info.of_cmo cmo in
     Pretty_print.string fmt "\n";
     Pretty_print.string fmt (Unit_info.to_string uinfo);
-    output code ~source_map ~standalone:false ~linkall:false output_file
+    output code ~source_map ~standalone ~linkall:false output_file
   in
   (if runtime_only
    then (
@@ -260,13 +259,15 @@ let run
        }
      in
      output_gen
+       ~standalone:true
+       ~custom_header
        ~build_info:(Build_info.create `Runtime)
        ~source_map
        (fst output_file)
-       (fun ~source_map ((_, fmt) as output_file) ->
+       (fun ~standalone ~source_map ((_, fmt) as output_file) ->
          Pretty_print.string fmt "\n";
          Pretty_print.string fmt (Unit_info.to_string uinfo);
-         output code ~source_map ~standalone:true ~linkall:true output_file))
+         output code ~source_map ~standalone ~linkall:true output_file))
    else
      let kind, ic, close_ic, include_dirs =
        match input_file with
@@ -299,10 +300,12 @@ let run
          in
          if times () then Format.eprintf "  parsing: %a@." Timer.print t1;
          output_gen
+           ~standalone:true
+           ~custom_header
            ~build_info:(Build_info.create `Exe)
            ~source_map
            (fst output_file)
-           (output code ~standalone:true ~linkall)
+           (output code ~linkall)
      | `Cmo cmo ->
          let output_file =
            match output_file, keep_unit_names with
@@ -327,6 +330,8 @@ let run
          in
          if times () then Format.eprintf "  parsing: %a@." Timer.print t1;
          output_gen
+           ~standalone:false
+           ~custom_header
            ~build_info:(Build_info.create `Cmo)
            ~source_map
            output_file
@@ -355,12 +360,14 @@ let run
              if times ()
              then Format.eprintf "  parsing: %a (%s)@." Timer.print t1 cmo.cu_name;
              output_gen
+               ~standalone:false
+               ~custom_header
                ~build_info:(Build_info.create `Cma)
                ~source_map
                (`Name output_file)
                (output_partial cmo code))
      | `Cma cma ->
-         let f ~source_map output =
+         let f ~standalone ~source_map output =
            List.fold_left cma.lib_units ~init:source_map ~f:(fun source_map cmo ->
                let t1 = Timer.make () in
                let code =
@@ -373,9 +380,15 @@ let run
                in
                if times ()
                then Format.eprintf "  parsing: %a (%s)@." Timer.print t1 cmo.cu_name;
-               output_partial cmo ~source_map code output)
+               output_partial cmo ~standalone ~source_map code output)
          in
-         output_gen ~build_info:(Build_info.create `Cma) ~source_map (fst output_file) f);
+         output_gen
+           ~standalone:false
+           ~custom_header
+           ~build_info:(Build_info.create `Cma)
+           ~source_map
+           (fst output_file)
+           f);
      close_ic ());
   Debug.stop_profiling ()
 

compiler/lib/driver.ml

@@ -187,11 +187,6 @@ let generate
     ~warn_on_unhandled_effect
     d
 
-let header formatter ~custom_header =
-  match custom_header with
-  | None -> ()
-  | Some c -> Pretty_print.string formatter (c ^ "\n")
-
 let debug_linker = Debug.find "linker"
 
 let extra_js_files =
@@ -399,10 +394,9 @@ let coloring js =
   if times () then Format.eprintf "  coloring: %a@." Timer.print t;
   js
 
-let output formatter ~standalone ~custom_header ~source_map () js =
+let output formatter ~source_map () js =
   let t = Timer.make () in
   if times () then Format.eprintf "Start Writing file...@.";
-  if standalone then header ~custom_header formatter;
   let sm = Js_output.program formatter ?source_map js in
   if times () then Format.eprintf "  write: %a@." Timer.print t;
   sm
@@ -568,16 +562,7 @@ let configure formatter =
   Code.Var.set_pretty (pretty && not (Config.Flag.shortvar ()));
   Code.Var.set_stable (Config.Flag.stable_var ())
 
-let full
-    ~standalone
-    ~wrap_with_fun
-    ~profile
-    ~linkall
-    ~source_map
-    ~custom_header
-    formatter
-    d
-    p =
+let full ~standalone ~wrap_with_fun ~profile ~linkall ~source_map formatter d p =
   let exported_runtime = not standalone in
   let opt =
     specialize_js_once
@@ -595,34 +580,17 @@ let full
     +> pack ~wrap_with_fun ~standalone
     +> coloring
     +> check_js
-    +> output formatter ~standalone ~custom_header ~source_map ()
+    +> output formatter ~source_map ()
   in
   if times () then Format.eprintf "Start Optimizing...@.";
   let t = Timer.make () in
   let r = opt p in
   let () = if times () then Format.eprintf " optimizations : %a@." Timer.print t in
   emit r
 
-let full_no_source_map
-    ~standalone
-    ~wrap_with_fun
-    ~profile
-    ~linkall
-    ~custom_header
-    formatter
-    d
-    p =
+let full_no_source_map ~standalone ~wrap_with_fun ~profile ~linkall formatter d p =
   let (_ : Source_map.t option) =
-    full
-      ~standalone
-      ~wrap_with_fun
-      ~profile
-      ~linkall
-      ~custom_header
-      ~source_map:None
-      formatter
-      d
-      p
+    full ~standalone ~wrap_with_fun ~profile ~linkall ~source_map:None formatter d p
   in
   ()
 
@@ -632,39 +600,20 @@ let f
     ?(profile = O1)
     ?(linkall = false)
     ?source_map
-    ?custom_header
     formatter
     d
     p =
-  full
-    ~standalone
-    ~wrap_with_fun
-    ~profile
-    ~linkall
-    ~source_map
-    ~custom_header
-    formatter
-    d
-    p
+  full ~standalone ~wrap_with_fun ~profile ~linkall ~source_map formatter d p
 
 let f'
     ?(standalone = true)
     ?(wrap_with_fun = `Iife)
     ?(profile = O1)
     ?(linkall = false)
-    ?custom_header
     formatter
     d
     p =
-  full_no_source_map
-    ~standalone
-    ~wrap_with_fun
-    ~profile
-    ~linkall
-    ~custom_header
-    formatter
-    d
-    p
+  full_no_source_map ~standalone ~wrap_with_fun ~profile ~linkall formatter d p
 
 let from_string ~prims ~debug s formatter =
   let p, d = Parse_bytecode.from_string ~prims ~debug s in
@@ -673,7 +622,6 @@ let from_string ~prims ~debug s formatter =
     ~wrap_with_fun:`Anonymous
     ~profile:O1
     ~linkall:false
-    ~custom_header:None
     formatter
     d
     p

compiler/lib/driver.mli

@@ -26,7 +26,6 @@ val f :
   -> ?profile:profile
   -> ?linkall:bool
   -> ?source_map:Source_map.t
-  -> ?custom_header:string
   -> Pretty_print.t
   -> Parse_bytecode.Debug.t
   -> Code.program
@@ -37,7 +36,6 @@ val f' :
   -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ]
   -> ?profile:profile
   -> ?linkall:bool
-  -> ?custom_header:string
   -> Pretty_print.t
   -> Parse_bytecode.Debug.t
   -> Code.program