From efa462bd1655c6b2c8f064e214762650092257e8 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 12 Jul 2016 13:18:42 +0200 Subject: Added heuristic for passing arg via responsefiles. Since gnu make and other tools under windows seem to have a limit of around 8000 bytes per command line the arguments should be passed via responsefiles instead. Bug 18308 --- driver/Driveraux.ml | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) (limited to 'driver/Driveraux.ml') diff --git a/driver/Driveraux.ml b/driver/Driveraux.ml index 3fe22fac..8ebf261d 100644 --- a/driver/Driveraux.ml +++ b/driver/Driveraux.ml @@ -14,12 +14,33 @@ open Printf open Clflags +(* Is this a gnu based tool chain *) +let gnu_system = Configuration.system <> "diab" + (* 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 = if !option_v then begin eprintf "+ %s" (String.concat " " args); @@ -94,8 +115,6 @@ let print_error oc msg = List.iter print_one_error msg; output_char oc '\n' -let gnu_system = Configuration.system <> "diab" - (* Command-line parsing *) let explode_comma_option s = match Str.split (Str.regexp ",") s with -- cgit 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/Driveraux.ml | 49 +++++++++++++++++++++++++++---------------------- 1 file changed, 27 insertions(+), 22 deletions(-) (limited to 'driver/Driveraux.ml') 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). -- cgit From f22c32dcda0e8b546e85e8ad95d0ad655e365d38 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 20 Jul 2016 13:20:19 +0200 Subject: Added simplified reader and printer for gnu @files The functions expandargv and writeargv resemble the functions from the libiberity that are used by the gnu tools. Additionaly a new configuration is added in order to determine which kind of response files are supported for calls to other tools. Bug 18308 --- driver/Driveraux.ml | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) (limited to 'driver/Driveraux.ml') diff --git a/driver/Driveraux.ml b/driver/Driveraux.ml index 2c03c65c..6bd48344 100644 --- a/driver/Driveraux.ml +++ b/driver/Driveraux.ml @@ -58,20 +58,25 @@ 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 +(* This function reimplements quoting of writeargv from libiberty *) +let gnu_quote arg = + let len = String.length arg in + let buf = Buffer.create len in + String.iter (fun c -> match c with + | ' ' | '\t' | '\r' | '\n' | '\\' | '\'' | '"' -> + Buffer.add_char buf '\\' + | _ -> (); + Buffer.add_char buf c) arg; + Buffer.contents buf let command ?stdout args = - if Sys.win32 && List.fold_left (fun len arg -> len + String.length arg + 1) 0 args > 7000 then + let resp = Sys.win32 && Configuration.response_file_style <> Configuration.Unsupported in + if resp && 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; + List.iter (fun a -> Printf.fprintf oc "%s " (gnu_quote a)) args; close_out oc; let arg = if gnu_system then "@"^file else "-@"^file in let ret = command stdout [cmd;arg] in -- cgit From 0a38e7727f3c38742704907e0c4dc60da6b99743 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 21 Jul 2016 14:39:00 +0200 Subject: Added support for quoting for diab backend. The diab data compiler has different quoting conventions compared to the gnu tools. Bug 18308. --- driver/Driveraux.ml | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'driver/Driveraux.ml') diff --git a/driver/Driveraux.ml b/driver/Driveraux.ml index 6bd48344..1ee39e8e 100644 --- a/driver/Driveraux.ml +++ b/driver/Driveraux.ml @@ -69,14 +69,30 @@ let gnu_quote arg = Buffer.add_char buf c) arg; Buffer.contents buf +let re_whitespace = Str.regexp ".*[ \t\n\r]" + +let diab_quote arg = + let buf = Buffer.create ((String.length arg) + 8) in + let doublequote = Str.string_match re_whitespace arg 0 in + if doublequote then Buffer.add_char buf '"'; + String.iter (fun c -> + if c = '"' then Buffer.add_char buf '\\'; + Buffer.add_char buf c) arg; + if doublequote then Buffer.add_char buf '"'; + Buffer.contents buf + let command ?stdout args = let resp = Sys.win32 && Configuration.response_file_style <> Configuration.Unsupported in if resp && List.fold_left (fun len arg -> len + String.length arg + 1) 0 args > 7000 then + let quote = match Configuration.response_file_style with + | Configuration.Unsupported -> assert false + | Configuration.Gnu -> gnu_quote + | Configuration.Diab -> diab_quote in 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 " (gnu_quote a)) args; + 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 -- cgit From 951c37603e2a807b116f91d7390bd6e641d8092b Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 21 Jul 2016 14:45:44 +0200 Subject: Corrected diab quoting. Bug 18308 --- driver/Driveraux.ml | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) (limited to 'driver/Driveraux.ml') diff --git a/driver/Driveraux.ml b/driver/Driveraux.ml index 1ee39e8e..a773b37c 100644 --- a/driver/Driveraux.ml +++ b/driver/Driveraux.ml @@ -69,17 +69,20 @@ let gnu_quote arg = Buffer.add_char buf c) arg; Buffer.contents buf -let re_whitespace = Str.regexp ".*[ \t\n\r]" +let re_quote = Str.regexp ".*[ \t\n\r\"]" let diab_quote arg = let buf = Buffer.create ((String.length arg) + 8) in - let doublequote = Str.string_match re_whitespace arg 0 in - if doublequote then Buffer.add_char buf '"'; - String.iter (fun c -> - if c = '"' then Buffer.add_char buf '\\'; - Buffer.add_char buf c) arg; - if doublequote then Buffer.add_char buf '"'; - Buffer.contents buf + let doublequote = Str.string_match re_quote arg 0 in + if doublequote then begin + Buffer.add_char buf '"'; + String.iter (fun c -> + if c = '"' then Buffer.add_char buf '\\'; + Buffer.add_char buf c) arg; + if doublequote then Buffer.add_char buf '"'; + Buffer.contents buf + end else + arg let command ?stdout args = let resp = Sys.win32 && Configuration.response_file_style <> Configuration.Unsupported in -- cgit From eb2844b87fa0e176bd65466d7ab7d16666344406 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 10 Aug 2016 13:31:25 +0200 Subject: Added missing begin end around quoting. Bug 18308. --- driver/Driveraux.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'driver/Driveraux.ml') diff --git a/driver/Driveraux.ml b/driver/Driveraux.ml index a773b37c..de1326ce 100644 --- a/driver/Driveraux.ml +++ b/driver/Driveraux.ml @@ -62,10 +62,10 @@ let command stdout args = let gnu_quote arg = let len = String.length arg in let buf = Buffer.create len in - String.iter (fun c -> match c with + String.iter (fun c -> begin match c with | ' ' | '\t' | '\r' | '\n' | '\\' | '\'' | '"' -> Buffer.add_char buf '\\' - | _ -> (); + | _ -> () end; Buffer.add_char buf c) arg; Buffer.contents buf -- cgit From 5309f16159e4decd81330622dcdd6eb4b25819a1 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 16 Aug 2016 10:35:17 +0200 Subject: Moved quoting functions in Responsefile Also corrected some typos and corrected exception handling for expandargv. Bug 18308 --- driver/Driveraux.ml | 36 +++++------------------------------- 1 file changed, 5 insertions(+), 31 deletions(-) (limited to 'driver/Driveraux.ml') diff --git a/driver/Driveraux.ml b/driver/Driveraux.ml index de1326ce..33cd9215 100644 --- a/driver/Driveraux.ml +++ b/driver/Driveraux.ml @@ -17,7 +17,7 @@ open Clflags (* Is this a gnu based tool chain *) let gnu_system = Configuration.system <> "diab" -(* Sage removale of files *) +(* Safe removal of files *) let safe_remove file = try Sys.remove file with Sys_error _ -> () @@ -58,46 +58,20 @@ let command stdout args = argv.(0) fn (Unix.error_message err) param; -1 -(* This function reimplements quoting of writeargv from libiberty *) -let gnu_quote arg = - let len = String.length arg in - let buf = Buffer.create len in - String.iter (fun c -> begin match c with - | ' ' | '\t' | '\r' | '\n' | '\\' | '\'' | '"' -> - Buffer.add_char buf '\\' - | _ -> () end; - Buffer.add_char buf c) arg; - Buffer.contents buf - -let re_quote = Str.regexp ".*[ \t\n\r\"]" - -let diab_quote arg = - let buf = Buffer.create ((String.length arg) + 8) in - let doublequote = Str.string_match re_quote arg 0 in - if doublequote then begin - Buffer.add_char buf '"'; - String.iter (fun c -> - if c = '"' then Buffer.add_char buf '\\'; - Buffer.add_char buf c) arg; - if doublequote then Buffer.add_char buf '"'; - Buffer.contents buf - end else - arg - let command ?stdout args = let resp = Sys.win32 && Configuration.response_file_style <> Configuration.Unsupported in if resp && List.fold_left (fun len arg -> len + String.length arg + 1) 0 args > 7000 then - let quote = match Configuration.response_file_style with + let quote,prefix = match Configuration.response_file_style with | Configuration.Unsupported -> assert false - | Configuration.Gnu -> gnu_quote - | Configuration.Diab -> diab_quote in + | Configuration.Gnu -> Responsefile.gnu_quote,"@" + | Configuration.Diab -> Responsefile.diab_quote,"-@" in 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 arg = prefix^file in let ret = command stdout [cmd;arg] in safe_remove file; ret -- cgit From 0200f6b77550e95c0ec309d1a44f5253fc790e4f Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 22 Aug 2016 13:34:56 +0200 Subject: Print whole command line. When response files are used CompCert should still print all command line arguments since the response file is deleted after usage. Bug 19297. --- driver/Driveraux.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'driver/Driveraux.ml') diff --git a/driver/Driveraux.ml b/driver/Driveraux.ml index 33cd9215..d25301d2 100644 --- a/driver/Driveraux.ml +++ b/driver/Driveraux.ml @@ -28,14 +28,6 @@ let rec waitpid_no_intr pid = with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_no_intr pid let command stdout args = - if !option_v then begin - eprintf "+ %s" (String.concat " " args); - begin match stdout with - | None -> () - | Some f -> eprintf " > %s" f - end; - prerr_endline "" - end; let argv = Array.of_list args in assert (Array.length argv > 0); try @@ -59,6 +51,14 @@ let command stdout args = -1 let command ?stdout args = + if !option_v then begin + eprintf "+ %s" (String.concat " " args); + begin match stdout with + | None -> () + | Some f -> eprintf " > %s" f + end; + prerr_endline "" + end; let resp = Sys.win32 && Configuration.response_file_style <> Configuration.Unsupported in if resp && List.fold_left (fun len arg -> len + String.length arg + 1) 0 args > 7000 then let quote,prefix = match Configuration.response_file_style with -- cgit