[commit: ghc] wip/nfs-locking: Refactor discovery of generated dependencies (bb43f24)

git at git.haskell.org git at git.haskell.org
Fri Oct 27 01:11:10 UTC 2017


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

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

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

commit bb43f249ba63559f988fedac9b5180bfdc28d1cf
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Fri Oct 21 01:30:10 2016 +0100

    Refactor discovery of generated dependencies
    
    See #285, #267.


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

bb43f249ba63559f988fedac9b5180bfdc28d1cf
 src/Builder.hs              |  8 ++----
 src/Rules/Compile.hs        | 59 +++++++++++++++++++++++----------------------
 src/Rules/Generate.hs       | 17 +------------
 src/Settings/Builders/Cc.hs | 12 ++-------
 4 files changed, 35 insertions(+), 61 deletions(-)

diff --git a/src/Builder.hs b/src/Builder.hs
index 09b87cb..860034e 100644
--- a/src/Builder.hs
+++ b/src/Builder.hs
@@ -20,12 +20,8 @@ import Stage
 -- 1) Compiling sources into object files.
 -- 2) Extracting source dependencies, e.g. by passing -M command line argument.
 -- 3) Linking object files & static libraries into an executable.
--- We have CcMode for CC and GhcMode for GHC.
-
--- TODO: Consider merging FindCDependencies and FindMissingInclude
-data CcMode = CompileC | FindCDependencies | FindMissingInclude
-    deriving (Eq, Generic, Show)
-
+-- We have CcMode for C compiler and GhcMode for GHC.
+data CcMode  = CompileC  | FindCDependencies deriving (Eq, Generic, Show)
 data GhcMode = CompileHs | FindHsDependencies | LinkHs
     deriving (Eq, Generic, Show)
 
diff --git a/src/Rules/Compile.hs b/src/Rules/Compile.hs
index 535758c..285abe0 100644
--- a/src/Rules/Compile.hs
+++ b/src/Rules/Compile.hs
@@ -1,5 +1,7 @@
 module Rules.Compile (compilePackage) where
 
+import Development.Shake.Util
+
 import Base
 import Context
 import Expression
@@ -9,21 +11,14 @@ import Rules.Generate
 import Settings.Paths
 import Target
 
-import Development.Shake.Util
-
-import qualified Data.Set as Set
-
 compilePackage :: [(Resource, Int)] -> Context -> Rules ()
 compilePackage rs context at Context {..} = do
     let path            = buildPath context
         nonHs extension = path </> extension <//> "*" <.> osuf way
         compile compiler obj2src obj = do
-            let depFile = obj -<.> "d"
-                src     = obj2src context obj
+            let src = obj2src context obj
             need [src]
-            needGenerated context src
-            build $ Target context (Cc FindCDependencies stage) [src] [depFile]
-            needMakefileDependencies depFile -- TODO: Is this actually needed?
+            needDependencies context src $ obj <.> "d"
             build $ Target context (compiler stage) [src] [obj]
         compileHs = \[obj, _] -> do
             (src, deps) <- fileDependencies context obj
