From a5912182e528eb2c92ca90bd9a22084ce3c27962 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 17 Aug 2015 10:14:10 +0300 Subject: [PATCH 1/3] Use a cached Setup exe #801 --- ChangeLog.md | 3 +- src/Stack/Build/Execute.hs | 78 ++++++++++++++++++++++++++++++++++---- 2 files changed, 73 insertions(+), 8 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index e960259c96..833e617410 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -11,6 +11,7 @@ Other enhancements: * Added the `extra-path` field to stack.yaml * Code page changes on Windows only apply to the build command (and its synonyms), and can be controlled via a command line flag (still defaults to on) [#757](https://github.com/commercialhaskell/stack/issues/757) * Implicitly add packages to extra-deps when a flag for them is set [#807](https://github.com/commercialhaskell/stack/issues/807) +* Use a precompiled Setup.hs for simple build types [#801](https://github.com/commercialhaskell/stack/issues/801) Bug fixes: @@ -63,7 +64,7 @@ Bug fixes: * Fix: stack fails on Windows with git package in stack.yaml and no git binary on path [#712](https://github.com/commercialhaskell/stack/issues/712) * Fixed GHCi issue: Specifying explicit package versions (#678) * Fixed GHCi issue: Specifying -odir and -hidir as .stack-work/odir (#529) -* Fixed GHCi issue: Specifying A instead of A.ext for modules (#498) +* Fixed GHCi issue: Specifying A instead of A.ext for modules (#498) ## 0.1.2.0 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 2043c416a5..35d6d2fa75 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -55,6 +55,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Word8 (_colon) import Distribution.System (OS (Windows), Platform (Platform)) +import qualified Distribution.Text import Language.Haskell.TH as TH (location) import Network.HTTP.Client.Conduit (HasHttpManager) import Path @@ -191,6 +192,9 @@ data ExecuteEnv = ExecuteEnv , eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed)) , eeTempDir :: !(Path Abs Dir) , eeSetupHs :: !(Path Abs File) + -- ^ Temporary Setup.hs for simple builds + , eeSetupExe :: !(Maybe (Path Abs File)) + -- ^ Compiled version of eeSetupHs , eeCabalPkgVer :: !Version , eeTotalWanted :: !Int , eeWanted :: !(Set PackageName) @@ -199,6 +203,63 @@ data ExecuteEnv = ExecuteEnv , eeGlobalDB :: !(Path Abs Dir) } +-- | Get a compiled Setup exe +getSetupExe :: M env m + => Path Abs File -- ^ Setup.hs input file + -> Path Abs Dir -- ^ temporary directory + -> m (Maybe (Path Abs File)) +getSetupExe setupHs tmpdir = do + econfig <- asks getEnvConfig + let config = getConfig econfig + + let filenameS = concat + [ "setup-Simple-Cabal-" + , versionString $ envConfigCabalVersion econfig + , "-" + , Distribution.Text.display $ configPlatform config + , "-" + , T.unpack $ compilerVersionName + $ envConfigCompilerVersion econfig + , case configPlatform config of + Platform _ Windows -> ".exe" + _ -> "" + ] + filenameP <- parseRelFile filenameS + let setupDir = + configStackRoot config + $(mkRelDir "setup-exe-cache") + setupExe = setupDir filenameP + + exists <- liftIO $ D.doesFileExist $ toFilePath setupExe + + if exists + then return $ Just setupExe + else do + tmpfilename <- parseRelFile $ "tmp-" ++ filenameS + let tmpSetupExe = setupDir tmpfilename + liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir + + menv <- getMinimalEnvOverride + case envConfigCompilerVersion econfig of + GhcVersion _ -> do + runIn tmpdir "ghc" menv + [ "-clear-package-db" + , "-global-package-db" + , "-hide-all-packages" + , "-package" + , "base" + , "-package" + , "Cabal-" ++ versionString (envConfigCabalVersion econfig) + , toFilePath setupHs + , "-o" + , toFilePath tmpSetupExe + ] + Nothing + renameFile tmpSetupExe setupExe + return $ Just setupExe + -- FIXME Sloan: need to add GHCJS caching + GhcjsVersion _ _ -> return Nothing + withExecuteEnv :: M env m => EnvOverride -> BuildOpts @@ -215,6 +276,7 @@ withExecuteEnv menv bopts baseConfigOpts locals sourceMap inner = do idMap <- liftIO $ newTVarIO Map.empty let setupHs = tmpdir' $(mkRelFile "Setup.hs") liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain" + setupExe <- getSetupExe setupHs tmpdir' cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) globalDB <- getGlobalDB menv =<< getWhichCompiler inner ExecuteEnv @@ -230,6 +292,7 @@ withExecuteEnv menv bopts baseConfigOpts locals sourceMap inner = do , eeGhcPkgIds = idMap , eeTempDir = tmpdir' , eeSetupHs = setupHs + , eeSetupExe = setupExe , eeCabalPkgVer = cabalPkgVer , eeTotalWanted = length $ filter lpWanted locals , eeWanted = wantedLocalPackages locals @@ -560,13 +623,13 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inne getRunhaskellPath <- runOnce $ liftIO $ join $ findExecutable menv "runhaskell" getGhcjsPath <- runOnce $ liftIO $ join $ findExecutable menv "ghcjs" distRelativeDir' <- distRelativeDir - setuphs <- + esetupexehs <- -- Avoid broken Setup.hs files causing problems for simple build -- types, see: -- https://github.com/commercialhaskell/stack/issues/370 - if packageSimpleType package - then return eeSetupHs - else liftIO $ getSetupHs pkgDir + case (packageSimpleType package, eeSetupExe) of + (True, Just setupExe) -> return $ Left setupExe + _ -> liftIO $ fmap Right $ getSetupHs pkgDir inner $ \stripTHLoading args -> do let packageArgs = ("-package=" ++ @@ -643,12 +706,13 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inne } wc <- getWhichCompiler - (exeName, fullArgs) <- case wc of - Ghc -> do + (exeName, fullArgs) <- case (esetupexehs, wc) of + (Left setupExe, _) -> return (setupExe, setupArgs) + (Right setuphs, Ghc) -> do exeName <- getRunhaskellPath let fullArgs = packageArgs ++ (toFilePath setuphs : setupArgs) return (exeName, fullArgs) - Ghcjs -> do + (Right setuphs, Ghcjs) -> do distDir <- distDirFromDir pkgDir let setupDir = distDir $(mkRelDir "setup") outputFile = setupDir $(mkRelFile "setup") From 1978a4b27c04dd593c5810ad9837b883e3519315 Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Mon, 17 Aug 2015 13:20:43 -0700 Subject: [PATCH 2/3] Add compilerExeName helper --- src/Stack/Build/Haddock.hs | 5 +---- src/Stack/Ghci.hs | 5 +---- src/Stack/Setup.hs | 7 ++----- src/Stack/Types/Compiler.hs | 4 ++++ 4 files changed, 8 insertions(+), 13 deletions(-) diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 40c920c0cc..7c2e67eb58 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -203,12 +203,9 @@ generateHaddockIndex descr envOverride wc packageIDs docRelDir destDir = do readProcessNull (Just destDir) envOverride - exeName + (compilerExeName wc) (["--gen-contents", "--gen-index"] ++ concatMap fst interfaceOpts) where - exeName = case wc of - Ghc -> "haddock" - Ghcjs -> "haddock-ghcjs" toInterfaceOpt pid@(PackageIdentifier name _) = do let interfaceRelFile = docRelDir FP. packageIdentifierString pid FP. diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index af8141a1bb..671049c1c2 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -78,15 +78,12 @@ ghci GhciOpts{..} = do odir = [ "-odir=" <> toFilePath (objectInterfaceDir bconfig) , "-hidir=" <> toFilePath (objectInterfaceDir bconfig)] - defaultCommand = case wc of - Ghc -> "ghc" - Ghcjs -> "ghcjs" $logInfo ("Configuring GHCi with the following packages: " <> T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs)) exec defaultEnvSettings - (fromMaybe defaultCommand ghciGhcCommand) + (fromMaybe (compilerExeName wc) ghciGhcCommand) ("--interactive" : odir <> pkgopts <> srcfiles <> ghciArgs) -- | Figure out the main-is file to load based on the targets. Sometimes there diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index a03919285b..bdf3dcf1c6 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -379,10 +379,7 @@ upgradeCabal menv wc = do let ident = PackageIdentifier name newest m <- unpackPackageIdents menv tmpdir' Nothing (Set.singleton ident) - let compilerName = case wc of - Ghc -> "ghc" - Ghcjs -> "ghcjs" - compilerPath <- join $ findExecutable menv compilerName + compilerPath <- join $ findExecutable menv (compilerExeName wc) newestDir <- parseRelDir $ versionString newest let installRoot = toFilePath $ parent (parent compilerPath) $(mkRelDir "new-cabal") @@ -393,7 +390,7 @@ upgradeCabal menv wc = do Nothing -> error $ "upgradeCabal: Invariant violated, dir missing" Just dir -> return dir - runIn dir compilerName menv ["Setup.hs"] Nothing + runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing let setupExe = toFilePath $ dir $(mkRelFile "Setup") dirArgument name' = concat [ "--" diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index 2e24ca4ecb..9e76fbc1ac 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -71,3 +71,7 @@ isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) = isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) = checkVersion check wanted actual && checkVersion check wantedGhc actualGhc isWantedCompiler _ _ _ = False + +compilerExeName :: WhichCompiler -> String +compilerExeName Ghc = "ghc" +compilerExeName Ghcjs = "ghcjs" From c9b823c485f46b5eaa7bd846e70888b18d8a4a8d Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Mon, 17 Aug 2015 15:52:57 -0700 Subject: [PATCH 3/3] Add GHCJS support to getSetupExe --- src/Stack/Build/Execute.hs | 69 +++++++++++++++++++++----------------- 1 file changed, 39 insertions(+), 30 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 35d6d2fa75..13ac599925 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -209,10 +209,10 @@ getSetupExe :: M env m -> Path Abs Dir -- ^ temporary directory -> m (Maybe (Path Abs File)) getSetupExe setupHs tmpdir = do + wc <- getWhichCompiler econfig <- asks getEnvConfig let config = getConfig econfig - - let filenameS = concat + baseNameS = concat [ "setup-Simple-Cabal-" , versionString $ envConfigCabalVersion econfig , "-" @@ -220,45 +220,54 @@ getSetupExe setupHs tmpdir = do , "-" , T.unpack $ compilerVersionName $ envConfigCompilerVersion econfig - , case configPlatform config of + ] + exeNameS = baseNameS ++ + case configPlatform config of Platform _ Windows -> ".exe" _ -> "" - ] - filenameP <- parseRelFile filenameS - let setupDir = + outputNameS = + case wc of + Ghc -> exeNameS + Ghcjs -> baseNameS ++ ".jsexe" + jsExeNameS = + baseNameS ++ ".jsexe" + setupDir = configStackRoot config $(mkRelDir "setup-exe-cache") - setupExe = setupDir filenameP - exists <- liftIO $ D.doesFileExist $ toFilePath setupExe + exePath <- fmap (setupDir ) $ parseRelFile exeNameS + jsExePath <- fmap (setupDir ) $ parseRelDir jsExeNameS + + exists <- liftIO $ D.doesFileExist $ toFilePath exePath if exists - then return $ Just setupExe + then return $ Just exePath else do - tmpfilename <- parseRelFile $ "tmp-" ++ filenameS - let tmpSetupExe = setupDir tmpfilename + tmpExePath <- fmap (setupDir ) $ parseRelFile $ "tmp-" ++ exeNameS + tmpOutputPath <- fmap (setupDir ) $ parseRelFile $ "tmp-" ++ outputNameS + tmpJsExePath <- fmap (setupDir ) $ parseRelDir $ "tmp-" ++ jsExeNameS + liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir menv <- getMinimalEnvOverride - case envConfigCompilerVersion econfig of - GhcVersion _ -> do - runIn tmpdir "ghc" menv - [ "-clear-package-db" - , "-global-package-db" - , "-hide-all-packages" - , "-package" - , "base" - , "-package" - , "Cabal-" ++ versionString (envConfigCabalVersion econfig) - , toFilePath setupHs - , "-o" - , toFilePath tmpSetupExe - ] - Nothing - renameFile tmpSetupExe setupExe - return $ Just setupExe - -- FIXME Sloan: need to add GHCJS caching - GhcjsVersion _ _ -> return Nothing + wc <- getWhichCompiler + let args = + [ "-clear-package-db" + , "-global-package-db" + , "-hide-all-packages" + , "-package" + , "base" + , "-package" + , "Cabal-" ++ versionString (envConfigCabalVersion econfig) + , toFilePath setupHs + , "-o" + , toFilePath tmpOutputPath + ] ++ + ["-build-runner" | wc == Ghcjs] + runIn tmpdir (compilerExeName wc) menv args Nothing + when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath + renameFile tmpExePath exePath + return $ Just exePath withExecuteEnv :: M env m => EnvOverride