Refactor package-specific settings (#622)
[hadrian.git] / src / Rules / Generate.hs
index 14fbca4..c6be43a 100644 (file)
@@ -1,24 +1,20 @@
 module Rules.Generate (
-    isGeneratedCFile, isGeneratedCmmFile, generatePackageCode, generateRules,
-    copyRules, includesDependencies, generatedDependencies
+    isGeneratedCmmFile, generatePackageCode, generateRules, copyRules,
+    includesDependencies, generatedDependencies
     ) where
 
-import Hadrian.Utilities
-
 import Base
-import Context hiding (package)
 import Expression
 import Flavour
 import GHC
-import Oracles.Config.Flag
-import Oracles.Config.Setting
+import Oracles.Flag
 import Oracles.ModuleFiles
+import Oracles.Setting
+import Rules.Gmp
 import Rules.Libffi
 import Settings
-import Settings.Path
 import Target
-import UserSettings
-import Util
+import Utilities
 
 -- | Track this file to rebuild generated files whenever it changes.
 trackGenerateHs :: Expr ()
@@ -28,19 +24,16 @@ primopsSource :: FilePath
 primopsSource = "compiler/prelude/primops.txt.pp"
 
 primopsTxt :: Stage -> FilePath
-primopsTxt stage = buildPath (vanillaContext stage compiler) -/- "primops.txt"
+primopsTxt stage = buildDir (vanillaContext stage compiler) -/- "primops.txt"
 
 platformH :: Stage -> FilePath
-platformH stage = buildPath (vanillaContext stage compiler) -/- "ghc_boot_platform.h"
-
-isGeneratedCFile :: FilePath -> Bool
-isGeneratedCFile file = takeBaseName file `elem` ["Evac_thr", "Scav_thr"]
+platformH stage = buildDir (vanillaContext stage compiler) -/- "ghc_boot_platform.h"
 
 isGeneratedCmmFile :: FilePath -> Bool
 isGeneratedCmmFile file = takeBaseName file == "AutoApply"
 
 includesDependencies :: [FilePath]
-includesDependencies = fmap (generatedPath -/-)
+includesDependencies = fmap (generatedDir -/-)
     [ "ghcautoconf.h"
     , "ghcplatform.h"
     , "ghcversion.h" ]
@@ -48,11 +41,11 @@ includesDependencies = fmap (generatedPath -/-)
 ghcPrimDependencies :: Expr [FilePath]
 ghcPrimDependencies = do
     stage <- getStage
-    let path = buildPath $ vanillaContext stage ghcPrim
+    path  <- expr $ buildPath (vanillaContext stage ghcPrim)
     return [path -/- "GHC/Prim.hs", path -/- "GHC/PrimopWrappers.hs"]
 
 derivedConstantsDependencies :: [FilePath]
-derivedConstantsDependencies = fmap (generatedPath -/-)
+derivedConstantsDependencies = fmap (generatedDir -/-)
     [ "DerivedConstants.h"
     , "GHCConstantsHaskellExports.hs"
     , "GHCConstantsHaskellType.hs"
@@ -60,14 +53,18 @@ derivedConstantsDependencies = fmap (generatedPath -/-)
 
 compilerDependencies :: Expr [FilePath]
 compilerDependencies = do
-    stage <- getStage
-    let path = buildPath $ vanillaContext stage compiler
-    mconcat [ return [platformH stage]
-            , return includesDependencies
-            , return derivedConstantsDependencies
-            , notStage0 ? integerLibrary flavour == integerGmp ? return [gmpLibraryH]
-            , notStage0 ? return libffiDependencies
-            , return $ fmap (path -/-)
+    root    <- getBuildRoot
+    stage   <- getStage
+    isGmp   <- (== integerGmp) <$> getIntegerPackage
+    ghcPath <- expr $ buildPath (vanillaContext stage compiler)
+    gmpPath <- expr gmpBuildPath
+    rtsPath <- expr rtsBuildPath
+    mconcat [ return [root -/- platformH stage]
+            , return ((root -/-) <$> includesDependencies)
+            , return ((root -/-) <$> derivedConstantsDependencies)
+            , notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH]
+            , notStage0 ? return ((rtsPath -/-) <$> libffiDependencies)
+            , return $ fmap (ghcPath -/-)
                   [ "primop-can-fail.hs-incl"
                   , "primop-code-size.hs-incl"
                   , "primop-commutable.hs-incl"
@@ -85,13 +82,15 @@ compilerDependencies = do
                   , "primop-vector-uniques.hs-incl" ] ]
 
 generatedDependencies :: Expr [FilePath]
-generatedDependencies = mconcat
-    [ package compiler ? compilerDependencies
-    , package ghcPrim  ? ghcPrimDependencies
-    , package rts      ? return (libffiDependencies
-        ++ includesDependencies
-        ++ derivedConstantsDependencies)
-    , stage0 ? return includesDependencies ]
+generatedDependencies = do
+    root    <- getBuildRoot
+    rtsPath <- expr rtsBuildPath
+    mconcat [ package compiler ? compilerDependencies
+            , package ghcPrim  ? ghcPrimDependencies
+            , package rts      ? return (fmap (rtsPath -/-) libffiDependencies
+                ++ fmap (root -/-) includesDependencies
+                ++ fmap (root -/-) derivedConstantsDependencies)
+            , stage0 ? return (fmap (root -/-) includesDependencies) ]
 
 generate :: FilePath -> Context -> Expr String -> Action ()
 generate file context expr = do
@@ -100,66 +99,94 @@ generate file context expr = do
     putSuccess $ "| Successfully generated " ++ file ++ "."
 
 generatePackageCode :: Context -> Rules ()
-generatePackageCode context@(Context stage pkg _) =
-    let path        = buildPath context
-        generated f = (path ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
+generatePackageCode context@(Context stage pkg _) = do
+    root <- buildRootRules
+    let dir         = buildDir context
+        generated f = (root -/- dir ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
         go gen file = generate file context gen
-    in do
-        generated ?> \file -> do
-            let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
-            (src, builder) <- unpack <$> findGenerator context file
-            need [src]
-            build $ target context builder [src] [file]
-            let boot = src -<.> "hs-boot"
-            whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot"
-
-        priority 2.0 $ do
-            when (pkg == compiler) $ path -/- "Config.hs" %> go generateConfigHs
-            when (pkg == ghcPkg) $ path -/- "Version.hs" %> go generateVersionHs
-
-        -- TODO: needing platformH is ugly and fragile
-        when (pkg == compiler) $ do
-            primopsTxt stage %> \file -> do
-                need $ [platformH stage, primopsSource] ++ includesDependencies
-                build $ target context HsCpp [primopsSource] [file]
-
-            platformH stage %> go generateGhcBootPlatformH
-
-        -- TODO: why different folders for generated files?
-        fmap (path -/-)
-            [ "GHC/Prim.hs"
-            , "GHC/PrimopWrappers.hs"
-            , "*.hs-incl" ] |%> \file -> do
-                need [primopsTxt stage]
-                build $ target context GenPrimopCode [primopsTxt stage] [file]
-
-        when (pkg == rts) $ path -/- "cmm/AutoApply.cmm" %> \file ->
+    generated ?> \file -> do
+        let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
+        (src, builder) <- unpack <$> findGenerator context file
+        need [src]
+        build $ target context builder [src] [file]
+        let boot = src -<.> "hs-boot"
+        whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot"
+
+    priority 2.0 $ do
+        when (pkg == compiler) $ do root <//> dir -/- "Config.hs" %> go generateConfigHs
+                                    root <//> dir -/- "*.hs-incl" %> genPrimopCode context
+        when (pkg == ghcPrim) $ do (root <//> dir -/- "GHC/Prim.hs") %> genPrimopCode context
+                                   (root <//> dir -/- "GHC/PrimopWrappers.hs") %> genPrimopCode context
+        when (pkg == ghcPkg) $ do root <//> dir -/- "Version.hs" %> go generateVersionHs
+
+    -- TODO: needing platformH is ugly and fragile
+    when (pkg == compiler) $ do
+        root -/- primopsTxt stage %> \file -> do
+            root <- buildRoot
+            need $ [ root -/- platformH stage
+                   , primopsSource]
+                ++ fmap (root -/-) includesDependencies
+            build $ target context HsCpp [primopsSource] [file]
+
+        -- only generate this once! Until we have the include logic fixed.
+        -- See the note on `platformH`
+        when (stage == Stage0) $ do
+            root <//> "compiler/ghc_boot_platform.h" %> go generateGhcBootPlatformH
+        root <//> platformH stage %> go generateGhcBootPlatformH
+
+    when (pkg == rts) $ do
+        root <//> dir -/- "cmm/AutoApply.cmm" %> \file ->
             build $ target context GenApply [] [file]
+        -- XXX: this should be fixed properly, e.g. generated here on demand.
+        (root <//> dir -/- "DerivedConstants.h") <~ (buildRoot <&> (-/- generatedDir))
+        (root <//> dir -/- "ghcautoconf.h") <~ (buildRoot <&> (-/- generatedDir))
+        (root <//> dir -/- "ghcplatform.h") <~ (buildRoot <&> (-/- generatedDir))
+        (root <//> dir -/- "ghcversion.h") <~ (buildRoot <&> (-/- generatedDir))
+    when (pkg == integerGmp) $ do
+        (root <//> dir -/- "ghc-gmp.h") <~ (buildRoot <&> (-/- "include"))
+ where
+    pattern <~ mdir = pattern %> \file -> do
+        dir <- mdir
+        copyFile (dir -/- takeFileName file) file
+
+genPrimopCode :: Context -> FilePath -> Action ()
+genPrimopCode context@(Context stage _pkg _) file = do
+    root <- buildRoot
+    need [root -/- primopsTxt stage]
+    build $ target context GenPrimopCode [root -/- primopsTxt stage] [file]
 
 copyRules :: Rules ()
 copyRules = do
-    (inplaceLibPath -/- "ghc-usage.txt")     <~ "driver"
-    (inplaceLibPath -/- "ghci-usage.txt"  )  <~ "driver"
-    (inplaceLibPath -/- "platformConstants") <~ generatedPath
-    (inplaceLibPath -/- "settings")          <~ "."
-    (inplaceLibPath -/- "template-hsc.h")    <~ pkgPath hsc2hs
-    rtsBuildPath -/- "c/sm/Evac_thr.c" %> copyFile (pkgPath rts -/- "sm/Evac.c")
-    rtsBuildPath -/- "c/sm/Scav_thr.c" %> copyFile (pkgPath rts -/- "sm/Scav.c")
+    root <- buildRootRules
+    forM_ [Stage0 ..] $ \stage -> do
+        let prefix = root -/- stageString stage -/- "lib"
+        prefix -/- "ghc-usage.txt"     <~ return "driver"
+        prefix -/- "ghci-usage.txt"    <~ return "driver"
+        prefix -/- "llvm-targets"      <~ return "."
+        prefix -/- "llvm-passes"       <~ return "."
+        prefix -/- "platformConstants" <~ (buildRoot <&> (-/- generatedDir))
+        prefix -/- "settings"          <~ return "."
+        prefix -/- "template-hsc.h"    <~ return (pkgPath hsc2hs)
   where
-    file <~ dir = file %> copyFile (dir -/- takeFileName file)
+    infixl 1 <~
+    pattern <~ mdir = pattern %> \file -> do
+        dir <- mdir
+        copyFile (dir -/- takeFileName file) file
 
 generateRules :: Rules ()
 generateRules = do
-    (generatedPath -/- "ghcautoconf.h") <~ generateGhcAutoconfH
-    (generatedPath -/- "ghcplatform.h") <~ generateGhcPlatformH
-    (generatedPath -/-  "ghcversion.h") <~ generateGhcVersionH
+    root <- buildRootRules
+    priority 2.0 $ (root -/- generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
+    priority 2.0 $ (root -/- generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
+    priority 2.0 $ (root -/- generatedDir -/-  "ghcversion.h") <~ generateGhcVersionH
 
-    ghcSplitPath %> \_ -> do
-        generate ghcSplitPath emptyTarget generateGhcSplit
-        makeExecutable ghcSplitPath
+    forM_ [Stage0 ..] $ \stage ->
+        root -/- ghcSplitPath stage %> \path -> do
+            generate path emptyTarget generateGhcSplit
+            makeExecutable path
 
     -- TODO: simplify, get rid of fake rts context
-    generatedPath ++ "//*" %> \file -> do
+    root -/- generatedDir ++ "//*" %> \file -> do
         withTempDir $ \dir -> build $
             target rtsContext DeriveConstants [] [file, dir]
   where
@@ -211,7 +238,7 @@ generateGhcPlatformH = do
     targetArch     <- getSetting TargetArch
     targetOs       <- getSetting TargetOs
     targetVendor   <- getSetting TargetVendor
-    ghcUnreg       <- getFlag GhcUnregisterised
+    ghcUnreg       <- getFlag    GhcUnregisterised
     return . unlines $
         [ "#ifndef __GHCPLATFORM_H__"
         , "#define __GHCPLATFORM_H__"
@@ -262,10 +289,12 @@ generateConfigHs = do
     cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
     cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
     cBooterVersion      <- getSetting GhcVersion
+    intLib              <- getIntegerPackage
+    debugged            <- ghcDebugged    <$> expr flavour
     let cIntegerLibraryType
-            | integerLibrary flavour == integerGmp    = "IntegerGMP"
-            | integerLibrary flavour == integerSimple = "IntegerSimple"
-            | otherwise = error $ "Unknown integer library: " ++ integerLibraryName
+            | intLib == integerGmp    = "IntegerGMP"
+            | intLib == integerSimple = "IntegerSimple"
+            | otherwise = error $ "Unknown integer library: " ++ pkgName intLib
     cSupportsSplitObjs         <- expr $ yesNo <$> supportsSplitObjects
     cGhcWithInterpreter        <- expr $ yesNo <$> ghcWithInterpreter
     cGhcWithNativeCodeGen      <- expr $ yesNo <$> ghcWithNativeCodeGen
@@ -281,6 +310,8 @@ generateConfigHs = do
         [ "{-# LANGUAGE CPP #-}"
         , "module Config where"
         , ""
+        , "import GhcPrelude"
+        , ""
         , "#include \"ghc_boot_platform.h\""
         , ""
         , "data IntegerLibrary = IntegerGMP"
@@ -313,7 +344,7 @@ generateConfigHs = do
         , "cStage                :: String"
         , "cStage                = show (STAGE :: Int)"
         , "cIntegerLibrary       :: String"
-        , "cIntegerLibrary       = " ++ show integerLibraryName
+        , "cIntegerLibrary       = " ++ show (pkgName intLib)
         , "cIntegerLibraryType   :: IntegerLibrary"
         , "cIntegerLibraryType   = " ++ cIntegerLibraryType
         , "cSupportsSplitObjs    :: String"
@@ -337,9 +368,9 @@ generateConfigHs = do
         , "cLibFFI               :: Bool"
         , "cLibFFI               = " ++ show cLibFFI
         , "cGhcThreaded :: Bool"
-        , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
+        , "cGhcThreaded = " ++ show (any (wayUnit Threaded) rtsWays)
         , "cGhcDebugged :: Bool"
-        , "cGhcDebugged = " ++ show (ghcDebugged flavour)
+        , "cGhcDebugged = " ++ show debugged
         , "cGhcRtsWithLibdw :: Bool"
         , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
 
@@ -349,7 +380,7 @@ generateGhcAutoconfH = do
     trackGenerateHs
     configHContents  <- expr $ map undefinePackage <$> readFileLines configH
     tablesNextToCode <- expr ghcEnableTablesNextToCode
-    ghcUnreg         <- getFlag GhcUnregisterised
+    ghcUnreg         <- getFlag    GhcUnregisterised
     ccLlvmBackend    <- getSetting CcLlvmBackend
     ccClangBackend   <- getSetting CcClangBackend
     return . unlines $
@@ -385,6 +416,7 @@ generateGhcBootPlatformH = do
     hostVendor     <- chooseSetting HostVendor    TargetVendor
     targetPlatform <- getSetting TargetPlatform
     targetArch     <- getSetting TargetArch
+    llvmTarget     <- getSetting LlvmTarget
     targetOs       <- getSetting TargetOs
     targetVendor   <- getSetting TargetVendor
     return $ unlines
@@ -405,6 +437,7 @@ generateGhcBootPlatformH = do
         , "#define BUILD_ARCH "  ++ show buildArch
         , "#define HOST_ARCH "   ++ show hostArch
         , "#define TARGET_ARCH " ++ show targetArch
+        , "#define LLVM_TARGET " ++ show llvmTarget
         , ""
         , "#define " ++ buildOs  ++ "_BUILD_OS 1"
         , "#define " ++ hostOs   ++ "_HOST_OS 1"