@@ -41,28 +36,27 @@ compilePackage rs context at Context {..} = do
     [ path <//> "*" <.> suf way | suf <- [    osuf,     hisuf] ] &%> compileHs
     [ path <//> "*" <.> suf way | suf <- [obootsuf, hibootsuf] ] &%> compileHs
 
--- TODO: Simplify.
-needGenerated :: Context -> FilePath -> Action ()
-needGenerated context origFile = go Set.empty
+-- | Discover dependencies of a given source file by iteratively calling @gcc@
+-- in the @-MM -MG@ mode and building generated dependencies if they are missing
+-- until reaching a fixed point.
+needDependencies :: Context -> FilePath -> FilePath -> Action ()
+needDependencies context at Context {..} src depFile = discover
   where
-    go :: Set.Set String -> Action ()
-    go done = withTempFile $ \outFile -> do
-        let builder = Cc FindMissingInclude $ stage context
-            target = Target context builder [origFile] [outFile]
-        build target
-        deps <- parseFile outFile
-
-        -- Get the full path if the include refers to a generated file and call
-        -- `need` on it.
-        needed <- liftM catMaybes $
-            interpretInContext context (mapM getPathIfGenerated deps)
-        need needed
+    discover = do
+        build $ Target context (Cc FindCDependencies stage) [src] [depFile]
+        deps <- parseFile depFile
+        -- Generated dependencies, if not yet built, will not be found and hence
+        -- will be referred to simply by their file names.
+        let notFound = filter (\file -> file == takeFileName file) deps
+        -- We find the full paths to generated dependencies, so we can request
+        -- to build them by calling 'need'.
+        todo <- catMaybes <$> mapM (fullPathIfGenerated context) notFound
 
-        let newdone = Set.fromList needed `Set.union` done
-        -- If we added a new file to the set of needed files, let's try one more
-        -- time, since the new file might include a genreated header of itself
-        -- (which we'll `need`).
-        when (Set.size newdone > Set.size done) (go newdone)
+        if null todo
+        then need deps -- The list of dependencies is final, need all
+        else do
+            need todo  -- Build newly discovered generated dependencies
+            discover   -- Continue the discovery process
 
     parseFile :: FilePath -> Action [String]
     parseFile file = do
@@ -71,6 +65,13 @@ needGenerated context origFile = go Set.empty
             [(_file, deps)] -> return deps
             _               -> return []
 
+-- | Find a given 'FilePath' in the list of generated files in the given
+-- 'Context' and return its full path.
+fullPathIfGenerated :: Context -> FilePath -> Action (Maybe FilePath)
+fullPathIfGenerated context file = interpretInContext context $ do
+    generated <- generatedDependencies
+    return $ find ((== file) . takeFileName) generated
+
 obj2src :: String -> (FilePath -> Bool) -> Context -> FilePath -> FilePath
 obj2src extension isGenerated context at Context {..} obj
     | isGenerated src = src
diff --git a/src/Rules/Generate.hs b/src/Rules/Generate.hs
index ceeb182..bfede1a 100644
--- a/src/Rules/Generate.hs
+++ b/src/Rules/Generate.hs
@@ -1,7 +1,6 @@
 module Rules.Generate (
     isGeneratedCFile, isGeneratedCmmFile, generatePackageCode, generateRules,
-    installTargets, copyRules, includesDependencies, generatedDependencies,
-    getPathIfGenerated
+    installTargets, copyRules, includesDependencies, generatedDependencies
     ) where
 
 import qualified System.Directory as IO
@@ -199,17 +198,3 @@ generateRules = do
 emptyTarget :: Context
 emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
                              (error "Rules.Generate.emptyTarget: unknown package")
-
-getPathIfGenerated :: FilePath -> Expr (Maybe FilePath)
-getPathIfGenerated include = do
-  generated <- generatedFiles
-  -- For includes of generated files, we cannot get the full path of the file
-  -- (since it might be included due to some include dir, i.e., through `-I`).
-  -- So here we try both the name and the path.
-  let nameOrPath (name, path) = include == name || include == path
-  return . fmap snd $ find nameOrPath generated
-
-generatedFiles :: Expr [(FilePath, FilePath)]
-generatedFiles = do
-  deps <- generatedDependencies
-  return [ (takeFileName fp, fp) | fp <- deps ]
diff --git a/src/Settings/Builders/Cc.hs b/src/Settings/Builders/Cc.hs
index 41a8466..595feab 100644
--- a/src/Settings/Builders/Cc.hs
+++ b/src/Settings/Builders/Cc.hs
@@ -21,19 +21,11 @@ ccBuilderArgs = builder Cc ? mconcat
         output <- getOutput
         mconcat [ arg "-E"
                 , arg "-MM"
+                , arg "-MG"
                 , arg "-MF"
                 , arg output
                 , arg "-MT"
                 , arg $ dropExtension output -<.> "o"
                 , arg "-x"
                 , arg "c"
-                , arg =<< getInput ]
-
-    , builder (Cc FindMissingInclude) ?
-        mconcat [ arg "-E"
-                , arg "-MM"
-                , arg "-MG"
-                , arg "-MF"
-                , arg =<< getOutput
-                , arg =<< getInput ]
-    ]
+                , arg =<< getInput ] ]



More information about the ghc-commits mailing list