From 2129fe8f2e19c4dd91955e5300e76d924e0a3e6d Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 19 Jul 2016 09:44:26 +0200 Subject: Merged responfile function into command. Command now decides whether to use a responsefile or call the external command directly. Bug 18004 --- driver/Assembler.ml | 9 ++------- driver/Driveraux.ml | 49 +++++++++++++++++++++++++++---------------------- driver/Driveraux.mli | 6 ------ driver/Frontend.ml | 9 ++------- driver/Linker.ml | 9 ++------- 5 files changed, 33 insertions(+), 49 deletions(-) diff --git a/driver/Assembler.ml b/driver/Assembler.ml index d6cb65ea..52fb17d8 100644 --- a/driver/Assembler.ml +++ b/driver/Assembler.ml @@ -18,17 +18,12 @@ open Driveraux (* From asm to object file *) let assemble ifile ofile = - let cmd,opts = match Configuration.asm with - | name::opts -> name,opts - | [] -> assert false (* Should be catched in Configuration *) in - let opts = List.concat [ - opts; + let cmd = List.concat [ + Configuration.asm; ["-o"; ofile]; List.rev !assembler_options; [ifile] ] in - let opts = responsefile opts (fun a -> if gnu_system then ["@"^a] else ["@"^a]) in - let cmd = cmd::opts in let exc = command cmd in if exc <> 0 then begin safe_remove ofile; diff --git a/driver/Driveraux.ml b/driver/Driveraux.ml index 8ebf261d..2c03c65c 100644 --- a/driver/Driveraux.ml +++ b/driver/Driveraux.ml @@ -17,31 +17,17 @@ open Clflags (* Is this a gnu based tool chain *) let gnu_system = Configuration.system <> "diab" +(* Sage removale of files *) +let safe_remove file = + try Sys.remove file with Sys_error _ -> () + (* Invocation of external tools *) let rec waitpid_no_intr pid = try Unix.waitpid [] pid with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_no_intr pid -let responsefile args resp_arg = - try - if Sys.win32 && (String.length (String.concat "" args) > 7000) then - let file,oc = Filename.open_temp_file "compcert" "" in - let whitespace = Str.regexp "[ \t\r\n]" in - let quote arg = - if Str.string_match whitespace arg 0 then - Filename.quote arg (* We need to quote arguments containing whitespaces *) - else - arg in - List.iter (fun a -> Printf.fprintf oc "%s " (quote a)) args; - close_out oc; - resp_arg file - else - args - with Sys_error _ -> - args - -let command ?stdout args = +let command stdout args = if !option_v then begin eprintf "+ %s" (String.concat " " args); begin match stdout with @@ -72,12 +58,31 @@ let command ?stdout args = argv.(0) fn (Unix.error_message err) param; -1 +let quote arg = + let whitespace = Str.regexp "[ \t\r\n]" in + if Str.string_match whitespace arg 0 then + Filename.quote arg (* We need to quote arguments containing whitespaces *) + else + arg + +let command ?stdout args = + if Sys.win32 && List.fold_left (fun len arg -> len + String.length arg + 1) 0 args > 7000 then + let file,oc = Filename.open_temp_file "compcert" "" in + let cmd,args = match args with + | cmd::args -> cmd,args + | [] -> assert false (* Should never happen *) in + List.iter (fun a -> Printf.fprintf oc "%s " (quote a)) args; + close_out oc; + let arg = if gnu_system then "@"^file else "-@"^file in + let ret = command stdout [cmd;arg] in + safe_remove file; + ret + else + command stdout args + let command_error n exc = eprintf "Error: %s command failed with exit code %d (use -v to see invocation)\n" n exc -let safe_remove file = - try Sys.remove file with Sys_error _ -> () - (* Determine names for output files. We use -o option if specified and if this is the final destination file (not a dump file). diff --git a/driver/Driveraux.mli b/driver/Driveraux.mli index 54df4336..e6bac6e3 100644 --- a/driver/Driveraux.mli +++ b/driver/Driveraux.mli @@ -12,12 +12,6 @@ (* *********************************************************************) -val responsefile: string list -> (string -> string list) -> string list - (** [responsefiles args resp_arg] Test whether [args] should be passed - via responsefile and writes them into a file. [resp_arg] generates - the new argument constructed from the responsefile. If no - responsefile is written the arguments are returned unchanged. *) - val command: ?stdout:string -> string list -> int (** Execute the command with the given arguments and an optional file for the stdout. Returns the exit code. *) diff --git a/driver/Frontend.ml b/driver/Frontend.ml index 41b09b58..043d4e5a 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -24,11 +24,8 @@ open Printf let preprocess ifile ofile = let output = if ofile = "-" then None else Some ofile in - let cmd,opts = match Configuration.prepro with - | name::opts -> name,opts - | [] -> assert false (* Should be catched in Configuration *) in - let opts = List.concat [ - opts; + let cmd = List.concat [ + Configuration.prepro; ["-D__COMPCERT__"]; (if !Clflags.use_standard_headers then ["-I" ^ Filename.concat !Clflags.stdlib_path "include" ] @@ -36,8 +33,6 @@ let preprocess ifile ofile = List.rev !prepro_options; [ifile] ] in - let opts = responsefile opts (fun a -> if gnu_system then ["@"^a] else ["@"^a]) in - let cmd = cmd::opts in let exc = command ?stdout:output cmd in if exc <> 0 then begin if ofile <> "-" then safe_remove ofile; diff --git a/driver/Linker.ml b/driver/Linker.ml index 14c9bcb3..305c5603 100644 --- a/driver/Linker.ml +++ b/driver/Linker.ml @@ -19,19 +19,14 @@ open Driveraux (* Linking *) let linker exe_name files = - let cmd,opts = match Configuration.linker with - | name::opts -> name,opts - | [] -> assert false (* Should be catched in Configuration *) in - let opts = List.concat [ - opts; + let cmd = List.concat [ + Configuration.linker; ["-o"; exe_name]; files; (if Configuration.has_runtime_lib then ["-L" ^ !stdlib_path; "-lcompcert"] else []) ] in - let opts = responsefile opts (fun a -> if gnu_system then ["@"^a] else ["-@"^a]) in - let cmd = cmd::opts in let exc = command cmd in if exc <> 0 then begin command_error "linker" exc; -- cgit