From 099785db58c2afcad06790601d392b62b3d4948f Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sat, 9 Feb 2019 01:49:23 +0800 Subject: [PATCH 1/5] Compiler: refactor interaction between js_of_ocaml and parse_bytecode --- compiler/js_of_ocaml.ml | 167 ++++++++++++++++++-------------- compiler/lib/parse_bytecode.ml | 35 ++++--- compiler/lib/parse_bytecode.mli | 11 ++- compiler/lib/pseudoFs.ml | 88 ++++++----------- compiler/lib/pseudoFs.mli | 11 ++- toplevel/bin/jsoo_mkcmis.ml | 12 ++- 6 files changed, 173 insertions(+), 151 deletions(-) diff --git a/compiler/js_of_ocaml.ml b/compiler/js_of_ocaml.ml index 331e992ebc..0d9fc7311b 100644 --- a/compiler/js_of_ocaml.ml +++ b/compiler/js_of_ocaml.ml @@ -136,39 +136,35 @@ let f then `Names else `No in - let p, cmis, d, standalone = + let result = if runtime_only then - ( Parse_bytecode.predefined_exceptions () - , StringSet.empty - , Parse_bytecode.Debug.create () - , true ) + Parse_bytecode.Standalone + { code = Parse_bytecode.predefined_exceptions () + ; cmis = StringSet.empty + ; debug = Parse_bytecode.Debug.create () } else - match input_file with - | None -> + let with_channel ~f = + match input_file with + | None -> f stdin + | Some fn -> + let ch = open_in_bin fn in + let res = f ch in + close_in ch; + res + in + with_channel ~f:(fun ch -> Parse_bytecode.from_channel ~includes:paths ~toplevel ?expunge ~dynlink ~debug:need_debug - stdin - | Some f -> - let ch = open_in_bin f in - let res = - Parse_bytecode.from_channel - ~includes:paths - ~toplevel - ?expunge - ~dynlink - ~debug:need_debug - ch - in - close_in ch; - res + ch) in - let () = - if (not runtime_only) && source_map <> None && Parse_bytecode.Debug.is_empty d + if times () then Format.eprintf " parsing: %a@." Timer.print t1; + let check_debug debug = + if (not runtime_only) && source_map <> None && Parse_bytecode.Debug.is_empty debug then warn "Warning: '--source-map' is enabled but the bytecode program was compiled with \ @@ -176,61 +172,82 @@ let f Warning: Consider passing '-g' option to ocamlc.\n\ %!" in - let cmis = if nocmis then StringSet.empty else cmis in - let p = - let l = - List.map static_env ~f:(fun (k, v) -> - Primitive.add_external "caml_set_static_env"; - let args = [Code.Pc (IString k); Code.Pc (IString v)] in - Code.(Let (Var.fresh (), Prim (Extern "caml_set_static_env", args)))) + let pseudo_fs_instr prim debug cmis = + let cmis = if nocmis then StringSet.empty else cmis in + let paths = + paths @ StringSet.elements (Parse_bytecode.Debug.paths debug ~units:cmis) in - Code.prepend p l + PseudoFs.f ~prim ~cmis ~files:fs_files ~paths in - let p = - if fs_external - then - let instrs = [Code.(Let (Var.fresh (), Prim (Extern "caml_fs_init", [])))] in - Code.prepend p instrs - else p + let env_instr = + List.map static_env ~f:(fun (k, v) -> + Primitive.add_external "caml_set_static_env"; + let args = [Code.Pc (IString k); Code.Pc (IString v)] in + Code.(Let (Var.fresh (), Prim (Extern "caml_set_static_env", args)))) in - if times () then Format.eprintf " parsing: %a@." Timer.print t1; - let paths = paths @ StringSet.elements (Parse_bytecode.Debug.paths d ~units:cmis) in - (match output_file with - | None -> - let p = PseudoFs.f p cmis fs_files paths in - let fmt = Pretty_print.to_out_channel stdout in - Driver.f - ~standalone - ?profile - ~linkall - ~global - ~dynlink - ?source_map - ?custom_header - fmt - d - p - | Some file -> - gen_file file (fun chan -> - let p = if fs_output = None then PseudoFs.f p cmis fs_files paths else p in - let fmt = Pretty_print.to_out_channel chan in - Driver.f - ~standalone - ?profile - ~linkall - ~global - ~dynlink - ?source_map - ?custom_header - fmt - d - p); - Option.iter fs_output ~f:(fun file -> - gen_file file (fun chan -> - let pfs = PseudoFs.f_empty cmis fs_files paths in - let pfs_fmt = Pretty_print.to_out_channel chan in - Driver.f ~standalone ?profile ?custom_header ~global pfs_fmt d pfs))); - if times () then Format.eprintf "compilation: %a@." Timer.print t; + let pseudo_fs_init_instr = if fs_external then [PseudoFs.init ()] else [] in + let output (one : Parse_bytecode.one) standalone output_file = + check_debug one.debug; + (match output_file with + | None -> + let instr = + List.concat + [ pseudo_fs_instr `caml_create_file one.debug one.cmis + ; pseudo_fs_init_instr + ; env_instr ] + in + let code = Code.prepend one.code instr in + let fmt = Pretty_print.to_out_channel stdout in + Driver.f + ~standalone + ?profile + ~linkall + ~global + ~dynlink + ?source_map + ?custom_header + fmt + one.debug + code + | Some file -> + let fs_instr1, fs_instr2 = + match fs_output with + | None -> pseudo_fs_instr `caml_create_file one.debug one.cmis, [] + | Some _ -> [], pseudo_fs_instr `caml_create_file_extern one.debug one.cmis + in + gen_file file (fun chan -> + let instr = List.concat [fs_instr1; pseudo_fs_init_instr; env_instr] in + let code = Code.prepend one.code instr in + let fmt = Pretty_print.to_out_channel chan in + Driver.f + ~standalone + ?profile + ~linkall + ~global + ~dynlink + ?source_map + ?custom_header + fmt + one.debug + code); + Option.iter fs_output ~f:(fun file -> + gen_file file (fun chan -> + 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 + ~global + pfs_fmt + one.debug + code))); + if times () then Format.eprintf "compilation: %a@." Timer.print t + in + (match result with + | Standalone code -> output code true output_file + | Partial code -> output code false output_file); Debug.stop_profiling () let main = Cmdliner.Term.(pure f $ CompileArg.options), CompileArg.info diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 5c1556b18e..dc7929a90b 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -26,7 +26,7 @@ let debug_parser = Debug.find "parser" let debug_sourcemap = Debug.find "sourcemap" -type code = string +type bytecode = string let predefined_exceptions = [ 0, "Out_of_memory" @@ -236,7 +236,7 @@ end module Blocks : sig type t - val analyse : Debug.data -> code -> t + val analyse : Debug.data -> bytecode -> t val add : t -> int -> t @@ -1955,6 +1955,15 @@ let match_exn_traps (blocks : 'a Addr.Map.t) = (****) +type one = + { code : Code.program + ; cmis : StringSet.t + ; debug : Debug.data } + +type result = + | Standalone of one + | Partial of one + let parse_bytecode ~debug code globals debug_data = let state = State.initial globals in Code.Var.reset (); @@ -2184,10 +2193,10 @@ let exe_from_channel StringSet.empty else StringSet.empty in - prepend p body, cmis, debug_data + {code = prepend p body; cmis; debug = debug_data} (* As input: list of primitives + size of global table *) -let from_bytes primitives (code : code) = +let from_bytes primitives (code : bytecode) = let globals = make_globals 0 [||] primitives in let debug_data = Debug.create () in let p = parse_bytecode ~debug:`No code globals debug_data in @@ -2331,7 +2340,7 @@ let from_compilation_units ~includes:_ ~toplevel ~debug ~debug_data l = StringSet.add compunit.Cmo_format.cu_name acc) else StringSet.empty in - prepend prog body, cmis, debug_data + {code = prepend prog body; cmis; debug = debug_data} let from_channel ?(includes = []) @@ -2368,10 +2377,10 @@ let from_channel else ( seek_in ic compunit.Cmo_format.cu_debug; Debug.read_event_list debug_data ~crcs:[] ~includes ~orig:0 ic); - let a, b, c = + let x = from_compilation_units ~toplevel ~includes ~debug ~debug_data [compunit, code] in - a, b, c, false + Partial x | `Cma -> if Config.Flag.check_magic () && magic <> Magic_number.current_cma then raise Magic_number.(Bad_magic_version magic); @@ -2393,21 +2402,19 @@ let from_channel orig := !orig + compunit.Cmo_format.cu_codesize; compunit, code) in - let a, b, c = - from_compilation_units ~toplevel ~includes ~debug ~debug_data units - in - a, b, c, false + let x = from_compilation_units ~toplevel ~includes ~debug ~debug_data units in + Partial x | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) | `Post magic -> ( match Magic_number.kind magic with | `Exe -> if Config.Flag.check_magic () && magic <> Magic_number.current_exe then raise Magic_number.(Bad_magic_version magic); - let a, b, c = + let x = exe_from_channel ~includes ~toplevel ?expunge ~dynlink ~debug ~debug_data ic in - Code.invariant a; - a, b, c, true + Code.invariant x.code; + Standalone x | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) let predefined_exceptions () = diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli index 2cf3ec342c..5292f59558 100644 --- a/compiler/lib/parse_bytecode.mli +++ b/compiler/lib/parse_bytecode.mli @@ -32,6 +32,15 @@ module Debug : sig val paths : data -> units:StringSet.t -> StringSet.t end +type one = + { code : Code.program + ; cmis : StringSet.t + ; debug : Debug.data } + +type result = + | Standalone of one + | Partial of one + val from_channel : ?includes:string list -> ?toplevel:bool @@ -39,7 +48,7 @@ val from_channel : -> ?dynlink:bool -> ?debug:[`Full | `Names | `No] -> in_channel - -> Code.program * StringSet.t * Debug.data * bool + -> result val from_string : string array -> string -> Code.program * Debug.data diff --git a/compiler/lib/pseudoFs.ml b/compiler/lib/pseudoFs.ml index cac4d266e4..b423b00793 100644 --- a/compiler/lib/pseudoFs.ml +++ b/compiler/lib/pseudoFs.ml @@ -70,77 +70,53 @@ let list_files name paths = in expand_path exts file virtname -let cmi_dir = "/static/cmis" - let find_cmi paths base = - try - let name = String.uncapitalize_ascii base ^ ".cmi" in - Filename.concat cmi_dir name, Findlib.find_in_findlib_paths paths name - with Not_found -> - let name = String.capitalize_ascii base ^ ".cmi" in - Filename.concat cmi_dir name, Findlib.find_in_findlib_paths paths name + let name, filename = + try + let name = String.uncapitalize_ascii base ^ ".cmi" in + name, Findlib.find_in_findlib_paths paths name + with Not_found -> + let name = String.capitalize_ascii base ^ ".cmi" in + name, Findlib.find_in_findlib_paths paths name + in + Filename.concat "/static/cmis" name, filename -open Code +let instr_of_name_content prim ~name ~content = + let open Code in + Let (Var.fresh (), Prim (Extern prim, [Pc (IString name); Pc (IString content)])) -let read name filename = - let content = Fs.read_file filename in - Pc (IString name), Pc (IString content) +let embed_file ~name ~filename = + instr_of_name_content "caml_create_file_extern" ~name ~content:(Fs.read_file filename) -let program_of_files l = - let fs = List.map l ~f:(fun (name, filename) -> read name filename) in - let body = - List.map fs ~f:(fun (n, c) -> - Let (Var.fresh (), Prim (Extern "caml_create_file_extern", [n; c]))) - in - let pc = 0 in - let blocks = - Addr.Map.add - pc - {params = []; handler = None; body = []; branch = Stop} - Addr.Map.empty - in - let p = pc, blocks, pc + 1 in - Code.prepend p body +let init () = Code.(Let (Var.fresh (), Prim (Extern "caml_fs_init", []))) -let make_body prim cmis files paths = - let fs, missing = +let f ~prim ~cmis ~files ~paths = + let prim = + match prim with + | `caml_create_file -> "caml_create_file" + | `caml_create_file_extern -> "caml_create_file_extern" + in + let cmi_files, missing_cmis = StringSet.fold (fun s (acc, missing) -> try let name, filename = find_cmi paths s in - read name filename :: acc, missing + (name, Fs.read_file filename) :: acc, missing with Not_found -> acc, s :: missing) cmis ([], []) in - if missing <> [] + if missing_cmis <> [] then ( warn "Some OCaml interface files were not found.@."; warn "Use [-I dir_of_cmis] option to bring them into scope@."; (* [`ocamlc -where`/expunge in.byte out.byte moduleA moduleB ... moduleN] *) - List.iter missing ~f:(fun nm -> warn " %s@." nm)); - let fs = - List.fold_left files ~init:fs ~f:(fun acc f -> - let l = list_files f paths in - List.fold_left l ~init:acc ~f:(fun acc (n, fn) -> read n fn :: acc)) - in - let body = - List.map fs ~f:(fun (n, c) -> Let (Var.fresh (), Prim (Extern prim, [n; c]))) - in - body - -let f p cmis files paths = - let body = make_body "caml_create_file" cmis files paths in - Code.prepend p body - -let f_empty cmis files paths = - let body = make_body "caml_create_file_extern" cmis files paths in - let pc = 0 in - let blocks = - Addr.Map.add - pc - {params = []; handler = None; body = []; branch = Stop} - Addr.Map.empty + List.iter missing_cmis ~f:(fun nm -> warn " %s@." nm)); + let other_files = + List.map files ~f:(fun f -> + List.map (list_files f paths) ~f:(fun (name, filename) -> + name, Fs.read_file filename)) + |> List.concat in - let p = pc, blocks, pc + 1 in - Code.prepend p body + List.map (other_files @ cmi_files) ~f:(fun (name, content) -> + instr_of_name_content prim ~name ~content) diff --git a/compiler/lib/pseudoFs.mli b/compiler/lib/pseudoFs.mli index 243d54e697..006737c015 100644 --- a/compiler/lib/pseudoFs.mli +++ b/compiler/lib/pseudoFs.mli @@ -19,8 +19,13 @@ open Stdlib -val f : Code.program -> StringSet.t -> string list -> string list -> Code.program +val f : + prim:[`caml_create_file | `caml_create_file_extern] + -> cmis:StringSet.t + -> files:string list + -> paths:string list + -> Code.instr list -val f_empty : StringSet.t -> string list -> string list -> Code.program +val embed_file : name:string -> filename:string -> Code.instr -val program_of_files : (string * string) list -> Code.program +val init : unit -> Code.instr diff --git a/toplevel/bin/jsoo_mkcmis.ml b/toplevel/bin/jsoo_mkcmis.ml index f8fa8086ff..7f1b047e1c 100644 --- a/toplevel/bin/jsoo_mkcmis.ml +++ b/toplevel/bin/jsoo_mkcmis.ml @@ -61,8 +61,16 @@ let args = let js, args = List.partition (fun s -> Filename.check_suffix s ".js") args in let js = if !runtime then "+runtime.js" :: js else js in let all = Jsoo_common.cmis args in - let all = List.map (fun x -> Filename.(concat !prefix (basename x)), x) all in - let program = Js_of_ocaml_compiler.PseudoFs.program_of_files all in + let instr = + List.map + (fun filename -> + let name = Filename.(concat !prefix (basename filename)) in + Js_of_ocaml_compiler.PseudoFs.embed_file ~name ~filename ) + all + in + let program = + Js_of_ocaml_compiler.Code.prepend Js_of_ocaml_compiler.Code.empty instr + in let oc = match !output, args with | Some x, _ -> open_out x From 5231e9f70b38624fdd4785dd8a8053856fdecf37 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sun, 17 Feb 2019 18:14:11 +0800 Subject: [PATCH 2/5] Compiler: comment on Parse_bytecode.Reloc --- compiler/lib/parse_bytecode.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index dc7929a90b..daee566afe 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -2222,6 +2222,7 @@ module Reloc = struct type t = { mutable pos : int ; mutable constants : Obj.t list + ; mutable step2_started : bool ; names : (string, int) Hashtbl.t ; primitives : (string, int) Hashtbl.t } @@ -2229,10 +2230,13 @@ module Reloc = struct let constants = [] in { pos = List.length constants ; constants + ; step2_started = false ; names = Hashtbl.create 17 ; primitives = Hashtbl.create 17 } + (* We currently rely on constants to be relocated before globals. *) let step1 t compunit code = + if t.step2_started then assert false; let open Cmo_format in List.iter compunit.cu_primitives ~f:(fun name -> Hashtbl.add t.primitives name (Hashtbl.length t.primitives)); @@ -2255,15 +2259,16 @@ module Reloc = struct | _ -> ()) let step2 t compunit code = + t.step2_started <- true; let open Cmo_format in let next id = let name = Ident.name id in try Hashtbl.find t.names name with Not_found -> - let x = t.pos in + let pos = t.pos in t.pos <- succ t.pos; - Hashtbl.add t.names name x; - x + Hashtbl.add t.names name pos; + pos in let slot_for_getglobal id = next id in let slot_for_setglobal id = next id in From 11aceb339beb89a620de75b7a10f1c562b33d789 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sat, 27 Apr 2019 23:20:11 +0800 Subject: [PATCH 3/5] Refactor --- compiler/compileArg.ml | 32 +++++--- compiler/compileArg.mli | 5 +- compiler/js_of_ocaml.ml | 130 ++++++++++++++++++++++---------- compiler/lib/parse_bytecode.ml | 105 ++++++++++++++------------ compiler/lib/parse_bytecode.mli | 27 +++++-- toplevel/bin/jsoo_mkcmis.ml | 2 +- 6 files changed, 192 insertions(+), 109 deletions(-) diff --git a/compiler/compileArg.ml b/compiler/compileArg.ml index 5556421233..82ac2f8ecc 100644 --- a/compiler/compileArg.ml +++ b/compiler/compileArg.ml @@ -28,7 +28,7 @@ type t = ; source_map : (string option * Source_map.t) option ; runtime_files : string list ; runtime_only : bool - ; output_file : string option + ; output_file : [`Name of string | `Stdout] * bool ; input_file : string option ; params : (string * string) list ; static_env : (string * string) list @@ -43,7 +43,8 @@ type t = include_dir : string list ; fs_files : string list ; fs_output : string option - ; fs_external : bool } + ; fs_external : bool + ; keep_unit_names : bool } let options = let toplevel_section = "OPTIONS (TOPLEVEL)" in @@ -67,6 +68,10 @@ let options = in Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv:"PROGRAM" ~doc) in + let keep_unit_names = + let doc = "Keep unit name" in + Arg.(value & flag & info ["keep-unit-names"] ~doc) + in let profile = let doc = "Set optimization profile : [$(docv)]." in let profile = List.map Driver.profiles ~f:(fun (i, p) -> string_of_int i, p) in @@ -191,7 +196,8 @@ let options = sourcemap_root output_file input_file - js_files = + js_files + keep_unit_names = let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in @@ -213,17 +219,21 @@ let options = in let output_file = match output_file with - | Some _ -> output_file - | None -> Option.map input_file ~f:(fun s -> chop_extension s ^ ".js") + | Some "-" -> `Stdout, true + | Some s -> `Name s, true + | None -> ( + match input_file with + | Some s -> `Name (chop_extension s ^ ".js"), false + | None -> `Stdout, false) in let source_map = if ((not no_sourcemap) && sourcemap) || sourcemap_inline_in_js then let file, sm_output_file = match output_file with - | Some file when sourcemap_inline_in_js -> file, None - | Some file -> file, Some (chop_extension file ^ ".map") - | None -> "STDIN", None + | `Name file, _ when sourcemap_inline_in_js -> file, None + | `Name file, _ -> file, Some (chop_extension file ^ ".map") + | `Stdout, _ -> "STDIN", None in Some ( sm_output_file @@ -268,7 +278,8 @@ let options = ; nocmis ; output_file ; input_file - ; source_map } + ; source_map + ; keep_unit_names } in let t = Term.( @@ -296,7 +307,8 @@ let options = $ sourcemap_root $ output_file $ input_file - $ js_files) + $ js_files + $ keep_unit_names) in Term.ret t diff --git a/compiler/compileArg.mli b/compiler/compileArg.mli index 69ccd66724..06e6103711 100644 --- a/compiler/compileArg.mli +++ b/compiler/compileArg.mli @@ -26,7 +26,7 @@ type t = ; source_map : (string option * Source_map.t) option ; runtime_files : string list ; runtime_only : bool - ; output_file : string option + ; output_file : [`Name of string | `Stdout] * bool ; input_file : string option ; params : (string * string) list ; static_env : (string * string) list @@ -41,7 +41,8 @@ type t = include_dir : string list ; fs_files : string list ; fs_output : string option - ; fs_external : bool } + ; fs_external : bool + ; keep_unit_names : bool } val options : t Cmdliner.Term.t diff --git a/compiler/js_of_ocaml.ml b/compiler/js_of_ocaml.ml index 0d9fc7311b..a3fbe5798b 100644 --- a/compiler/js_of_ocaml.ml +++ b/compiler/js_of_ocaml.ml @@ -52,6 +52,9 @@ let gen_file file f = Sys.remove f_tmp; raise exc +let gen_unit_filename dir u = + Filename.concat dir (Printf.sprintf "%s.js" u.Cmo_format.cu_name) + let f { CompileArg.common ; profile @@ -71,7 +74,8 @@ let f ; fs_files ; fs_output ; fs_external - ; export_file } = + ; export_file + ; keep_unit_names } = let dynlink = dynlink || toplevel || runtime_only in let custom_header = common.CommonArg.custom_header in let global = @@ -81,9 +85,9 @@ let f in CommonArg.eval common; (match output_file with - | None | Some "" | Some "-" -> () - | Some name when debug_mem () -> Debug.start_profiling name - | Some _ -> ()); + | `Stdout, _ -> () + | `Name name, _ when debug_mem () -> Debug.start_profiling name + | `Name _, _ -> ()); List.iter params ~f:(fun (s, v) -> Config.Param.set s v); List.iter static_env ~f:(fun (s, v) -> Eval.set_static_env s v); let t = Timer.make () in @@ -127,7 +131,6 @@ let f try List.append include_dir [Findlib.find_pkg_dir "stdlib"] with Not_found -> include_dir in - let t1 = Timer.make () in if times () then Format.eprintf "Start parsing...@."; let need_debug = if source_map <> None || Config.Flag.debuginfo () || toplevel @@ -136,33 +139,6 @@ let f then `Names else `No in - let result = - if runtime_only - then - Parse_bytecode.Standalone - { code = Parse_bytecode.predefined_exceptions () - ; cmis = StringSet.empty - ; debug = Parse_bytecode.Debug.create () } - else - let with_channel ~f = - match input_file with - | None -> f stdin - | Some fn -> - let ch = open_in_bin fn in - let res = f ch in - close_in ch; - res - in - with_channel ~f:(fun ch -> - Parse_bytecode.from_channel - ~includes:paths - ~toplevel - ?expunge - ~dynlink - ~debug:need_debug - ch) - in - if times () then Format.eprintf " parsing: %a@." Timer.print t1; let check_debug debug = if (not runtime_only) && source_map <> None && Parse_bytecode.Debug.is_empty debug then @@ -179,7 +155,7 @@ let f in PseudoFs.f ~prim ~cmis ~files:fs_files ~paths in - let env_instr = + let env_instr () = List.map static_env ~f:(fun (k, v) -> Primitive.add_external "caml_set_static_env"; let args = [Code.Pc (IString k); Code.Pc (IString v)] in @@ -189,12 +165,12 @@ let f let output (one : Parse_bytecode.one) standalone output_file = check_debug one.debug; (match output_file with - | None -> + | `Stdout -> let instr = List.concat [ pseudo_fs_instr `caml_create_file one.debug one.cmis ; pseudo_fs_init_instr - ; env_instr ] + ; env_instr () ] in let code = Code.prepend one.code instr in let fmt = Pretty_print.to_out_channel stdout in @@ -209,14 +185,14 @@ let f fmt one.debug code - | Some file -> + | `Name file -> let fs_instr1, fs_instr2 = match fs_output with | None -> pseudo_fs_instr `caml_create_file one.debug one.cmis, [] | Some _ -> [], pseudo_fs_instr `caml_create_file_extern one.debug one.cmis in gen_file file (fun chan -> - let instr = List.concat [fs_instr1; pseudo_fs_init_instr; env_instr] in + let instr = List.concat [fs_instr1; pseudo_fs_init_instr; env_instr ()] in let code = Code.prepend one.code instr in let fmt = Pretty_print.to_out_channel chan in Driver.f @@ -245,9 +221,83 @@ let f code))); if times () then Format.eprintf "compilation: %a@." Timer.print t in - (match result with - | Standalone code -> output code true output_file - | Partial code -> output code false output_file); + (if runtime_only + then + let code : Parse_bytecode.one = + { code = Parse_bytecode.predefined_exceptions () + ; cmis = StringSet.empty + ; debug = Parse_bytecode.Debug.create () } + in + output code true (fst output_file) + else + let kind, ic, close_ic = + match input_file with + | None -> Parse_bytecode.from_channel stdin, stdin, fun () -> () + | Some fn -> + let ch = open_in_bin fn in + let res = Parse_bytecode.from_channel ch in + res, ch, fun () -> close_in ch + in + (match kind with + | `Exe -> + let t1 = Timer.make () in + let code = + Parse_bytecode.from_exe + ~includes:paths + ~toplevel + ?expunge + ~dynlink + ~debug:need_debug + ic + in + if times () then Format.eprintf " parsing: %a@." Timer.print t1; + output code true (fst output_file) + | `Cmo cmo -> + let output_file = + match output_file, keep_unit_names with + | (`Stdout, false), true -> `Name (gen_unit_filename "./" cmo) + | (`Name x, false), true -> `Name (gen_unit_filename (Filename.dirname x) cmo) + | (`Stdout, _), false -> `Stdout + | (`Name x, _), false -> `Name x + | (`Name x, true), true + when String.length x > 0 && x.[String.length x - 1] = '/' -> + `Name (gen_unit_filename x cmo) + | (`Name _, true), true | (`Stdout, true), true -> + failwith "use [-o dirname/] or remove [--keep-unit-names]" + in + let t1 = Timer.make () in + let code = + Parse_bytecode.from_cmo ~includes:paths ~toplevel ~debug:need_debug cmo ic + in + if times () then Format.eprintf " parsing: %a@." Timer.print t1; + output code false output_file + | `Cma cma when keep_unit_names -> + List.iter cma.lib_units ~f:(fun cmo -> + let output_file = + match output_file with + | `Stdout, false -> `Name (gen_unit_filename "./" cmo) + | `Name x, false -> `Name (gen_unit_filename (Filename.dirname x) cmo) + | `Name x, true when String.length x > 0 && x.[String.length x - 1] = '/' + -> + `Name (gen_unit_filename x cmo) + | `Stdout, true | `Name _, true -> + failwith "use [-o dirname/] or remove [--keep-unit-names]" + in + let t1 = Timer.make () in + let code = + Parse_bytecode.from_cmo ~includes:paths ~toplevel ~debug:need_debug cmo ic + in + if times () + then Format.eprintf " parsing: %a (%s)@." Timer.print t1 cmo.cu_name; + output code false output_file) + | `Cma cma -> + let t1 = Timer.make () in + let code = + Parse_bytecode.from_cma ~includes:paths ~toplevel ~debug:need_debug cma ic + in + if times () then Format.eprintf " parsing: %a@." Timer.print t1; + output code false (fst output_file)); + close_ic ()); Debug.stop_profiling () let main = Cmdliner.Term.(pure f $ CompileArg.options), CompileArg.info diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index daee566afe..a23239e76f 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -1960,10 +1960,6 @@ type one = ; cmis : StringSet.t ; debug : Debug.data } -type result = - | Standalone of one - | Partial of one - let parse_bytecode ~debug code globals debug_data = let state = State.initial globals in Code.Var.reset (); @@ -2037,14 +2033,14 @@ let read_toc ic = done; !section_table -let exe_from_channel - ~includes +let from_exe + ?(includes = []) ?(toplevel = false) ?(expunge = fun _ -> `Keep) ?(dynlink = false) - ~debug - ~debug_data + ?(debug = `No) ic = + let debug_data = Debug.create () 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 @@ -2193,12 +2189,14 @@ let exe_from_channel StringSet.empty else StringSet.empty in - {code = prepend p body; cmis; debug = debug_data} + let code = prepend p body in + Code.invariant code; + {code; cmis; debug = debug_data} (* As input: list of primitives + size of global table *) let from_bytes primitives (code : bytecode) = - let globals = make_globals 0 [||] primitives in let debug_data = Debug.create () in + let globals = make_globals 0 [||] primitives in let p = parse_bytecode ~debug:`No code globals debug_data in let gdata = Var.fresh () in let body = @@ -2347,14 +2345,51 @@ let from_compilation_units ~includes:_ ~toplevel ~debug ~debug_data l = in {code = prepend prog body; cmis; debug = debug_data} -let from_channel - ?(includes = []) - ?(toplevel = false) - ?expunge - ?(dynlink = false) - ?(debug = `No) - ic = +let from_cmo ?(includes = []) + ?(toplevel = false) + ?(debug = `No) + compunit + ic = + let debug_data = Debug.create () in + seek_in ic compunit.Cmo_format.cu_pos; + let code = Bytes.create compunit.Cmo_format.cu_codesize in + really_input ic code 0 compunit.Cmo_format.cu_codesize; + if debug = `No || compunit.Cmo_format.cu_debug = 0 + then () + else ( + seek_in ic compunit.Cmo_format.cu_debug; + Debug.read_event_list debug_data ~crcs:[] ~includes ~orig:0 ic); + let p = + from_compilation_units ~toplevel ~includes ~debug ~debug_data [compunit, code] + in + Code.invariant p.code; + p + +let from_cma ?(includes = []) + ?(toplevel = false) + ?(debug = `No) + lib + ic = let debug_data = Debug.create () in + let orig = ref 0 in + let units = + List.map lib.Cmo_format.lib_units ~f:(fun compunit -> + seek_in ic compunit.Cmo_format.cu_pos; + let code = Bytes.create compunit.Cmo_format.cu_codesize in + really_input ic code 0 compunit.Cmo_format.cu_codesize; + if debug = `No || compunit.Cmo_format.cu_debug = 0 + then () + else ( + seek_in ic compunit.Cmo_format.cu_debug; + Debug.read_event_list debug_data ~crcs:[] ~includes ~orig:!orig ic); + orig := !orig + compunit.Cmo_format.cu_codesize; + compunit, code) + in + let p = from_compilation_units ~toplevel ~includes ~debug ~debug_data units in + Code.invariant p.code; + p + +let from_channel ic = let format = try let header = really_input_string ic Magic_number.size in @@ -2374,18 +2409,7 @@ let from_channel let compunit_pos = input_binary_int ic in seek_in ic compunit_pos; let compunit : Cmo_format.compilation_unit = input_value ic in - seek_in ic compunit.Cmo_format.cu_pos; - let code = Bytes.create compunit.Cmo_format.cu_codesize in - really_input ic code 0 compunit.Cmo_format.cu_codesize; - if debug = `No || compunit.Cmo_format.cu_debug = 0 - then () - else ( - seek_in ic compunit.Cmo_format.cu_debug; - Debug.read_event_list debug_data ~crcs:[] ~includes ~orig:0 ic); - let x = - from_compilation_units ~toplevel ~includes ~debug ~debug_data [compunit, code] - in - Partial x + `Cmo compunit | `Cma -> if Config.Flag.check_magic () && magic <> Magic_number.current_cma then raise Magic_number.(Bad_magic_version magic); @@ -2393,33 +2417,14 @@ let from_channel (* Go to table of contents *) seek_in ic pos_toc; let lib : Cmo_format.library = input_value ic in - let orig = ref 0 in - let units = - List.map lib.Cmo_format.lib_units ~f:(fun compunit -> - seek_in ic compunit.Cmo_format.cu_pos; - let code = Bytes.create compunit.Cmo_format.cu_codesize in - really_input ic code 0 compunit.Cmo_format.cu_codesize; - if debug = `No || compunit.Cmo_format.cu_debug = 0 - then () - else ( - seek_in ic compunit.Cmo_format.cu_debug; - Debug.read_event_list debug_data ~crcs:[] ~includes ~orig:!orig ic); - orig := !orig + compunit.Cmo_format.cu_codesize; - compunit, code) - in - let x = from_compilation_units ~toplevel ~includes ~debug ~debug_data units in - Partial x + `Cma lib | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) | `Post magic -> ( match Magic_number.kind magic with | `Exe -> if Config.Flag.check_magic () && magic <> Magic_number.current_exe then raise Magic_number.(Bad_magic_version magic); - let x = - exe_from_channel ~includes ~toplevel ?expunge ~dynlink ~debug ~debug_data ic - in - Code.invariant x.code; - Standalone x + `Exe | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) let predefined_exceptions () = diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli index 5292f59558..9cdd43468e 100644 --- a/compiler/lib/parse_bytecode.mli +++ b/compiler/lib/parse_bytecode.mli @@ -37,18 +37,33 @@ type one = ; cmis : StringSet.t ; debug : Debug.data } -type result = - | Standalone of one - | Partial of one - -val from_channel : +val from_exe : ?includes:string list -> ?toplevel:bool -> ?expunge:(string -> [`Keep | `Skip]) -> ?dynlink:bool -> ?debug:[`Full | `Names | `No] -> in_channel - -> result + -> one + +val from_cmo : + ?includes:string list + -> ?toplevel:bool + -> ?debug:[`Full | `Names | `No] + -> Cmo_format.compilation_unit + -> in_channel + -> one + +val from_cma : + ?includes:string list + -> ?toplevel:bool + -> ?debug:[`Full | `Names | `No] + -> Cmo_format.library + -> in_channel + -> one + +val from_channel : + in_channel -> [`Cmo of Cmo_format.compilation_unit | `Cma of Cmo_format.library | `Exe] val from_string : string array -> string -> Code.program * Debug.data diff --git a/toplevel/bin/jsoo_mkcmis.ml b/toplevel/bin/jsoo_mkcmis.ml index 7f1b047e1c..1a0eaefeab 100644 --- a/toplevel/bin/jsoo_mkcmis.ml +++ b/toplevel/bin/jsoo_mkcmis.ml @@ -65,7 +65,7 @@ let args = List.map (fun filename -> let name = Filename.(concat !prefix (basename filename)) in - Js_of_ocaml_compiler.PseudoFs.embed_file ~name ~filename ) + Js_of_ocaml_compiler.PseudoFs.embed_file ~name ~filename) all in let program = From 4af219b2f0e124c25bff13fcbf0e415e7bd15c47 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 29 Apr 2019 09:56:07 +0800 Subject: [PATCH 4/5] Compiler: don't generate var too early --- compiler/js_of_ocaml.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/js_of_ocaml.ml b/compiler/js_of_ocaml.ml index a3fbe5798b..bcf62e14f0 100644 --- a/compiler/js_of_ocaml.ml +++ b/compiler/js_of_ocaml.ml @@ -161,7 +161,7 @@ let f let args = [Code.Pc (IString k); Code.Pc (IString v)] in Code.(Let (Var.fresh (), Prim (Extern "caml_set_static_env", args)))) in - let pseudo_fs_init_instr = if fs_external then [PseudoFs.init ()] else [] in + let pseudo_fs_init_instr () = if fs_external then [PseudoFs.init ()] else [] in let output (one : Parse_bytecode.one) standalone output_file = check_debug one.debug; (match output_file with @@ -169,7 +169,7 @@ let f let instr = List.concat [ pseudo_fs_instr `caml_create_file one.debug one.cmis - ; pseudo_fs_init_instr + ; pseudo_fs_init_instr () ; env_instr () ] in let code = Code.prepend one.code instr in @@ -192,7 +192,7 @@ let f | Some _ -> [], pseudo_fs_instr `caml_create_file_extern one.debug one.cmis in gen_file file (fun chan -> - let instr = List.concat [fs_instr1; pseudo_fs_init_instr; env_instr ()] in + let instr = List.concat [fs_instr1; pseudo_fs_init_instr (); env_instr ()] in let code = Code.prepend one.code instr in let fmt = Pretty_print.to_out_channel chan in Driver.f From 04ff51c0a88d5cbbbe1113dbf0a488853626c0e2 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 29 Apr 2019 10:02:27 +0800 Subject: [PATCH 5/5] update dune --- compiler/dune | 1 + 1 file changed, 1 insertion(+) diff --git a/compiler/dune b/compiler/dune index e19d8b5331..9b951500dc 100644 --- a/compiler/dune +++ b/compiler/dune @@ -5,6 +5,7 @@ (libraries js_of_ocaml-compiler cmdliner + compiler-libs.common (select empty-findlib.ml from ;; Only link js_of_ocaml-compiler.findlib-support if it exists (js_of_ocaml-compiler.findlib-support -> empty-findlib.ml.in)