1 files changed, 218 insertions, 24 deletions

diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs
index 4e85db2df6..74570a1556 100644
--- a/hadrian/src/Rules/Compile.hs
+++ b/hadrian/src/Rules/Compile.hs
@@ -1,39 +1,233 @@
 module Rules.Compile (compilePackage) where
 
+import Hadrian.BuildPath
 import Hadrian.Oracles.TextFile
 
 import Base
 import Context
 import Expression
 import Rules.Generate
+import Settings
+import Settings.Default
 import Target
 import Utilities
 
-compilePackage :: [(Resource, Int)] -> Context -> Rules ()
-compilePackage rs context@Context {..} = do
+import qualified Text.Parsec as Parsec
+
+-- * Rules for building objects and Haskell interface files
+
+compilePackage :: [(Resource, Int)] -> Rules ()
+compilePackage rs = do
     root <- buildRootRules
-    let dir             = root -/- buildDir context
-        nonHs extension = dir -/- extension <//> "*" <.> osuf way
-        compile compiler obj2src obj = do
-            src <- obj2src context obj
-            need [src]
-            needDependencies context src $ obj <.> "d"
-            buildWithResources rs $ target context (compiler stage) [src] [obj]
-        compileHs = \[obj, _hi] -> do
-            path <- contextPath context
-            (src, deps) <- lookupDependencies (path -/- ".dependencies") obj
-            need $ src : deps
-            needLibrary =<< contextDependencies context
-            buildWithResources rs $ target context (Ghc CompileHs stage) [src] [obj]
-
-    priority 2.0 $ do
-        nonHs "c"   %> compile (Ghc CompileCWithGhc) (obj2src "c"   $ const False     )
-        nonHs "cmm" %> compile (Ghc CompileHs)       (obj2src "cmm" isGeneratedCmmFile)
-        nonHs "s"   %> compile (Ghc CompileHs)       (obj2src "S"   $ const False     )
-
-    -- TODO: Add dependencies for #include of .h and .hs-incl files (gcc -MM?).
-    [ dir <//> "*" <.> suf way | suf <- [    osuf,     hisuf] ] &%> compileHs
-    [ dir <//> "*" <.> suf way | suf <- [obootsuf, hibootsuf] ] &%> compileHs
+
+    -- We match all file paths that look like:
+    --   <root>/...stuffs.../build/...stuffs.../<something>.<suffix>
+    --
+    -- where:
+    --   - the '...stuffs...' bits can be one or more path components,
+    --   - the '<suffix>' part is a way prefix (e.g thr_p_, or nothing if
+    --     vanilla) followed by an object file extension, without the dot
+    --     (o, o-boot, hi, hi-boot),
+    --
+    -- and parse the information we need (stage, package path, ...) from
+    -- the path and figure out the suitable way to produce that object file.
+    objectFilesUnder root |%> \path -> do
+      obj <- parsePath (parseBuildObject root) "<object file path parser>" path
+      compileObject rs path obj
+
+  where
+    objectFilesUnder r = [ r -/- ("**/build/**/*" ++ pat)
+                         | pat <- extensionPats
+                         ]
+
+    exts = [ "o", "hi", "o-boot", "hi-boot" ]
+    patternsFor e = [ "." ++ e, ".*_" ++ e ]
+    extensionPats = concatMap patternsFor exts
+
+-- * Object file paths types and parsers
+
+{- We are using a non uniform representation that separates
+   object files produced from Haskell code and from other
+   languages, because the two "groups" have to be parsed
+   differently enough that this would complicated the parser
+   significantly.
+
+   Indeed, non-Haskell files can only produce .o (or .thr_o, ...)
+   files while Haskell modules can produce those as well as
+   interface files, both in -boot or non-boot variants.
+
+   Moreover, non-Haskell object files live under:
+     <root>/stage<N>/<path/to/pkg>/build/{c,cmm,s}/
+
+   while Haskell object/interface files live under:
+     <root>/stage<N>/<path/to/pkg>/build/
+
+   So the kind of object is partially determined by
+   whether we're in c/, cmm/ or s/ but also by the
+   object file's extension, in the case of a Haskell file.
+   This could have been addressed with some knot-tying but
+   Parsec's monad doesn't give us a MonadFix instance.
+
+   We therefore stick to treating those two type of object
+   files non uniformly.
+-}
+
+-- | Non Haskell source languages that we compile to get object files.
+data SourceLang = Asm | C | Cmm
+  deriving (Eq, Show)
+
+parseSourceLang :: Parsec.Parsec String () SourceLang
+parseSourceLang = Parsec.choice
+  [ Parsec.char 'c' *> Parsec.choice
+      [ Parsec.string "mm" *> pure Cmm
+      , pure C
+      ]
+  , Parsec.char 's' *> pure Asm
+  ]
+
+type Basename = String
+
+parseBasename :: Parsec.Parsec String () Basename
+parseBasename = Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.char '.')
+
+-- | > <c|cmm|s>/<file>.<way prefix>_o
+data NonHsObject = NonHsObject SourceLang Basename Way
+  deriving (Eq, Show)
+
+parseNonHsObject :: Parsec.Parsec String () NonHsObject
+parseNonHsObject = do
+  lang <- parseSourceLang
+  _ <- Parsec.char '/'
+  file <- parseBasename
+  way <- parseWayPrefix vanilla
+  _ <- Parsec.char 'o'
+  return (NonHsObject lang file way)
+
+-- | > <o|hi|o-boot|hi-boot>
+data SuffixType = O | Hi | OBoot | HiBoot
+  deriving (Eq, Show)
+
+parseSuffixType :: Parsec.Parsec String () SuffixType
+parseSuffixType = Parsec.choice
+  [ Parsec.char 'o' *> Parsec.choice
+      [ Parsec.string "-boot" *> pure OBoot
+      , pure O
+      ]
+  , Parsec.string "hi" *> Parsec.choice
+      [ Parsec.string "-boot" *> pure HiBoot
+      , pure Hi
+      ]
+  ]
+
+-- | > <way prefix>_<o|hi|o-boot|hi-boot>
+data Extension = Extension Way SuffixType
+  deriving (Eq, Show)
+
+parseExtension :: Parsec.Parsec String () Extension
+parseExtension =
+  Extension <$> parseWayPrefix vanilla <*> parseSuffixType
+
+-- | > <file>.<way prefix>_<o|hi|o-boot|hi-boot>
+data HsObject = HsObject Basename Extension
+  deriving (Eq, Show)
+
+parseHsObject :: Parsec.Parsec String () HsObject
+parseHsObject = do
+  file <- parseBasename
+  ext <- parseExtension
+  return (HsObject file ext)
+
+data Object = Hs HsObject | NonHs NonHsObject
+  deriving (Eq, Show)
+
+parseObject :: Parsec.Parsec String () Object
+parseObject = Parsec.choice
+  [ NonHs <$> parseNonHsObject
+  , Hs    <$> parseHsObject
+  ]
+
+-- * Toplevel parsers
+
+parseBuildObject :: FilePath -> Parsec.Parsec String () (BuildPath Object)
+parseBuildObject root = parseBuildPath root parseObject
+
+-- * Getting contexts from objects
+
+objectContext :: BuildPath Object -> Action Context
+objectContext (BuildPath _ stage pkgpath obj) = do
+  pkg <- getPackageFromPath pkgpath
+  return (Context stage pkg way)
+
+  where way = case obj of
+          NonHs (NonHsObject _lang _file w)      -> w
+          Hs (HsObject _file (Extension w _suf)) -> w
+
+        getPackageFromPath path = do
+          pkgs <- getPackages
+          case filter (\p -> pkgPath p == path) pkgs of
+            (p:_) -> return p
+            _     -> error $ "couldn't find a package with path: " ++ path
+
+        getPackages = do
+          pkgs <- stagePackages stage
+          testPkgs <- testsuitePackages
+          return $ pkgs ++ if stage == Stage1 then testPkgs else []
+
+-- * Building an object
+
+compileHsObject
+  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> HsObject -> Action ()
+compileHsObject rs objpath b@(BuildPath _root stage _path _o) hsobj =
+  case hsobj of
+    HsObject _basename (Extension _way Hi)     ->
+      need [ change "hi" "o" objpath ]
+    HsObject _basename (Extension _way HiBoot) ->
+      need [ change "hi-boot" "o-boot" objpath ]
+    HsObject _basename (Extension _way _suf)   -> do
+      ctx <- objectContext b
+      ctxPath <- contextPath ctx
+      (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
+      need (src:deps)
+      needLibrary =<< contextDependencies ctx
+      buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
+
+  where change oldSuffix newSuffix str
+          | not (oldSuffix `isSuffixOf` str) = error $
+              "compileHsObject.change: " ++ oldSuffix ++
+              " not a suffix of " ++ str
+          | otherwise = take (length str - length oldSuffix) str
+                     ++ newSuffix
+
+compileNonHsObject
+  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> NonHsObject
+  -> Action ()
+compileNonHsObject rs objpath b@(BuildPath _root stage _path _o) nonhsobj =
+  case nonhsobj of
+    NonHsObject lang _basename _way ->
+      go (builderFor lang) (toSrcFor lang)
+
+  where builderFor C = Ghc CompileCWithGhc
+        builderFor _ = Ghc CompileHs
+
+        toSrcFor Asm = obj2src "S"   (const False)
+        toSrcFor C   = obj2src "c"   (const False)
+        toSrcFor Cmm = obj2src "cmm" isGeneratedCmmFile
+
+        go builder tosrc = do
+          ctx <- objectContext b
+          src <- tosrc ctx objpath
+          need [src]
+          needDependencies ctx src (objpath <.> "d")
+          buildWithResources rs $ target ctx (builder stage) [src] [objpath]
+
+compileObject
+  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> Action ()
+compileObject rs objpath b@(BuildPath _root _stage _path (Hs o)) =
+  compileHsObject rs objpath b o
+compileObject rs objpath b@(BuildPath _root _stage _path (NonHs o)) =
+  compileNonHsObject rs objpath b o
+
+-- * Helpers
 
 -- | Discover dependencies of a given source file by iteratively calling @gcc@
 -- in the @-MM -MG@ mode and building generated dependencies if they are missing