diff options
| -rw-r--r-- | aclocal.m4 | 3 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | compiler/main/Ar.hs | 258 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 37 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 16 | ||||
| -rw-r--r-- | compiler/main/FileCleanup.hs | 48 | ||||
| -rw-r--r-- | compiler/main/Packages.hs | 8 | ||||
| -rw-r--r-- | compiler/main/SysTools.hs | 49 | ||||
| -rw-r--r-- | settings.in | 1 |
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@"), |