hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Honour GHC bootstrap compiler during git clone stages

Browse Source 
Fixes #250
This commit is contained in:
Julian Ospald 2021-09-27 12:51:59 +02:00
parent be9b3a3857
commit d2b4eccac2
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
1 changed files with 21 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
lib/GHCup.hs
View File

@ -2121,6 +2121,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)
(workdir, tmpUnpack, tver) <- case targetGhc of (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do Left tver -> do
@ -2147,7 +2151,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
Right GitBranch{..} -> do Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do tver <- reThrowAll @_ @'[ProcessError, NotFoundInPATH] DownloadFailed $ do
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ] lEM $ git [ "init" ]
@ -2167,8 +2171,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
lEM $ git [ "checkout", "FETCH_HEAD" ] lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
lEM $ execLogged "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" Nothing env <- liftE $ ghcEnv bghc
lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" Nothing lEM $ execLogged "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" (Just env)
lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" (Just env)
CapturedProcess {..} <- lift $ makeOut CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack) ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
case _exitCode of case _exitCode of
@ -2199,10 +2204,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
Just isoDir -> pure isoDir Just isoDir -> pure isoDir
Nothing -> lift $ ghcupGHCDir installVer Nothing -> lift $ ghcupGHCDir installVer
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)
(mBindist, bmk) <- liftE $ runBuildAction (mBindist, bmk) <- liftE $ runBuildAction
tmpUnpack tmpUnpack
Nothing Nothing
@ -2478,14 +2479,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
forM_ patchdir (\dir -> liftE $ applyPatches dir workdir) forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
cEnv <- liftIO getEnvironment
if | _tvVersion tver >= [vver|8.8.0|] -> do if | _tvVersion tver >= [vver|8.8.0|] -> do
bghcPath <- case bghc of env <- liftE $ ghcEnv bghc
Right ghc' -> pure ghc'
Left bver -> do
spaths <- liftIO getSearchPath
liftIO (searchPath spaths bver) !? NotFoundInPATH bver
lEM $ execLogged lEM $ execLogged
"sh" "sh"
("./configure" : maybe mempty ("./configure" : maybe mempty
@ -2499,7 +2495,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
) )
(Just workdir) (Just workdir)
"ghc-conf" "ghc-conf"
(Just (("GHC", bghcPath) : cEnv)) (Just env)
| otherwise -> do | otherwise -> do
lEM $ execLogged lEM $ execLogged
"sh" "sh"
@ -2516,9 +2512,19 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
) )
(Just workdir) (Just workdir)
"ghc-conf" "ghc-conf"
(Just cEnv) Nothing
pure () pure ()
ghcEnv :: MonadIO m => Either FilePath FilePath -> Excepts '[NotFoundInPATH] m [(String, String)]
ghcEnv bghc = do
cEnv <- liftIO getEnvironment
bghcPath <- case bghc of
Right ghc' -> pure ghc'
Left bver -> do
spaths <- liftIO getSearchPath
liftIO (searchPath spaths bver) !? NotFoundInPATH bver
pure (("GHC", bghcPath) : cEnv)