Minor revision of install stages
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 28 Aug 2017 23:28:55 +0000 (00:28 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 28 Aug 2017 23:28:55 +0000 (00:28 +0100)
See #403

src/GHC.hs
src/Rules/Install.hs
src/Rules/Program.hs
src/Rules/Wrappers.hs
src/Settings.hs

index d36de56..d7238f2 100644 (file)
@@ -11,7 +11,7 @@ module GHC (
     ghcPackages, isGhcPackage, defaultPackages,
 
     -- * Package information
-    programName, nonCabalContext, nonHsMainPackage, autogenPath,
+    programName, nonCabalContext, nonHsMainPackage, autogenPath, installStages,
 
     -- * Miscellaneous
     programPath, ghcSplitPath, stripCmdPath, inplaceInstallPath, buildDll0
@@ -215,12 +215,20 @@ programName Context {..}
     | package == iservBin = "ghc-iserv"
     | otherwise           = pkgName package
 
-isInstallContext :: Context -> Action Bool
-isInstallContext Context {..}
-    | not (isGhcPackage package) = return False
+-- | Given a 'Package' this action returns the sorted list of stages in which
+-- the package build results are installed. For most GHC packages we install the
+-- /latest/ build stage. The only exception is the GHC itself, whose binaries
+-- are installed in all stages. User packages are not installed, hence the
+-- resulting list is empty.
+installStages :: Package -> Action [Stage]
+installStages pkg
+    | not (isGhcPackage pkg) = return [] -- Only GHC packages are installed.
     | otherwise = do
-        stages <- filterM (fmap (package `elem`) . defaultPackages) [Stage0 ..]
-        return (null stages || package == ghc || stage == maximum stages)
+        stages <- filterM (fmap (pkg `elem`) . defaultPackages) [Stage0 ..]
+        return $ if pkg == ghc then stages else takeEnd 1 stages
+
+isInstallContext :: Context -> Action Bool
+isInstallContext Context {..} = (stage `elem`) <$> installStages package
 
 -- | The 'FilePath' to a program executable in a given 'Context'.
 programPath :: Context -> Action FilePath
index bd6d615..2ecd915 100644 (file)
@@ -46,6 +46,7 @@ installRules = do
         installBins
         installPackages
 
+-- TODO: Get rid of hard-coded list.
 -- | Binaries to install.
 installBinPkgs :: [Package]
 installBinPkgs = [ghc, ghcPkg, ghcSplit, hp2ps, hpc, hsc2hs, runGhc, unlit]
@@ -60,8 +61,7 @@ installLibExecScripts = do
     libExecDir <- getLibExecDir
     destDir <- getDestDir
     installDirectory (destDir ++ libExecDir)
-    forM_ libExecScripts $ \script -> do
-        installScript script (destDir ++ libExecDir)
+    forM_ libExecScripts $ \script -> installScript script (destDir ++ libExecDir)
   where
     libExecScripts :: [FilePath]
     libExecScripts = [ghcSplitPath]
@@ -74,7 +74,7 @@ installLibExecs = do
     destDir <- getDestDir
     installDirectory (destDir ++ libExecDir)
     forM_ installBinPkgs $ \pkg -> do
-        withLatestBuildStage pkg $ \stage -> do
+        withLatestInstallStage pkg $ \stage -> do
             context <- programContext stage pkg
             let bin = inplaceLibBinPath -/- programName context <.> exe
             installProgram bin (destDir ++ libExecDir)
@@ -94,17 +94,15 @@ installBins = do
     when win $
         copyDirectoryContents matchAll (destDir ++ libDir -/- "bin") (destDir ++ binDir)
     unless win $ forM_ installBinPkgs $ \pkg ->
-        withLatestBuildStage pkg $ \stage -> do
+        withLatestInstallStage pkg $ \stage -> do
             context <- programContext stage pkg
             version <- setting ProjectVersion
             -- Name of the binary file
-            let binName = if pkg == ghc
-                          then "ghc-" ++ version <.> exe
-                          else programName context ++ "-" ++ version <.> exe
+            let binName | pkg == ghc = "ghc-" ++ version <.> exe
+                        | otherwise  = programName context ++ "-" ++ version <.> exe
             -- Name of the symbolic link
-            let symName = if pkg == ghc
-                          then "ghc" <.> exe
-                          else programName context <.> exe
+            let symName | pkg == ghc = "ghc" <.> exe
+                        | otherwise  = programName context <.> exe
             case lookup context installWrappers of
                 Nothing -> return ()
                 Just wrapper -> do
@@ -117,12 +115,10 @@ installBins = do
                         linkSymbolic (destDir ++ binDir -/- binName)
                                      (destDir ++ binDir -/- symName)
 
-withLatestBuildStage :: Package -> (Stage -> Action ()) -> Action ()
-withLatestBuildStage pkg m = do
-  maybeStage <- latestBuildStage pkg
-  case maybeStage of
-      Just stage -> m stage
-      Nothing    -> return ()
+withLatestInstallStage :: Package -> (Stage -> Action ()) -> Action ()
+withLatestInstallStage pkg m = do
+    stages <- installStages pkg
+    mapM_ m (takeEnd 1 stages)
 
 pkgConfInstallPath :: Action FilePath
 pkgConfInstallPath = buildPath (vanillaContext Stage0 rts) <&> (-/- "package.conf.install")
@@ -178,10 +174,10 @@ installPackages = do
 
     copyFile ghcBootPlatformHeader (pkgPath compiler -/- "ghc_boot_platform.h")
 
-    activePackages <- filterM ((isJust <$>) . latestBuildStage)
-                              (knownPackages \\ [rts, libffi])
+    installPackages <- filterM ((not . null <$>) . installStages)
+                               (knownPackages \\ [rts, libffi])
 
-    installLibPkgs <- topsortPackages (filter isLibrary activePackages)
+    installLibPkgs <- topsortPackages (filter isLibrary installPackages)
 
     -- TODO (izgzhen): figure out what is the root cause of the missing ghc-gmp.h error
     copyFile (pkgPath integerGmp -/- "gmp/ghc-gmp.h") (pkgPath integerGmp -/- "ghc-gmp.h")
@@ -189,7 +185,7 @@ installPackages = do
     forM_ installLibPkgs $ \pkg -> do
         case pkgCabalFile pkg of
             Nothing -> error $ "Non-Haskell project in installLibPkgs" ++ show pkg
-            Just cabalFile -> withLatestBuildStage pkg $ \stage -> do
+            Just cabalFile -> withLatestInstallStage pkg $ \stage -> do
                 let context = vanillaContext stage pkg
                 top <- topDirectory
                 installDistDir <- buildPath context
@@ -235,28 +231,27 @@ installPackages = do
                                    , confPath ]
 
     forM_ installLibPkgs $ \pkg -> do
-        when (isLibrary pkg) $
-            withLatestBuildStage pkg $ \stage -> do
-                let context = vanillaContext stage pkg
-                top <- topDirectory
-                installDistDir <- (top -/-) <$> buildPath context
-                -- TODO: better reference to the built inplace binary path
-                let ghcCabalInplace = inplaceBinPath -/- "ghc-cabal"
-                pref   <- setting InstallPrefix
-                docDir <- installDocDir
-                r      <- relocatableBuild
-                unit $ cmd ghcCabalInplace
-                    [ "register"
-                    , pkgPath pkg
-                    , installDistDir
-                    , installedGhcReal
-                    , installedGhcPkgReal
-                    , destDir ++ ghcLibDir
-                    , destDir
-                    , destDir ++ pref
-                    , destDir ++ ghcLibDir
-                    , destDir ++ docDir -/- "html/libraries"
-                    , if r then "YES" else "NO" ]
+        withLatestInstallStage pkg $ \stage -> do
+            let context = vanillaContext stage pkg
+            top <- topDirectory
+            installDistDir <- (top -/-) <$> buildPath context
+            -- TODO: better reference to the built inplace binary path
+            let ghcCabalInplace = inplaceBinPath -/- "ghc-cabal"
+            pref   <- setting InstallPrefix
+            docDir <- installDocDir
+            r      <- relocatableBuild
+            unit $ cmd ghcCabalInplace
+                [ "register"
+                , pkgPath pkg
+                , installDistDir
+                , installedGhcReal
+                , installedGhcPkgReal
+                , destDir ++ ghcLibDir
+                , destDir
+                , destDir ++ pref
+                , destDir ++ ghcLibDir
+                , destDir ++ docDir -/- "html/libraries"
+                , if r then "YES" else "NO" ]
 
     confs <- getDirectoryContents installedPackageConf
     forM_ confs (\f -> createData $ installedPackageConf -/- f)
index 031189b..c8a725e 100644 (file)
@@ -18,8 +18,11 @@ import Utilities
 buildProgram :: [(Resource, Int)] -> Context -> Rules ()
 buildProgram rs context@Context {..} = when (isProgram package) $ do
     let installStage = do
-            latest <- latestBuildStage package -- fromJust below is safe
-            return $ if package == ghc then stage else fromJust latest
+            stages <- installStages package
+            case stages of
+                [s] -> return s
+                _   -> error $ "Exactly one install stage expected for package "
+                    ++ quote (pkgName package) ++ " (got " ++ show stages ++ ")."
 
     "//" ++ contextDir context -/- programName context <.> exe %> \bin -> do
         context' <- programContext stage package
@@ -30,7 +33,7 @@ buildProgram rs context@Context {..} = when (isProgram package) $ do
         -- Some binaries in inplace/bin are wrapped
         inplaceBinPath -/- programName context <.> exe %> \bin -> do
             context' <- programContext stage package
-            binStage <- installStage
+            binStage <- if package == ghc then return stage else installStage
             buildBinaryAndWrapper rs (context' { stage = binStage }) bin
 
         inplaceLibBinPath -/- programName context <.> exe %> \bin -> do
@@ -72,10 +75,10 @@ buildBinaryAndWrapper rs context bin = do
         Nothing      -> buildBinary rs context bin -- No wrapper found
         Just wrapper -> do
             top <- topDirectory
-            let libdir = top -/- inplaceLibPath
-            let wrappedBin = inplaceLibBinPath -/- takeFileName bin
+            let libPath    = top -/- inplaceLibPath
+                wrappedBin = inplaceLibBinPath -/- takeFileName bin
             need [wrappedBin]
-            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName bin))
+            buildWrapper context wrapper bin (WrappedBinary libPath (takeFileName bin))
 
 buildWrapper :: Context -> Wrapper -> FilePath -> WrappedBinary -> Action ()
 buildWrapper context@Context {..} wrapper wrapperPath wrapped = do
