Commit 91262e75 authored by Moritz Angermann's avatar Moritz Angermann Committed by Ben Gamari

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
parent f8e383f0
......@@ -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)
......
......@@ -162,6 +162,7 @@ Library
vectorise
Exposed-Modules:
Ar
FileCleanup
DriverBkp
BkpSyn
......
{-# 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
......@@ -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
......
......@@ -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"
......
......@@ -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
......@@ -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)
......
......@@ -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
......
......@@ -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@"),
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment