SysTools: make file copy more efficient

3 files changed, 43 insertions, 47 deletions

diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index 81336912de..f654d0a7fa 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -359,27 +359,20 @@ endMkDependHS logger dflags
   case makefile_hdl of
      Nothing  -> return ()
      Just hdl -> do
-
-          -- slurp the rest of the original makefile and copy it into the output
-        let slurp = do
-                l <- hGetLine hdl
-                hPutStrLn tmp_hdl l
-                slurp
-
-        catchIO slurp
-                (\e -> if isEOFError e then return () else ioError e)
-
+        -- slurp the rest of the original makefile and copy it into the output
+        SysTools.copyHandle hdl tmp_hdl
         hClose hdl
 
   hClose tmp_hdl  -- make sure it's flushed
 
         -- Create a backup of the original makefile
-  when (isJust makefile_hdl)
-       (SysTools.copy logger dflags ("Backing up " ++ makefile)
-          makefile (makefile++".bak"))
+  when (isJust makefile_hdl) $ do
+    showPass logger dflags ("Backing up " ++ makefile)
+    SysTools.copyFile makefile (makefile++".bak")
 
         -- Copy the new makefile in place
-  SysTools.copy logger dflags "Installing new makefile" tmp_file makefile
+  showPass logger dflags "Installing new makefile"
+  SysTools.copyFile tmp_file makefile
 
 
 -----------------------------------------------------------------
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 2ad69bc4a2..c4de774033 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -895,9 +895,10 @@ pipeLoop phase input_fn = do
                                         stopPhase output (src_basename env)
                                         dflags stopPhase (maybe_loc pst)
                when (final_fn /= input_fn) $ do
-                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
-                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
-                  liftIO $ copyWithHeader logger dflags msg line_prag input_fn final_fn
+                  let msg = "Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'"
+                      line_prag = "{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n"
+                  liftIO $ showPass logger dflags msg
+                  liftIO $ copyWithHeader line_prag input_fn final_fn
                return final_fn
 
 
diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs
index 36f924bf90..0b19d50825 100644
--- a/compiler/GHC/SysTools.hs
+++ b/compiler/GHC/SysTools.hs
@@ -20,7 +20,9 @@ module GHC.SysTools (
         module GHC.SysTools.Tasks,
         module GHC.SysTools.Info,
 
-        copy,
+        -- * Fast file copy
+        copyFile,
+        copyHandle,
         copyWithHeader,
 
         -- * General utilities
@@ -32,21 +34,22 @@ import GHC.Prelude
 
 import GHC.Settings.Utils
 
-import GHC.Utils.Error
 import GHC.Utils.Panic
-import GHC.Utils.Logger
 import GHC.Driver.Session
 
-import Control.Monad.Trans.Except (runExceptT)
-import System.FilePath
-import System.IO
-import System.IO.Unsafe (unsafeInterleaveIO)
 import GHC.Linker.ExtraObj
 import GHC.SysTools.Info
 import GHC.SysTools.Tasks
 import GHC.SysTools.BaseDir
 import GHC.Settings.IO
 
+import Control.Monad.Trans.Except (runExceptT)
+import System.FilePath
+import System.IO
+import System.IO.Unsafe (unsafeInterleaveIO)
+import Foreign.Marshal.Alloc (allocaBytes)
+import System.Directory (copyFile)
+
 {-
 Note [How GHC finds toolchain utilities]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -184,26 +187,25 @@ for more information.
 
 -}
 
-copy :: Logger -> DynFlags -> String -> FilePath -> FilePath -> IO ()
-copy logger dflags purpose from to = copyWithHeader logger dflags purpose Nothing from to
-
-copyWithHeader :: Logger -> DynFlags -> String -> Maybe String -> FilePath -> FilePath
-               -> IO ()
-copyWithHeader logger dflags purpose maybe_header from to = do
-  showPass logger dflags purpose
-
-  hout <- openBinaryFile to   WriteMode
-  hin  <- openBinaryFile from ReadMode
-  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
-  maybe (return ()) (header hout) maybe_header
-  hPutStr hout ls
-  hClose hout
-  hClose hin
- where
-  -- write the header string in UTF-8.  The header is something like
-  --   {-# LINE "foo.hs" #-}
-  -- and we want to make sure a Unicode filename isn't mangled.
-  header h str = do
-   hSetEncoding h utf8
-   hPutStr h str
-   hSetBinaryMode h True
+-- | Copy remaining bytes from the first Handle to the second one
+copyHandle :: Handle -> Handle -> IO ()
+copyHandle hin hout = do
+  let buf_size = 8192
+  allocaBytes buf_size $ \ptr -> do
+    let go = do
+          c <- hGetBuf hin ptr buf_size
+          hPutBuf hout ptr c
+          if c == 0 then return () else go
+    go
+
+-- | Copy file after printing the given header
+copyWithHeader :: String -> FilePath -> FilePath -> IO ()
+copyWithHeader header from to =
+  withBinaryFile to WriteMode $ \hout -> do
+    -- write the header string in UTF-8.  The header is something like
+    --   {-# LINE "foo.hs" #-}
+    -- and we want to make sure a Unicode filename isn't mangled.
+    hSetEncoding hout utf8
+    hPutStr hout header
+    withBinaryFile from ReadMode $ \hin ->
+      copyHandle hin hout