shake 0.2.9 → 0.2.10

raw patch · 6 files changed

+58/−12 lines, 6 files

Files

• Development/Shake/Core.hs +1/−1
• Development/Shake/Database.hs +4/−1
• Development/Shake/Derived.hs +20/−0
• Development/Shake/Pool.hs +14/−7
• Examples/Test/Pool.hs +18/−2
• shake.cabal +1/−1

@@ -36,7 +36,7 @@ -- | Options to control the execution of Shake, usually specified by overriding fields in --   'shakeOptions': -----   @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=Just "report.html"} @+--   @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=Just \"report.html\"} @ data ShakeOptions = ShakeOptions     {shakeFiles :: FilePath -- ^ Where shall I store the database and journal files (defaults to @.shake@).     ,shakeThreads :: Int -- ^ What is the maximum number of rules I should run in parallel (defaults to @1@).

@@ -333,7 +333,10 @@ -- DATABASE  withDatabase :: (String -> IO ()) -> FilePath -> Int -> (Database -> IO a) -> IO a-withDatabase logger filename version = bracket (openDatabase logger filename version) closeDatabase+withDatabase logger filename version act = do+    -- expand the filename, in case pwd has changed by the close action+    filename <- canonicalizePath filename+    bracket (openDatabase logger filename version) closeDatabase act   -- Files are named based on the FilePath, but with different extensions,

@@ -24,6 +24,26 @@     when (res /= ExitSuccess) $         error $ "System command failed:\n" ++ cmd ++-- | Execute a system command with a specified current working directory (first argument).+--   This function will raise an error if the exit code is non-zero.+--   Before running 'systemCwd' make sure you 'need' any required files.+--+-- > systemCwd "/usr/MyDirectory" "pwd" []+systemCwd :: FilePath -> FilePath -> [String] -> Action ()+systemCwd cwd path args = do+    let path2 = toNative path+    let cmd = unwords $ path2 : args+    putLoud cmd+    res <- traced ("system " ++ cmd) $ do+        -- FIXME: Should I be using the non-exported System.Process.syncProcess?+        --        That installs/removes signal handlers.+        hdl <- runProcess path2 args (Just cwd) Nothing Nothing Nothing Nothing+        waitForProcess hdl+    when (res /= ExitSuccess) $+        error $ "System command failed:\n" ++ cmd++ -- | Execute a system command, returning @(stdout,stderr)@. --   This function will raise an error if the exit code is non-zero. --   Before running 'systemOutput' make sure you 'need' any required files.

@@ -104,10 +104,17 @@ runPool :: Int -> (Pool -> IO ()) -> IO () -- run all tasks in the pool runPool n act = do     s <- newVar $ Just emptyS-    res <- newBarrier-    let pool = Pool n s res-    addPool pool $ act pool-    res <- waitBarrier res-    case res of-        Nothing -> return ()-        Just e -> throw e+    let cleanup = modifyVar_ s $ \s -> do+            -- if someone kills our thread, make sure we kill our child threads+            case s of+                Just s -> mapM_ killThread $ Set.toList $ threads s+                Nothing -> return ()+            return Nothing+    flip onException cleanup $ do+        res <- newBarrier+        let pool = Pool n s res+        addPool pool $ act pool+        res <- waitBarrier res+        case res of+            Nothing -> return ()+            Just e -> throw e

@@ -50,7 +50,7 @@             blockPool pool $ takeMVar var             modifyMVar_ done $ const $ return True     done <- readMVar done-    assert done "Blocking works"+    assert done "Blocking"      -- check someone spawned when at zero todo still gets run     done <- newMVar False@@ -61,4 +61,20 @@                 wait                 modifyMVar_ done $ const $ return True     done <- readMVar done-    assert done "Waiting on someone works"+    assert done "Waiting on someone"++    -- check that killing a thread pool stops the tasks, bug 545+    thread <- newEmptyMVar+    done <- newEmptyMVar+    res <- newMVar True+    t <- forkIO $ finally (putMVar done ()) $ runPool 1 $ \pool ->+        addPool pool $ do+            t <- takeMVar thread+            killThread t+            wait -- allow the thread to die first+            modifyMVar_ res (const $ return False)+    putMVar thread t+    takeMVar done+    wait >> wait >> wait -- allow the bad thread to continue+    res <- readMVar res+    assert res "Early termination"

@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               shake-version:            0.2.9+version:            0.2.10 license:            BSD3 license-file:       LICENSE category:           Development