From efa462bd1655c6b2c8f064e214762650092257e8 Mon Sep 17 00:00:00 2001
From: Bernhard Schommer <bernhardschommer@gmail.com>
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/Assembler.ml  |  9 +++++++--
 driver/Driveraux.ml  | 23 +++++++++++++++++++++--
 driver/Driveraux.mli |  8 +++++++-
 driver/Frontend.ml   |  9 +++++++--
 driver/Linker.ml     | 13 +++++++++----
 5 files changed, 51 insertions(+), 11 deletions(-)

(limited to 'driver')

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;
-- 
cgit