git.barrelfish.org Git - barrelfish/blob - hake/Main.hs

   1 import Control.Monad.Error
   2
   3 import Data.Dynamic
   4 import Data.List
   5 import Data.Maybe
   6 import qualified Data.Set as S
   7
   8 import System.Directory
   9 import System.Environment
  10 import System.Exit
  11 import System.FilePath
  12 import System.IO
  13 import System.Mem
  14
  15 import GHC hiding (Target, Ghc, GhcT, runGhc, runGhcT, FunBind, Match)
  16 import GHC.Paths (libdir)
  17 import Control.Monad.Ghc
  18 import DynFlags (defaultFatalMessager, defaultFlushOut,
  19                  xopt_set, ExtensionFlag (Opt_DeriveDataTypeable))
  20 import GHC.Stats
  21
  22 import Language.Haskell.Exts
  23
  24 import RuleDefs
  25 import HakeTypes
  26 import qualified Args
  27 import qualified Config
  28 import qualified Path
  29
  30 data HakeError = HakeError String Int
  31 instance Error HakeError
  32 type HakeMonad = ErrorT HakeError IO
  33
  34 --
  35 -- Command line options and parsing code
  36 --
  37 data Opts = Opts { opt_makefilename :: String,
  38                    opt_installdir :: String,
  39                    opt_sourcedir :: String,
  40                    opt_bfsourcedir :: String,
  41                    opt_usage_error :: Bool,
  42                    opt_architectures :: [String],
  43                    opt_verbosity :: Integer
  44                  }
  45           deriving (Show,Eq)
  46
  47 parse_arguments :: [String] -> Opts
  48 parse_arguments [] =
  49   Opts { opt_makefilename = "Makefile",
  50          opt_installdir = Config.install_dir,
  51          opt_sourcedir = Config.source_dir,
  52          opt_bfsourcedir = Config.source_dir,
  53          opt_usage_error = False,
  54          opt_architectures = [],
  55          opt_verbosity = 1 }
  56 parse_arguments ("--install-dir" : (s : t)) =
  57   (parse_arguments t) { opt_installdir = s }
  58 parse_arguments ("--source-dir" : s : t) =
  59   (parse_arguments t) { opt_sourcedir = s }
  60 parse_arguments ("--bfsource-dir" : s : t) =
  61   (parse_arguments t) { opt_bfsourcedir = s }
  62 parse_arguments ("--output-filename" : s : t) =
  63   (parse_arguments t) { opt_makefilename = s }
  64 parse_arguments ("--quiet" : t ) =
  65   (parse_arguments t) { opt_verbosity = 0 }
  66 parse_arguments ("--verbose" : t ) =
  67   (parse_arguments t) { opt_verbosity = 2 }
  68 parse_arguments ("--architecture" : a : t ) =
  69   let
  70     o2 = parse_arguments t
  71     arches = (a : opt_architectures o2)
  72   in
  73     o2 { opt_architectures = arches }
  74 parse_arguments _ =
  75   (parse_arguments []) { opt_usage_error = True }
  76
  77 usage :: String
  78 usage = unlines [ "Usage: hake <options>",
  79                   "   --source-dir <dir> (required)",
  80                   "   --bfsource-dir <dir> (defaults to source dir)",
  81                   "   --install-dir <dir> (defaults to source dir)",
  82                   "   --quiet",
  83                   "   --verbose"
  84                 ]
  85
  86 -- check the configuration options, returning an error string if they're insane
  87 configErrors :: Maybe String
  88 configErrors
  89     | unknownArchs /= [] =
  90         Just ("unknown architecture(s) specified: " ++
  91         (concat $ intersperse ", " unknownArchs))
  92     | Config.architectures == [] =
  93         Just "no architectures defined"
  94     | Config.lazy_thc && not Config.use_fp =
  95         Just "Config.use_fp must be true to use Config.lazy_thc."
  96     | otherwise =
  97         Nothing
  98     where
  99         unknownArchs = Config.architectures \\ Args.allArchitectures
 100
 101 --
 102 -- Walk all over a directory tree and build a complete list of pathnames
 103 --
 104 listFiles :: FilePath -> IO ([FilePath], [(FilePath, String)])
 105 listFiles root = do
 106     isdir <- doesDirectoryExist root
 107     if isdir then do
 108         children <- getDirectoryContents root
 109         walkchildren children
 110     else
 111         return ([], [])
 112     where
 113         walkchildren :: [FilePath] -> IO ([FilePath], [(FilePath, String)])
 114         walkchildren [] = return ([], [])
 115         walkchildren (child:siblings) = do
 116             (allfiles, hakefiles) <- walkchild child
 117             (allfilesS, hakefilesS) <- walkchildren siblings
 118             return $ (allfiles ++ allfilesS, hakefiles ++ hakefilesS)
 119
 120         walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)])
 121         walkchild child = do
 122             if ignore child
 123             then return ([], [])
 124             else do
 125                 (allfiles, hakefiles) <- listFiles (root </> child)
 126                 hake <- maybeHake child
 127                 return $ ((root </> child) : allfiles,
 128                           hake ++ hakefiles)
 129             where
 130                 maybeHake "Hakefile" = do
 131                     contents <- readFile (root </> child)
 132                     return [(root </> child, contents)]
 133                 maybeHake _ = return []
 134
 135         ignore :: FilePath -> Bool
 136         ignore "."          = True
 137         ignore ".."         = True
 138         ignore "CMakeFiles" = True
 139         ignore ".hg"        = True
 140         ignore "build"      = True
 141         ignore ".git"       = True
 142         ignore _            = False
 143
 144 instance Show SuccessFlag
 145 instance Show RunResult
 146
 147 driveGhc :: Opts -> [FilePath] -> [(FilePath, String)] ->
 148             Ghc ([(String, HRule)])
 149 driveGhc o allfiles hakefiles = do
 150     -- Set the RTS flags
 151     dflags <- getSessionDynFlags
 152     let dflags' = foldl xopt_set dflags [ Opt_DeriveDataTypeable ]
 153     _ <- setSessionDynFlags dflags'{
 154         importPaths = module_paths,
 155         hiDir = Just "./hake",
 156         objectDir = Just "./hake"
 157     }
 158
 159     -- Set compilation targets
 160     targets <- mapM (\m -> guessTarget m Nothing) source_modules
 161     setTargets targets
 162     load LoadAllTargets
 163
 164     -- Import modules
 165     setContext
 166         ([IIDecl $ simpleImportDecl $ mkModuleName m |
 167             m <- modules] ++
 168          [IIDecl $ (simpleImportDecl $ mkModuleName m) {
 169                 ideclQualified = True
 170           } | m <- qualified_modules])
 171
 172     mapM evaluate hakefiles
 173
 174     where
 175         module_paths = [ (opt_installdir o) </> "hake", ".",
 176                          (opt_bfsourcedir o) </> "hake" ]
 177         source_modules = [ "HakeTypes", "RuleDefs", "Path", "Args", "Config" ]
 178         modules = [ "Prelude", "HakeTypes", "RuleDefs", "Path", "Args" ]
 179         qualified_modules = [ "Config", "Data.List" ]
 180
 181         evaluate :: (FilePath, String) -> Ghc ((String, HRule))
 182         evaluate (hake_name, hake_raw) = do
 183             case hake_parse of
 184                 Left hake_expr -> do
 185                     let hake_wrapped =
 186                             prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
 187                                 wrapHake hake_name hake_expr
 188
 189                     val <- dynCompileExpr $ hake_wrapped ++ " :: [String] -> HRule"
 190                     liftIO $ putStrLn ( "Success: " ++ hake_name )
 191                     let rule = fromDyn val (\_ -> Error "failed")
 192                     let resolved_rule =
 193                             resolveRelativePaths o (rule allfiles) hake_name
 194                     return $ (hake_name, resolved_rule)
 195                 Right hake_error -> do
 196                     return $ (hake_name, Error "failed")
 197             where
 198                 hake_parse = parseHake (hake_name, hake_raw)
 199
 200 evalHakeFiles :: Opts -> [FilePath] -> [(FilePath, String)] ->
 201                  IO ([(String, HRule)])
 202 evalHakeFiles o allfiles hakefiles =
 203     defaultErrorHandler defaultFatalMessager defaultFlushOut $
 204         runGhc (Just libdir) $
 205         driveGhc o allfiles hakefiles
 206
 207 parseHake :: (FilePath, String) -> Either Exp HakeError
 208 parseHake (filename, contents) =
 209     case result of
 210         ParseOk e -> Left e
 211         ParseFailed loc str ->
 212             Right $ HakeError (show loc ++ ": " ++ str) 2
 213     where
 214         result =
 215             parseExpWithMode
 216                 (defaultParseMode {
 217                     parseFilename = filename,
 218                     baseLanguage = Haskell2010 })
 219                 contents
 220
 221 wrapHake :: FilePath -> Exp -> Exp
 222 wrapHake hakefile hake_exp =
 223     Paren (
 224     Lambda dummy_loc [PVar (Ident "allfiles")] (
 225     Let (BDecls
 226         [FunBind [Match
 227             dummy_loc
 228             (Ident "find")
 229             [PVar (Ident "fn"), PVar (Ident "arg")]
 230             Nothing
 231             (UnGuardedRhs
 232                 (Paren (App (App (App (Var (UnQual (Ident "fn")))
 233                                       (Var (UnQual (Ident "allfiles"))))
 234                                  (Lit (String hakefile)))
 235                        (Var (UnQual (Ident "arg"))))))
 236             (BDecls [])],
 237
 238         FunBind [Match
 239             dummy_loc
 240             (Ident "build")
 241             [PVar (Ident "a")]
 242             Nothing
 243             (UnGuardedRhs
 244                 (App (App (App (Paren (App (Var (UnQual (Ident "buildFunction")))
 245                                            (Var (UnQual (Ident "a")))))
 246                                (Var (UnQual (Ident "allfiles"))))
 247                           (Lit (String hakefile)))
 248                      (Var (UnQual (Ident "a")))))
 249             (BDecls [])]
 250         ])
 251         (Paren (App (Con (UnQual (Ident "Rules")))
 252                     hake_exp))
 253     ))
 254     where
 255         dummy_loc = SrcLoc { srcFilename = "<hake internal>",
 256                                 srcLine = 0, srcColumn = 0 }
 257
 258 makefilePreamble :: Handle -> Opts -> [String] -> IO ()
 259 makefilePreamble h opts args =
 260     mapM_ (hPutStrLn h)
 261           ([ "# This Makefile is generated by Hake.  Do not edit!",
 262              "# ",
 263              "# Hake was invoked with the following command line args:" ] ++
 264            [ "#        " ++ a | a <- args ] ++
 265            [ "# ",
 266              "SRCDIR=" ++ (opt_sourcedir opts),
 267              "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
 268              "include ./symbolic_targets.mk" ])
 269
 270 -- a rule is included if it has only "special" architectures and enabled architectures
 271 allowedArchs :: [String] -> Bool
 272 allowedArchs = all (\a -> a `elem` (Config.architectures ++ specialArchitectures))
 273     where specialArchitectures = ["", "src", "hake", "root", "tools", "docs"]
 274
 275 makefileSection :: Handle -> Opts -> [FilePath] ->
 276                    (String, HRule) -> IO (S.Set FilePath)
 277 makefileSection h opts allfiles (hake_name, rule) = do
 278     hPutStrLn h $ "# From: " ++ hake_name ++ "\n"
 279     makefileRule h rule
 280
 281 makefileRule :: Handle -> HRule -> IO (S.Set FilePath)
 282 makefileRule h (Error s) = do
 283     hPutStrLn h $ "$(error " ++ s ++ ")\n"
 284     return S.empty
 285 makefileRule h (Rules rules) = do
 286     dir_lists <- mapM (makefileRule h) rules
 287     return $ S.unions dir_lists
 288 makefileRule h (Include token) = do
 289     when (allowedArchs [frArch token]) $
 290         mapM_ (hPutStrLn h) [
 291             "ifeq ($(MAKECMDGOALS),clean)",
 292             "else ifeq ($(MAKECMDGOALS),rehake)",
 293             "else ifeq ($(MAKECMDGOALS),Makefile)",
 294             "else",
 295             "include " ++ (formatToken token),
 296             "endif",
 297             "" ]
 298     return S.empty
 299 makefileRule h (HakeTypes.Rule tokens) =
 300     if allowedArchs (map frArch tokens)
 301         then makefileRuleInner h tokens False
 302         else return S.empty
 303 makefileRule h (Phony name double_colon tokens) = do
 304     hPutStrLn h $ ".PHONY: " ++ name
 305     makefileRuleInner h (Target "build" name : tokens) double_colon
 306
 307 printTokens :: Handle -> S.Set RuleToken -> IO ()
 308 printTokens h tokens =
 309     S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
 310
 311 printDirs :: Handle -> S.Set FilePath -> IO ()
 312 printDirs h dirs =
 313     S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs
 314
 315 makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath)
 316 makefileRuleInner h tokens double_colon = do
 317     if S.null (ruleOutputs compiledRule)
 318     then do
 319         hPutStr h "# hake: omitted rule with no output: "
 320         doBody
 321     else do
 322         printTokens h $ ruleOutputs compiledRule
 323         if double_colon then hPutStr h ":: " else hPutStr h ": "
 324         printTokens h $ ruleDepends compiledRule
 325         printDirs h $ ruleDirs compiledRule
 326         when (not (S.null (rulePreDepends compiledRule))) $ do
 327             hPutStr h " | "
 328             printTokens h $ rulePreDepends compiledRule
 329         hPutStrLn h ""
 330         doBody
 331     where
 332         compiledRule = compileRule tokens
 333
 334         doBody :: IO (S.Set FilePath)
 335         doBody = do
 336             when (ruleBody compiledRule /= []) $ do
 337                 hPutStr h "\t"
 338                 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
 339             hPutStrLn h "\n"
 340             return $ ruleDirs compiledRule
 341
 342 ---
 343 --- Functions to resolve relative path names in rules.
 344 ---
 345 --- First, the outer function: resolve path names in an HRule. The
 346 --- third argument, 'root', is frequently the pathname of the Hakefile
 347 --- relative to the source tree - since relative pathnames in
 348 --- Hakefiles are interpreted relative to the Hakefile location.
 349 ---
 350 resolveRelativePaths :: Opts -> HRule -> String -> HRule
 351 resolveRelativePaths o (Rules hrules) root
 352     = Rules [ resolveRelativePaths o r root | r <- hrules ]
 353 resolveRelativePaths o (HakeTypes.Rule tokens) root
 354     = HakeTypes.Rule [ resolveRelativePath o t root | t <- tokens ]
 355 resolveRelativePaths o (Include token) root
 356     = Include ( resolveRelativePath o token root )
 357 resolveRelativePaths o (Error s) root
 358     = Error s
 359 resolveRelativePaths o (Phony name dbl tokens) root
 360     = Phony name dbl [ resolveRelativePath o t root | t <- tokens ]
 361
 362 --- Now resolve at the level of individual rule tokens.  At this
 363 --- level, we need to take into account the tree (source, build, or
 364 --- install).
 365 resolveRelativePath :: Opts -> RuleToken -> String -> RuleToken
 366 resolveRelativePath o (In t a f) root =
 367     (In t a (resolveRelativePathName o t a f root))
 368 resolveRelativePath o (Out a f) root =
 369     (Out a (resolveRelativePathName o BuildTree a f root))
 370 resolveRelativePath o (Dep t a f) root =
 371     (Dep t a (resolveRelativePathName o t a f root))
 372 resolveRelativePath o (NoDep t a f) root =
 373     (NoDep t a (resolveRelativePathName o t a f root))
 374 resolveRelativePath o (PreDep t a f) root =
 375     (PreDep t a (resolveRelativePathName o t a f root))
 376 resolveRelativePath o (Target a f) root =
 377     (Target a (resolveRelativePathName o BuildTree a f root))
 378 resolveRelativePath _ (Str s) _ = (Str s)
 379 resolveRelativePath _ (NStr s) _ = (NStr s)
 380 resolveRelativePath _ (ErrorMsg s) _ = (ErrorMsg s)
 381 resolveRelativePath _ NL _ = NL
 382
 383 --- Now we get down to the nitty gritty.  We have, in order:
 384 ---   o: The options in force.
 385 ---   t: The tree (source, build, or install)
 386 ---   a: The architecture (e.g. armv7)
 387 ---   p: The pathname we want to resolve to a full path, and
 388 ---   h: The dirname of the Hakefile in which it occurs.
 389 --- If the tree is SrcTree or the architecture is "root", everything
 390 --- is relative to the top-level directory for that tree.  Otherwise,
 391 --- it's relative to the top-level directory plus the architecture.
 392 resolveRelativePathName :: Opts -> TreeRef -> String -> String -> String -> String
 393
 394 resolveRelativePathName o SrcTree "root" f h =
 395     resolveRelativePathName' ((opt_sourcedir o)) f h
 396 resolveRelativePathName o BuildTree "root" f h =
 397     resolveRelativePathName' "." f h
 398 resolveRelativePathName o InstallTree "root" f h =
 399     resolveRelativePathName' ((opt_installdir o)) f h
 400
 401 resolveRelativePathName o SrcTree a f h =
 402     resolveRelativePathName' (opt_sourcedir o) f h
 403 resolveRelativePathName o BuildTree a f h =
 404     resolveRelativePathName' ("." </> a) f h
 405 resolveRelativePathName o InstallTree a f h =
 406     resolveRelativePathName' ((opt_installdir o) </> a) f h
 407
 408 --- This is where the work is done: take 'hd' (pathname relative to
 409 --- us of the Hakefile) and resolve the filename we're interested in
 410 --- relative to this.  This gives us a pathname relative to some root
 411 --- of some architecture tree, then return this relative to the actual
 412 --- tree we're interested in.  It's troubling that this takes more
 413 --- bytes to explain than to code.
 414 ---   d:    Pathname of top directory of the tree (source, build, install)
 415 ---   f:    Filename we are interested in, relative to 'root' below
 416 ---   hd:   Directory containing the Hakefile
 417 ---
 418 resolveRelativePathName' d f hd =
 419     let af = Path.relToFile f hd
 420         rf = Path.makeRel $ Path.relToDir af "/"
 421     in Path.relToDir rf d
 422
 423 makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
 424 makeHakeDeps h o l = do
 425     makefileRule h rule
 426     hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to all targets in the Makefile
 427     where
 428         hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
 429         makefile = resolveRelativePath o (Out "root" (opt_makefilename o)) "/Hakefile"
 430         rule = HakeTypes.Rule
 431                     ( [ hake,
 432                         Str "--source-dir", Str (opt_sourcedir o),
 433                         Str "--install-dir", Str (opt_installdir o),
 434                         Str "--output-filename", makefile
 435                       ] ++
 436                       [ Dep SrcTree "root" h | h <- l ]
 437                     )
 438
 439 makeDirectories :: Handle -> S.Set FilePath -> IO ()
 440 makeDirectories h dirs = do
 441     hPutStrLn h "# Directories follow"
 442     mapM_ (makeDir h) (S.toList (S.delete ("." </> ".marker") dirs))
 443
 444 makeDir :: Handle -> FilePath -> IO ()
 445 makeDir h dir = do
 446     hPutStrLn h $ "hake_dirs: " ++ dir ++ "\n"
 447     hPutStrLn h $ dir ++ ":"
 448     hPutStrLn h $ "\tmkdir -p " ++ (takeDirectory dir)
 449     hPutStrLn h $ "\ttouch " ++ dir
 450     hPutStrLn h ""
 451
 452 scanTokens :: [RuleToken] -> (S.Set RuleToken, S.Set RuleToken,
 453                               S.Set RuleToken, [RuleToken],
 454                               S.Set FilePath)
 455 scanTokens [] = (S.empty, S.empty, S.empty, [], S.empty)
 456 scanTokens (t:ts) =
 457     case t of
 458         Out _ f      -> (S.insert t outs, deps, predeps, body', dirs' f)
 459         Target _ f   -> (S.insert t outs, deps, predeps, body', dirs' f)
 460         In _ _ f     -> (outs, S.insert t deps, predeps, body', dirs' f)
 461         Dep _ _ f    -> (outs, S.insert t deps, predeps, body', dirs' f)
 462         PreDep _ _ f -> (outs, deps, S.insert t predeps, body', dirs' f)
 463         NoDep _ _ f  -> (outs, deps, predeps, body', dirs' f)
 464         _            -> (outs, deps, predeps, body', dirs)
 465     where
 466         (outs, deps, predeps, body, dirs) = scanTokens ts
 467         body' = if inRule t then t:body else body
 468         dirs' f = if Path.isBelow (takeDirectory f) "." &&
 469                      takeDirectory f /= "."
 470                   then S.insert (dirOf f) dirs else dirs
 471
 472         dirOf :: FilePath -> FilePath
 473         dirOf f = (takeDirectory f) </> ".marker"
 474
 475
 476 data CompiledRule =
 477     CompiledRule {
 478         ruleOutputs    :: S.Set RuleToken,
 479         ruleDepends    :: S.Set RuleToken,
 480         rulePreDepends :: S.Set RuleToken,
 481         ruleBody       :: [RuleToken],
 482         ruleDirs       :: S.Set FilePath
 483     }
 484
 485 compileRule :: [RuleToken] -> CompiledRule
 486 compileRule tokens
 487     = CompiledRule {
 488         ruleOutputs    = outs,
 489         ruleDepends    = deps,
 490         rulePreDepends = predeps,
 491         ruleBody       = body,
 492         ruleDirs       = dirs
 493         }
 494     where
 495         (outs, deps, predeps, body, dirs) = scanTokens tokens
 496
 497 gcStats :: IO ()
 498 gcStats = do
 499     performGC
 500     gc_stats <- getGCStats
 501     putStrLn $ show (currentBytesUsed gc_stats) ++ " - " ++
 502                show (numGcs gc_stats) ++ " - " ++
 503                show (maxBytesUsed gc_stats) ++ " - " ++
 504                show (wallSeconds gc_stats)
 505
 506 body :: HakeMonad ()
 507 body =  do
 508     -- parse arguments; architectures default to config file
 509     args <- liftIO $ System.Environment.getArgs
 510     let o1 = parse_arguments args
 511         al = if opt_architectures o1 == []
 512              then Config.architectures
 513              else opt_architectures o1
 514         opts = o1 { opt_architectures = al }
 515
 516     when (opt_usage_error opts) $
 517         throwError (HakeError usage 1)
 518
 519     -- sanity-check configuration settings
 520     -- this is currently known at compile time, but might not always be!
 521     when (isJust configErrors) $
 522         throwError (HakeError ("Error in configuration: " ++
 523                                (fromJust configErrors)) 2)
 524
 525     liftIO $ putStrLn ("Source directory: " ++ opt_sourcedir opts)
 526     liftIO $ putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts)
 527     liftIO $ putStrLn ("Install directory: " ++ opt_installdir opts)
 528
 529     liftIO gcStats
 530
 531     liftIO $ putStrLn "Reading directory tree..."
 532     (allfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
 533
 534     liftIO gcStats
 535
 536     rules <- liftIO $ evalHakeFiles opts allfiles hakefiles
 537     liftIO $ putStrLn $ show (length rules)
 538
 539     liftIO gcStats
 540
 541     liftIO $ putStrLn $ "Generating " ++ (opt_makefilename opts)
 542     makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
 543     liftIO $ makefilePreamble makefile opts args
 544     liftIO $ makeHakeDeps makefile opts $ map fst hakefiles
 545     dirs <- liftIO $ mapM (makefileSection makefile opts allfiles) rules
 546     liftIO $ makeDirectories makefile (S.unions dirs)
 547
 548     liftIO gcStats
 549
 550     return ()
 551
 552 main :: IO ()
 553 main = do
 554     r <- runErrorT $ body `catchError` handleFailure
 555     exitWith ExitSuccess
 556     where
 557         handleFailure (HakeError str n) = do
 558             liftIO $ putStrLn str
 559             liftIO $ exitWith (ExitFailure n)