index cf237f8..24d865c 100644 (file)
@@ -122,10 +122,9 @@ iservBinWrapper WrappedBinary{..} = do
     -- TODO: Figure our the reason of this hardcoded exclusion
     let pkgs = activePackages \\ [ cabal, process, haskeline
                                  , terminfo, ghcCompact, hpc, compiler ]
-    contexts <- catMaybes <$> mapM (\p -> do
-                                        m <- expr $ latestBuildStage p
-                                        return $ fmap (\s -> vanillaContext s p) m
-                                   ) pkgs
+    contexts <- expr $ concatForM pkgs $ \p -> do
+        ss <- installStages p
+        return [ vanillaContext s p | s <- ss ]
     buildPaths <- expr $ mapM buildPath contexts
     return $ unlines
         [ "#!/bin/bash"
index aa21ab8..87bb894 100644 (file)
@@ -1,7 +1,7 @@
 module Settings (
     getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
     findPackageByName, getPkgData, getPkgDataList, isLibrary, stagePackages,
-    latestBuildStage, programContext, integerLibraryName, getDestDir
+    programContext, integerLibraryName, getDestDir
     ) where
 
 import CommandLine
@@ -61,13 +61,6 @@ knownPackages = sort $ ghcPackages ++ userPackages
 findPackageByName :: PackageName -> Maybe Package
 findPackageByName name = find (\pkg -> pkgName pkg == name) knownPackages
 
--- | Determine the latest 'Stage' in which a given 'Package' is built. Returns
--- Nothing if the package is never built.
-latestBuildStage :: Package -> Action (Maybe Stage)
-latestBuildStage pkg = do
-    stages <- filterM (fmap (pkg `elem`) . stagePackages) [Stage0 ..]
-    return $ if null stages then Nothing else Just $ maximum stages
-
 -- | Install's DESTDIR setting.
 getDestDir :: Action FilePath
 getDestDir = fromMaybe "" <$> cmdInstallDestDir