[commit: ghc] wip/nfs-locking: Add ghc-iserv wrapper (#367) (05b3ebe)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/05b3ebe6911890145c12bd8022b2cc11002de98c/ghc

>---------------------------------------------------------------

commit 05b3ebe6911890145c12bd8022b2cc11002de98c
Author: Zhen Zhang <izgzhen at gmail.com>
Date:   Tue Jul 18 23:12:22 2017 +0800

    Add ghc-iserv wrapper (#367)


>---------------------------------------------------------------

05b3ebe6911890145c12bd8022b2cc11002de98c
 src/GHC.hs            |  9 +++++----
 src/Rules/Program.hs  | 26 +++++++++++++++++++++++++-
 src/Rules/Wrappers.hs | 24 ++++++++++++++++++++++--
 src/Settings.hs       |  2 +-
 src/Settings/Path.hs  | 13 +++++++------
 5 files changed, 60 insertions(+), 14 deletions(-)

diff --git a/src/GHC.hs b/src/GHC.hs
index 0f5e2fb..ce88cb0 100644
--- a/src/GHC.hs
+++ b/src/GHC.hs
@@ -116,10 +116,11 @@ builderProvenance = \case
 -- 'Library', the function simply returns its name.
 programName :: Context -> String
 programName Context {..}
-    | package == ghc    = "ghc-stage" ++ show (fromEnum stage + 1)
-    | package == hpcBin = "hpc"
-    | package == runGhc = "runhaskell"
-    | otherwise         = pkgNameString package
+    | package == ghc      = "ghc-stage" ++ show (fromEnum stage + 1)
+    | package == hpcBin   = "hpc"
+    | package == runGhc   = "runhaskell"
+    | package == iservBin = "ghc-iserv"
+    | otherwise           = pkgNameString package
 
 -- | Some contexts are special: their packages do have @.cabal@ metadata or
 -- we cannot run @ghc-cabal@ on them, e.g. because the latter hasn't been built
diff --git a/src/Rules/Program.hs b/src/Rules/Program.hs
index 12e661b..8c9a7ab 100644
--- a/src/Rules/Program.hs
+++ b/src/Rules/Program.hs
@@ -34,11 +34,35 @@ buildProgram rs context at Context {..} = when (isProgram package) $ do
         inplaceBinPath -/- programName context <.> exe %> \bin -> do
             binStage <- installStage
             buildBinaryAndWrapper rs (context { stage = binStage }) bin
-        -- We build only unwrapped binaries in inplace/lib/bin
+
         inplaceLibBinPath -/- programName context <.> exe %> \bin -> do
             binStage <- installStage
+            if package /= iservBin then
+                -- We *normally* build only unwrapped binaries in inplace/lib/bin,
+                buildBinary rs (context { stage = binStage }) bin
+            else
+                -- build both binary and wrapper in inplace/lib/bin
+                -- for ghc-iserv on *nix platform now
+                buildBinaryAndWrapperLib rs (context { stage = binStage }) bin
+
+        inplaceLibBinPath -/- programName context <.> "bin" %> \bin -> do
+            binStage <- installStage
             buildBinary rs (context { stage = binStage }) bin
 
+buildBinaryAndWrapperLib :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+buildBinaryAndWrapperLib rs context bin = do
+    windows <- windowsHost
+    if windows
+    then buildBinary rs context bin -- We don't build wrappers on Windows
+    else case lookup context inplaceWrappers of
+        Nothing      -> buildBinary rs context bin -- No wrapper found
+        Just wrapper -> do
+            top <- topDirectory
+            let libdir = top -/- inplaceLibPath
+            let wrappedBin = inplaceLibBinPath -/- programName context <.> "bin"
+            need [wrappedBin]
+            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName wrappedBin))
+
 buildBinaryAndWrapper :: [(Resource, Int)] -> Context -> FilePath -> Action ()
 buildBinaryAndWrapper rs context bin = do
     windows <- windowsHost
