Use ar for -staticlib

Hopefully we can get rid of libtool, by using ar only

Depends on:  D3579

Test Plan: validate

Reviewers: austin, hvr, bgamari, erikd

Reviewed By: bgamari

Subscribers: rwbarton, thomie, erikd

Differential Revision: https://phabricator.haskell.org/D3721

aclocal.m4

@@ -470,6 +470,7 @@ AC_DEFUN([FP_SETTINGS],
         SettingsHaskellCPPFlags="$HaskellCPPArgs"
         SettingsLdCommand="\$topdir/../${mingw_bin_prefix}ld.exe"
         SettingsArCommand="\$topdir/../${mingw_bin_prefix}ar.exe"
+        SettingsRanlibCommand="\$topdir/../${mingw_bin_prefix}ranlib.exe"
         SettingsPerlCommand='$topdir/../perl/perl.exe'
         SettingsDllWrapCommand="\$topdir/../${mingw_bin_prefix}dllwrap.exe"
         SettingsWindresCommand="\$topdir/../${mingw_bin_prefix}windres.exe"
@@ -492,6 +493,7 @@ AC_DEFUN([FP_SETTINGS],
         SettingsHaskellCPPFlags="$HaskellCPPArgs"
         SettingsLdCommand="$LdCmd"
         SettingsArCommand="$ArCmd"
+        SettingsRanlibCommand="$RanlibCmd"
         SettingsPerlCommand="$PerlCmd"
         if test -z "$DllWrapCmd"
         then
@@ -544,6 +546,7 @@ AC_DEFUN([FP_SETTINGS],
     AC_SUBST(SettingsLdCommand)
     AC_SUBST(SettingsLdFlags)
     AC_SUBST(SettingsArCommand)
+    AC_SUBST(SettingsRanlibCommand)
     AC_SUBST(SettingsPerlCommand)
     AC_SUBST(SettingsDllWrapCommand)
     AC_SUBST(SettingsWindresCommand)

compiler/ghc.cabal.in

@@ -162,6 +162,7 @@ Library
         vectorise
 
     Exposed-Modules:
+        Ar
         FileCleanup
         DriverBkp
         BkpSyn

compiler/main/Ar.hs

+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}
+{- Note: [The need for Ar.hs]
+Building `-staticlib` required the presence of libtool, and was a such
+restricted to mach-o only. As libtool on macOS and gnu libtool are very
+different, there was no simple portable way to support this.
+
+libtool for static archives does essentially: concatinate the input archives,
+add the input objects, and create a symbol index. Using `ar` for this task
+fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same
+features across platforms (e.g. index prefixed retrieval of objects with
+the same name.)
+
+As Archives are rather simple structurally, we can just build the archives
+with Haskell directly and use ranlib on the final result to get the symbol
+index. This should allow us to work around with the differences/abailability
+of libtool across differet platforms.
+-}
+module Ar
+  (ArchiveEntry(..)
+  ,Archive(..)
+  ,afilter
+
+  ,parseAr
+
+  ,loadAr
+  ,loadObj
+  ,writeBSDAr
+  ,writeGNUAr
+
+  ,isBSDSymdef
+  ,isGNUSymdef
+  )
+   where
+
+import Data.Semigroup (Semigroup)
+import Data.List (mapAccumL, isPrefixOf)
+import Data.Monoid ((<>))
+import Data.Binary.Get
+import Data.Binary.Put
+import Control.Monad
+import Control.Applicative
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as L
+#if !defined(mingw32_HOST_OS)
+import qualified System.Posix.Files as POSIX
+#endif
+import System.FilePath (takeFileName)
+
+data ArchiveEntry = ArchiveEntry
+    { filename :: String       -- ^ File name.
+    , filetime :: Int          -- ^ File modification time.
+    , fileown  :: Int          -- ^ File owner.
+    , filegrp  :: Int          -- ^ File group.
+    , filemode :: Int          -- ^ File mode.
+    , filesize :: Int          -- ^ File size.
+    , filedata :: B.ByteString -- ^ File bytes.
+    } deriving (Eq, Show)
+
+newtype Archive = Archive [ArchiveEntry]
+        deriving (Eq, Show, Semigroup, Monoid)
+
+afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
+afilter f (Archive xs) = Archive (filter f xs)
+
+isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
+isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)
+isGNUSymdef a = "/" == (filename a)
+
+-- | Archives have numeric values padded with '\x20' to the right.
+getPaddedInt :: B.ByteString -> Int
+getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')
+
+putPaddedInt :: Int -> Int -> Put
+putPaddedInt padding i = putPaddedString '\x20' padding (show i)
+
+putPaddedString :: Char -> Int -> String -> Put
+putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)
+
+getBSDArchEntries :: Get [ArchiveEntry]
+getBSDArchEntries = do
+    empty <- isEmpty
+    if empty then
+        return []
+     else do
+        name    <- getByteString 16
+        when ('/' `C.elem` name && C.take 3 name /= "#1/") $
+          fail "Looks like GNU Archive"
+        time    <- getPaddedInt <$> getByteString 12
+        own     <- getPaddedInt <$> getByteString 6
+        grp     <- getPaddedInt <$> getByteString 6
+        mode    <- getPaddedInt <$> getByteString 8
+        st_size <- getPaddedInt <$> getByteString 10
+        end     <- getByteString 2
+        when (end /= "\x60\x0a") $
+          fail "Invalid archive header end marker"
+        off1    <- liftM fromIntegral bytesRead :: Get Int
+        -- BSD stores extended filenames, by writing #1/<length> into the
+        -- name field, the first @length@ bytes then represent the file name
+        -- thus the payload size is filesize + file name length.
+        name    <- if C.unpack (C.take 3 name) == "#1/" then
+                        liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)
+                    else
+                        return $ C.unpack $ C.takeWhile (/= ' ') name
+        off2    <- liftM fromIntegral bytesRead :: Get Int
+        file    <- getByteString (st_size - (off2 - off1))
+        rest    <- getBSDArchEntries
+        return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest
+
+-- | GNU Archives feature a special '//' entry that contains the
+-- extended names. Those are referred to as /<num>, where num is the
+-- offset into the '//' entry.
+-- In addition, filenames are terminated with '/' in the archive.
+getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
+getGNUArchEntries extInfo = do
+  empty <- isEmpty
+  if empty
+    then return []
+    else
+    do
+      name    <- getByteString 16
+      time    <- getPaddedInt <$> getByteString 12
+      own     <- getPaddedInt <$> getByteString 6
+      grp     <- getPaddedInt <$> getByteString 6
+      mode    <- getPaddedInt <$> getByteString 8
+      st_size <- getPaddedInt <$> getByteString 10
+      end     <- getByteString 2
+      when (end /= "\x60\x0a") $
+        fail "Invalid archive header end marker"
+      file <- getByteString st_size
+      name <- return . C.unpack $
+        if C.unpack (C.take 1 name) == "/"
+        then case C.takeWhile (/= ' ') name of
+               name@"/"  -> name               -- symbol table
+               name@"//" -> name               -- extendedn file names table
+               name      -> getExtName extInfo (read . C.unpack $ C.drop 1 name)
+        else C.takeWhile (/= '/') name
+      case name of
+        "/"  -> getGNUArchEntries extInfo
+        "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))
+        _    -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo
+
+  where
+   getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
+   getExtName Nothing _ = error "Invalid extended filename reference."
+   getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info
+
+-- | put an Archive Entry. This assumes that the entries
+-- have been preprocessed to account for the extenden file name
+-- table section "//" e.g. for GNU Archives. Or that the names
+-- have been move into the payload for BSD Archives.
+putArchEntry :: ArchiveEntry -> PutM ()
+putArchEntry (ArchiveEntry name time own grp mode st_size file) = do
+  putPaddedString ' '  16 name
+  putPaddedInt         12 time
+  putPaddedInt          6 own
+  putPaddedInt          6 grp
+  putPaddedInt          8 mode
+  putPaddedInt         10 (st_size + pad)
+  putByteString           "\x60\x0a"
+  putByteString           file
+  when (pad == 1) $
+    putWord8              0x0a
+  where
+    pad         = st_size `mod` 2
+
+getArchMagic :: Get ()
+getArchMagic = do
+  magic <- liftM C.unpack $ getByteString 8
+  if magic /= "!<arch>\n"
+    then fail $ "Invalid magic number " ++ show magic
+    else return ()
+
+putArchMagic :: Put
+putArchMagic = putByteString $ C.pack "!<arch>\n"
+
+getArch :: Get Archive
+getArch = Archive <$> do
+  getArchMagic
+  getBSDArchEntries <|> getGNUArchEntries Nothing
+
+putBSDArch :: Archive -> PutM ()
+putBSDArch (Archive as) = do
+  putArchMagic
+  mapM_ putArchEntry (processEntries as)
+
+  where
+    padStr pad size str = take size $ str <> repeat pad
+    nameSize name = case length name `divMod` 4 of
+      (n, 0) -> 4 * n
+      (n, _) -> 4 * (n + 1)
+    needExt name = length name > 16 || ' ' `elem` name
+    processEntry :: ArchiveEntry -> ArchiveEntry
+    processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)
+      | needExt name = archive { filename = "#1/" <> show sz
+                               , filedata = C.pack (padStr '\0' sz name) <> filedata archive
+                               , filesize = st_size + sz }
+      | otherwise    = archive
+
+      where sz = nameSize name
+
+    processEntries = map processEntry
+
+putGNUArch :: Archive -> PutM ()
+putGNUArch (Archive as) = do
+  putArchMagic
+  mapM_ putArchEntry (processEntries as)
+
+  where
+    processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
+    processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)
+      | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2
+                                    ,  filedata = filedata extInfo <>  C.pack name <> "/\n" }
+                           , archive { filename = "/" <> show (filesize extInfo) } )
+      | otherwise        = ( extInfo, archive { filename = name <> "/" } )
+
+    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
+    processEntries =
+      uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)
+
+parseAr :: B.ByteString -> Archive
+parseAr = runGet getArch . L.fromChunks . pure
+
+writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
+writeBSDAr fp = L.writeFile fp . runPut . putBSDArch
+writeGNUAr fp = L.writeFile fp . runPut . putGNUArch
+
+loadAr :: FilePath -> IO Archive
+loadAr fp = parseAr <$> B.readFile fp
+
+loadObj :: FilePath -> IO ArchiveEntry
+loadObj fp = do
+  payload <- B.readFile fp
+  (modt, own, grp, mode) <- fileInfo fp
+  return $ ArchiveEntry
+    (takeFileName fp) modt own grp mode
+    (B.length payload) payload
+
+-- | Take a filePath and return (mod time, own, grp, mode in decimal)
+fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)
+#if defined(mingw32_HOST_OS)
+-- on windows mod time, owner group and mode are zero.
+fileInfo _ = pure (0,0,0,0)
+#else
+fileInfo fp = go <$> POSIX.getFileStatus fp
+  where go status = ( fromEnum $ POSIX.modificationTime status
+                    , fromIntegral $ POSIX.fileOwner status
+                    , fromIntegral $ POSIX.fileGroup status
+                    , oct2dec . fromIntegral $ POSIX.fileMode status
+                    )
+
+oct2dec :: Int -> Int
+oct2dec = foldl (\a b -> a * 10 + b) 0 . reverse . dec 8
+  where dec _ 0 = []
+        dec b i = let (rest, last) = i `quotRem` b
+                  in last:dec b rest
+
+#endif

