rattle (empty) → 0.1
raw patch · 18 files changed
+1140/−0 lines, 18 filesdep +basedep +bytestringdep +cryptohash-sha256setup-changed
Dependencies added: base, bytestring, cryptohash-sha256, deepseq, directory, extra, filepath, filepattern, hashable, rattle, shake, time, transformers, unordered-containers
Files
- CHANGES.txt +4/−0
- LICENSE +217/−0
- README.md +28/−0
- Setup.hs +2/−0
- rattle.cabal +72/−0
- src/Development/Rattle.hs +48/−0
- src/Development/Rattle/Hash.hs +72/−0
- src/Development/Rattle/Limit.hs +72/−0
- src/Development/Rattle/Server.hs +274/−0
- src/Development/Rattle/Shared.hs +80/−0
- src/Development/Rattle/Types.hs +50/−0
- src/General/Bilist.hs +37/−0
- src/General/Extra.hs +69/−0
- src/General/Thread.hs +47/−0
- test/C/constants.c +7/−0
- test/C/constants.h +1/−0
- test/C/main.c +8/−0
- test/Test.hs +52/−0
+ CHANGES.txt view
@@ -0,0 +1,4 @@+Changelog for Rattle (* = breaking change)++0.1, released 2019-04-17+ Initial version, not ready for public use
+ LICENSE view
@@ -0,0 +1,217 @@+Copyright Neil Mitchell 2019.++Licensed under either of:++* BSD-3-Clause license (https://opensource.org/licenses/BSD-3-Clause)+* Apache License, version 2.0 (https://opensource.org/licenses/Apache-2.0)++As a user, you may use this code under either license, at your option.+++---------------------------------------------------------------------+BSD 3-Clause License+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Neil Mitchell nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++---------------------------------------------------------------------+Apache License+Version 2.0, January 2004+<http://www.apache.org/licenses/>++Terms and Conditions for use, reproduction, and distribution+1. Definitions+"License" shall mean the terms and conditions for use, reproduction,+and distribution as defined by Sections 1 through 9 of this document.++"Licensor" shall mean the copyright owner or entity authorized by the+copyright owner that is granting the License.++"Legal Entity" shall mean the union of the acting entity and all+other entities that control, are controlled by, or are under common+control with that entity. For the purposes of this definition,+"control" means (i) the power, direct or indirect, to cause the+direction or management of such entity, whether by contract or+otherwise, or (ii) ownership of fifty percent (50%) or more of the+outstanding shares, or (iii) beneficial ownership of such entity.++"You" (or "Your") shall mean an individual or Legal Entity exercising+permissions granted by this License.++"Source" form shall mean the preferred form for making modifications,+including but not limited to software source code, documentation+source, and configuration files.++"Object" form shall mean any form resulting from mechanical+transformation or translation of a Source form, including but not+limited to compiled object code, generated documentation, and+conversions to other media types.++"Work" shall mean the work of authorship, whether in Source or Object+form, made available under the License, as indicated by a copyright+notice that is included in or attached to the work).++"Derivative Works" shall mean any work, whether in Source or Object+form, that is based on (or derived from) the Work and for which the+editorial revisions, annotations, elaborations, or other+modifications represent, as a whole, an original work of authorship.+For the purposes of this License, Derivative Works shall not include+works that remain separable from, or merely link (or bind by name) to+the interfaces of, the Work and Derivative Works thereof.++"Contribution" shall mean any work of authorship, including the+original version of the Work and any modifications or additions to+that Work or Derivative Works thereof, that is intentionally+submitted to Licensor for inclusion in the Work by the copyright+owner or by an individual or Legal Entity authorized to submit on+behalf of the copyright owner. For the purposes of this definition,+"submitted" means any form of electronic, verbal, or written+communication sent to the Licensor or its representatives, including+but not limited to communication on electronic mailing lists, source+code control systems, and issue tracking systems that are managed by,+or on behalf of, the Licensor for the purpose of discussing and+improving the Work, but excluding communication that is conspicuously+marked or otherwise designated in writing by the copyright owner as+"Not a Contribution."++"Contributor" shall mean Licensor and any individual or Legal Entity+on behalf of whom a Contribution has been received by Licensor and+subsequently incorporated within the Work.++2. Grant of Copyright License+Subject to the terms and conditions of this License, each Contributor+hereby grants to You a perpetual, worldwide, non-exclusive,+no-charge, royalty-free, irrevocable copyright license to reproduce,+prepare Derivative Works of, publicly display, publicly perform,+sublicense, and distribute the Work and such Derivative Works in+Source or Object form.++3. Grant of Patent License+Subject to the terms and conditions of this License, each Contributor+hereby grants to You a perpetual, worldwide, non-exclusive,+no-charge, royalty-free, irrevocable (except as stated in this+section) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer the Work, where such license applies+only to those patent claims licensable by such Contributor that are+necessarily infringed by their Contribution(s) alone or by+combination of their Contribution(s) with the Work to which such+Contribution(s) was submitted. If You institute patent litigation+against any entity (including a cross-claim or counterclaim in a+lawsuit) alleging that the Work or a Contribution incorporated within+the Work constitutes direct or contributory patent infringement, then+any patent licenses granted to You under this License for that Work+shall terminate as of the date such litigation is filed.++4. Redistribution+You may reproduce and distribute copies of the Work or Derivative+Works thereof in any medium, with or without modifications, and in+Source or Object form, provided that You meet the following+conditions:++(a) You must give any other recipients of the Work or Derivative+Works a copy of this License; and+(b) You must cause any modified files to carry prominent notices+stating that You changed the files; and+(c) You must retain, in the Source form of any Derivative Works that+You distribute, all copyright, patent, trademark, and attribution+notices from the Source form of the Work, excluding those notices+that do not pertain to any part of the Derivative Works; and+(d) If the Work includes a "NOTICE" text file as part of its+distribution, then any Derivative Works that You distribute must+include a readable copy of the attribution notices contained within+such NOTICE file, excluding those notices that do not pertain to any+part of the Derivative Works, in at least one of the following+places: within a NOTICE text file distributed as part of the+Derivative Works; within the Source form or documentation, if+provided along with the Derivative Works; or, within a display+generated by the Derivative Works, if and wherever such third-party+notices normally appear. The contents of the NOTICE file are for+informational purposes only and do not modify the License. You may+add Your own attribution notices within Derivative Works that You+distribute, alongside or as an addendum to the NOTICE text from the+Work, provided that such additional attribution notices cannot be+construed as modifying the License.+You may add Your own copyright statement to Your modifications and+may provide additional or different license terms and conditions for+use, reproduction, or distribution of Your modifications, or for any+such Derivative Works as a whole, provided Your use, reproduction,+and distribution of the Work otherwise complies with the conditions+stated in this License.++5. Submission of Contributions+Unless You explicitly state otherwise, any Contribution intentionally+submitted for inclusion in the Work by You to the Licensor shall be+under the terms and conditions of this License, without any+additional terms or conditions. Notwithstanding the above, nothing+herein shall supersede or modify the terms of any separate license+agreement you may have executed with Licensor regarding such+Contributions.++6. Trademarks+This License does not grant permission to use the trade names,+trademarks, service marks, or product names of the Licensor, except+as required for reasonable and customary use in describing the origin+of the Work and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty+Unless required by applicable law or agreed to in writing, Licensor+provides the Work (and each Contributor provides its Contributions)+on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,+either express or implied, including, without limitation, any+warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY,+or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for+determining the appropriateness of using or redistributing the Work+and assume any risks associated with Your exercise of permissions+under this License.++8. Limitation of Liability+In no event and under no legal theory, whether in tort (including+negligence), contract, or otherwise, unless required by applicable+law (such as deliberate and grossly negligent acts) or agreed to in+writing, shall any Contributor be liable to You for damages,+including any direct, indirect, special, incidental, or consequential+damages of any character arising as a result of this License or out+of the use or inability to use the Work (including but not limited to+damages for loss of goodwill, work stoppage, computer failure or+malfunction, or any and all other commercial damages or losses), even+if such Contributor has been advised of the possibility of such+damages.++9. Accepting Warranty or Additional Liability+While redistributing the Work or Derivative Works thereof, You may+choose to offer, and charge a fee for, acceptance of support,+warranty, indemnity, or other liability obligations and/or rights+consistent with this License. However, in accepting such obligations,+You may act only on Your own behalf and on Your sole responsibility,+not on behalf of any other Contributor, and only if You agree to+indemnify, defend, and hold each Contributor harmless for any+liability incurred by, or claims asserted against, such Contributor+by reason of your accepting any such warranty or additional+liability.
+ README.md view
@@ -0,0 +1,28 @@+# Rattle [](https://hackage.haskell.org/package/rattle) [](https://www.stackage.org/package/rattle) [](https://travis-ci.org/ndmitchell/rattle) [](https://ci.appveyor.com/project/ndmitchell/rattle)++A very early prototype of a unique build system.++A forward based build system, where you can make calls to `cmd`. These are:++1) Skipped if their inputs/outputs haven't changed+2) Have their outputs copied in if only the outputs have changed+3) Can be speculated in advance++The innovation over something like Fabricate is that I have a notion+of hazards - if two rules write to the same file, or one writes after+another reads, I consider that a build hazard and throw an error - the+result is no longer consistent. For speculation, I just run commands+that look useful and don't look like they'll cause a hazard. If+speculation does cause a hazard, I give up and try again without+speculation.++This build system fundamentally relies on tracing the files used by system commands, and currently uses the [`fsatrace`](https://github.com/jacereda/fsatrace) program to do so, which must be installed. As a consequence of the design, if `fsatrace` fails, then `rattle` won't work properly. Example reasons that `fsatrace` might fail include:++* If you use Go compiled binaries on Linux or Mac then it's unlikely to be traced, see [Issue 24](https://github.com/jacereda/fsatrace/issues/24).+* If you a Mac OS X 1.10 or higher then system binaries that themselves invoke system binaries they won't be traced, unless you [disable System Integrity Protection](https://developer.apple.com/library/content/documentation/Security/Conceptual/System_Integrity_Protection_Guide/ConfiguringSystemIntegrityProtection/ConfiguringSystemIntegrityProtection.html) (which you do at your own risk).+* If you use statically linked binaries on Linux they probably won't be traced.++It is possible to write alternative tracing mechanisms that wouldn't have these limitations, for example:++* [Bigbro](https://github.com/droundy/bigbro/) uses `ptrace` so works for Go binaries and statically linked binaries.+* [traced-fs](https://github.com/jacereda/traced-fs) is an unfinished file system tracer that implements a user file system that would also work for Go binaries and static linking.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rattle.cabal view
@@ -0,0 +1,72 @@+cabal-version: >= 1.18+build-type: Simple+name: rattle+version: 0.1+license: BSD3+x-license: BSD-3-Clause OR Apache-2.0+license-file: LICENSE+category: Development+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Neil Mitchell <ndmitchell@gmail.com>+copyright: Neil Mitchell 2019+synopsis: Forward build system, with caching and speculation+description:+ A forward build system like Fabrciate but with speculation and remote caching.+homepage: https://github.com/ndmitchell/rattle#readme+bug-reports: https://github.com/ndmitchell/rattle/issues+tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2+extra-doc-files:+ CHANGES.txt+ README.md+extra-source-files:+ test/C/constants.c+ test/C/constants.h+ test/C/main.c++source-repository head+ type: git+ location: https://github.com/ndmitchell/rattle.git++library+ default-language: Haskell2010+ hs-source-dirs: src+ build-depends:+ base >= 4.8 && < 5,+ bytestring,+ cryptohash-sha256,+ deepseq >= 1.1,+ directory,+ extra >= 1.6.14,+ filepath,+ hashable >= 1.1.2.3,+ shake >= 0.17.8,+ time,+ transformers >= 0.2,+ unordered-containers >= 0.2.7++ exposed-modules:+ Development.Rattle++ other-modules:+ Development.Rattle.Hash+ Development.Rattle.Limit+ Development.Rattle.Server+ Development.Rattle.Shared+ Development.Rattle.Types+ General.Bilist+ General.Extra+ General.Thread++test-suite rattle-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: test/Test.hs+ ghc-options: -main-is Test.main -rtsopts -with-rtsopts=-K1K -threaded++ build-depends:+ base >= 4.8 && < 5,+ directory,+ extra,+ filepattern,+ rattle,+ shake
+ src/Development/Rattle.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | General rules for writing consistent rattle build systems:+--+-- * Never write to the same file twice. Never read then write.+--+-- * Don't delete files that have been produced. Each command should make+-- new files, not delete old files.+module Development.Rattle(+ rattle, Run,+ Hazard,+ RattleOptions(..), rattleOptions,+ cmd,+ parallel, forP,+ liftIO+ ) where++import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import Development.Rattle.Server+import General.Thread+++-- | Type of actions to run. Executed using 'rattle'.+newtype Run a = Run {fromRun :: ReaderT Rattle IO a}+ deriving (Functor, Applicative, Monad, MonadIO)++-- | Run a sequence of 'Run' actions in parallel. They will be run in parallel with no limit+-- on simultaneous executions.+parallel :: [Run a] -> Run [a]+parallel xs = do+ r <- Run ask+ liftIO $ withThreadsList $ map (flip runReaderT r . fromRun) xs++-- | Parallel version of 'forM'.+forP :: (a -> Run b) -> [a] -> Run [b]+forP f xs = parallel $ map f xs++-- | Run a system command with the given arguments.+cmd :: [String] -> Run ()+cmd args = do+ r <- Run ask+ liftIO $ cmdRattle r args++-- | Given an Action to run, and a list of previous commands that got run, run it again+rattle :: RattleOptions -> Run a -> IO a+rattle opts (Run act) = withRattle opts $ \r ->+ runReaderT act r
+ src/Development/Rattle/Hash.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Development.Rattle.Hash(+ Hash, fromHash,+ hashFile, hashString+ ) where++import System.IO+import Data.Hashable+import qualified Crypto.Hash.SHA256 as SHA+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.HashMap.Strict as Map+import Data.Time+import System.Directory+import Data.Char+import System.IO.Unsafe+import System.IO.Error+import Control.Monad.Extra+import Data.IORef+import Numeric+import Control.Exception.Extra+import Control.DeepSeq+++newtype Hash = Hash String+ deriving (NFData, Show, Read, Eq, Hashable)++fromHash :: Hash -> String+fromHash (Hash x) = x+++mkHash :: BS.ByteString -> Hash+mkHash = Hash . concatMap (f . ord) . BS.unpack+ where f i = ['0' | i < 16] ++ showHex i ""+++-- Hashing lots of files is expensive, so we keep a cache+{-# NOINLINE hashCache #-}+hashCache :: IORef (Map.HashMap FilePath (UTCTime, Hash))+hashCache = unsafePerformIO $ newIORef Map.empty+++getModTime :: FilePath -> IO (Maybe UTCTime)+getModTime x = handleBool isDoesNotExistError (const $ return Nothing) (Just <$> getModificationTime x)+++hashFile :: FilePath -> IO (Maybe Hash)+hashFile file = do+ start <- getModTime file+ case start of+ Nothing -> return Nothing+ Just start -> do+ mp <- readIORef hashCache+ case Map.lookup file mp of+ Just (time, hash) | time == start -> return $ Just hash+ _ -> do+ -- we can get a ModTime on a directory, but can't withFile it+ b <- doesFileExist file+ if not b then return Nothing else do+ res <- withFile file ReadMode $ \h -> do+ chunks <- LBS.hGetContents h+ evaluate $ force $ mkHash $ SHA.finalize $ SHA.updates SHA.init $ LBS.toChunks chunks+ end <- getModTime file+ when (Just start == end) $+ atomicModifyIORef' hashCache $ \mp -> (Map.insert file (start, res) mp, ())+ return $ Just res+++hashString :: String -> Hash+-- we first 'show' the String to avoid having > 256 characters in it+hashString = mkHash . SHA.hash . BS.pack . show
+ src/Development/Rattle/Limit.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TupleSections, LambdaCase #-}++module Development.Rattle.Limit(+ Limit, newLimit, withLimit, withLimitMaybe,+ ) where++import qualified General.Bilist as B+import Control.Exception+import Control.Monad+import Control.Concurrent.Extra+++newtype Limit = Limit (Var S)++data S = Free !Int+ | Queued (B.Bilist (IO ()))+++newLimit :: Int -> IO Limit+newLimit i+ | i < 1 = error $ "newLimit, argument must be >= 1, got " ++ show i+ | otherwise = Limit <$> newVar (Free i)++data LS+ = Wait -- I am waiting like normal, default state+ | Fire -- I got asked to run+ | Died -- I got an async exception++withLimit :: Limit -> IO a -> IO a+withLimit (Limit var) act = mask $ \unmask ->+ join $ modifyVar var $ \x -> case x of+ Free i | i >= 1 -> return $ (Free (i-1),) $+ execute unmask+ _ -> do+ let q = case x of Queued q -> q; _ -> mempty+ -- a real pain to deal with async exceptions while waiting+ -- but I think this does it - although not very elegant+ wait <- newBarrier+ ls <- newVar Wait+ let go = join $ modifyVar ls $ \x -> return $ case x of+ Wait -> (Fire, signalBarrier wait ())+ Died -> (Died, finished var)+ return $ (Queued $ B.cons go q, ) $ do+ unmask (waitBarrier wait) `onException` do+ join $ modifyVar ls $ \x -> return $ case x of+ Wait -> (Died, return ())+ Fire -> (Fire, finished var)+ execute unmask+ where+ execute unmask = do+ res <- unmask act `onException` finished var+ finished var+ return res+++withLimitMaybe :: Limit -> IO a -> IO (Maybe a)+withLimitMaybe (Limit var) act = mask $ \unmask ->+ join $ modifyVar var $ \x -> case x of+ Free i | i >= 1 -> return $ (Free (i-1),) $ do+ res <- unmask act `onException` finished var+ finished var+ return $ Just res+ _ -> return (x, return Nothing)+++finished :: Var S -> IO ()+finished var = mask_ $+ join $ modifyVar var $ \case+ Free i -> return (Free (i+1), return ())+ Queued q -> case B.uncons q of+ Nothing -> return (Free 1, return ())+ Just (q, qs) -> return (Queued qs, q)
+ src/Development/Rattle/Server.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TupleSections, ViewPatterns, LambdaCase #-}++module Development.Rattle.Server(+ RattleOptions(..), rattleOptions,+ Rattle, withRattle,+ Hazard,+ cmdRattle+ ) where++import Control.Monad.Extra+import Development.Rattle.Limit+import Development.Rattle.Types+import Development.Rattle.Shared+import Development.Rattle.Hash+import Control.Exception.Extra+import Control.Concurrent.Extra+import General.Extra+import System.FilePath+import qualified Data.ByteString.Char8 as BS+import System.IO.Unsafe(unsafeInterleaveIO)+import qualified Development.Shake.Command as C+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set+import Data.IORef+import Data.Hashable+import Data.List.Extra+import Data.Tuple.Extra+++-- | Basic options for configuring rattle.+data RattleOptions = RattleOptions+ {rattleFiles :: FilePath -- ^ Where all my shared files go+ ,rattleSpeculate :: Maybe String -- ^ Should I speculate? Under which key?+ ,rattleShare :: Bool -- ^ Should I share files from the cache+ ,rattleProcesses :: Int -- ^ Number of simulateous processes+ } deriving Show++-- | Default 'RattleOptions' value.+rattleOptions :: RattleOptions+rattleOptions = RattleOptions ".rattle" (Just "") True 8++data ReadOrWrite = Read | Write deriving (Show,Eq)++data S = S+ {timestamp :: !T+ -- ^ The current timestamp we are on+ ,started :: Map.HashMap Cmd (NoShow (IO ()))+ -- ^ Things that have got to running - if you find a duplicate just run the IO+ -- to wait for it.+ ,running :: [(T, Cmd, [Trace ()])]+ -- ^ Things currently running, with the time they started,+ -- and an amalgamation of their previous Trace (if we have any)+ ,hazard :: Map.HashMap FilePath (ReadOrWrite, T, Cmd)+ -- ^ Things that have been read or written, at what time, and by which command+ -- Used to detect hazards.+ -- Read is recorded as soon as it can, Write as late as it can, as that increases hazards.+ ,pending :: [(T, Cmd, Trace Hash)]+ -- ^ Things that have completed, and would like to get recorded, but have to wait+ -- to confirm they didn't cause hazards+ ,required :: [Cmd]+ -- ^ Things what were required by the user calling cmdRattle, not added due to speculation.+ -- Will be the 'speculate' list next time around.+ } deriving Show+++data Problem+ = Finished+ | Hazard Hazard++throwProblem :: Problem -> IO a+throwProblem Finished = fail "Finished, but still trying to do stuff"+throwProblem (Hazard h) = throwIO h++-- | Type of exception thrown if there is a hazard when running the build system.+data Hazard+ = ReadWriteHazard FilePath Cmd Cmd+ | WriteWriteHazard FilePath Cmd Cmd+ deriving Show+instance Exception Hazard+++data Rattle = Rattle+ {options :: RattleOptions+ ,speculate :: [(Cmd, [Trace Hash])] -- ^ Things that were used in the last speculation with this name+ ,state :: Var (Either Problem S)+ ,speculated :: IORef Bool+ ,limit :: Limit+ ,shared :: Shared+ }+++withRattle :: RattleOptions -> (Rattle -> IO a) -> IO a+withRattle options@RattleOptions{..} act = withShared rattleFiles $ \shared -> do+ speculate <- maybe (return []) (getSpeculate shared) rattleSpeculate+ speculate <- fmap (takeWhile (not . null . snd)) $ forM speculate $ \x -> (x,) <$> unsafeInterleaveIO (getCmdTraces shared x)+ speculated <- newIORef False+ let s0 = Right $ S t0 Map.empty [] Map.empty [] []+ state <- newVar s0+ limit <- newLimit rattleProcesses+ let r = Rattle{..}+ runSpeculate r++ let saveSpeculate state =+ whenJust rattleSpeculate $ \name ->+ whenRightM (readVar state) $ \v ->+ setSpeculate shared name $ reverse $ required v++ -- first try and run it+ ((act r <* saveSpeculate state) `finally` writeVar state (Left Finished)) `catch`+ \(h :: Hazard) -> do+ b <- readIORef speculated+ if not b then throwIO h else do+ -- if we speculated, and we failed with a hazard, try again+ putStrLn "Warning: Speculation lead to a hazard, retrying without speculation"+ print h+ state <- newVar s0+ limit <- newLimit rattleProcesses+ let r = Rattle{speculate=[], ..}+ (act r <* saveSpeculate state) `finally` writeVar state (Left Finished)+++runSpeculate :: Rattle -> IO ()+runSpeculate rattle@Rattle{..} = void $ withLimitMaybe limit $ forkIO $+ -- speculate on a process iff it is the first process in speculate that:+ -- 1) we have some parallelism free+ -- 2) it is the first eligible in the list+ -- 3) not already been started+ -- 4) no read/write conflicts with anything completed+ -- 5) no read conflicts with anything running or any earlier speculation+ join $ modifyVar state $ \s -> case s of+ Right s | Just cmd <- nextSpeculate rattle s -> do+ writeIORef speculated True+ cmdRattleStarted rattle cmd s ["speculating"]+ _ -> return (s, return ())+++nextSpeculate :: Rattle -> S -> Maybe Cmd+nextSpeculate Rattle{..} S{..}+ | any (null . thd3) running = Nothing+ | otherwise = step (addTrace (Set.empty, Set.empty) $ mconcat $ concatMap thd3 running) speculate+ where+ addTrace (r,w) Trace{..} = (f r tRead, f w tWrite)+ where f set xs = Set.union set $ Set.fromList $ map fst xs++ step _ [] = Nothing+ step rw ((x,_):xs)+ | x `Map.member` started = step rw xs -- do not update the rw, since its already covered+ step rw@(r, w) ((x, mconcat -> t@Trace{..}):xs)+ | not $ any (\v -> v `Set.member` r || v `Set.member` w || v `Map.member` hazard) $ map fst tWrite+ -- if anyone I write has ever been read or written, or might be by an ongoing thing, that would be bad+ , not $ any (`Set.member` w) $ map fst tRead+ -- if anyone I read might be being written right now, that would be bad+ = Just x+ | otherwise+ = step (addTrace rw t) xs+++cmdRattle :: Rattle -> [String] -> IO ()+cmdRattle rattle args = cmdRattleRequired rattle $ Cmd args++cmdRattleRequired :: Rattle -> Cmd -> IO ()+cmdRattleRequired rattle@Rattle{..} cmd = withLimit limit $ do+ modifyVar_ state $ return . fmap (\s -> s{required = cmd : required s})+ cmdRattleStart rattle cmd++cmdRattleStart :: Rattle -> Cmd -> IO ()+cmdRattleStart rattle@Rattle{..} cmd = join $ modifyVar state $ \case+ Left e -> throwProblem e+ Right s -> cmdRattleStarted rattle cmd s []++cmdRattleStarted :: Rattle -> Cmd -> S -> [String] -> IO (Either Problem S, IO ())+cmdRattleStarted rattle@Rattle{..} cmd s msgs = do+ let start = timestamp s+ s <- return s{timestamp = succ $ timestamp s}+ case Map.lookup cmd (started s) of+ Just (NoShow wait) -> return (Right s, wait)+ Nothing -> do+ hist <- unsafeInterleaveIO $ getCmdTraces shared cmd+ go <- once $ cmdRattleRun rattle cmd start hist msgs+ s <- return s{running = (start, cmd, map void hist) : running s}+ s <- return s{started = Map.insert cmd (NoShow go) $ started s}+ return (Right s, runSpeculate rattle >> go >> runSpeculate rattle)+++-- either fetch it from the cache or run it)+cmdRattleRun :: Rattle -> Cmd -> T -> [Trace Hash] -> [String] -> IO ()+cmdRattleRun rattle@Rattle{..} cmd@(Cmd args) start hist msgs = do+ hasher <- memoIO hashFile+ let match (fp, h) = (== Just h) <$> hasher fp+ histRead <- filterM (allM match . tRead) hist+ histBoth <- filterM (allM match . tWrite) histRead+ case histBoth of+ t:_ ->+ -- we have something consistent at this point, no work to do+ -- technically we aren't writing to the tWrite part of the trace, but if we don't include that+ -- skipping can turn write/write hazards into read/write hazards+ cmdRattleFinished rattle start cmd t False+ [] -> do+ -- lets see if any histRead's are also available in the cache+ fetcher <- memoIO $ getFile shared+ let fetch (fp, h) = do v <- fetcher h; case v of Nothing -> return Nothing; Just op -> return $ Just $ op fp+ download <- if not (rattleShare options)+ then return Nothing+ else firstJustM (\t -> fmap (t,) <$> allMaybeM fetch (tWrite t)) histRead+ case download of+ Just (t, download) -> do+ display ["copying"]+ sequence_ download+ cmdRattleFinished rattle start cmd t False+ Nothing -> do+ display []+ t <- fsaTrace <$> C.cmd args+ let skip x = "/dev/" `isPrefixOf` x || hasTrailingPathSeparator x+ let f xs = mapMaybeM (\x -> fmap (x,) <$> hashFile x) $ filter (not . skip) $ map fst xs+ t <- Trace <$> f (tRead t) <*> f (tWrite t)+ when (rattleShare options) $+ forM_ (tWrite t) $ \(fp, h) ->+ setFile shared fp h ((== Just h) <$> hashFile fp)+ cmdRattleFinished rattle start cmd t True+ where+ display msgs2 = BS.putStrLn $ BS.pack $ unwords $ "#" : args ++ ["(" ++ unwords (msgs ++ msgs2) ++ ")" | not $ null $ msgs ++ msgs2]++-- | I finished running a command+cmdRattleFinished :: Rattle -> T -> Cmd -> Trace Hash -> Bool -> IO ()+cmdRattleFinished rattle@Rattle{..} start cmd trace@Trace{..} save = join $ modifyVar state $ \case+ Left e -> throwProblem e+ Right s -> do+ -- update all the invariants+ let stop = timestamp s+ s <- return s{timestamp = succ $ timestamp s}+ s <- return s{running = filter ((/= start) . fst3) $ running s}+ s <- return s{pending = [(stop, cmd, trace) | save] ++ pending s}++ -- look for hazards+ let newHazards = Map.fromList $ map ((,(Write,start,cmd)) . fst) tWrite +++ map ((,(Read ,stop ,cmd)) . fst) tRead+ case unionWithKeyEithers mergeFileOps (hazard s) newHazards of+ (ps@(p:_), _) -> return (Left $ Hazard p, print ps >> throwIO p)+ ([], hazard2) -> do+ s <- return s{hazard = hazard2}++ -- move people out of pending if they have survived long enough+ let earliest = minimum $ succ stop : map fst3 (running s)+ (safe, pending) <- return $ partition (\x -> fst3 x < earliest) $ pending s+ s <- return s{pending = pending}+ return (Right s, forM_ safe $ \(_,c,t) -> addCmdTrace shared c t)+++mergeFileOps :: FilePath -> (ReadOrWrite, T, Cmd) -> (ReadOrWrite, T, Cmd) -> Either Hazard (ReadOrWrite, T, Cmd)+mergeFileOps x (Read, t1, cmd1) (Read, t2, cmd2) = Right (Read, min t1 t2, if t1 < t2 then cmd1 else cmd2)+mergeFileOps x (Write, t1, cmd1) (Write, t2, cmd2) = Left $ WriteWriteHazard x cmd1 cmd2+mergeFileOps x (Read, t1, cmd1) (Write, t2, cmd2)+ | t1 <= t2 = Left $ ReadWriteHazard x cmd2 cmd1+ | otherwise = Right (Write, t2, cmd2)+mergeFileOps x v1 v2 = mergeFileOps x v2 v1 -- must be Write/Read, so match the other way around+++allMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe [b])+allMaybeM f [] = return $ Just []+allMaybeM f (x:xs) = do+ y <- f x+ case y of+ Nothing -> return Nothing+ Just y -> fmap (y:) <$> allMaybeM f xs+++unionWithKeyEithers :: (Eq k, Hashable k) => (k -> v -> v -> Either e v) -> Map.HashMap k v -> Map.HashMap k v -> ([e], Map.HashMap k v)+unionWithKeyEithers op lhs rhs = foldl' f ([], lhs) $ Map.toList rhs+ where+ f (es, mp) (k, v2) = case Map.lookup k mp of+ Nothing -> (es, Map.insert k v2 mp)+ Just v1 -> case op k v1 v2 of+ Left e -> (e:es, mp)+ Right v -> (es, Map.insert k v mp)
@@ -0,0 +1,80 @@+{-# LANGUAGE ViewPatterns #-}++module Development.Rattle.Shared(+ Shared, withShared,+ getSpeculate, setSpeculate,+ getFile, setFile,+ getCmdTraces, addCmdTrace+ ) where++import General.Extra+import Development.Rattle.Types+import Development.Rattle.Hash+import System.FilePath+import System.Directory+import System.IO.Extra+import Data.Maybe+import Control.Monad.Extra+import Text.Read+import Control.Concurrent.Extra+++data Shared = Shared Lock FilePath++withShared :: FilePath -> (Shared -> IO a) -> IO a+withShared dir act = do+ lock <- newLock+ createDirectoryRecursive dir+ act $ Shared lock dir++filename :: Hash -> String+filename (fromHash -> a:b:cs) = [a,b] </> cs++getList :: (Show a, Read b) => String -> Shared -> a -> IO [b]+getList typ (Shared lock dir) name = withLock lock $ do+ let file = dir </> typ </> filename (hashString $ show name)+ b <- doesFileExist file+ if not b then return [] else mapMaybe readMaybe . lines <$> readFileUTF8' file++setList :: (Show a, Show b) => String -> IOMode -> Shared -> a -> [b] -> IO ()+setList typ mode (Shared lock dir) name vals = withLock lock $ do+ let file = dir </> typ </> filename (hashString $ show name)+ createDirectoryRecursive $ takeDirectory file+ unlessM (doesFileExist $ file <.> "txt") $+ writeFile (file <.> "txt") $ show name+ withFile file mode $ \h -> do+ hSetEncoding h utf8+ hPutStr h $ unlines $ map show vals+++getSpeculate :: Shared -> String -> IO [Cmd]+getSpeculate = getList "speculate"++setSpeculate :: Shared -> String -> [Cmd] -> IO ()+setSpeculate = setList "speculate" WriteMode++getCmdTraces :: Shared -> Cmd -> IO [Trace Hash]+getCmdTraces = getList "command"++addCmdTrace :: Shared -> Cmd -> Trace Hash -> IO ()+addCmdTrace share cmd t = setList "command" AppendMode share cmd [t]+++getFile :: Shared -> Hash -> IO (Maybe (FilePath -> IO ()))+getFile (Shared lock dir) hash = do+ let file = dir </> "files" </> filename hash+ b <- doesFileExist file+ return $ if not b then Nothing else Just $ copyFile file++setFile :: Shared -> FilePath -> Hash -> IO Bool -> IO ()+setFile (Shared lock dir) source hash check = do+ let file = dir </> "files" </> filename hash+ b <- doesFileExist file+ unlessM (doesFileExist file) $ withLock lock $ do+ createDirectoryRecursive $ takeDirectory file+ copyFile source (file <.> "tmp")+ good <- check+ if not good then+ removeFile $ file <.> "tmp"+ else+ renameFile (file <.> "tmp") file
+ src/Development/Rattle/Types.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++module Development.Rattle.Types(+ Trace(..), fsaTrace,+ Cmd(..),+ T, t0,+ ) where++import Data.Hashable+import Data.List.Extra+import Development.Shake.Command+import Data.Semigroup+import Prelude++newtype Cmd = Cmd [String]+ deriving (Show, Read, Eq, Hashable)++data Trace a = Trace+ {tRead :: [(FilePath, a)]+ ,tWrite :: [(FilePath, a)]+ } deriving (Show, Read, Functor, Foldable, Traversable)++instance Semigroup (Trace a) where+ Trace r1 w1 <> Trace r2 w2 = Trace (r1++r2) (w1++w2)++instance Monoid (Trace a) where+ mempty = Trace [] []+ mappend = (<>)+++fsaTrace :: [FSATrace] -> Trace ()+fsaTrace = nubTrace . mconcat . map f+ where+ g r w = Trace (map (,()) r) (map (,()) w)+ f (FSAWrite x) = g [] [x]+ f (FSARead x) = g [x] []+ f (FSADelete x) = g [] [x]+ f (FSAMove x y) = g [] [x,y]+ f (FSAQuery x) = g [x] []+ f (FSATouch x) = g [] [x]++nubTrace :: Ord a => Trace a -> Trace a+nubTrace (Trace a b) = Trace (nubOrd a \\ b) (nubOrd b)+++newtype T = T Int -- timestamps+ deriving (Enum,Eq,Ord,Show)++t0 :: T+t0 = T 0
+ src/General/Bilist.hs view
@@ -0,0 +1,37 @@++-- | List type that supports O(1) amortized 'cons', 'snoc', 'uncons' and 'isEmpty'.+module General.Bilist(+ Bilist, cons, snoc, uncons, toList, isEmpty+ ) where++import Data.Semigroup (Semigroup(..))+++data Bilist a = Bilist [a] [a]++toList :: Bilist a -> [a]+toList (Bilist as bs) = as ++ reverse bs++isEmpty :: Bilist a -> Bool+isEmpty (Bilist as bs) = null as && null bs++instance Eq a => Eq (Bilist a) where+ a == b = toList a == toList b++instance Semigroup (Bilist a) where+ a <> b = Bilist (toList a ++ toList b) []++instance Monoid (Bilist a) where+ mempty = Bilist [] []+ mappend = (<>)++cons :: a -> Bilist a -> Bilist a+cons x (Bilist as bs) = Bilist (x:as) bs++snoc :: Bilist a -> a -> Bilist a+snoc (Bilist as bs) x = Bilist as (x:bs)++uncons :: Bilist a -> Maybe (a, Bilist a)+uncons (Bilist [] []) = Nothing+uncons (Bilist (a:as) bs) = Just (a, Bilist as bs)+uncons (Bilist [] bs) = uncons $ Bilist (reverse bs) []
+ src/General/Extra.hs view
@@ -0,0 +1,69 @@++module General.Extra(+ whenLeft,+ whenRightM,+ createDirectoryRecursive,+ NoShow(..),+ memoIO+ ) where++import Control.Exception.Extra+import System.Directory+import Data.IORef+import qualified Data.HashMap.Strict as Map+import Data.Hashable+import Control.Monad+++---------------------------------------------------------------------+-- Prelude++newtype NoShow a = NoShow a+instance Show (NoShow a) where show _ = "NoShow"+++---------------------------------------------------------------------+-- Control.Monad++whenRightM :: Monad m => m (Either l r) -> (r -> m ()) -> m ()+whenRightM x act = either (const $ return ()) act =<< x+++---------------------------------------------------------------------+-- Control.Exception++tryIO :: IO a -> IO (Either IOException a)+tryIO = try+++---------------------------------------------------------------------+-- System.Directory++-- | Like @createDirectoryIfMissing True@ but faster, as it avoids+-- any work in the common case the directory already exists.+createDirectoryRecursive :: FilePath -> IO ()+createDirectoryRecursive dir = do+ x <- tryIO $ doesDirectoryExist dir+ when (x /= Right True) $ createDirectoryIfMissing True dir+++---------------------------------------------------------------------+-- Data.Either++whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m ()+whenLeft x f = either f (const $ pure ()) x+++---------------------------------------------------------------------+-- Data.Memo++memoIO :: (Hashable k, Eq k) => (k -> IO v) -> IO (k -> IO v)+memoIO f = do+ ref <- newIORef Map.empty+ return $ \k -> do+ mp <- readIORef ref+ case Map.lookup k mp of+ Just v -> return v+ Nothing -> do+ v <- f k+ atomicModifyIORef ref $ \mp -> (Map.insert k v mp, v)
+ src/General/Thread.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | A bit like 'Fence', but not thread safe and optimised for avoiding taking the fence+module General.Thread(+ withThreadsList,+ ) where++import Control.Concurrent.Extra+import Control.Exception+import General.Extra+import Control.Monad.Extra+++-- Run both actions. If either throws an exception, both threads+-- are killed and an exception reraised.+-- Not called much, so simplicity over performance (2 threads).+withThreadsBoth :: IO a -> IO b -> IO (a, b)+withThreadsBoth act1 act2 = do+ bar1 <- newBarrier+ bar2 <- newBarrier+ parent <- myThreadId+ ignore <- newVar False+ mask $ \unmask -> do+ t1 <- forkIOWithUnmask $ \unmask -> do+ res1 :: Either SomeException a <- try $ unmask act1+ unlessM (readVar ignore) $ whenLeft res1 $ throwTo parent+ signalBarrier bar1 res1+ t2 <- forkIOWithUnmask $ \unmask -> do+ res2 :: Either SomeException b <- try $ unmask act2+ unlessM (readVar ignore) $ whenLeft res2 $ throwTo parent+ signalBarrier bar2 res2+ res :: Either SomeException (a,b) <- try $ unmask $ do+ Right v1 <- waitBarrier bar1+ Right v2 <- waitBarrier bar2+ return (v1,v2)+ writeVar ignore True+ killThread t1+ forkIO $ killThread t2+ waitBarrier bar1+ waitBarrier bar2+ either throwIO return res+++withThreadsList :: [IO a] -> IO [a]+withThreadsList [] = return []+withThreadsList [x] = (:[]) <$> x+withThreadsList (x:xs) = uncurry (:) <$> withThreadsBoth x (withThreadsList xs)
+ test/C/constants.c view
@@ -0,0 +1,7 @@++char msg[] = "Hello Rattle Users!";++char* message()+{+ return msg;+}
+ test/C/constants.h view
@@ -0,0 +1,1 @@+char* message();
+ test/C/main.c view
@@ -0,0 +1,8 @@+#include <stdio.h>+#include "constants.h"++int main()+{+ printf("%s\n", message());+ return 0;+}
+ test/Test.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test(main) where++import Development.Rattle+import System.FilePattern.Directory+import Development.Shake.FilePath+import Control.Exception+import System.Directory+import System.Info.Extra+import Control.Monad.Extra+++withOutput :: (FilePath -> IO a) -> IO a+withOutput act = do+ ignoreIO $ removeDirectoryRecursive "output"+ createDirectoryIfMissing True "output"+ withCurrentDirectory "output" $ act ".."++ignoreIO :: IO () -> IO ()+ignoreIO act = catch act $ \(_ :: IOException) -> return ()+++-- Don't run on Mac because of https://github.com/jacereda/fsatrace/issues/25+main = unless isMac $ withOutput $ \root -> do+ let wipe = mapM (ignoreIO . removeFile) =<< getDirectoryFiles "." ["*"]+ cs <- liftIO $ getDirectoryFiles "." [root </> "test/C/*.c"]+ let toO x = takeBaseName x <.> "o"+ let build = do+ forM_ cs $ \c -> cmd ["gcc","-o",toO c,"-c",c]+ cmd $ ["gcc","-o","Main" <.> exe] ++ map toO cs+ cmd ["./Main" <.> exe]++ putStrLn "Build 1: Expect everything"+ rattle rattleOptions build+ putStrLn "Build 2: Expect nothing"+ rattle rattleOptions build+ wipe+ putStrLn "Build 3: Expect cached (some speculation)"+ rattle rattleOptions build+++ putStrLn "Build 4: Read/write hazard"+ handle (\(h :: Hazard) -> print h) $ do+ rattle rattleOptions{rattleSpeculate=Nothing} $ do+ cmd ["./Main" <.> exe]+ cmd $ ["gcc","-o","Main" <.> exe] ++ reverse (map toO cs)+ putStrLn "Hoped it failed, but doesn't always"+ -- fail "Expected a hazard"++ putStrLn "Build 5: Rebuild after"+ rattle rattleOptions build