From 1cb7a494a9b068c56f2e9de86b7ad81e87f0af7e Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 3 Apr 2012 18:41:40 +0200 Subject: [PATCH] rebuild application with GHC API (incomplete, only tested on linux, GHC 7.4.1 required) --- yesod/Build.hs | 1 + yesod/Devel.hs | 61 +++++-- yesod/GhcBuild.hs | 379 ++++++++++++++++++++++++++++++++++++++++++++ yesod/ghcwrapper.hs | 41 +++++ yesod/yesod.cabal | 19 +++ 5 files changed, 487 insertions(+), 14 deletions(-) create mode 100644 yesod/GhcBuild.hs create mode 100644 yesod/ghcwrapper.hs diff --git a/yesod/Build.hs b/yesod/Build.hs index fb147114..f68d4877 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -5,6 +5,7 @@ module Build , touchDeps , touch , recompDeps + , isNewerThan ) where -- FIXME there's a bug when getFileStatus applies to a file diff --git a/yesod/Devel.hs b/yesod/Devel.hs index af80a98f..ad4c967f 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -30,7 +30,10 @@ import System.Process (createProcess, proc, terminateProcess, readProc waitForProcess, rawSystem, runInteractiveProcess) import System.IO (hClose, hIsEOF, hGetLine, stdout, stderr, hPutStrLn) -import Build (recompDeps, getDeps) +import Build (recompDeps, getDeps, isNewerThan) +import GhcBuild (getBuildFlags, buildPackage) + +import qualified Config as GHC lockFile :: FilePath lockFile = "dist/devel-terminate" @@ -57,7 +60,7 @@ devel isCabalDev passThroughArgs = do _<- rawSystem cmd args - mainLoop hsSourceDirs + mainLoop hsSourceDirs cabal _ <- getLine writeLock @@ -67,32 +70,36 @@ devel isCabalDev passThroughArgs = do | otherwise = "cabal" diffArgs | isCabalDev = [ - "--cabal-install-arg=-fdevel" -- legacy + "--cabal-install-arg=--with-compiler=yesod-ghc-wrapper" + , "--cabal-install-arg=--with-ld=yesod-ld-wrapper" + , "--cabal-install-arg=--with-ar=yesod-ar-wrapper" + , "--cabal-install-arg=-fdevel" -- legacy , "--cabal-install-arg=-flibrary-only" ] | otherwise = [ - "-fdevel" -- legacy + "--with-compiler=yesod-ghc-wrapper" + , "--with-ld=yesod-ld-wrapper" + , "--with-ar=yesod-ar-wrapper" + , "-fdevel" -- legacy , "-flibrary-only" ] args = "configure":diffArgs ++ ["--disable-library-profiling" ] - mainLoop :: [FilePath] -> IO () - mainLoop hsSourceDirs = do + mainLoop :: [FilePath] -> FilePath -> IO () + mainLoop hsSourceDirs cabal = do ghcVer <- ghcVersion - when isCabalDev (rawSystemFilter cmd ["build"] >> return ()) -- cabal-dev fails with strange errors sometimes if we cabal-dev buildinfo before cabal-dev build + rebuildCabal cmd pkgArgs <- ghcPackageArgs isCabalDev ghcVer + rebuild <- mkRebuild ghcVer cabal cmd let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs forever $ do - putStrLn "Rebuilding application..." - recompDeps hsSourceDirs list <- getFileList hsSourceDirs - exit <- rawSystemFilter cmd ["build"] - - case exit of - ExitFailure _ -> putStrLn "Build failure, pausing..." - _ -> do + success <- rebuild + if not success + then putStrLn "Build failure, pausing..." + else do removeLock putStrLn $ "Starting development server: runghc " ++ L.unwords devArgs (_,_,_,ph) <- createProcess $ proc "runghc" devArgs @@ -108,6 +115,30 @@ devel isCabalDev passThroughArgs = do Ex.throwTo watchTid (userError "process finished") watchForChanges hsSourceDirs list +mkRebuild :: String -> FilePath -> String -> IO (IO Bool) +mkRebuild ghcVer cabalFile cabalCmd + | GHC.cProjectVersion == ghcVer = do + bf <- getBuildFlags + return $ do + n <- cabalFile `isNewerThan` "dist/ghcargs.txt" + if n + then rebuildCabal cabalCmd + else rebuildGhc bf + | otherwise = return $ do + putStrLn "WARNING: yesod is compiled with a different ghc version, falling back to cabal" + rebuildCabal cabalCmd + +rebuildGhc bf = do + putStrLn "Rebuilding application... (GHC API)" + buildPackage bf + +rebuildCabal cmd = do + putStrLn "Rebuilding application... (cabal)" + exit <- rawSystemFilter cmd ["build"] + return $ case exit of + ExitSuccess -> True + _ -> False + try_ :: forall a. IO a -> IO () try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return () @@ -221,3 +252,5 @@ rawSystemFilter command args = do _ <- forkIO $ go outh stdout _ <- forkIO $ go errh stderr waitForProcess ph + + diff --git a/yesod/GhcBuild.hs b/yesod/GhcBuild.hs new file mode 100644 index 00000000..aaa71362 --- /dev/null +++ b/yesod/GhcBuild.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +{- + build package with the GHC API +-} + +module GhcBuild (getBuildFlags, buildPackage) where + +import qualified Control.Exception as Ex +import System.Process (rawSystem) +import Control.Monad (when) + +import qualified GHC +import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename ) +import Util (looksLikeModuleName, consIORef) +import DriverPipeline (oneShot, compileFile, link, linkBinary ) +import StaticFlags (v_Ld_inputs) +import HscTypes ( emptyHomePackageTable, HscEnv(..) ) +import System.FilePath (normalise) +import GHC.Paths (libdir) +import MonadUtils ( liftIO ) +import CmdLineParser +import SrcLoc (Located, mkGeneralLocated) +import DynFlags (DynFlags, compilerInfo) +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Panic (panic, ghcError) +import Data.List (partition, isPrefixOf) + +getBuildFlags :: IO [Located String] +getBuildFlags = do + argv0 <- fmap read $ readFile "dist/ghcargs.txt" -- generated by yesod-ghc-wrapper + let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 + mbMinusB | null minusB_args = Nothing + | otherwise = Just (drop 2 (last minusB_args)) + let argv1' = map (mkGeneralLocated "on the commandline") argv1 + (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1' + return argv2 + +buildPackage :: [Located String] -> IO Bool +buildPackage a = buildPackage' a `Ex.catch` \(e::Ex.SomeException) -> do + putStrLn ("exception building package: " ++ show e) + return False + +buildPackage' argv2 = do + (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + GHC.runGhc (Just libdir) $ do + dflags0 <- GHC.getSessionDynFlags + (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3 + let dflags2 = dflags1 { GHC.ghcMode = GHC.CompManager + , GHC.hscTarget = GHC.hscTarget dflags1 + , GHC.ghcLink = GHC.LinkBinary + , GHC.verbosity = 1 + } + (dflags3, fileish_args, _) <- GHC.parseDynamicFlags dflags2 argv3 + GHC.setSessionDynFlags dflags3 + let normal_fileish_paths = map (normalise . GHC.unLoc) fileish_args + (srcs, objs) = partition_args normal_fileish_paths [] [] + (hs_srcs, non_hs_srcs) = partition haskellish srcs + haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f + haskellish (_,Just phase) = + phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] + hsc_env <- GHC.getSession +-- if (null hs_srcs) +-- then liftIO (oneShot hsc_env StopLn srcs) +-- else do + o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) + non_hs_srcs + liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) + targets <- mapM (uncurry GHC.guessTarget) hs_srcs + GHC.setTargets targets + ok_flag <- GHC.load GHC.LoadAllTargets + if GHC.failed ok_flag + then return False + else liftIO linkPkg >> return True + +-- fixme, find default ar and ld versions +linkPkg = do + arargs <- fmap read $ readFile "dist/arargs.txt" + rawSystem "ar" arargs + ldargs <- fmap read $ readFile "dist/ldargs.txt" + rawSystem "ld" ldargs + + +-------------------------------------------------------------------------------------------- +-- stuff below copied from ghc main.hs +-------------------------------------------------------------------------------------------- + +partition_args :: [String] -> [(String, Maybe Phase)] -> [String] + -> ([(String, Maybe Phase)], [String]) +partition_args [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + {- + We split out the object files (.o, .dll) and add them + to v_Ld_inputs for use by the linker. + + The following things should be considered compilation manager inputs: + + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + + - module names (not forgetting hierarchical module names), + + - and finally we consider everything not containing a '.' to be + a comp manager input, as shorthand for a .hs or .lhs filename. + + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} +looks_like_an_input :: String -> Bool +looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m + || '.' `notElem` m + + + +-- Parsing the mode flag + +parseModeFlags :: [Located String] + -> IO (Mode, + [Located String], + [Located String]) +parseModeFlags args = do + let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = + runCmdLine (processArgs mode_flags args) + (Nothing, [], []) + mode = case mModeFlag of + Nothing -> doMakeMode + Just (m, _) -> m + errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2 + when (not (null errs)) $ ghcError $ errorsToGhcException errs + return (mode, flags' ++ leftover, warns) + +type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) + -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) + -- so we collect the new ones and return them. + +mode_flags :: [Flag ModeM] +mode_flags = + [ ------- help / version ---------------------------------------------- + Flag "?" (PassFlag (setMode showGhcUsageMode)) + , Flag "-help" (PassFlag (setMode showGhcUsageMode)) + , Flag "V" (PassFlag (setMode showVersionMode)) + , Flag "-version" (PassFlag (setMode showVersionMode)) + , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) + , Flag "-info" (PassFlag (setMode showInfoMode)) + , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) + , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) + ] ++ + [ Flag k' (PassFlag (setMode (printSetting k))) + | k <- ["Project version", + "Booter version", + "Stage", + "Build platform", + "Host platform", + "Target platform", + "Have interpreter", + "Object splitting supported", + "Have native code generator", + "Support SMP", + "Unregisterised", + "Tables next to code", + "RTS ways", + "Leading underscore", + "Debug on", + "LibDir", + "Global Package DB", + "C compiler flags", + "Gcc Linker flags", + "Ld Linker flags"], + let k' = "-print-" ++ map (replaceSpace . toLower) k + replaceSpace ' ' = '-' + replaceSpace c = c + ] ++ + ------- interfaces ---------------------------------------------------- + [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) + "--show-iface")) + + ------- primary modes ------------------------------------------------ + , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f + addFlag "-no-link" f)) + , Flag "M" (PassFlag (setMode doMkDependHSMode)) + , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) + , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f + addFlag "-fvia-C" f)) + , Flag "S" (PassFlag (setMode (stopBeforeMode As))) + , Flag "-make" (PassFlag (setMode doMakeMode)) + , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) + , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode)) + , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) + ] + +setMode :: Mode -> String -> EwM ModeM () +setMode newMode newFlag = liftEwM $ do + (mModeFlag, errs, flags') <- getCmdLineState + let (modeFlag', errs') = + case mModeFlag of + Nothing -> ((newMode, newFlag), errs) + Just (oldMode, oldFlag) -> + case (oldMode, newMode) of + -- -c/--make are allowed together, and mean --make -no-link + _ | isStopLnMode oldMode && isDoMakeMode newMode + || isStopLnMode newMode && isDoMakeMode oldMode -> + ((doMakeMode, "--make"), []) + + -- If we have both --help and --interactive then we + -- want showGhciUsage + _ | isShowGhcUsageMode oldMode && + isDoInteractiveMode newMode -> + ((showGhciUsageMode, oldFlag), []) + | isShowGhcUsageMode newMode && + isDoInteractiveMode oldMode -> + ((showGhciUsageMode, newFlag), []) + -- Otherwise, --help/--version/--numeric-version always win + | isDominantFlag oldMode -> ((oldMode, oldFlag), []) + | isDominantFlag newMode -> ((newMode, newFlag), []) + -- We need to accumulate eval flags like "-e foo -e bar" + (Right (Right (DoEval esOld)), + Right (Right (DoEval [eNew]))) -> + ((Right (Right (DoEval (eNew : esOld))), oldFlag), + errs) + -- Saying e.g. --interactive --interactive is OK + _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs) + -- Otherwise, complain + _ -> let err = flagMismatchErr oldFlag newFlag + in ((oldMode, oldFlag), err : errs) + putCmdLineState (Just modeFlag', errs', flags') + where isDominantFlag f = isShowGhcUsageMode f || + isShowGhciUsageMode f || + isShowVersionMode f || + isShowNumVersionMode f + +flagMismatchErr :: String -> String -> String +flagMismatchErr oldFlag newFlag + = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" + +addFlag :: String -> String -> EwM ModeM () +addFlag s flag = liftEwM $ do + (m, e, flags') <- getCmdLineState + putCmdLineState (m, e, mkGeneralLocated loc s : flags') + where loc = "addFlag by " ++ flag ++ " on the commandline" + +type Mode = Either PreStartupMode PostStartupMode +type PostStartupMode = Either PreLoadMode PostLoadMode + +data PreStartupMode + = ShowVersion -- ghc -V/--version + | ShowNumVersion -- ghc --numeric-version + | ShowSupportedExtensions -- ghc --supported-extensions + | Print String -- ghc --print-foo + +showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode +showVersionMode = mkPreStartupMode ShowVersion +showNumVersionMode = mkPreStartupMode ShowNumVersion +showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions + +mkPreStartupMode :: PreStartupMode -> Mode +mkPreStartupMode = Left + +isShowVersionMode :: Mode -> Bool +isShowVersionMode (Left ShowVersion) = True +isShowVersionMode _ = False + +isShowNumVersionMode :: Mode -> Bool +isShowNumVersionMode (Left ShowNumVersion) = True +isShowNumVersionMode _ = False + +data PreLoadMode + = ShowGhcUsage -- ghc -? + | ShowGhciUsage -- ghci -? + | ShowInfo -- ghc --info + | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo + +showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode +showGhcUsageMode = mkPreLoadMode ShowGhcUsage +showGhciUsageMode = mkPreLoadMode ShowGhciUsage +showInfoMode = mkPreLoadMode ShowInfo + +printSetting :: String -> Mode +printSetting k = mkPreLoadMode (PrintWithDynFlags f) + where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) + $ lookup k (compilerInfo dflags) + +mkPreLoadMode :: PreLoadMode -> Mode +mkPreLoadMode = Right . Left + +isShowGhcUsageMode :: Mode -> Bool +isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True +isShowGhcUsageMode _ = False + +isShowGhciUsageMode :: Mode -> Bool +isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True +isShowGhciUsageMode _ = False + +data PostLoadMode + = ShowInterface FilePath -- ghc --show-iface + | DoMkDependHS -- ghc -M + | StopBefore Phase -- ghc -E | -C | -S + -- StopBefore StopLn is the default + | DoMake -- ghc --make + | DoInteractive -- ghc --interactive + | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] + | DoAbiHash -- ghc --abi-hash + +doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode +doMkDependHSMode = mkPostLoadMode DoMkDependHS +doMakeMode = mkPostLoadMode DoMake +doInteractiveMode = mkPostLoadMode DoInteractive +doAbiHashMode = mkPostLoadMode DoAbiHash + + +showInterfaceMode :: FilePath -> Mode +showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) + +stopBeforeMode :: Phase -> Mode +stopBeforeMode phase = mkPostLoadMode (StopBefore phase) + +doEvalMode :: String -> Mode +doEvalMode str = mkPostLoadMode (DoEval [str]) + +mkPostLoadMode :: PostLoadMode -> Mode +mkPostLoadMode = Right . Right + +isDoInteractiveMode :: Mode -> Bool +isDoInteractiveMode (Right (Right DoInteractive)) = True +isDoInteractiveMode _ = False + +isStopLnMode :: Mode -> Bool +isStopLnMode (Right (Right (StopBefore StopLn))) = True +isStopLnMode _ = False + +isDoMakeMode :: Mode -> Bool +isDoMakeMode (Right (Right DoMake)) = True +isDoMakeMode _ = False + +#ifdef GHCI +isInteractiveMode :: PostLoadMode -> Bool +isInteractiveMode DoInteractive = True +isInteractiveMode _ = False +#endif + +-- isInterpretiveMode: byte-code compiler involved +isInterpretiveMode :: PostLoadMode -> Bool +isInterpretiveMode DoInteractive = True +isInterpretiveMode (DoEval _) = True +isInterpretiveMode _ = False + +needsInputsMode :: PostLoadMode -> Bool +needsInputsMode DoMkDependHS = True +needsInputsMode (StopBefore _) = True +needsInputsMode DoMake = True +needsInputsMode _ = False + +-- True if we are going to attempt to link in this mode. +-- (we might not actually link, depending on the GhcLink flag) +isLinkMode :: PostLoadMode -> Bool +isLinkMode (StopBefore StopLn) = True +isLinkMode DoMake = True +isLinkMode DoInteractive = True +isLinkMode (DoEval _) = True +isLinkMode _ = False + +isCompManagerMode :: PostLoadMode -> Bool +isCompManagerMode DoMake = True +isCompManagerMode DoInteractive = True +isCompManagerMode (DoEval _) = True +isCompManagerMode _ = False + diff --git a/yesod/ghcwrapper.hs b/yesod/ghcwrapper.hs new file mode 100644 index 00000000..b71b475e --- /dev/null +++ b/yesod/ghcwrapper.hs @@ -0,0 +1,41 @@ +{- + wrapper executable that captures arguments to ghc, ar or ld +-} + +{-# LANGUAGE CPP #-} +module Main where + +import System.Process (rawSystem, readProcess) +import System.Environment (getArgs) +import Data.Maybe (fromMaybe) +import Control.Monad (when) +import System.Exit (exitWith) +import System.Directory (doesDirectoryExist) + +#ifdef LDCMD +cmd = lookupGhcInfo "ld command" "ld" +outFile = "dist/ldargs.txt" +#else +#ifdef ARCMD +cmd = lookupGhcInfo "ar command" "ar" +outFile ="dist/arargs.txt" +#else +cmd = return "ghc" +outFile = "dist/ghcargs.txt" +#endif +#endif + +lookupGhcInfo :: String -> String -> IO String +lookupGhcInfo xs d = fmap (fromMaybe d . lookup xs . read) (readProcess "ghc" ["--info"] "") + +passthrough args = do + c <- cmd + rawSystem c args + +main = do + args <- getArgs + e <- doesDirectoryExist "dist" + when e $ writeFile outFile (show args ++ "\n") + ex <- passthrough args + exitWith ex + diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 058770b2..ca56929b 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -90,6 +90,22 @@ library exposed-modules: Yesod ghc-options: -Wall +executable yesod-ghc-wrapper + main-is: ghcwrapper.hs + build-depends: + base >= 4 && < 5 + +executable yesod-ld-wrapper + main-is: ghcwrapper.hs + cpp-options: -DLDCMD + build-depends: + base >= 4 && < 5 +executable yesod-ar-wrapper + main-is: ghcwrapper.hs + cpp-options: -DARCMD + build-depends: + base >= 4 && < 5 + executable yesod if flag(ghc7) build-depends: base >= 4.3 && < 5 @@ -114,6 +130,8 @@ executable yesod , filepath >= 1.1 , fast-logger >= 0.0.2 && < 0.1 , process + , ghc >= 7.4.1 + , ghc-paths >= 0.1.0.8 ghc-options: -Wall if flag(threaded) ghc-options: -threaded @@ -122,6 +140,7 @@ executable yesod Scaffolding.Scaffolder Devel Build + GhcBuild source-repository head type: git