compiler/main/DriverPipeline.hs

@@ -63,6 +63,7 @@ import TcRnTypes
 import Hooks
 import qualified GHC.LanguageExtensions as LangExt
 import FileCleanup
+import Ar
 
 import Exception
 import System.Directory
@@ -423,7 +424,7 @@ link' dflags batch_attempt_linking hpt
         -- Don't showPass in Batch mode; doLink will do that for us.
         let link = case ghcLink dflags of
                 LinkBinary    -> linkBinary
-                LinkStaticLib -> linkStaticLibCheck
+                LinkStaticLib -> linkStaticLib
                 LinkDynLib    -> linkDynLibCheck
                 other         -> panicBadLink other
         link dflags obj_files pkg_deps
@@ -574,7 +575,7 @@ doLink dflags stop_phase o_files
   = case ghcLink dflags of
         NoLink        -> return ()
         LinkBinary    -> linkBinary         dflags o_files []
-        LinkStaticLib -> linkStaticLibCheck dflags o_files []
+        LinkStaticLib -> linkStaticLib      dflags o_files []
         LinkDynLib    -> linkDynLibCheck    dflags o_files []
         other         -> panicBadLink other
 
@@ -2129,9 +2130,35 @@ linkDynLibCheck dflags o_files dep_packages
 
     linkDynLib dflags o_files dep_packages
 
-linkStaticLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
-linkStaticLibCheck dflags o_files dep_packages
- = linkBinary' True dflags o_files dep_packages
+-- | Linking a static lib will not really link anything. It will merely produce
+-- a static archive of all dependent static libraries. The resulting library
+-- will still need to be linked with any remaining link flags.
+linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
+linkStaticLib dflags o_files dep_packages = do
+  let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
+      modules = o_files ++ extra_ld_inputs
+      output_fn = exeFileName True dflags
+
+  full_output_fn <- if isAbsolute output_fn
+                    then return output_fn
+                    else do d <- getCurrentDirectory
+                            return $ normalise (d </> output_fn)
+  output_exists <- doesFileExist full_output_fn
+  (when output_exists) $ removeFile full_output_fn
+
+  pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages
+  archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs
+
+  ar <- foldl mappend
+        <$> (Archive <$> mapM loadObj modules)
+        <*> mapM loadAr archives
+
+  if sLdIsGnuLd (settings dflags)
+    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
+    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
+
+  -- run ranlib over the archive. write*Ar does *not* create the symbol index.
+  runRanlib dflags [SysTools.FileOption "" output_fn]
 
 -- -----------------------------------------------------------------------------
 -- Running CPP

compiler/main/DynFlags.hs

@@ -86,11 +86,10 @@ module DynFlags (
         versionedAppDir,
         extraGccViaCFlags, systemPackageConfig,
         pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
-        pgm_windres, pgm_libtool, pgm_lo, pgm_lc, pgm_lcc, pgm_i,
-        opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,
+        pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc,
+        pgm_lcc, pgm_i, opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,
         opt_windres, opt_lo, opt_lc, opt_lcc,
 
-
         -- ** Manipulating DynFlags
         defaultDynFlags,                -- Settings -> DynFlags
         defaultWays,
@@ -1039,6 +1038,8 @@ data Settings = Settings {
   sPgm_T                 :: String,
   sPgm_windres           :: String,
   sPgm_libtool           :: String,
+  sPgm_ar                :: String,
+  sPgm_ranlib            :: String,
   sPgm_lo                :: (String,[Option]), -- LLVM: opt llvm optimiser
   sPgm_lc                :: (String,[Option]), -- LLVM: llc static compiler
   sPgm_lcc               :: (String,[Option]), -- LLVM: c compiler
@@ -1103,6 +1104,10 @@ pgm_libtool           :: DynFlags -> String
 pgm_libtool dflags = sPgm_libtool (settings dflags)
 pgm_lcc               :: DynFlags -> (String,[Option])
 pgm_lcc dflags = sPgm_lcc (settings dflags)
+pgm_ar                :: DynFlags -> String
+pgm_ar dflags = sPgm_ar (settings dflags)
+pgm_ranlib            :: DynFlags -> String
+pgm_ranlib dflags = sPgm_ranlib (settings dflags)
 pgm_lo                :: DynFlags -> (String,[Option])
 pgm_lo dflags = sPgm_lo (settings dflags)
 pgm_lc                :: DynFlags -> (String,[Option])
@@ -2693,6 +2698,11 @@ dynamic_flags_deps = [
       (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f})))
   , make_ord_flag defFlag "pgmlibtool"
       (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f})))