diff --git a/src/Rules/Wrappers.hs b/src/Rules/Wrappers.hs
index 6adf3f7..7d90067 100644
--- a/src/Rules/Wrappers.hs
+++ b/src/Rules/Wrappers.hs
@@ -5,8 +5,9 @@ module Rules.Wrappers (
 import Base
 import Expression
 import GHC
+import Settings (getPackages, latestBuildStage)
 import Settings.Install (installPackageDbDirectory)
-import Settings.Path (inplacePackageDbDirectory)
+import Settings.Path (buildPath, inplacePackageDbDirectory)
 import Oracles.Path (getTopDirectory, bashPath)
 import Oracles.Config.Setting (SettingList(..), settingList)
 
@@ -117,13 +118,32 @@ haddockWrapper WrappedBinary{..} = do
     , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
       ++ " -B" ++ binaryLibPath ++ " -l" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
 
+iservBinWrapper :: WrappedBinary -> Expr String
+iservBinWrapper WrappedBinary{..} = do
+    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    activePackages <- filter isLibrary <$> getPackages
+    -- 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 <- lift $ latestBuildStage p
+                                        return $ fmap (\s -> vanillaContext s p) m
+                                   ) pkgs
+    let buildPaths = map buildPath contexts
+    return $ unlines
+        [ "#!/bin/bash"
+        , "export DYLD_LIBRARY_PATH=\"" ++ intercalate ":" buildPaths ++
+          "${DYLD_LIBRARY_PATH:+:$DYLD_LIBRARY_PATH}\""
+       , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
+
 wrappersCommon :: [(Context, Wrapper)]
 wrappersCommon = [ (vanillaContext Stage0 ghc   , ghcWrapper)
                  , (vanillaContext Stage1 ghc   , ghcWrapper)
                  , (vanillaContext Stage1 hp2ps , hp2psWrapper)
                  , (vanillaContext Stage1 hpc   , hpcWrapper)
                  , (vanillaContext Stage1 hsc2hs, hsc2hsWrapper)
-                 , (vanillaContext Stage2 haddock, haddockWrapper)]
+                 , (vanillaContext Stage2 haddock, haddockWrapper)
+                 , (vanillaContext Stage1 iservBin, iservBinWrapper) ]
 
 -- | List of wrappers for inplace artefacts
 inplaceWrappers :: [(Context, Wrapper)]
diff --git a/src/Settings.hs b/src/Settings.hs
index 8152a6e..2f75095 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -112,7 +112,7 @@ programPath context at Context {..} = do
     maybeLatest <- latestBuildStage package
     return $ do
         install <- (\l -> l == stage || package == ghc) <$> maybeLatest
-        let path = if install then installPath package else buildPath context
+        let path = if install then inplaceInstallPath package else buildPath context
         return $ path -/- programName context <.> exe
 
 pkgConfInstallPath :: FilePath
diff --git a/src/Settings/Path.hs b/src/Settings/Path.hs
index 8814620..1b0dc13 100644
--- a/src/Settings/Path.hs
+++ b/src/Settings/Path.hs
@@ -5,7 +5,7 @@ module Settings.Path (
     rtsContext, rtsBuildPath, rtsConfIn, shakeFilesPath,inplacePackageDbDirectory,
     pkgConfFile, packageDbStamp, bootPackageConstraints, packageDependencies,
     objectPath, inplaceBinPath, inplaceLibBinPath, inplaceLibPath,
-    installPath, autogenPath, pkgInplaceConfig, ghcSplitPath, stripCmdPath,
+    inplaceInstallPath, autogenPath, pkgInplaceConfig, ghcSplitPath, stripCmdPath,
     pkgSetupConfigFile
     ) where
 
@@ -190,11 +190,12 @@ objectPath context at Context {..} src
 
 -- | Given a 'Package', return the path where the corresponding program is
 -- installed. Most programs are installed in 'programInplacePath'.
-installPath :: Package -> FilePath
-installPath pkg
-    | pkg == touchy = inplaceLibBinPath
-    | pkg == unlit  = inplaceLibBinPath
-    | otherwise     = inplaceBinPath
+inplaceInstallPath :: Package -> FilePath
+inplaceInstallPath pkg
+    | pkg == touchy   = inplaceLibBinPath
+    | pkg == unlit    = inplaceLibBinPath
+    | pkg == iservBin = inplaceLibBinPath
+    | otherwise       = inplaceBinPath
 
 -- | @ghc-split@ is a Perl script used by GHC with @-split-objs@ flag. It is
 -- generated in "Rules.Generators.GhcSplit".