summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--aclocal.m43
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/main/Ar.hs258
-rw-r--r--compiler/main/DriverPipeline.hs37
-rw-r--r--compiler/main/DynFlags.hs16
-rw-r--r--compiler/main/FileCleanup.hs48
-rw-r--r--compiler/main/Packages.hs8
-rw-r--r--compiler/main/SysTools.hs49
-rw-r--r--settings.in1
9 files changed, 399 insertions, 22 deletions
diff --git a/aclocal.m4 b/aclocal.m4
index 8146e796c3..d053311d02 100644
--- a/aclocal.m4
+++ b/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)
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 247d2ee055..a961160e61 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -162,6 +162,7 @@ Library
vectorise
Exposed-Modules:
+ Ar
FileCleanup
DriverBkp
BkpSyn
diff --git a/compiler/main/Ar.hs b/compiler/main/Ar.hs
new file mode 100644
index 0000000000..d3b50f39dd
--- /dev/null
+++ b/compiler/main/Ar.hs
@@ -0,0 +1,258 @@
+{-# 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
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index bf39ee1cf1..a90de8153d 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d68299ad54..ec014e8ab1 100644
--- a/compiler/main/DynFlags.hs
+++ b/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"
diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs
index f4c30d6112..22a492aa04 100644
--- a/compiler/main/FileCleanup.hs
+++ b/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
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 088f58a675..ca77c30099 100644
--- a/compiler/main/Packages.hs
+++ b/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)
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 04f4107d9d..cb2840b6ff 100644
--- a/compiler/main/SysTools.hs
+++ b/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
- -> [String] -> Maybe [(String, String)]
+ -> [String] -> Maybe FilePath -> Maybe [(String, String)]
-> IO ExitCode
-builderMainLoop dflags filter_fn pgm real_args mb_env = do
+builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
chan <- newChan
-- We use a mask here rather than a bracket because we want
@@ -1162,7 +1183,7 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
let safely inner = mask $ \restore -> do
-- acquire
(hStdIn, hStdOut, hStdErr, hProcess) <- restore $
- runInteractiveProcess pgm real_args Nothing mb_env
+ runInteractiveProcess pgm real_args mb_cwd mb_env
let cleanup_handles = do
hClose hStdIn
hClose hStdOut
diff --git a/settings.in b/settings.in
index 6bf5156a03..30bfe7072b 100644
--- a/settings.in
+++ b/settings.in
@@ -14,6 +14,7 @@
("ar command", "@SettingsArCommand@"),
("ar flags", "@ArArgs@"),
("ar supports at file", "@ArSupportsAtFile@"),
+ ("ranlib command", "@SettingsRanlibCommand@"),
("touch command", "@SettingsTouchCommand@"),
("dllwrap command", "@SettingsDllWrapCommand@"),
("windres command", "@SettingsWindresCommand@"),