+  , make_ord_flag defFlag "pgmar"
+      (hasArg (\f -> alterSettings (\s -> s { sPgm_ar = f})))
+  , make_ord_flag defFlag "pgmranlib"
+      (hasArg (\f -> alterSettings (\s -> s { sPgm_ranlib = f})))
+
 
     -- need to appear before -optl/-opta to be parsed as LLVM flags.
   , make_ord_flag defFlag "optlo"

compiler/main/FileCleanup.hs

@@ -4,6 +4,7 @@ module FileCleanup
   , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles
   , addFilesToClean, changeTempFilesLifetime
   , newTempName, newTempLibName
+  , withSystemTempDirectory, withTempDirectory
   ) where
 
 import DynFlags
@@ -247,3 +248,50 @@ foreign import ccall unsafe "_getpid" getProcessID :: IO Int
 getProcessID :: IO Int
 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 #endif
+
+-- The following three functions are from the `temporary` package.
+
+-- | Create and use a temporary directory in the system standard temporary
+-- directory.
+--
+-- Behaves exactly the same as 'withTempDirectory', except that the parent
+-- temporary directory will be that returned by 'getTemporaryDirectory'.
+withSystemTempDirectory :: String   -- ^ Directory name template. See 'openTempFile'.
+                        -> (FilePath -> IO a) -- ^ Callback that can use the directory
+                        -> IO a
+withSystemTempDirectory template action =
+  getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action
+
+
+-- | Create and use a temporary directory.
+--
+-- Creates a new temporary directory inside the given directory, making use
+-- of the template. The temp directory is deleted after use. For example:
+--
+-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...
+--
+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
+-- @src/sdist.342@.
+withTempDirectory :: FilePath -- ^ Temp directory to create the directory in
+                  -> String   -- ^ Directory name template. See 'openTempFile'.
+                  -> (FilePath -> IO a) -- ^ Callback that can use the directory
+                  -> IO a
+withTempDirectory targetDir template =
+  Exception.bracket
+    (createTempDirectory targetDir template)
+    (ignoringIOErrors . removeDirectoryRecursive)
+
+ignoringIOErrors :: IO () -> IO ()
+ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError))
+
+
+createTempDirectory :: FilePath -> String -> IO FilePath
+createTempDirectory dir template = do
+  pid <- getProcessID
+  findTempName pid
+  where findTempName x = do
+            let path = dir </> template ++ show x
+            createDirectory path
+            return path
+          `catchIO` \e -> if isAlreadyExistsError e
+                          then findTempName (x+1) else ioError e

