hmk 0.9.2 → 0.9.3
raw patch · 5 files changed
+143/−23 lines, 5 files
Files
- Control/Hmk.lhs +10/−2
- Control/Hmk.lhs-boot +0/−9
- Control/Hmk/Concurrent.lhs +77/−0
- Main.lhs +51/−10
- hmk.cabal +5/−2
Control/Hmk.lhs view
@@ -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 **
− Control/Hmk.lhs-boot
@@ -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 }
+ Control/Hmk/Concurrent.lhs view
@@ -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
Main.lhs view
@@ -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
hmk.cabal view
@@ -1,12 +1,14 @@ name: hmk-version: 0.9.2+version: 0.9.3 author: Mathieu Boespflug maintainer: Mathieu Boespflug <mboes@tweag.net> 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