1 2{- 3 Hake: a meta build system for Barrelfish 4 5 Copyright (c) 2009, 2015, ETH Zurich. 6 All rights reserved. 7 8 This file is distributed under the terms in the attached LICENSE file. 9 If you do not find this file, copies can be found by writing to: 10 ETH Zurich D-INFK, Universitaetstasse 6, CH-8092 Zurich. Attn: Systems Group. 11-} 12 13 14 15-- Asynchronous IO for walking directories 16import Control.Concurrent.Async 17import Control.DeepSeq 18 19import Control.Exception.Base 20import Control.Monad 21 22import Exception 23 24import Data.Dynamic 25import Data.List 26import Data.Maybe 27import Data.Char 28import qualified Data.Set as S 29import qualified Data.Map.Strict as Map 30 31import System.Directory 32import System.Environment 33import System.Exit 34import System.FilePath 35import System.IO 36import Debug.Trace 37 38-- The GHC API. We use the mtl-compatible version in order to use liftIO 39-- within the GHC monad. 40import GHC hiding (Target, Ghc, runGhc, FunBind, Match) 41import GHC.Paths (libdir) 42import Control.Monad.Ghc 43 44-- We parse and pretty-print Hakefiles. 45import Language.Haskell.Exts 46 47 48-- Hake components 49import RuleDefs 50import HakeTypes 51import qualified Args 52import qualified Config 53import TreeDB 54import LibDepTree 55 56data HakeError = HakeError String Int 57 deriving (Show, Typeable) 58instance Exception HakeError 59 60-- 61-- Command line options and parsing code 62-- 63data Opts = Opts { opt_makefilename :: String, 64 opt_installdir :: String, 65 opt_sourcedir :: String, 66 opt_bfsourcedir :: String, 67 opt_builddir :: String, 68 opt_ghc_libdir :: String, 69 opt_abs_installdir :: String, 70 opt_abs_sourcedir :: String, 71 opt_abs_bfsourcedir :: String, 72 opt_abs_builddir :: String, 73 opt_usage_error :: Bool, 74 opt_architectures :: [String], 75 opt_verbosity :: Integer 76 } 77 deriving (Show,Eq) 78 79parse_arguments :: [String] -> Opts 80parse_arguments [] = 81 Opts { opt_makefilename = "Makefile", 82 opt_installdir = Config.install_dir, 83 opt_sourcedir = Config.source_dir, 84 opt_bfsourcedir = Config.source_dir, 85 opt_builddir = ".", 86 opt_ghc_libdir = libdir, 87 opt_abs_installdir = "", 88 opt_abs_sourcedir = "", 89 opt_abs_bfsourcedir = "", 90 opt_abs_builddir = "", 91 opt_usage_error = False, 92 opt_architectures = [], 93 opt_verbosity = 1 } 94parse_arguments ("--install-dir" : (s : t)) = 95 (parse_arguments t) { opt_installdir = s } 96parse_arguments ("--source-dir" : s : t) = 97 (parse_arguments t) { opt_sourcedir = s } 98parse_arguments ("--bfsource-dir" : s : t) = 99 (parse_arguments t) { opt_bfsourcedir = s } 100parse_arguments ("--build-dir" : s : t) = 101 (parse_arguments t) { opt_builddir = s } 102parse_arguments ("--ghc-libdir" : (s : t)) = 103 (parse_arguments t) { opt_ghc_libdir = s } 104parse_arguments ("--output-filename" : s : t) = 105 (parse_arguments t) { opt_makefilename = s } 106parse_arguments ("--quiet" : t ) = 107 (parse_arguments t) { opt_verbosity = 0 } 108parse_arguments ("--verbose" : t ) = 109 (parse_arguments t) { opt_verbosity = 2 } 110parse_arguments ("--architecture" : a : t ) = 111 let 112 o2 = parse_arguments t 113 arches = (a : opt_architectures o2) 114 in 115 o2 { opt_architectures = arches } 116parse_arguments _ = 117 (parse_arguments []) { opt_usage_error = True } 118 119usage :: String 120usage = unlines [ "Usage: hake <options>", 121 " --source-dir <dir> (required)", 122 " --bfsource-dir <dir> (defaults to source dir)", 123 " --install-dir <dir> (defaults to source dir)", 124 " --ghc-libdir <dir> (defaults to " ++ libdir ++ ")", 125 " --quiet", 126 " --verbose" 127 ] 128 129-- Check the configuration options, returning an error string if they're 130-- invalid. 131configErrors :: Maybe String 132configErrors 133 | unknownArchs /= [] = 134 Just ("unknown architecture(s) specified: " ++ 135 (concat $ intersperse ", " unknownArchs)) 136 | Config.architectures == [] = 137 Just "no architectures defined" 138 | Config.lazy_thc && not Config.use_fp = 139 Just "Config.use_fp must be true to use Config.lazy_thc." 140 | otherwise = 141 Nothing 142 where 143 unknownArchs = Config.architectures \\ Args.allArchitectures 144 145-- Walk the source tree and build a complete list of pathnames, loading any 146-- Hakefiles. 147listFiles :: FilePath -> IO ([FilePath], [(FilePath, String)]) 148listFiles root = listFiles' root root 149 150listFiles' :: FilePath -> FilePath -> IO ([FilePath], [(FilePath, String)]) 151listFiles' root current 152 | ignore (takeFileName current) = return ([], []) 153 | otherwise = do 154 isdir <- doesDirectoryExist current 155 if isdir then do 156 children <- getDirectoryContents current 157 walkchildren $ filter isRealChild children 158 else do 159 hake <- maybeHake current 160 return ([makeRelative root current], hake) 161 where 162 -- Walk the child directories in parallel. This speeds things up 163 -- dramatically over NFS, with its high latency. 164 walkchildren :: [FilePath] -> IO ([FilePath], [(FilePath, String)]) 165 walkchildren children = do 166 children_async <- mapM (async.walkchild) children 167 results <- mapM wait children_async 168 return $ joinResults results 169 170 joinResults :: [([a],[b])] -> ([a],[b]) 171 joinResults [] = ([],[]) 172 joinResults ((as,bs):xs) = 173 let (as',bs') = joinResults xs in 174 (as ++ as', bs ++ bs') 175 176 walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)]) 177 walkchild child = listFiles' root (current </> child) 178 179 -- Load Hakfiles eagerly. This amounts to <1MB for Barrelfish (2015). 180 maybeHake path 181 | takeFileName path == "Hakefile" = do 182 contents <- readFile path 183 return [(path, contents)] 184 | otherwise = return [] 185 186 -- Don't descend into revision-control or build directories. 187 ignore :: FilePath -> Bool 188 ignore "CMakeFiles" = True 189 ignore ".hg" = True 190 ignore ".git" = True 191 ignore ('.':[]) = False 192 ignore ('.':xs) = True 193 ignore "build" = True 194 ignore _ = False 195 196 -- We ignore self-links and parent-links 197 isRealChild :: FilePath -> Bool 198 isRealChild "." = False 199 isRealChild ".." = False 200 isRealChild _ = True 201 202-- 203-- Hake parsing using the GHC API 204-- 205 206-- We invoke GHC to parse the Hakefiles in a preconfigured environment, 207-- to implement the Hake DSL. 208evalHakeFiles :: FilePath -> Opts -> TreeDB -> [(FilePath, String)] -> 209 (FilePath -> HRule -> Ghc a) -> IO ([a]) 210evalHakeFiles the_libdir o srcDB hakefiles rulef = 211 --defaultErrorHandler defaultFatalMessager defaultFlushOut $ 212 errorHandler $ 213 runGhc (Just the_libdir) $ 214 driveGhc o srcDB hakefiles rulef 215 216-- This is the code that executes in the GHC monad. 217driveGhc :: forall a. Opts -> TreeDB -> [(FilePath, String)] -> 218 (FilePath -> HRule -> Ghc a) -> Ghc ([a]) 219driveGhc o srcDB hakefiles rulef = do 220 -- Set the RTS flags 221 dflags <- getSessionDynFlags 222 _ <- setSessionDynFlags dflags { 223 importPaths = module_paths, 224 hiDir = Just "./hake", 225 objectDir = Just "./hake" 226 } 227 228 -- Set compilation targets i.e. everything that needs to be built from 229 -- source (*.hs). 230 targets <- mapM (\m -> guessTarget m Nothing) source_modules 231 setTargets targets 232 load LoadAllTargets 233 234 -- Import both system and Hake modules. 235 setContext 236 ([IIDecl $ simpleImportDecl $ mkModuleName m | 237 m <- modules] ++ 238 [IIDecl $ (simpleImportDecl $ mkModuleName m) { 239 ideclQualified = True 240 } | m <- qualified_modules]) 241 242 -- Collect rules from Hakefiles 243 collectRules hakefiles 244 245 where 246 module_paths = [ (opt_installdir o) </> "hake", ".", 247 (opt_bfsourcedir o) </> "hake" ] 248 source_modules = [ "HakeTypes", "RuleDefs", "Args", "Config", 249 "TreeDB" ] 250 modules = [ "Prelude", "System.FilePath", "HakeTypes", "RuleDefs", 251 "Args", "TreeDB" ] 252 qualified_modules = [ "Config", "Data.List" ] 253 254 -- Evaluate one Hakefile, and emit its Makefile section. We collect 255 -- referenced directories as we go, to generate the 'directories' 256 -- rules later. 257 collectRules' :: [a] -> [(FilePath, String)] -> Ghc ([a]) 258 collectRules' rules [] = return rules 259 collectRules' rules ((abs_hakepath, contents):hs) = do 260 let hakepath = makeRelative (opt_sourcedir o) abs_hakepath 261 rule <- evaluate hakepath contents 262 ruleout <- rulef hakepath rule 263 collectRules' (ruleout : rules) hs 264 265 collectRules :: [(FilePath, String)] -> Ghc ([a]) 266 collectRules hs = collectRules' [] hs 267 268 -- Evaluate a Hakefile, returning something of the form 269 -- Rule [...] 270 evaluate :: FilePath -> String -> Ghc HRule 271 evaluate hakepath hake_raw = do 272 case hake_parse of 273 Left hake_expr -> do 274 let hake_wrapped = 275 prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $ 276 wrapHake hakepath hake_expr 277 278 -- Evaluate in GHC 279 val <- ghandle handleFailure $ 280 dynCompileExpr -- $ traceShowId 281 $ hake_wrapped ++ " :: TreeDB -> HRule" 282 283 284 285 rule <- 286 case fromDynamic val of 287 Just r -> return r 288 Nothing -> throw $ 289 HakeError (hakepath ++ 290 " - Compilation failed") 1 291 292 -- Path resolution 293 let resolved_rule = 294 resolvePaths o (takeDirectory hakepath) 295 (rule srcDB) 296 return resolved_rule 297 Right hake_error -> throw hake_error 298 where 299 hake_parse = parseHake hakepath hake_raw 300 301 handleFailure :: SomeException -> Ghc Dynamic 302 handleFailure e 303 = throw $ HakeError (hakepath ++ ":\n" ++ show e) 1 304 305errorHandler :: (ExceptionMonad m, MonadIO m) => m a -> m a 306errorHandler inner = 307 ghandle (\exception -> liftIO $ do 308 hFlush stdout 309 handleIOException exception 310 handleAsyncException exception 311 handleExitException exception 312 handleHakeError exception 313 throw exception 314 ) $ 315 316 -- error messages propagated as exceptions 317 ghandle 318 (\(ge :: GhcException) -> liftIO $ do 319 hFlush stdout 320 throw $ HakeError (show ge) 1 321 ) $ 322 inner 323 where 324 handleIOException e = 325 case fromException e of 326 Just (ioe :: IOException) -> 327 throw $ HakeError ("IO Exception: " ++ (show ioe)) 1 328 _ -> return () 329 330 handleAsyncException e = 331 case fromException e of 332 Just UserInterrupt -> 333 throw $ HakeError "Interrupted" 1 334 Just StackOverflow -> 335 throw $ HakeError ("Stack Overflow: use +RTS " ++ 336 "-K<size> to increase it") 1 337 _ -> return () 338 339 handleExitException e = 340 case fromException e of 341 Just ExitSuccess -> 342 throw $ HakeError "GHC terminated early" 1 343 Just (ExitFailure n) -> 344 throw $ HakeError "GHC terminated early" n 345 _ -> return () 346 347 handleHakeError e = 348 case fromException e of 349 Just (HakeError s n) -> throw $ HakeError s n 350 _ -> return () 351 352printSrcLoc :: Language.Haskell.Exts.SrcLoc -> String 353printSrcLoc sl = 354 srcFilename sl ++ ":" ++ 355 (show $ srcLine sl) ++ "." ++ 356 (show $ srcColumn sl) 357 358-- Parse a Hakefile, prior to wrapping it with Hake definitions 359parseHake :: FilePath -> String -> Either (Exp SrcSpanInfo) HakeError 360parseHake filename contents = 361 case result of 362 ParseOk e -> Left e 363 ParseFailed loc str -> 364 Right $ HakeError (printSrcLoc loc ++ " - " ++ str) 1 365 where 366 result = 367 parseExpWithMode 368 (defaultParseMode { 369 parseFilename = filename, 370 baseLanguage = Haskell2010 }) 371 contents 372 373-- Split a Hake rule up by token type. It's more efficient to do this 374-- in a single pass, than to filter each as it's required. 375data CompiledRule = 376 CompiledRule { 377 ruleOutputs :: S.Set RuleToken, 378 ruleDepends :: S.Set RuleToken, 379 rulePreDepends :: S.Set RuleToken, 380 ruleBody :: [RuleToken], 381 ruleDirs :: S.Set FilePath 382 } 383 384 385-- Get the relative rule from an absolute rule pair 386makeRelativeRule :: RuleToken -> RuleToken 387makeRelativeRule (Abs _ t) = t 388makeRelativeRule t = t 389 390compileRule :: [RuleToken] -> CompiledRule 391compileRule [] = CompiledRule S.empty S.empty S.empty [] S.empty 392compileRule (t:ts) = 393 let CompiledRule outs deps predeps body dirs = compileRule ts 394 outs' = if isOutput t then S.insert (makeRelativeRule t) outs else outs 395 deps' = if isDependency t then S.insert (makeRelativeRule t) deps else deps 396 predeps' = if isPredependency t then S.insert (makeRelativeRule t) predeps else predeps 397 body' = if inRule t then t:body else body 398 dirs' = if isFileRef t && 399 inTree (frPath t) && 400 takeDirectory (frPath t) /= "." 401 then S.insert (replaceFileName (frPath t) ".marker") dirs 402 else dirs 403 in 404 CompiledRule outs' deps' predeps' body' dirs' 405 where 406 inTree :: FilePath -> Bool 407 inTree p = 408 case splitDirectories p of 409 "..":_ -> False 410 "/":_ -> False 411 _ -> True 412 413-- We wrap the AST of the parsed Hakefile to defind the 'find' and 'build' 414-- primitives, and generate the correct expression type (HRule). The result 415-- is an unevaluted function [FilePath] -> HRule, that needs to be supplied 416-- with the list of all files in the source directory. 417wrapHake :: FilePath -> Exp SrcSpanInfo -> Exp SrcSpanInfo 418wrapHake hakefile hake_exp = 419 Paren loc ( 420 Lambda loc [PVar loc (Ident loc "sourceDB")] ( 421 Let loc ( 422 BDecls loc [ 423 FunBind loc [ 424 -- This is 'find' 425 Match loc (Ident loc "find") 426 [PVar loc (Ident loc "fn"), PVar loc (Ident loc "arg")] 427 -- Nothing 428 (UnGuardedRhs loc 429 (Paren loc (App loc (App loc (App loc (Var loc (UnQual loc (Ident loc "fn"))) 430 (Var loc (UnQual loc (Ident loc "sourceDB")))) 431 (Lit loc (String loc hakefile ""))) 432 (Var loc (UnQual loc (Ident loc "arg")))))) 433 (Just (BDecls loc [])) 434 ], 435 436 FunBind loc [ 437 Match loc 438 (Ident loc "build") -- This is 'build' 439 [PVar loc (Ident loc "a")] 440 (UnGuardedRhs loc 441 (App loc (App loc (App loc (Paren loc (App loc (Var loc (UnQual loc (Ident loc "buildFunction"))) 442 (Var loc (UnQual loc (Ident loc "a"))))) 443 (Var loc (UnQual loc (Ident loc "sourceDB")))) 444 (Lit loc(String loc hakefile ""))) 445 (Var loc (UnQual loc (Ident loc "a"))))) 446 (Just (BDecls loc [])) 447 ] 448 ] 449 ) (Paren loc (App loc (Con loc (UnQual loc (Ident loc "Rules"))) hake_exp)) 450 ) 451 ) 452 where 453 dummy_loc = SrcLoc { srcFilename = "<hake internal>", 454 srcLine = 0, srcColumn = 0 } 455 loc = Language.Haskell.Exts.noSrcSpan 456-- 457-- Makefile generation 458-- 459 460-- The Makefile header, generated once. 461makefilePreamble :: Handle -> Opts -> [String] -> IO () 462makefilePreamble h opts args = 463 mapM_ (hPutStrLn h) 464 ([ "# This Makefile is generated by Hake. Do not edit!", 465 "# ", 466 "# Hake was invoked with the following command line args:" ] ++ 467 [ "# " ++ a | a <- args ] ++ 468 [ "# ", 469 "Q=@", 470 "SRCDIR=" ++ opt_sourcedir opts, 471 "HAKE_ARCHS=" ++ intercalate " " Config.architectures, 472 -- Disable built-in implicit rules. GNU make adds environment's MAKEFLAGS too. 473 "MAKEFLAGS=r", 474 -- Explicitly disable the flex and bison implicit rules 475 "%.c : %.y", 476 "%.c : %.l", 477 "INSTALL_PREFIX ?= /home/netos/tftpboot/$(USER)" ]) 478 479-- There a several valid top-level build directores, apart from the 480-- architecture-specific one. 481arch_list :: S.Set String 482arch_list = S.fromList (Config.architectures ++ 483 ["", "src", "hake", "root", "tools", "docs", "cache"]) 484 485-- A rule is included if it applies to only "special" and configured 486-- architectures. 487allowedArchs :: [String] -> Bool 488allowedArchs = all (\a -> a `S.member` arch_list) 489 490 491-- The section corresponding to a Hakefile. These routines all collect 492-- and directories they see. 493makefileSectionArr :: Handle -> Opts -> [(FilePath,HRule)] -> IO (S.Set FilePath) 494makefileSectionArr h opts xs = makefileSectionArr' S.empty xs 495 where 496 makefileSectionArr' :: (S.Set FilePath) -> [(FilePath,HRule)] -> 497 IO (S.Set FilePath) 498 makefileSectionArr' dirs [] = return dirs 499 makefileSectionArr' dirs ((fp,rule) : xs) = do 500 dirs' <- makefileSection h opts fp rule 501 makefileSectionArr' (S.union dirs' dirs) xs 502 503makefileSection :: Handle -> Opts -> FilePath -> HRule -> IO (S.Set FilePath) 504makefileSection h opts hakepath rule = do 505 hPutStrLn h $ "# From: " ++ hakepath ++ "\n" 506 makefileRule h rule 507 508makefileRule :: Handle -> HRule -> IO (S.Set FilePath) 509makefileRule h (Error s) = do 510 hPutStrLn h $ "$(error " ++ s ++ ")\n" 511 return S.empty 512makefileRule h (Rules rules) = do 513 dir_lists <- mapM (makefileRule h) rules 514 return $! S.unions dir_lists 515makefileRule h (Include token) = do 516 when (allowedArchs [frArch token]) $ 517 mapM_ (hPutStrLn h) [ 518 "ifeq ($(MAKECMDGOALS),clean)", 519 "else ifeq ($(MAKECMDGOALS),rehake)", 520 "else ifeq ($(MAKECMDGOALS),Makefile)", 521 "else", 522 "include " ++ (formatToken token), 523 "endif", 524 "" ] 525 return S.empty 526makefileRule h (HakeTypes.Rule tokens) = 527 if allowedArchs (map frArch tokens) 528 then makefileRuleInner h tokens False 529 else return S.empty 530makefileRule h (Phony name double_colon tokens) = do 531 if allowedArchs (map frArch tokens) 532 then do 533 hPutStrLn h $ ".PHONY: " ++ name 534 makefileRuleInner h (Target "build" name : tokens) double_colon 535 else return S.empty 536 537printTokens :: Handle -> S.Set RuleToken -> IO () 538printTokens h tokens = 539 S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens 540 541printDirs :: Handle -> S.Set FilePath -> IO () 542printDirs h dirs = 543 S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs 544 545 546 547makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath) 548makefileRuleInner h tokens double_colon = do 549 if S.null (ruleOutputs compiledRule) 550 then do 551 return $ ruleDirs compiledRule 552 else do 553 printTokens h $ ruleOutputs compiledRule 554 if double_colon then hPutStr h ":: " else hPutStr h ": " 555 printTokens h $ ruleDepends compiledRule 556 hPutStr h " | directories " 557 printTokens h $ rulePreDepends compiledRule 558 hPutStrLn h "" 559 doBody 560 where 561 compiledRule = compileRule tokens 562 563 doBody :: IO (S.Set FilePath) 564 doBody = do 565 when (ruleBody compiledRule /= []) $ do 566 hPutStr h "\t" 567 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule 568 hPutStrLn h "\n" 569 return $ ruleDirs compiledRule 570 571-- 572-- Functions to resolve path names in rules. 573-- 574-- Absolute paths are interpreted relative to one of the three trees: source, 575-- build or install. Relative paths are interpreted relative to the directory 576-- containing the Hakefile that referenced them, within one of the above tree. 577-- Both build and install trees are divided by architecture, while the source 578-- tree is not. All paths are output relative to the build directory. 579-- 580-- For example, if we are building for architecture 'x86_64', with build tree 581-- '/home/user/barrelfish/build' and build tree '/home/user/barrelfish' 582-- relative path '../', and we are compiling a Hakefile at 'apps/init/Hakefile' 583-- relative path '../apps/init/Hakefile', we would resolve as follows: 584-- 585-- In SourceTree "../apps/init" "x86_64" "main.c" 586-- -> "../apps/init/main.c" 587-- In BuildTree "../apps/init" "x86_64" "/include/generated.h" 588-- -> "./x86_64/include/generated.h" 589-- Out BuildTree "../apps/init" "root" "/doc/manual.pdf" 590-- -> "./doc/manual.pdf" 591-- 592-- Note that the 'root' architecture is special, and always refers to the root 593-- of the relevant tree. 594 595-- Recurse through the Hake AST 596resolvePaths :: Opts -> FilePath -> HRule -> HRule 597resolvePaths o hakepath (Rules hrules) 598 = Rules $ map (resolvePaths o hakepath) hrules 599resolvePaths o hakepath (HakeTypes.Rule tokens) 600 = HakeTypes.Rule $ map (resolveTokenPath o hakepath) tokens 601resolvePaths o hakepath (Include token) 602 = Include $ resolveTokenPath o hakepath token 603resolvePaths o hakepath (Error s) 604 = Error s 605resolvePaths o hakepath (Phony name dbl tokens) 606 = Phony name dbl $ map (resolveTokenPath o hakepath) tokens 607 608-- Now resolve at the level of individual rule tokens. At this level, 609-- we need to take into account the tree (source, build, or install). 610resolveTokenPath :: Opts -> FilePath -> RuleToken -> RuleToken 611-- An input token specifies which tree it refers to. 612resolveTokenPath o hakepath (In tree arch path) = 613 (In tree arch (treePath o tree arch path hakepath)) 614-- An output token implicitly refers to the build tree. 615resolveTokenPath o hakepath (Out arch path) = 616 (Out arch (treePath o BuildTree arch path hakepath)) 617-- A dependency token specifies which tree it refers to. 618resolveTokenPath o hakepath (Dep tree arch path) = 619 (Dep tree arch (treePath o tree arch path hakepath)) 620-- A non-dependency token specifies which tree it refers to. 621resolveTokenPath o hakepath (NoDep tree arch path) = 622 (NoDep tree arch (treePath o tree arch path hakepath)) 623-- A pre-dependency token specifies which tree it refers to. 624resolveTokenPath o hakepath (PreDep tree arch path) = 625 (PreDep tree arch (treePath o tree arch path hakepath)) 626-- An target token implicitly refers to the build tree. 627resolveTokenPath o hakepath (Target arch path) = 628 (Target arch (treePath o BuildTree arch path hakepath)) 629-- A target token referring to an absolute resource 630resolveTokenPath o hakepath (Abs rule rule2) = 631 let o' = o { 632 opt_sourcedir = opt_abs_sourcedir o, 633 opt_installdir = opt_abs_installdir o, 634 opt_builddir = opt_abs_builddir o, 635 opt_bfsourcedir = opt_abs_bfsourcedir o 636 } 637 in Abs (resolveTokenPath o' hakepath rule) (resolveTokenPath o hakepath rule2) 638-- Other tokens don't contain paths to resolve. 639resolveTokenPath _ _ token = token 640 641-- Now we get down to the nitty gritty. We have, in order: 642-- o: The options in force 643-- tree: The tree (source, build, or install) 644-- arch: The architecture (e.g. armv7) 645-- path: The pathname we want to resolve 646-- hakepath: The directory containing the Hakefile 647-- If the tree is SrcTree or the architecture is "root", everything 648-- is relative to the top-level directory for that tree. Otherwise, 649-- it's relative to the top-level directory plus the architecture. 650treePath :: Opts -> TreeRef -> FilePath -> FilePath -> FilePath -> FilePath 651-- The architecture 'root' is special. 652treePath o SrcTree "root" path hakepath = 653 relPath (opt_sourcedir o) path hakepath 654treePath o BFSrcTree "root" path hakepath = 655 relPath (opt_bfsourcedir o) path hakepath 656treePath o BuildTree "root" path hakepath = 657 relPath (opt_builddir o) path hakepath 658treePath o InstallTree "root" path hakepath = 659 relPath (opt_installdir o) path hakepath 660-- The architecture 'cache' is special. 661treePath o SrcTree "cache" path hakepath = 662 relPath Config.cache_dir path hakepath 663treePath o BFSrcTree "cache" path hakepath = 664 relPath Config.cache_dir path hakepath 665treePath o BuildTree "cache" path hakepath = 666 relPath Config.cache_dir path hakepath 667treePath o InstallTree "cache" path hakepath = 668 relPath Config.cache_dir path hakepath 669-- Source-tree paths don't get an architecture. 670treePath o SrcTree arch path hakepath = 671 relPath (opt_sourcedir o) path hakepath 672treePath o BFSrcTree arch path hakepath = 673 relPath (opt_bfsourcedir o) path hakepath 674treePath o BuildTree arch path hakepath = 675 relPath ((opt_builddir o) </> arch) path hakepath 676treePath o InstallTree arch path hakepath = 677 relPath (opt_installdir o </> arch) path hakepath 678 679-- First evaluate the given path 'path', relative to the Hakefile directory 680-- 'hakepath'. If 'path' is absolute (i.e. begins with a /), it is unchanged. 681-- Otherwise it is appended to 'hakepath'. We then treat this as a relative 682-- path (by removing any initial /), and append it to the relevant tree root 683-- (which may or may not have an architecture path appended already). 684relPath :: String -> String -> String -> String 685-- The first rule prevents a path of / to be reduced to the empty string 686relPath "." "/" hakepath = 687 "." 688relPath "." path hakepath = 689 stripSlash (hakepath </> path) 690relPath treeroot path hakepath = 691 treeroot </> stripSlash (hakepath </> path) 692 693-- Strip any leading slash from the filename. This is much faster than 694-- 'makeRelative "/"'. 695stripSlash :: FilePath -> FilePath 696stripSlash ('/':cs) = cs 697stripSlash cs = cs 698 699-- Emit the rule to rebuild the Hakefile. 700makeHakeDeps :: Handle -> Opts -> [String] -> IO () 701makeHakeDeps h o l = do 702 hPutStrLn h "ifneq ($(MAKECMDGOALS),rehake)" 703 makefileRule h rule 704 hPutStrLn h "endif" 705 hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to following targets. 706 where 707 hake = resolveTokenPath o "" (In InstallTree "root" "/hake/hake") 708 makefile = resolveTokenPath o "/" (Out "root" (opt_makefilename o)) 709 rule = HakeTypes.Rule 710 ( [ hake, 711 Str "--source-dir", Str (opt_sourcedir o), 712 Str "--install-dir", Str (opt_installdir o), 713 Str "--bfsource-dir", Str (opt_bfsourcedir o), 714 Str "--output-filename", makefile, 715 Str "--ghc-libdir", Str (opt_ghc_libdir o) 716 ] ++ 717 [ Dep SrcTree "root" h | h <- l ] 718 ) 719 720-- Emit the rules to create the build directories 721makeDirectories :: Handle -> S.Set FilePath -> IO () 722makeDirectories h dirs = do 723 hPutStrLn h "# Directories follow" 724 hPutStrLn h "DIRECTORIES=\\" 725 mapM_ (\d -> hPutStrLn h $ " " ++ d ++ " \\") (S.toList dirs) 726 hPutStrLn h "\n" 727 hPutStrLn h ".PHONY: directories" 728 hPutStr h "directories: $(DIRECTORIES)" 729 hPutStrLn h "" 730 hPutStrLn h "%.marker:" 731 hPutStrLn h "\t$(Q)echo \"MKDIR $@\"" 732 hPutStrLn h "\t$(Q)mkdir -p `dirname $@`" 733 hPutStrLn h "\t$(Q)touch $@" 734 735makeDriverDomainDb :: String -> LibDepTree2 -> IO() 736makeDriverDomainDb build t = do 737 let fileName = build ++ "/sockeyefacts/ddomain_db.pl" 738 let dirName = build ++ "/sockeyefacts" 739 createDirectoryIfMissing True dirName 740 writeFile fileName "" 741 h <- openFile(fileName) WriteMode 742 mapM_ (hPutStrLn h . pairToPl) (ldtDriverModules t) 743 hFlush h 744 hClose h 745 return () 746 where 747 pairToPl :: (DepEl, DepEl) -> String 748 pairToPl (a,b) = "drivermodule(" ++ toPl a ++ "," ++ toPl b ++ ")." 749 toPl :: DepEl -> String 750 toPl x = "(\"" ++ depElArch x ++ "\",\"" ++ depElName x ++ "\")" 751 752 753-- 754-- The top level 755-- 756 757extractrule :: FilePath -> HRule -> Ghc (HRule) 758extractrule fp hr = return hr 759 760extractDep :: FilePath -> HRule -> Ghc (DepElMap) 761extractDep fp hr = return $ ldtHRuleToDepElMap Config.architectures hr 762 763writeMF :: Handle -> Opts -> (HRule -> HRule) -> FilePath -> HRule -> Ghc (S.Set FilePath) 764writeMF h o rule_transform fp rule = liftIO $ makefileSection h o fp (rule_transform rule) 765 766body :: IO () 767body = do 768 -- Parse arguments; architectures default to config file 769 args <- System.Environment.getArgs 770 let o1 = parse_arguments args 771 al = if opt_architectures o1 == [] 772 then Config.architectures 773 else opt_architectures o1 774 opts' = o1 { opt_architectures = al } 775 776 when (opt_usage_error opts') $ 777 throw (HakeError usage 1) 778 779 -- Check configuration settings. 780 -- This is currently known at compile time, but might not always be! 781 when (isJust configErrors) $ 782 throw (HakeError ("Error in configuration: " ++ 783 (fromJust configErrors)) 2) 784 785 -- Canonicalise directories 786 abs_sourcedir <- canonicalizePath $ opt_sourcedir opts' 787 abs_bfsourcedir <- canonicalizePath $ opt_bfsourcedir opts' 788 abs_installdir <- canonicalizePath $ opt_installdir opts' 789 abs_builddir <- canonicalizePath $ "." 790 let opts = opts' { opt_abs_sourcedir = abs_sourcedir, 791 opt_abs_bfsourcedir = abs_bfsourcedir, 792 opt_abs_installdir = abs_installdir, 793 opt_abs_builddir = abs_builddir } 794 795 putStrLn ("Source directory: " ++ opt_sourcedir opts ++ 796 " (" ++ opt_abs_sourcedir opts ++ ")") 797 putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts ++ 798 " (" ++ opt_abs_bfsourcedir opts ++ ")") 799 putStrLn ("Install directory: " ++ opt_installdir opts ++ 800 " (" ++ opt_abs_installdir opts ++ ")") 801 putStrLn ("GHC libdir: " ++ opt_ghc_libdir opts) 802 803 -- Find Hakefiles 804 putStrLn "Scanning directory tree..." 805 (relfiles, hakefiles) <- listFiles (opt_sourcedir opts) 806 let srcDB = tdbBuild relfiles 807 808 -- Open the Makefile and write the preamble 809 putStrLn $ "Creating " ++ (opt_makefilename opts) ++ "..." 810 makefile <- openFile(opt_makefilename opts) WriteMode 811 makefilePreamble makefile opts args 812 makeHakeDeps makefile opts $ map fst hakefiles 813 814 -- Evaluate Hakefiles 815 putStrLn $ "Evaluating " ++ show (length hakefiles) ++ " Hakefiles for dependencies..." 816 depElMap <- evalHakeFiles (opt_ghc_libdir opts) opts srcDB hakefiles extractDep 817 818 let dep_graph = ldtEmToGraph (foldr ldtDepElMerge Map.empty depElMap) 819 let rtrans = ldtRuleExpand $ dep_graph 820 putStrLn $ "Evaluating " ++ show (length hakefiles) ++ " Hakefiles..." 821 822 dirs_a <- evalHakeFiles (opt_ghc_libdir opts) opts srcDB hakefiles (writeMF makefile opts rtrans) 823 824 let dirs = foldr S.union S.empty dirs_a 825 826 putStrLn "Generating build directory dependencies..." 827 makeDirectories makefile dirs 828 829 makeDriverDomainDb abs_builddir dep_graph 830 831 hFlush makefile 832 hClose makefile 833 return () 834 835main :: IO () 836main = do 837 r <- body `catch` handleHakeError 838 exitWith ExitSuccess 839 where 840 handleHakeError :: HakeError -> IO () 841 handleHakeError (HakeError str n) = do 842 putStrLn str 843 exitWith $ ExitFailure n 844