Commit 80370b42 authored by tibbe's avatar tibbe
Browse files

Avoid relinking if nothing changed

parents 4b779075 bc0e2a4c
......@@ -2,6 +2,7 @@
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.CopyFile (
copyFile,
filesEqual,
copyOrdinaryFile,
copyExecutableFile,
setFileOrdinary,
......@@ -10,10 +11,13 @@ module Distribution.Compat.CopyFile (
) where
import Control.Applicative
( (<$>), (<*>) )
import Control.Monad
( when )
import Control.Exception
( bracket, bracketOnError, throwIO )
( bracket, bracketOnError, evaluate, throwIO )
import qualified Data.ByteString.Lazy as BSL
import Distribution.Compat.Exception
( catchIO )
import System.IO.Error
......@@ -25,7 +29,8 @@ import Distribution.Compat.TempFile
import System.FilePath
( takeDirectory )
import System.IO
( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )
( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf
, withBinaryFile )
import Foreign
( allocaBytes )
......@@ -79,3 +84,11 @@ copyFile fromFPath toFPath =
when (count > 0) $ do
hPutBuf hTo buffer count
copyContents hFrom hTo buffer
-- | Checks if two files are byte-identical.
-- Returns False if either of the files do not exist.
filesEqual :: FilePath -> FilePath -> IO Bool
filesEqual f1 f2 = (`catchIO` \ _ -> return False) $ do
withBinaryFile f1 ReadMode $ \ h1 -> do
withBinaryFile f2 ReadMode $ \ h2 -> do
evaluate =<< (==) <$> BSL.hGetContents h1 <*> BSL.hGetContents h2
......@@ -105,7 +105,7 @@ import Distribution.Simple.Program
, requireProgramVersion, requireProgram
, userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
, ghcProgram, ghcPkgProgram, hsc2hsProgram
, arProgram, ranlibProgram, ldProgram
, arProgram, ldProgram
, gccProgram, stripProgram )
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Ar as Ar
......@@ -136,8 +136,7 @@ import qualified Data.Map as M ( Map, fromList, lookup )
import Data.Maybe ( catMaybes, fromMaybe, maybeToList )
import Data.Monoid ( Monoid(..) )
import System.Directory
( removeFile, getDirectoryContents, doesFileExist
, getTemporaryDirectory )
( getDirectoryContents, doesFileExist, getTemporaryDirectory )
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension,
splitExtension )
......@@ -861,11 +860,6 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
else return []
unless (null hObjs && null cObjs && null stubObjs) $ do
-- first remove library files if they exists
unless forRepl $ sequence_
[ removeFile libFilePath `catchIO` \_ -> return ()
| libFilePath <- [vanillaLibFilePath, profileLibFilePath
,sharedLibFilePath, ghciLibFilePath] ]
let staticObjectFiles =
hObjs
......@@ -1310,12 +1304,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
whenGHCi $ mapM_ (copy builtDir targetDir) ghciLibNames
whenShared $ mapM_ (copyShared builtDir dynlibTargetDir) sharedLibNames
-- run ranlib if necessary:
whenVanilla $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))
vanillaLibNames
whenProf $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))
profileLibNames
where
cid = compilerId (compiler lbi)
libNames = componentLibraries clbi
......@@ -1331,18 +1319,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
whenGHCi = when (hasLib && withGHCiLib lbi)
whenShared = when (hasLib && withSharedLib lbi)
-- | On MacOS X we have to call @ranlib@ to regenerate the archive index after
-- copying. This is because the silly MacOS X linker checks that the archive
-- index is not older than the file itself, which means simply
-- copying/installing the file breaks it!!
--
updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()
updateLibArchive verbosity lbi path
| buildOS == OSX = do
(ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi)
rawSystemProgram verbosity ranlib [path]
| otherwise = return ()
-- -----------------------------------------------------------------------------
-- Registering
......
......@@ -96,7 +96,7 @@ import Distribution.Simple.Program
, rawSystemProgramStdout, rawSystemProgramStdoutConf
, requireProgramVersion
, userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
, arProgram, ranlibProgram, ldProgram
, arProgram, ldProgram
, gccProgram, stripProgram
, lhcProgram, lhcPkgProgram )
import qualified Distribution.Simple.Program.HcPkg as HcPkg
......@@ -783,12 +783,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
ifGHCi $ mapM_ (copy builtDir targetDir) ghciLibNames
ifShared $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames
-- run ranlib if necessary:
ifVanilla $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))
vanillaLibNames
ifProf $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))
profileLibNames
where
cid = compilerId (compiler lbi)
libNames = componentLibraries clbi
......@@ -806,20 +800,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)
-- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems
-- like MacOS X. If we can't find those, don't worry too much about it.
--
updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()
updateLibArchive verbosity lbi path =
case lookupProgram ranlibProgram (withPrograms lbi) of
Just ranlib -> rawSystemProgram verbosity ranlib [path]
Nothing -> case lookupProgram arProgram (withPrograms lbi) of
Just ar -> rawSystemProgram verbosity ar ["-s", path]
Nothing -> warn verbosity $
"Unable to generate a symbol index for the static "
++ "library '" ++ path
++ "' (missing the 'ranlib' and 'ar' programs)"
-- -----------------------------------------------------------------------------
-- Registering
......
......@@ -100,7 +100,6 @@ module Distribution.Simple.Program (
, ffihugsProgram
, uhcProgram
, gccProgram
, ranlibProgram
, arProgram
, stripProgram
, happyProgram
......
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Program.Ar
......@@ -13,21 +15,37 @@ module Distribution.Simple.Program.Ar (
multiStageProgramInvocation,
) where
import Control.Monad (unless)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Char (isSpace)
import Distribution.Compat.CopyFile (filesEqual)
import Distribution.Simple.Program.Types
( ConfiguredProgram(..) )
import Distribution.Simple.Program.Run
( programInvocation, multiStageProgramInvocation
, runProgramInvocation )
import Distribution.Simple.Utils
( dieWithLocation, withTempDirectory )
import Distribution.System
( OS(..), buildOS )
import Distribution.Verbosity
( Verbosity, deafening, verbose )
import System.Directory (doesFileExist, renameFile)
import System.FilePath ((</>), splitFileName)
import System.IO
( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek)
, hFileSize, hSeek, withBinaryFile )
-- | Call @ar@ to create a library archive from a bunch of object files.
--
createArLibArchive :: Verbosity -> ConfiguredProgram
-> FilePath -> [FilePath] -> IO ()
createArLibArchive verbosity ar target files =
createArLibArchive verbosity ar targetPath files = do
let (targetDir, targetName) = splitFileName targetPath
withTempDirectory verbosity targetDir targetName $ \ tmpDir -> do
let tmpPath = tmpDir </> targetName
-- The args to use with "ar" are actually rather subtle and system-dependent.
-- In particular we have the following issues:
......@@ -52,19 +70,90 @@ createArLibArchive verbosity ar target files =
OSX -> ["-q", "-s"]
_ -> ["-q"]
extraArgs = verbosityOpts verbosity ++ [target]
extraArgs = verbosityOpts verbosity ++ [tmpPath]
simple = programInvocation ar (simpleArgs ++ extraArgs)
initial = programInvocation ar (initialArgs ++ extraArgs)
middle = initial
final = programInvocation ar (finalArgs ++ extraArgs)
in sequence_
sequence_
[ runProgramInvocation verbosity inv
| inv <- multiStageProgramInvocation
simple (initial, middle, final) files ]
wipeMetadata tmpPath
equal <- filesEqual tmpPath targetPath
unless equal $ renameFile tmpPath targetPath
where
verbosityOpts v | v >= deafening = ["-v"]
| v >= verbose = []
| otherwise = ["-c"]
-- | @ar@ by default includes various metadata for each object file in their
-- respective headers, so the output can differ for the same inputs, making
-- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode
-- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644
-- for the file mode. However detecting whether @-D@ is supported seems
-- rather harder than just re-implementing this feature.
wipeMetadata :: FilePath -> IO ()
wipeMetadata path = do
-- Check for existence first (ReadWriteMode would create one otherwise)
exists <- doesFileExist path
unless exists $ wipeError "Temporary file disappeared"
withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h
where
wipeError msg = dieWithLocation path Nothing $
"Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg
archLF = "!<arch>\x0a" -- global magic, 8 bytes
x60LF = "\x60\x0a" -- header magic, 2 bytes
metadata = BS.concat
[ "0 " -- mtime, 12 bytes
, "0 " -- UID, 6 bytes
, "0 " -- GID, 6 bytes
, "0644 " -- mode, 8 bytes
]
headerSize = 60
-- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
wipeArchive :: Handle -> Integer -> IO ()
wipeArchive h archiveSize = do
global <- BS.hGet h (BS.length archLF)
unless (global == archLF) $ wipeError "Bad global header"
wipeHeader (toInteger $ BS.length archLF)
where
wipeHeader :: Integer -> IO ()
wipeHeader offset = case compare offset archiveSize of
EQ -> return ()
GT -> wipeError (atOffset "Archive truncated")
LT -> do
header <- BS.hGet h headerSize
unless (BS.length header == headerSize) $
wipeError (atOffset "Short header")
let magic = BS.drop 58 header
unless (magic == x60LF) . wipeError . atOffset $
"Bad magic " ++ show magic ++ " in header"
let name = BS.take 16 header
let size = BS.take 10 $ BS.drop 48 header
objSize <- case reads (BS8.unpack size) of
[(n, s)] | all isSpace s -> return n
_ -> wipeError (atOffset "Bad file size in header")
let replacement = BS.concat [ name, metadata, size, magic ]
unless (BS.length replacement == headerSize) $
wipeError (atOffset "Something has gone terribly wrong")
hSeek h AbsoluteSeek offset
BS.hPut h replacement
let nextHeader = offset + toInteger headerSize +
-- Odd objects are padded with an extra '\x0a'
if odd objSize then objSize + 1 else objSize
hSeek h AbsoluteSeek nextHeader
wipeHeader nextHeader
where
atOffset msg = msg ++ " at offset " ++ show offset
......@@ -29,7 +29,6 @@ module Distribution.Simple.Program.Builtin (
haskellSuitePkgProgram,
uhcProgram,
gccProgram,
ranlibProgram,
arProgram,
stripProgram,
happyProgram,
......@@ -88,7 +87,6 @@ builtinPrograms =
, greencardProgram
-- platform toolchain
, gccProgram
, ranlibProgram
, arProgram
, stripProgram
, ldProgram
......@@ -237,9 +235,6 @@ gccProgram = (simpleProgram "gcc") {
programFindVersion = findProgramVersion "-dumpversion" id
}
ranlibProgram :: Program
ranlibProgram = simpleProgram "ranlib"
arProgram :: Program
arProgram = simpleProgram "ar"
......
......@@ -42,6 +42,7 @@ import PackageTests.PathsModule.Library.Check
import PackageTests.PreProcess.Check
import PackageTests.TemplateHaskell.Check
import PackageTests.CMain.Check
import PackageTests.DeterministicAr.Check
import PackageTests.EmptyLib.Check
import PackageTests.TestOptions.Check
import PackageTests.TestStanza.Check
......@@ -86,6 +87,8 @@ tests version inplaceSpec ghcPath ghcPkgPath =
, hunit "PathsModule/Executable"
(PackageTests.PathsModule.Executable.Check.suite ghcPath)
, hunit "PathsModule/Library" (PackageTests.PathsModule.Library.Check.suite ghcPath)
, hunit "DeterministicAr"
(PackageTests.DeterministicAr.Check.suite ghcPath ghcPkgPath)
, hunit "EmptyLib/emptyLib"
(PackageTests.EmptyLib.Check.emptyLib ghcPath)
, hunit "BuildTestSuiteDetailedV09"
......
{-# LANGUAGE OverloadedStrings #-}
module PackageTests.DeterministicAr.Check where
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Char (isSpace)
import Data.List
import Data.Traversable
import PackageTests.PackageTester
import System.Exit
import System.FilePath
import System.IO
import Test.HUnit (Assertion, Test (TestCase), assertFailure)
-- Perhaps these should live in PackageTester.
-- For a polymorphic @IO a@ rather than @Assertion = IO ()@.
assertFailure' :: String -> IO a
assertFailure' msg = assertFailure msg >> return {-unpossible!-}undefined
ghcPkg_field :: String -> String -> FilePath -> IO [FilePath]
ghcPkg_field libraryName fieldName ghcPkgPath = do
(cmd, exitCode, raw) <- run Nothing ghcPkgPath
["--user", "field", libraryName, fieldName]
let output = filter ('\r' /=) raw -- Windows
-- copypasta of PackageTester.requireSuccess
unless (exitCode == ExitSuccess) . assertFailure $
"Command " ++ cmd ++ " failed.\n" ++ "output: " ++ output
let prefix = fieldName ++ ": "
case traverse (stripPrefix prefix) (lines output) of
Nothing -> assertFailure' $ "Command " ++ cmd ++ " failed: expected "
++ show prefix ++ " prefix on every line.\noutput: " ++ output
Just fields -> return fields
ghcPkg_field1 :: String -> String -> FilePath -> IO FilePath
ghcPkg_field1 libraryName fieldName ghcPkgPath = do
fields <- ghcPkg_field libraryName fieldName ghcPkgPath
case fields of
[field] -> return field
_ -> assertFailure' $ "Command ghc-pkg field failed: "
++ "output not a single line.\noutput: " ++ show fields
------------------------------------------------------------------------
this :: String
this = "DeterministicAr"
suite :: FilePath -> FilePath -> Test
suite ghcPath ghcPkgPath = TestCase $ do
let dir = "PackageTests" </> this
let spec = PackageSpec dir []
unregister this ghcPkgPath
iResult <- cabal_install spec ghcPath
assertInstallSucceeded iResult
let distBuild = dir </> "dist" </> "build"
libdir <- ghcPkg_field1 this "library-dirs" ghcPkgPath
mapM_ checkMetadata [distBuild, libdir]
unregister this ghcPkgPath
-- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata
checkMetadata :: FilePath -> Assertion
checkMetadata dir = withBinaryFile path ReadMode $ \ h -> do
hFileSize h >>= checkArchive h
where
path = dir </> "libHS" ++ this ++ "-0.a"
checkError msg = assertFailure' $
"PackageTests.DeterministicAr.checkMetadata: " ++ msg ++
" in " ++ path
archLF = "!<arch>\x0a" -- global magic, 8 bytes
x60LF = "\x60\x0a" -- header magic, 2 bytes
metadata = BS.concat
[ "0 " -- mtime, 12 bytes
, "0 " -- UID, 6 bytes
, "0 " -- GID, 6 bytes
, "0644 " -- mode, 8 bytes
]
headerSize = 60
-- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
checkArchive :: Handle -> Integer -> IO ()
checkArchive h archiveSize = do
global <- BS.hGet h (BS.length archLF)
unless (global == archLF) $ checkError "Bad global header"
checkHeader (toInteger $ BS.length archLF)
where
checkHeader :: Integer -> IO ()
checkHeader offset = case compare offset archiveSize of
EQ -> return ()
GT -> checkError (atOffset "Archive truncated")
LT -> do
header <- BS.hGet h headerSize
unless (BS.length header == headerSize) $
checkError (atOffset "Short header")
let magic = BS.drop 58 header
unless (magic == x60LF) . checkError . atOffset $
"Bad magic " ++ show magic ++ " in header"
unless (metadata == BS.take 32 (BS.drop 16 header))
. checkError . atOffset $ "Metadata has changed"
let size = BS.take 10 $ BS.drop 48 header
objSize <- case reads (BS8.unpack size) of
[(n, s)] | all isSpace s -> return n
_ -> checkError (atOffset "Bad file size in header")
let nextHeader = offset + toInteger headerSize +
-- Odd objects are padded with an extra '\x0a'
if odd objSize then objSize + 1 else objSize
hSeek h AbsoluteSeek nextHeader
checkHeader nextHeader
where
atOffset msg = msg ++ " at offset " ++ show offset
module Lib where
dummy :: IO ()
dummy = return ()
name: DeterministicAr
version: 0
license: BSD3
cabal-version: >= 1.9.1
author: Liyang HU
stability: stable
category: PackageTests
build-type: Simple
description:
Ensure our GNU ar -D emulation (#1537) works as advertised: check that
all metadata in the resulting .a archive match the default.
Library
exposed-modules: Lib
build-depends: base
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