diff --git a/Control/Hmk.lhs b/Control/Hmk.lhs --- a/Control/Hmk.lhs +++ b/Control/Hmk.lhs @@ -16,11 +16,13 @@ a standalone program or as a library, for convenience. > module Control.Hmk ( module Control.Hmk.Analyze -> , mk -> , Cmp, Rule(..), Task +> , mk, mkConcurrent +> , Cmp, Rule(..) +> , Task, DepGraph, Tree(..) > , Schedule, Result(..) ) where > > import Control.Hmk.Analyze +> import Control.Hmk.Concurrent > import Control.Applicative > import Control.Monad.State > import Control.Monad.Reader @@ -131,6 +133,12 @@ > mk :: (Ord a, Applicative m, Monad m) => [Rule m a] -> [a] -> m (Schedule m) > mk rules targets = schedule <$> (prune $ depgraph rules targets) + +A version running as many as the given number of jobs simultaneously. +(Equivalent of make -jN.) + +> mkConcurrent :: (Ord a, Show a) => Int -> [Rule IO a] -> [a] -> IO () +> mkConcurrent jobs rules targets = processTree jobs =<< (prune $ depgraph rules targets) ** Tests ** diff --git a/Control/Hmk.lhs-boot b/Control/Hmk.lhs-boot deleted file mode 100644 --- a/Control/Hmk.lhs-boot +++ /dev/null @@ -1,9 +0,0 @@ -> module Control.Hmk where -> -> type Cmp m a = a -> a -> m Bool -> data Result = TaskSuccess | TaskFailure -> type Task m = m Result -> data Rule m a = Rule { target :: a -> , prereqs :: [a] -> , recipe :: Maybe ([a] -> Task m) -> , isStale :: Cmp m a } diff --git a/Control/Hmk/Concurrent.lhs b/Control/Hmk/Concurrent.lhs new file mode 100644 --- /dev/null +++ b/Control/Hmk/Concurrent.lhs @@ -0,0 +1,77 @@ + +2007 Sep 15 + +The author disclaims copyright to this source. In place of a legal +notice, here is a blessing: + + May you do good and not evil. + May you find forgiveness for yourself and forgive others. + May you share freely, never taking more than you give. + +(after the sqlite source code) + +-- + +> module Control.Hmk.Concurrent where +> +> import {-# SOURCE #-} Control.Hmk +> import Control.Concurrent +> import Control.Monad.State +> import Control.Applicative +> import qualified Data.Map as Map + +Map the dependency graph to a tree of concurrent threads, where each thread +encapsulates a recipe to execute after having waited for the completion of the +threads of each prerequesite. It is up to the runtime to schedule the +execution of the threads as it best sees fit. + +However, interleaving the execution of potentially many thousands threads +simultaneously, which are usually all I/O bound, is a bad idea. So we do +enforce some rate limiting of the number of threads that can run +simultaneously by making all threads wait on the same quantity semaphore. The +quantity semaphore can be thought of as making available a fixed amount of +slots. So long as slots remain, threads may take a slot and run. But if slots +run out, the remaining threads must wait until existing threads have finished +their job. + +Because one cannot wait for a thread to finish directly, we signal job +completion by means of MVar's. A finished thread writes some inessential value +to its MVar, which unblocks threads waiting on that MVar. + +Note that there are two distinct monadic levels here. One level is the IO +monad to which a state transformer is applied. This level constructs and +combines monadic values that form the process tree. This process tree is then +pulled out of the state transformed IO monad and executed. + +> data Done = Done +> +> processTree :: (Ord a, Show a) => Int -> DepGraph IO a -> IO () +> processTree slots gr = do +> sem <- newQSem slots +> join $ evalStateT (sequence_ <$> mapM (aux sem) gr) Map.empty +> where aux sem (Node x ps rule) = do +> ws <- mapM (wait sem) ps +> signal <- liftIO $ newEmptyMVar +> modify (Map.insert x signal) +> return $ do +> sequence ws +> waitQSem sem +> result <- maybe (return TaskSuccess) ($ prereqs rule) (recipe rule) +> case result of +> TaskSuccess -> do +> signalQSem sem +> putMVar signal Done +> TaskFailure -> error $ "Recipe for " ++ show x ++ " failed." +> wait sem n@(Node x _ _) = do +> seen <- get +> case Map.lookup x seen of +> Just signal -> return $ do +> readMVar signal +> return () +> Nothing -> do +> work <- aux sem n +> signal <- (Map.! x) <$> get +> return $ do +> tid <- forkIO work +> readMVar signal +> killThread tid diff --git a/Main.lhs b/Main.lhs --- a/Main.lhs +++ b/Main.lhs @@ -34,26 +34,67 @@ > import Control.Applicative > import qualified Data.Sequence as Seq > import qualified Data.Foldable as Seq - -The exit code of the command is the exit code of the last recipe executed. - > import System.IO > import System.Environment +> import System.Exit +> import System.Console.GetOpt > > +> data HmkOption = OptHelp | OptJobs Int | OptMkfile FilePath +> | OptQuestion | OptAll +> deriving (Eq, Ord, Show) +> +> options = [ Option ['a', 'B'] [] (NoArg OptAll) +> "Unconditionally make all targets." +> , Option ['f'] ["file"] (ReqArg OptMkfile "FILE") +> "Read FILE as an mkfile." +> , Option ['j'] ["jobs"] (ReqArg (OptJobs . read) "N") +> "Allow N jobs at once." +> , Option ['q'] ["question"] (NoArg OptQuestion) +> "Run no commands; exit status says if up to date." +> , Option ['h'] ["help"] (NoArg OptHelp) +> "This usage information." ] +> +> usage = "Usage: hmk [OPTION]... [TARGET]..." +> +> printUsage = hPutStrLn stderr usage +> +> printHelp = do +> let header = usage ++ "\nOptions:" +> putStrLn (usageInfo header options) +> +> bailout = printUsage >> exitFailure +> > main :: IO () > main = do -> targets <- map File <$> getArgs -> metarules <- eval =<< parse "mkfile" <$> readFile "mkfile" +> (opts, other, errs) <- getOpt RequireOrder options <$> getArgs +> unless (null errs) $ do +> hPutStr stderr (concat errs) +> exitFailure +> when (OptHelp `elem` opts) (printHelp >> exitSuccess) +> let targets = map File other +> -- number of jobs to run simultaneously. +> slots = foldr (\x y -> case x of OptJobs j -> j; _ -> y) 1 opts +> mkfile = foldr (\x y -> case x of OptMkfile f -> f; _ -> y) "mkfile" opts +> metarules <- eval =<< parse mkfile <$> readFile mkfile > let rules = Seq.toList $ instantiateRecurse (Seq.fromList targets) metarules +> let arules = if OptAll `elem` opts +> then map (\r -> r{Control.Hmk.isStale = \_ _ -> return True}) rules +> else rules > when (null rules) (fail "No rules in mkfile.") > -- completed and coalesced rules. -> let crules = process Eval.isStale rules +> let crules = process Eval.isStale arules +Question mode. + +> when (OptQuestion `elem` opts) $ do +> let ts = if null targets then [target (head rules)] else targets +> schedule <- mk crules targets +> if null schedule then exitSuccess else exitFailure + Per the mk man page, if no targets are specified on the command line, then assume the target is that of the first rule. -> schedule <- case targets of -> [] -> mk crules [target (head rules)] -> _ -> mk crules targets -> sequence_ schedule +> if null targets then +> mkConcurrent slots crules [target (head rules)] else +> mkConcurrent slots crules targets diff --git a/hmk.cabal b/hmk.cabal --- a/hmk.cabal +++ b/hmk.cabal @@ -1,12 +1,14 @@ name: hmk -version: 0.9.2 +version: 0.9.3 author: Mathieu Boespflug maintainer: Mathieu Boespflug homepage: http://code.haskell.org/~mboes/hmk synopsis: A make alternative based on Plan9's mk. description: Clone of Plan9's mk command, said to have \"improved on make by - removing all the vowels from the name\". + removing all the vowels from the name\". Most features of mk + are implemented, including basic meta-rules support and + concurrent execution of jobs. . The library exports a generic dependency graph traversal that can be used independently of the rest. @@ -30,6 +32,7 @@ exposed-modules: Control.Hmk Control.Hmk.Analyze Control.Hmk.IO + Control.Hmk.Concurrent executable hmk main-is: Main.lhs