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

7 files changed, 51 insertions, 31 deletions

diff --git a/driver/Assembler.ml b/driver/Assembler.ml
index 52fb17d8..d6cb65ea 100644
--- a/driver/Assembler.ml
+++ b/driver/Assembler.ml
@@ -18,12 +18,17 @@ open Driveraux
 (* From asm to object file *)
 
 let assemble ifile ofile =
-  let cmd = List.concat [
-    Configuration.asm;
+  let cmd,opts = match Configuration.asm with
+  | name::opts -> name,opts
+  | [] -> assert false (* Should be catched in Configuration *) in
+  let opts = List.concat [
+    opts;
     ["-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 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
diff --git a/driver/Driveraux.mli b/driver/Driveraux.mli
index 60efcc80..54df4336 100644
--- a/driver/Driveraux.mli
+++ b/driver/Driveraux.mli
@@ -12,7 +12,13 @@
 (* *********************************************************************)
 
 
-val command: ?stdout:string  -> string list -> int
+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 043d4e5a..41b09b58 100644
--- a/driver/Frontend.ml
+++ b/driver/Frontend.ml
@@ -24,8 +24,11 @@ open Printf
 let preprocess ifile ofile =
   let output =
     if ofile = "-" then None else Some ofile in
-  let cmd = List.concat [
-    Configuration.prepro;
+  let cmd,opts = match Configuration.prepro with
+  | name::opts -> name,opts
+  | [] -> assert false (* Should be catched in Configuration *) in
+  let opts = List.concat [
+    opts;
     ["-D__COMPCERT__"];
     (if !Clflags.use_standard_headers
      then ["-I" ^ Filename.concat !Clflags.stdlib_path "include" ]
@@ -33,6 +36,8 @@ 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 2f767023..14c9bcb3 100644
--- a/driver/Linker.ml
+++ b/driver/Linker.ml
@@ -19,14 +19,19 @@ open Driveraux
 (* Linking *)
 
 let linker exe_name files =
-  let cmd = List.concat [
-    Configuration.linker;
+  let cmd,opts = match Configuration.linker with
+  | name::opts -> name,opts
+  | [] -> assert false (* Should be catched in Configuration *) in
+  let opts = List.concat [
+    opts;
     ["-o"; exe_name];
     files;
     (if Configuration.has_runtime_lib
-     then ["-L" ^ !stdlib_path; "-lcompcert"]
-     else [])
+    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;
diff --git a/lib/Responsefile.ml b/lib/Responsefile.ml
index 6dd1bc93..c10fe302 100644
--- a/lib/Responsefile.ml
+++ b/lib/Responsefile.ml
@@ -131,19 +131,3 @@ let expand_responsefiles args =
       acc := file::!acc
   done;
   Array.of_list !acc
-
-let write_responsefile oc args start =
-  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
-  let first = ref true in
-  let sep oc = if !first then
-    first := false
-  else
-    output_string oc " " in
-  for i = start to (Array.length args -1) do
-    Printf.fprintf oc "%t%s" sep (quote args.(i))
-  done
diff --git a/lib/Responsefile.mli b/lib/Responsefile.mli
index 95c74bda..b55dac16 100644
--- a/lib/Responsefile.mli
+++ b/lib/Responsefile.mli
@@ -18,7 +18,3 @@
 val expand_responsefiles: string array -> string array
   (** Expand responsefile arguments contained in the array and return the full
       set of arguments. *)
-
-val write_responsefile: out_channel -> string array -> int -> unit
-  (** Write the arguments starting at the given index as repsonsefile on the given
-      out_channel. All arguments that contain whitespaces are quoted. *)