Refactor package-specific settings (#622)
[hadrian.git] / src / Rules / Generate.hs
index a3e95f1..c6be43a 100644 (file)
@@ -1,10 +1,9 @@
 module Rules.Generate (
-    isGeneratedCFile, isGeneratedCmmFile, generatePackageCode, generateRules,
-    copyRules, includesDependencies, generatedDependencies
+    isGeneratedCmmFile, generatePackageCode, generateRules, copyRules,
+    includesDependencies, generatedDependencies
     ) where
 
 import Base
-import Context hiding (package)
 import Expression
 import Flavour
 import GHC
@@ -25,13 +24,10 @@ primopsSource :: FilePath
 primopsSource = "compiler/prelude/primops.txt.pp"
 
 primopsTxt :: Stage -> FilePath
-primopsTxt stage = contextDir (vanillaContext stage compiler) -/- "primops.txt"
+primopsTxt stage = buildDir (vanillaContext stage compiler) -/- "primops.txt"
 
 platformH :: Stage -> FilePath
-platformH stage = contextDir (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"
@@ -59,14 +55,14 @@ compilerDependencies :: Expr [FilePath]
 compilerDependencies = do
     root    <- getBuildRoot
     stage   <- getStage
-    intLib  <- expr (integerLibrary =<< flavour)
+    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 ? intLib == integerGmp ? return [gmpPath -/- gmpLibraryH]
+            , notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH]
             , notStage0 ? return ((rtsPath -/-) <$> libffiDependencies)
             , return $ fmap (ghcPath -/-)
                   [ "primop-can-fail.hs-incl"
@@ -103,71 +99,94 @@ generate file context expr = do
     putSuccess $ "| Successfully generated " ++ file ++ "."
 
 generatePackageCode :: Context -> Rules ()
-generatePackageCode context@(Context stage pkg _) =
-    let dir         = contextDir context
-        generated f = ("//" ++ dir ++ "//*.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) $ "//" -/- dir -/- "Config.hs" %> go generateConfigHs
-            when (pkg == ghcPkg) $ "//" -/- dir -/- "Version.hs" %> go generateVersionHs
-
-        -- TODO: needing platformH is ugly and fragile
-        when (pkg == compiler) $ do
-            "//" ++ primopsTxt stage %> \file -> do
-                root <- buildRoot
-                need $ [root -/- platformH stage, primopsSource]
-                    ++ fmap (root -/-) includesDependencies
-                build $ target context HsCpp [primopsSource] [file]
-
-            "//" ++ platformH stage %> go generateGhcBootPlatformH
-
-        -- TODO: why different folders for generated files?
-        priority 2.0 $ fmap (("//" ++ dir) -/-)
-            [ "GHC/Prim.hs"
-            , "GHC/PrimopWrappers.hs"
-            , "*.hs-incl" ] |%> \file -> do
-                root <- buildRoot
-                need [root -/- primopsTxt stage]
-                build $ target context GenPrimopCode [root -/- primopsTxt stage] [file]
-
-        when (pkg == rts) $ "//" ++ dir -/- "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")     <~ return "driver"
-    (inplaceLibPath -/- "ghci-usage.txt"  )  <~ return "driver"
-    (inplaceLibPath -/- "platformConstants") <~ (buildRoot <&> (-/- generatedDir))
-    (inplaceLibPath -/- "settings")          <~ return "."
-    (inplaceLibPath -/- "template-hsc.h")    <~ return (pkgPath hsc2hs)
-    "//c/sm/Evac_thr.c" %> copyFile (pkgPath rts -/- "sm/Evac.c")
-    "//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
+    infixl 1 <~
     pattern <~ mdir = pattern %> \file -> do
         dir <- mdir
         copyFile (dir -/- takeFileName file) file
 
 generateRules :: Rules ()
 generateRules = do
-    priority 2.0 $ ("//" ++ generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
-    priority 2.0 $ ("//" ++ generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
-    priority 2.0 $ ("//" ++ generatedDir -/-  "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
-    "//" ++ generatedDir ++ "//*" %> \file -> do
+    root -/- generatedDir ++ "//*" %> \file -> do
         withTempDir $ \dir -> build $
             target rtsContext DeriveConstants [] [file, dir]
   where
@@ -219,7 +238,7 @@ generateGhcPlatformH = do
     targetArch     <- getSetting TargetArch
     targetOs       <- getSetting TargetOs
     targetVendor   <- getSetting TargetVendor
-    ghcUnreg       <- expr $ flag GhcUnregisterised
+    ghcUnreg       <- getFlag    GhcUnregisterised
     return . unlines $
         [ "#ifndef __GHCPLATFORM_H__"
         , "#define __GHCPLATFORM_H__"
@@ -270,12 +289,12 @@ generateConfigHs = do
     cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
     cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
     cBooterVersion      <- getSetting GhcVersion
-    intLib              <- expr (integerLibrary =<< flavour)
+    intLib              <- getIntegerPackage
     debugged            <- ghcDebugged    <$> expr flavour
     let cIntegerLibraryType
             | intLib == integerGmp    = "IntegerGMP"
             | intLib == integerSimple = "IntegerSimple"
-            | otherwise = error $ "Unknown integer library: " ++ pkgNameString intLib
+            | otherwise = error $ "Unknown integer library: " ++ pkgName intLib
     cSupportsSplitObjs         <- expr $ yesNo <$> supportsSplitObjects
     cGhcWithInterpreter        <- expr $ yesNo <$> ghcWithInterpreter
     cGhcWithNativeCodeGen      <- expr $ yesNo <$> ghcWithNativeCodeGen
@@ -285,12 +304,14 @@ generateConfigHs = do
     cGHC_UNLIT_PGM             <- fmap takeFileName $ getBuilderPath Unlit
     cLibFFI                    <- expr useLibFFIForAdjustors
     rtsWays                    <- getRtsWays
-    cGhcRtsWithLibdw           <- expr $ flag WithLibdw
+    cGhcRtsWithLibdw           <- getFlag WithLibdw
     let cGhcRTSWays = unwords $ map show rtsWays
     return $ unlines
         [ "{-# LANGUAGE CPP #-}"
         , "module Config where"
         , ""
+        , "import GhcPrelude"
+        , ""
         , "#include \"ghc_boot_platform.h\""
         , ""
         , "data IntegerLibrary = IntegerGMP"
@@ -323,7 +344,7 @@ generateConfigHs = do
         , "cStage                :: String"
         , "cStage                = show (STAGE :: Int)"
         , "cIntegerLibrary       :: String"
-        , "cIntegerLibrary       = " ++ show (pkgNameString intLib)
+        , "cIntegerLibrary       = " ++ show (pkgName intLib)
         , "cIntegerLibraryType   :: IntegerLibrary"
         , "cIntegerLibraryType   = " ++ cIntegerLibraryType
         , "cSupportsSplitObjs    :: String"
@@ -347,7 +368,7 @@ generateConfigHs = do
         , "cLibFFI               :: Bool"
         , "cLibFFI               = " ++ show cLibFFI
         , "cGhcThreaded :: Bool"
-        , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
+        , "cGhcThreaded = " ++ show (any (wayUnit Threaded) rtsWays)
         , "cGhcDebugged :: Bool"
         , "cGhcDebugged = " ++ show debugged
         , "cGhcRtsWithLibdw :: Bool"
@@ -359,7 +380,7 @@ generateGhcAutoconfH = do
     trackGenerateHs
     configHContents  <- expr $ map undefinePackage <$> readFileLines configH
     tablesNextToCode <- expr ghcEnableTablesNextToCode
-    ghcUnreg         <- expr $ flag GhcUnregisterised
+    ghcUnreg         <- getFlag    GhcUnregisterised
     ccLlvmBackend    <- getSetting CcLlvmBackend
     ccClangBackend   <- getSetting CcClangBackend
     return . unlines $
@@ -395,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
@@ -415,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"