compiler/main/Packages.hs

@@ -46,6 +46,7 @@ module Packages (
         getPackageConfigMap,
         getPreloadPackagesAnd,
 
+        collectArchives,
         collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
         packageHsLibs,
 
@@ -1688,6 +1689,13 @@ collectLinkOpts dflags ps =
         concatMap (map ("-l" ++) . extraLibraries) ps,
         concatMap ldOptions ps
     )
+collectArchives :: DynFlags -> PackageConfig -> IO [FilePath]
+collectArchives dflags pc =
+  filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")
+                        | searchPath <- searchPaths
+                        , lib <- libs ]
+  where searchPaths = nub . filter notNull . libraryDirsForWay dflags $ pc
+        libs        = packageHsLibs dflags pc ++ extraLibraries pc
 
 packageHsLibs :: DynFlags -> PackageConfig -> [String]
 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)

compiler/main/SysTools.hs

@@ -20,6 +20,7 @@ module SysTools (
         runPp,                   -- [Option] -> IO ()
         runSplit,                -- [Option] -> IO ()
         runAs, runLink, runLibtool, -- [Option] -> IO ()
+        runAr, askAr, runRanlib,
         runMkDLL,
         runWindres,
         runLlvmOpt,
@@ -292,6 +293,8 @@ initSysTools mbMinusB
 
        windres_path <- getSetting "windres command"
        libtool_path <- getSetting "libtool command"
+       ar_path <- getSetting "ar command"
+       ranlib_path <- getSetting "ranlib command"
 
        tmpdir <- getTemporaryDirectory
 
@@ -366,6 +369,8 @@ initSysTools mbMinusB
                     sPgm_T   = touch_path,
                     sPgm_windres = windres_path,
                     sPgm_libtool = libtool_path,
+                    sPgm_ar = ar_path,
+                    sPgm_ranlib = ranlib_path,
                     sPgm_lo  = (lo_prog,[]),
                     sPgm_lc  = (lc_prog,[]),
                     sPgm_lcc = (lcc_prog,[]),
@@ -419,7 +424,7 @@ runCpp dflags args =   do
                 ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
   mb_env <- getGccEnv args2
   runSomethingFiltered dflags id  "C pre-processor" p
-                       (args0 ++ args1 ++ args2 ++ args) mb_env
+                       (args0 ++ args1 ++ args2 ++ args) Nothing mb_env
 
 runPp :: DynFlags -> [Option] -> IO ()
 runPp dflags args =   do
@@ -571,7 +576,7 @@ runAs dflags args = do
       args1 = map Option (getOpts dflags opt_a)
       args2 = args0 ++ args1 ++ args
   mb_env <- getGccEnv args2
-  runSomethingFiltered dflags id "Assembler" p args2 mb_env
+  runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env
 
 -- | Run the LLVM Optimiser
 runLlvmOpt :: DynFlags -> [Option] -> IO ()
@@ -600,7 +605,7 @@ runClang dflags args = do
       args2 = args0 ++ args1 ++ args
   mb_env <- getGccEnv args2
   Exception.catch (do
-        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
+        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env
     )
     (\(err :: SomeException) -> do
         errorMsg dflags $
@@ -982,14 +987,30 @@ runLibtool dflags args = do
       args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
       libtool    = pgm_libtool dflags
   mb_env <- getGccEnv args2
-  runSomethingFiltered dflags id "Linker" libtool args2 mb_env
+  runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env
+
+runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()
+runAr dflags cwd args = do
+  let ar = pgm_ar dflags
+  runSomethingFiltered dflags id "Ar" ar args cwd Nothing
+
+askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String
+askAr dflags mb_cwd args = do
+  let ar = pgm_ar dflags
+  runSomethingWith dflags "Ar" ar args $ \real_args ->
+    readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }
+
+runRanlib :: DynFlags -> [Option] -> IO ()
+runRanlib dflags args = do
+  let ranlib = pgm_ranlib dflags
+  runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing
 
 runMkDLL :: DynFlags -> [Option] -> IO ()
 runMkDLL dflags args = do
   let (p,args0) = pgm_dll dflags
       args1 = args0 ++ args
   mb_env <- getGccEnv (args0++args)
-  runSomethingFiltered dflags id "Make DLL" p args1 mb_env
+  runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env
 
 runWindres :: DynFlags -> [Option] -> IO ()
 runWindres dflags args = do
@@ -1012,7 +1033,7 @@ runWindres dflags args = do
             : Option "--use-temp-file"
             : args
   mb_env <- getGccEnv gcc_args
-  runSomethingFiltered dflags id "Windres" windres args' mb_env
+  runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env
 
 touch :: DynFlags -> String -> String -> IO ()
 touch dflags purpose arg =
@@ -1054,7 +1075,7 @@ runSomething :: DynFlags
              -> IO ()
 
 runSomething dflags phase_name pgm args =
-  runSomethingFiltered dflags id phase_name pgm args Nothing
+  runSomethingFiltered dflags id phase_name pgm args Nothing Nothing
 
 -- | Run a command, placing the arguments in an external response file.
 --
@@ -1073,7 +1094,7 @@ runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
     runSomethingWith dflags phase_name pgm args $ \real_args -> do
         fp <- getResponseFile real_args
         let args = ['@':fp]
-        r <- builderMainLoop dflags filter_fn pgm args mb_env
+        r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env
         return (r,())
   where
     getResponseFile args = do
@@ -1114,11 +1135,11 @@ runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
 
 runSomethingFiltered
   :: DynFlags -> (String->String) -> String -> String -> [Option]
-  -> Maybe [(String,String)] -> IO ()
+  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()
 
-runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
+runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do
     runSomethingWith dflags phase_name pgm args $ \real_args -> do
-        r <- builderMainLoop dflags filter_fn pgm real_args mb_env
+        r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env
         return (r,())
 
 runSomethingWith
@@ -1150,9 +1171,9 @@ handleProc pgm phase_name proc = do
 
 
 builderMainLoop :: DynFlags -> (String -> String) -> FilePath