diff --git a/.depend b/.depend index 6ba99fac2..de33bcee8 100644 --- a/.depend +++ b/.depend @@ -5721,7 +5721,8 @@ driver/compenv.cmx : \ utils/clflags.cmx \ utils/ccomp.cmx \ driver/compenv.cmi -driver/compenv.cmi : +driver/compenv.cmi : \ + utils/clflags.cmi driver/compile.cmo : \ lambda/translmod.cmi \ lambda/simplif.cmi \ @@ -5752,7 +5753,8 @@ driver/compile.cmi : \ typing/typedtree.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ - driver/compile_common.cmi + driver/compile_common.cmi \ + utils/clflags.cmi driver/compile_common.cmo : \ utils/warnings.cmi \ typing/typemod.cmi \ @@ -5945,6 +5947,7 @@ driver/optcompile.cmx : \ driver/optcompile.cmi : \ typing/typedtree.cmi \ driver/compile_common.cmi \ + utils/clflags.cmi \ middle_end/backend_intf.cmi driver/opterrors.cmo : \ parsing/location.cmi \ diff --git a/Changes b/Changes index c20b69525..a8dc05591 100644 --- a/Changes +++ b/Changes @@ -460,6 +460,9 @@ Working version - #8939: Command-line option to save Linear IR before emit. (Greta Yorsh, review by Mark Shinwell, Sébastien Hinderer and Frédéric Bour) +- #9003: Start compilation from Emit when the input file is in Linear IR format. + (Greta Yorsh, review by Jérémie Dimino, Gabriel Scherer and Frédéric Bour) + ### Build system: - #7121, #9558: Always the autoconf-discovered ld in PACKLD. For diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index de6d5300b..3bb3a6009 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -23,7 +23,9 @@ open Clflags open Misc open Cmm -type error = Assembler_error of string +type error = + | Assembler_error of string + | Mismatched_for_pack of string option exception Error of error @@ -39,18 +41,23 @@ let pass_dump_linear_if ppf flag message phrase = if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; phrase +let start_from_emit = ref true + let should_save_before_emit () = - should_save_ir_after Compiler_pass.Scheduling + should_save_ir_after Compiler_pass.Scheduling && (not !start_from_emit) let linear_unit_info = { Linear_format.unit_name = ""; items = []; + for_pack = None; } let reset () = + start_from_emit := false; if should_save_before_emit () then begin linear_unit_info.unit_name <- Compilenv.current_unit_name (); linear_unit_info.items <- []; + linear_unit_info.for_pack <- !Clflags.for_package; end let save_data dl = @@ -65,9 +72,9 @@ let save_linear f = end; f -let write_linear output_prefix = +let write_linear prefix = if should_save_before_emit () then begin - let filename = output_prefix ^ Clflags.Compiler_ir.(extension Linear) in + let filename = Compiler_pass.(to_output_filename Scheduling ~prefix) in linear_unit_info.items <- List.rev linear_unit_info.items; Linear_format.save filename linear_unit_info end @@ -218,14 +225,15 @@ type middle_end = -> Lambda.program -> Clambda.with_constants +let asm_filename output_prefix = + if !keep_asm_file || !Emitaux.binary_backend_available + then output_prefix ^ ext_asm + else Filename.temp_file "camlasm" ext_asm + let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end ~ppf_dump (program : Lambda.program) = - let asm_filename = - if !keep_asm_file || !Emitaux.binary_backend_available - then prefixname ^ ext_asm - else Filename.temp_file "camlasm" ext_asm - in - compile_unit ~output_prefix:prefixname ~asm_filename ~keep_asm:!keep_asm_file + compile_unit ~output_prefix:prefixname + ~asm_filename:(asm_filename prefixname) ~keep_asm:!keep_asm_file ~obj_filename:(prefixname ^ ext_obj) (fun () -> Ident.Set.iter Compilenv.require_global program.required_globals; @@ -234,12 +242,43 @@ let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end in end_gen_implementation ?toplevel ~ppf_dump clambda_with_constants) +let linear_gen_implementation filename = + let open Linear_format in + let linear_unit_info, _ = restore filename in + (match !Clflags.for_package, linear_unit_info.for_pack with + | None, None -> () + | Some expected, Some saved when String.equal expected saved -> () + | _, saved -> raise(Error(Mismatched_for_pack saved))); + let emit_item = function + | Data dl -> emit_data dl + | Func f -> emit_fundecl f + in + start_from_emit := true; + emit_begin_assembly (); + Profile.record "Emit" (List.iter emit_item) linear_unit_info.items; + emit_end_assembly () + +let compile_implementation_linear output_prefix ~progname = + compile_unit ~output_prefix + ~asm_filename:(asm_filename output_prefix) ~keep_asm:!keep_asm_file + ~obj_filename:(output_prefix ^ ext_obj) + (fun () -> + linear_gen_implementation progname) + (* Error report *) let report_error ppf = function | Assembler_error file -> fprintf ppf "Assembler error, input left in file %a" Location.print_filename file + | Mismatched_for_pack saved -> + let msg = function + | None -> "without -for-pack" + | Some s -> "with -for-pack "^s + in + fprintf ppf + "This input file cannot be compiled %s: it was generated %s." + (msg !Clflags.for_package) (msg saved) let () = Location.register_error_of_exn diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 95df2eae4..f86bd6737 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -35,10 +35,16 @@ val compile_implementation -> Lambda.program -> unit +val compile_implementation_linear : + string -> progname:string -> unit + val compile_phrase : ppf_dump:Format.formatter -> Cmm.phrase -> unit -type error = Assembler_error of string +type error = + | Assembler_error of string + | Mismatched_for_pack of string option + exception Error of error val report_error: Format.formatter -> error -> unit diff --git a/driver/compenv.ml b/driver/compenv.ml index 9f6fa692b..8efe79e6b 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -193,6 +193,30 @@ let check_bool ppf name s = "bad value %s for %s" s name; false +let decode_compiler_pass ppf v ~name ~filter = + let module P = Clflags.Compiler_pass in + let passes = P.available_pass_names ~filter ~native:!native_code in + begin match List.find_opt (String.equal v) passes with + | None -> + Printf.ksprintf (print_error ppf) + "bad value %s for option \"%s\" (expected one of: %s)" + v name (String.concat ", " passes); + None + | Some v -> P.of_string v + end + +let set_compiler_pass ppf ~name v flag ~filter = + match decode_compiler_pass ppf v ~name ~filter with + | None -> () + | Some pass -> + match !flag with + | None -> flag := Some pass + | Some p -> + if not (p = pass) then begin + Printf.ksprintf (print_error ppf) + "Please specify at most one %s ." name + end + (* 'can-discard=' specifies which arguments can be discarded without warning because they are not understood by some versions of OCaml. *) let can_discard = ref [] @@ -436,35 +460,14 @@ let read_one_param ppf position name v = profile_columns := if check_bool ppf name v then if_on else [] | "stop-after" -> - let module P = Clflags.Compiler_pass in - let passes = P.available_pass_names - ~filter:(fun _ -> true) - ~native:!native_code in - begin match List.find_opt (String.equal v) passes with - | None -> - Printf.ksprintf (print_error ppf) - "bad value %s for option \"stop-after\" (expected one of: %s)" - v (String.concat ", " passes) - | Some v -> - let pass = Option.get (P.of_string v) in - Clflags.stop_after := Some pass - end + set_compiler_pass ppf v ~name Clflags.stop_after ~filter:(fun _ -> true) | "save-ir-after" -> if !native_code then begin - let module P = Clflags.Compiler_pass in - let passes = P.available_pass_names - ~filter:P.can_save_ir_after - ~native:!native_code in - begin match List.find_opt (String.equal v) passes with - | None -> - Printf.ksprintf (print_error ppf) - "bad value %s for option \"save-ir-after\" (expected one of: %s)" - v (String.concat ", " passes) - | Some v -> - let pass = Option.get (P.of_string v) in - set_save_ir_after pass true - end + let filter = Clflags.Compiler_pass.can_save_ir_after in + match decode_compiler_pass ppf v ~name ~filter with + | None -> () + | Some pass -> set_save_ir_after pass true end | _ -> @@ -475,6 +478,7 @@ let read_one_param ppf position name v = name end + let read_OCAMLPARAM ppf position = try let s = Sys.getenv "OCAMLPARAM" in @@ -614,12 +618,15 @@ let c_object_of_filename name = let process_action (ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action = + let impl ~start_from name = + readenv ppf (Before_compile name); + let opref = output_prefix name in + implementation ~start_from ~source_file:name ~output_prefix:opref; + objfiles := (opref ^ ocaml_mod_ext) :: !objfiles + in match action with | ProcessImplementation name -> - readenv ppf (Before_compile name); - let opref = output_prefix name in - implementation ~source_file:name ~output_prefix:opref; - objfiles := (opref ^ ocaml_mod_ext) :: !objfiles + impl ~start_from:Compiler_pass.Parsing name | ProcessInterface name -> readenv ppf (Before_compile name); let opref = output_prefix name in @@ -646,7 +653,11 @@ let process_action else if not !native_code && Filename.check_suffix name Config.ext_dll then dllibs := name :: !dllibs else - raise(Arg.Bad("don't know what to do with " ^ name)) + match Compiler_pass.of_input_filename name with + | Some start_from -> + Location.input_name := name; + impl ~start_from name + | None -> raise(Arg.Bad("don't know what to do with " ^ name)) let action_of_file name = diff --git a/driver/compenv.mli b/driver/compenv.mli index a8c22f308..93a585dc7 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -71,7 +71,8 @@ val intf : string -> unit val process_deferred_actions : Format.formatter * - (source_file:string -> output_prefix:string -> unit) * + (start_from:Clflags.Compiler_pass.t -> + source_file:string -> output_prefix:string -> unit) * (* compile implementation *) (source_file:string -> output_prefix:string -> unit) * (* compile interface *) diff --git a/driver/compile.ml b/driver/compile.ml index c41a877ff..ead460368 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -54,10 +54,13 @@ let emit_bytecode i (bytecode, required_globals) = (Emitcode.to_file oc i.module_name cmofile ~required_globals); ) -let implementation ~source_file ~output_prefix = +let implementation ~start_from ~source_file ~output_prefix = let backend info typed = let bytecode = to_bytecode info typed in emit_bytecode info bytecode in with_info ~source_file ~output_prefix ~dump_ext:"cmo" @@ fun info -> - Compile_common.implementation info ~backend + match (start_from : Clflags.Compiler_pass.t) with + | Parsing -> Compile_common.implementation info ~backend + | _ -> Misc.fatal_errorf "Cannot start from %s" + (Clflags.Compiler_pass.to_string start_from) diff --git a/driver/compile.mli b/driver/compile.mli index 7c564c3e3..968955762 100644 --- a/driver/compile.mli +++ b/driver/compile.mli @@ -18,6 +18,7 @@ val interface: source_file:string -> output_prefix:string -> unit val implementation: + start_from:Clflags.Compiler_pass.t -> source_file:string -> output_prefix:string -> unit (** {2 Internal functions} **) diff --git a/driver/maindriver.ml b/driver/maindriver.ml index be9a8e5e6..81d7edfd2 100644 --- a/driver/maindriver.ml +++ b/driver/maindriver.ml @@ -63,7 +63,7 @@ let main argv ppf = are incompatible with -pack, -a, -output-obj" (String.concat "|" (P.available_pass_names ~filter:(fun _ -> true) ~native:false)) - | Some P.Scheduling -> assert false (* native only *) + | Some (P.Scheduling | P.Emit) -> assert false (* native only *) end; if !make_archive then begin Compmisc.init_path (); diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 9ca93c33b..693a35f48 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -85,7 +85,12 @@ let clambda i backend typed = ~ppf_dump:i.ppf_dump; Compilenv.save_unit_info (cmx i)) -let implementation ~backend ~source_file ~output_prefix = +(* Emit assembly directly from Linear IR *) +let emit i = + Compilenv.reset ?packname:!Clflags.for_package i.module_name; + Asmgen.compile_implementation_linear i.output_prefix ~progname:i.source_file + +let implementation ~backend ~start_from ~source_file ~output_prefix = let backend info typed = Compilenv.reset ?packname:!Clflags.for_package info.module_name; if Config.flambda @@ -93,4 +98,8 @@ let implementation ~backend ~source_file ~output_prefix = else clambda info backend typed in with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info -> - Compile_common.implementation info ~backend + match (start_from:Clflags.Compiler_pass.t) with + | Parsing -> Compile_common.implementation info ~backend + | Emit -> emit info + | _ -> Misc.fatal_errorf "Cannot start from %s" + (Clflags.Compiler_pass.to_string start_from) diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 9a23b8b23..f04e75e62 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -19,6 +19,7 @@ val interface: source_file:string -> output_prefix:string -> unit val implementation: backend:(module Backend_intf.S) + -> start_from:Clflags.Compiler_pass.t -> source_file:string -> output_prefix:string -> unit (** {2 Internal functions} **) diff --git a/driver/optmaindriver.ml b/driver/optmaindriver.ml index 0c9626f2b..9986a5a5b 100644 --- a/driver/optmaindriver.ml +++ b/driver/optmaindriver.ml @@ -75,7 +75,7 @@ let main argv ppf = | None -> Compenv.fatal "Please specify at most one of -pack, -a, -shared, -c, \ -output-obj"; - | Some ((P.Parsing | P.Typing | P.Scheduling) as p) -> + | Some ((P.Parsing | P.Typing | P.Scheduling | P.Emit) as p) -> assert (P.is_compilation_pass p); Printf.ksprintf Compenv.fatal "Options -i and -stop-after (%s) \ diff --git a/file_formats/linear_format.ml b/file_formats/linear_format.ml index a12711fc6..5525a6970 100644 --- a/file_formats/linear_format.ml +++ b/file_formats/linear_format.ml @@ -24,6 +24,7 @@ type linear_unit_info = { mutable unit_name : string; mutable items : linear_item_info list; + mutable for_pack : string option } type error = diff --git a/file_formats/linear_format.mli b/file_formats/linear_format.mli index d8856bc7d..766db5db2 100644 --- a/file_formats/linear_format.mli +++ b/file_formats/linear_format.mli @@ -27,6 +27,7 @@ type linear_unit_info = { mutable unit_name : string; mutable items : linear_item_info list; + mutable for_pack : string option } (* Marshal and unmarshal a compilation unit in Linear format. diff --git a/testsuite/tests/tool-ocamlopt-save-ir/check_for_pack.compilers.reference b/testsuite/tests/tool-ocamlopt-save-ir/check_for_pack.compilers.reference new file mode 100644 index 000000000..df07426a4 --- /dev/null +++ b/testsuite/tests/tool-ocamlopt-save-ir/check_for_pack.compilers.reference @@ -0,0 +1,2 @@ +File "check_for_pack.cmir-linear", line 1: +Error: This input file cannot be compiled with -for-pack foo: it was generated without -for-pack. diff --git a/testsuite/tests/tool-ocamlopt-save-ir/check_for_pack.ml b/testsuite/tests/tool-ocamlopt-save-ir/check_for_pack.ml new file mode 100644 index 000000000..610abbdc3 --- /dev/null +++ b/testsuite/tests/tool-ocamlopt-save-ir/check_for_pack.ml @@ -0,0 +1,19 @@ +(* TEST + * native-compiler + ** setup-ocamlopt.byte-build-env + *** ocamlopt.byte + flags = "-save-ir-after scheduling" + ocamlopt_byte_exit_status = "0" + **** script + script = "touch empty.ml" + ***** ocamlopt.byte + flags = "-S check_for_pack.cmir-linear -for-pack foo" + module = "empty.ml" + ocamlopt_byte_exit_status = "2" + ****** check-ocamlopt.byte-output +*) + +let foo f x = + if x > 0 then x * 7 else f x + +let bar x y = x + y diff --git a/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.ml b/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.ml new file mode 100644 index 000000000..6f6cdf0f2 --- /dev/null +++ b/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.ml @@ -0,0 +1,31 @@ +(* TEST + * native-compiler + ** setup-ocamlopt.byte-build-env + *** ocamlopt.byte + flags = "-save-ir-after scheduling -stop-after scheduling" + ocamlopt_byte_exit_status = "0" + **** script + script = "touch empty.ml" + ***** ocamlopt.byte + flags = "-S start_from_emit.cmir-linear" + module = "empty.ml" + ocamlopt_byte_exit_status = "0" + ****** check-ocamlopt.byte-output + ******* script + script = "sh ${test_source_directory}/start_from_emit.sh" + ******** ocamlopt.byte + flags = "-S start_from_emit.cmir-linear -save-ir-after scheduling" + module = "empty.ml" + ocamlopt_byte_exit_status = "0" + ********* script + script = "cp start_from_emit.cmir-linear expected.cmir_linear" + ********** check-ocamlopt.byte-output + *********** script + script = "cmp start_from_emit.cmir-linear expected.cmir_linear" + +*) + +let foo f x = + if x > 0 then x * 7 else f x + +let bar x y = x + y diff --git a/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.sh b/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.sh new file mode 100755 index 000000000..99eb8136e --- /dev/null +++ b/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.sh @@ -0,0 +1,14 @@ +#!/bin/sh + +set -e + +obj=start_from_emit.${objext} + +# Check that obj is generated +if [ -e "$obj" ] ; then + test_result=${TEST_PASS} +else + echo "not found $obj" > ${ocamltest_response} + test_result=${TEST_FAIL} +fi +exit ${test_result} diff --git a/utils/clflags.ml b/utils/clflags.ml index 534551f80..a193d53d2 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -417,21 +417,43 @@ let unboxed_types = ref false (* This is used by the -save-ir-after option. *) module Compiler_ir = struct type t = Linear - let extension t = - let ext = - match t with - | Linear -> "linear" - in - ".cmir-" ^ ext - - let magic t = - let open Config in - match t with - | Linear -> linear_magic_number let all = [ Linear; ] + + let extension t = + let ext = + match t with + | Linear -> "linear" + in + ".cmir-" ^ ext + + (** [extract_extension_with_pass filename] returns the IR whose extension + is a prefix of the extension of [filename], and the suffix, + which can be used to distinguish different passes on the same IR. + For example, [extract_extension_with_pass "foo.cmir-linear123"] + returns [Some (Linear, "123")]. *) + let extract_extension_with_pass filename = + let ext = Filename.extension filename in + let ext_len = String.length ext in + if ext_len <= 0 then None + else begin + let is_prefix ir = + let s = extension ir in + let s_len = String.length s in + s_len <= ext_len && s = String.sub ext 0 s_len + in + let drop_prefix ir = + let s = extension ir in + let s_len = String.length s in + String.sub ext s_len (ext_len - s_len) + in + let ir = List.find_opt is_prefix all in + match ir with + | None -> None + | Some ir -> Some (ir, drop_prefix ir) + end end (* This is used by the -stop-after option. *) @@ -441,32 +463,37 @@ module Compiler_pass = struct - the manpages in man/ocaml{c,opt}.m - the manual manual/manual/cmds/unified-options.etex *) - type t = Parsing | Typing | Scheduling + type t = Parsing | Typing | Scheduling | Emit let to_string = function | Parsing -> "parsing" | Typing -> "typing" | Scheduling -> "scheduling" + | Emit -> "emit" let of_string = function | "parsing" -> Some Parsing | "typing" -> Some Typing | "scheduling" -> Some Scheduling + | "emit" -> Some Emit | _ -> None let rank = function | Parsing -> 0 | Typing -> 1 | Scheduling -> 50 + | Emit -> 60 let passes = [ Parsing; Typing; Scheduling; + Emit; ] let is_compilation_pass _ = true let is_native_only = function | Scheduling -> true + | Emit -> true | _ -> false let enabled is_native t = not (is_native_only t) || is_native @@ -479,6 +506,19 @@ module Compiler_pass = struct |> List.filter (enabled native) |> List.filter filter |> List.map to_string + + let compare a b = + compare (rank a) (rank b) + + let to_output_filename t ~prefix = + match t with + | Scheduling -> prefix ^ Compiler_ir.(extension Linear) + | _ -> Misc.fatal_error "Not supported" + + let of_input_filename name = + match Compiler_ir.extract_extension_with_pass name with + | Some (Linear, _) -> Some Emit + | None -> None end let stop_after = ref None (* -stop-after *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 6fde1fc3e..645ff4aaa 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -235,20 +235,16 @@ val unboxed_types : bool ref val insn_sched : bool ref val insn_sched_default : bool -module Compiler_ir : sig - type t = Linear - val extension : t -> string - val magic : t -> string - val all : t list -end - module Compiler_pass : sig - type t = Parsing | Typing | Scheduling + type t = Parsing | Typing | Scheduling | Emit val of_string : string -> t option val to_string : t -> string val is_compilation_pass : t -> bool val available_pass_names : filter:(t -> bool) -> native:bool -> string list val can_save_ir_after : t -> bool + val compare : t -> t -> int + val to_output_filename: t -> prefix:string -> string + val of_input_filename: string -> t option end val stop_after : Compiler_pass.t option ref val should_stop_after : Compiler_pass.t -> bool