RFC: build rule memoization

shake.cabal

@@ -94,6 +94,7 @@ library
         transformers >= 0.2,
         extra >= 1.4.10,
         deepseq >= 1.1,
+        SHA,
         primitive
 
     if flag(portable)
@@ -113,6 +114,7 @@ library
         Development.Shake.Config
         Development.Shake.FilePath
         Development.Shake.Forward
+        Development.Shake.Memo
         Development.Shake.Rule
         Development.Shake.Util
 
@@ -137,6 +139,7 @@ library
         Development.Shake.Internal.FilePattern
         Development.Shake.Internal.Core.Monad
         Development.Shake.Internal.Core.Pool
+        Development.Shake.Internal.Memo
         Development.Shake.Internal.Profile
         Development.Shake.Internal.Progress
         Development.Shake.Internal.Resource
@@ -194,6 +197,7 @@ executable shake
         transformers >= 0.2,
         extra >= 1.4.10,
         deepseq >= 1.1,
+        SHA,
         primitive
 
     if flag(portable)
@@ -230,6 +234,7 @@ executable shake
         Development.Shake.Internal.FileInfo
         Development.Shake.FilePath
         Development.Shake.Internal.FilePattern
+        Development.Shake.Internal.Memo
         Development.Shake.Internal.Core.Monad
         Development.Shake.Internal.Core.Pool
         Development.Shake.Internal.Profile

src/Development/Shake/Command.hs

@@ -40,7 +40,7 @@ import System.Process
 import System.Info.Extra
 import System.Time.Extra
 import System.IO.Unsafe(unsafeInterleaveIO)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import General.Process
 import Control.Applicative
@@ -50,6 +50,7 @@ import Development.Shake.Internal.CmdOption
 import Development.Shake.Internal.Core.Run
 import Development.Shake.FilePath
 import Development.Shake.Internal.FilePattern
+import Development.Shake.Internal.Memo
 import Development.Shake.Internal.Options
 import Development.Shake.Internal.Rules.File
 import Development.Shake.Internal.Derived
@@ -133,10 +134,17 @@ commandExplicit funcName oopts results exe args = do
             verb <- getVerbosity
             (if verb >= Loud then quietly else id) act
 
-    let tracer = case reverse [x | Traced x <- opts] of
-            "":_ -> liftIO
-            msg:_ -> traced msg
-            [] -> traced (takeFileName exe)
+    let traceMsg = case reverse [x | Traced x <- opts] of
+            "":_ -> Nothing
+            msg:_ -> Just msg
+            [] -> Just (takeFileName exe)
+
+    let tracer = maybe liftIO traced traceMsg
+
+    let memoiser exe args = case reverse [x | Capture x <- opts] of
+            [] -> id
+            xs -> fmap (fromMaybe [])
+                . memoFiles' (show $ exe:args) traceMsg (concat xs)
 
     let tracker act
             | useLint = fsatrace act
@@ -207,8 +215,7 @@ commandExplicit funcName oopts results exe args = do
             unsafeAllowApply $ need $ ham cwd xs
             return res
 
-    skipper $ tracker $ \exe args -> verboser $ tracer $ commandExplicitIO funcName opts results exe args
-
+    skipper $ tracker $ \exe args -> memoiser exe args $ verboser $ tracer $ commandExplicitIO funcName opts results exe args
 
 -- | Given a shell command, call the continuation with the sanitised exec-style arguments
 runShell :: String -> (String -> [String] -> Action a) -> Action a

src/Development/Shake/Forward.hs

@@ -76,7 +76,8 @@ shakeArgsForward opts act = shakeArgs (forwardOptions opts) (forwardRule act)
 -- | Given an 'Action', turn it into a 'Rules' structure which runs in forward mode.
 forwardRule :: Action () -> Rules ()
 forwardRule act = do
-    addBuiltinRule noLint $ \k old dirty ->
+    let summary _ _ = error "Rule memoization cannot be used with the Forward mode"
+    addBuiltinRule noLint summary $ \k old dirty ->
         case old of
             Just old | not dirty -> return $ RunResult ChangedNothing old ()
             _ -> do

src/Development/Shake/Internal/Args.hs

@@ -7,6 +7,7 @@ import Development.Shake.Internal.Options
 import Development.Shake.Internal.Core.Rules
 import Development.Shake.Internal.Demo
 import Development.Shake.FilePath
+import Development.Shake.Internal.Memo
 import Development.Shake.Internal.Rules.File
 import Development.Shake.Internal.Progress
 import Development.Shake.Internal.Shake
@@ -250,6 +251,8 @@ shakeOptsEx =
     ,yes $ Option ""  ["lint-fsatrace"] (noArg $ \s -> s{shakeLint=Just LintFSATrace}) "Use fsatrace to do validation."
     ,yes $ Option ""  ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint."
     ,yes $ Option ""  ["live"] (OptArg (\x -> Right ([], \s -> s{shakeLiveFiles=shakeLiveFiles s ++ [fromMaybe "live.txt" x]})) "FILE") "List the files that are live [to live.txt]."
+    ,yes $ Option ""  ["memo-store"] (reqArg "DIRECTORY" $ \x s -> s{shakeMemoSave = fsMemoSave x, shakeMemoRestore = fsMemoRestore x}) "Enable rule memoization, storing files in DIRECTORY"
+    ,yes $ Option ""  ["no-memo"] (noArg $ \s -> s{shakeMemoSave = \_ _ _ -> return (), shakeMemoRestore = \_ -> return False}) "Disable rule memoization"
     ,yes $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."
     ,no  $ Option ""  ["numeric-version"] (NoArg $ Right ([NumericVersion],id)) "Print just the version number and exit."
     ,yes $ Option ""  ["skip-commands"] (noArg $ \s -> s{shakeRunCommands=False}) "Try and avoid running external programs."

src/Development/Shake/Internal/CmdOption.hs

@@ -4,6 +4,8 @@ module Development.Shake.Internal.CmdOption(CmdOption(..)) where
 import Data.Data
 import qualified Data.ByteString.Lazy.Char8 as LBS
 
+import Development.Shake.Internal.FilePattern
+
 -- | Options passed to 'command' or 'cmd' to control how processes are executed.
 data CmdOption
     = Cwd FilePath -- ^ Change the current directory in the spawned process. By default uses this processes current directory.
@@ -25,4 +27,5 @@ data CmdOption
     | FileStdout FilePath -- ^ Should I put the @stdout@ to a file.
     | FileStderr FilePath -- ^ Should I put the @stderr@ to a file.
     | AutoDeps -- ^ Compute dependencies automatically.
+    | Capture [FilePattern] -- ^ Output files captured for rule memoization. See 'Development.Shake.Memo.memoFiles' for more information.
       deriving (Eq,Ord,Show,Data,Typeable)

src/Development/Shake/Internal/Core/Database.hs

@@ -5,7 +5,7 @@
 module Development.Shake.Internal.Core.Database(
     Trace(..), newTrace,
     Database, withDatabase, assertFinishedDatabase,
-    listDepends, lookupDependencies,
+    listDepends, lookupValue, lookupDependencies,
     BuildKey(..), build, Depends,
     Step, Result(..),
     progress,
@@ -419,6 +419,13 @@ listLive Database{..} = do
     status <- Ids.toList status
     return [k | (_, (k, Ready{})) <- status]
 
+lookupValue :: Database -> Key -> IO Value
+lookupValue Database{..} k = do
+    withLock lock $ do
+        intern <- readIORef intern
+        let Just i = Intern.lookup k intern
+        Just (_, Ready r) <- Ids.lookup status i
+        return $ result r
 
 listDepends :: Database -> Depends -> IO [Key]
 listDepends Database{..} (Depends xs) =

src/Development/Shake/Internal/Core/Rules.hs

@@ -5,13 +5,15 @@
 
 module Development.Shake.Internal.Core.Rules(
     Rules, runRules,
-    RuleResult, addBuiltinRule, addBuiltinRuleEx, noLint,
+    RuleResult, addBuiltinRule, addBuiltinRuleEx,
+    noLint, binarySummary, showSummary,
     getShakeOptionsRules, userRuleMatch,
     getUserRules, addUserRule, alternatives, priority,
     action, withoutActions
     ) where
 
 import Control.Applicative
+import Control.DeepSeq (force)
 import Data.Tuple.Extra
 import Control.Monad.Extra
 import Control.Monad.Fix
@@ -21,6 +23,7 @@ import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Writer.Strict
 import Data.Binary
 import General.Binary
+import qualified Data.Digest.Pure.SHA as SHA
 import Data.Typeable.Extra
 import Data.Function
 import Data.List.Extra
@@ -126,25 +129,35 @@ addUserRule r = newRules mempty{userRules = Map.singleton (typeOf r) $ UserRule_
 noLint :: BuiltinLint key value
 noLint _ _ = return Nothing
 
+-- | A 'BuiltinSummary' based on a 'Binary' instance.
+binarySummary :: (Binary value) => BuiltinSummary key value
+binarySummary _ value = return $! force $ SHA.showDigest $ SHA.sha256 $
+    encode value
+
+-- | A 'BuiltinSummary' based on a 'Show' instance.
+showSummary :: (Show value) => BuiltinSummary key value
+showSummary _ value = return $! force $ show value
+
 type family RuleResult key -- = value
 
 -- | Add a builtin rule, comprising of a lint rule and an action. Each builtin rule must be identified by
 --   a unique key.
-addBuiltinRule :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => BuiltinLint key value -> BuiltinRun key value -> Rules ()
+addBuiltinRule :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => BuiltinLint key value -> BuiltinSummary key value -> BuiltinRun key value -> Rules ()
 addBuiltinRule = addBuiltinRuleEx $ BinaryOp
     (putEx . Bin.toLazyByteString . execPut . put)
     (runGet get . LBS.fromChunks . return)
 
 
 -- | Initial version of 'addBuiltinRule', which also lets me set the 'BinaryOp'.
-addBuiltinRuleEx :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => BinaryOp key -> BuiltinLint key value -> BuiltinRun key value -> Rules ()
-addBuiltinRuleEx binary lint (run :: BuiltinRun key value) = do
+addBuiltinRuleEx :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => BinaryOp key -> BuiltinLint key value -> BuiltinSummary key value -> BuiltinRun key value -> Rules ()
+addBuiltinRuleEx binary lint summary (run :: BuiltinRun key value) = do
     let k = Proxy :: Proxy key
         v = Proxy :: Proxy value
     let run_ k v b = fmap newValue <$> run (fromKey k) v b
     let lint_ k v = lint (fromKey k) (fromValue v)
+    let summary_ k v = summary (fromKey k) (fromValue v)
     let binary_ = BinaryOp (putOp binary . fromKey) (newKey . getOp binary)
-    newRules mempty{builtinRules = Map.singleton (typeRep k) $ BuiltinRule run_ lint_ (typeRep v) binary_}
+    newRules mempty{builtinRules = Map.singleton (typeRep k) $ BuiltinRule run_ lint_ summary_ (typeRep v) binary_}
 
 
 -- | Change the priority of a given set of rules, where higher priorities take precedence.

src/Development/Shake/Internal/Core/Run.hs

@@ -88,6 +88,7 @@ run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id
 
     after <- newIORef []
     absent <- newIORef []
+    cacheRef <- newIORef Map.empty
     withCleanup $ \cleanup -> do
         _ <- addCleanup cleanup $ do
             when shakeTimings printTimings
@@ -108,7 +109,7 @@ run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id
 
                 addTiming "Running rules"
                 runPool (shakeThreads == 1) shakeThreads $ \pool -> do
-                    let s0 = Global database pool cleanup start ruleinfo output opts diagnostic curdir after absent getProgress userRules
+                    let s0 = Global database pool cleanup start ruleinfo output opts diagnostic curdir after absent getProgress userRules cacheRef
                     let s1 = newLocal emptyStack shakeVerbosity
                     forM_ actions $ \act ->
                         addPoolLowPriority pool $ runAction s0 s1 act $ \x -> case x of

src/Development/Shake/Internal/Core/Types.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE ExistentialQuantification, ConstraintKinds, DeriveFunctor #-}
 
 module Development.Shake.Internal.Core.Types(
-    BuiltinRun, BuiltinLint, RunResult(..), RunChanged(..),
+    BuiltinRun, BuiltinLint, BuiltinSummary, RunResult(..), RunChanged(..),
     UserRule(..), UserRule_(..),
     BuiltinRule(..), Global(..), Local(..), Action(..),
     newLocal
@@ -82,9 +82,15 @@ type BuiltinRun key value = key -> Maybe BS.ByteString -> Bool -> Action (RunRes
 --   For builtin rules where the value is expected to change use 'Development.Shake.Rules.noLint'.
 type BuiltinLint key value = key -> value -> IO (Maybe String)
 
+-- | A function that summarizes the current value into a short string, typically a hash.
+--   The result should be stable, and should not depend on the state of the Shake database.
+--   Used for rule memoization.
+type BuiltinSummary key value = key -> value -> IO String
+
 data BuiltinRule = BuiltinRule
     {builtinRun :: BuiltinRun Key Value
     ,builtinLint :: BuiltinLint Key Value
+    ,builtinSummary :: BuiltinSummary Key Value
     ,builtinResult :: TypeRep
     ,builtinKey :: BinaryOp Key
     }
@@ -123,6 +129,7 @@ data Global = Global
     ,globalTrackAbsent :: IORef [(Key, Key)] -- ^ Tracked things, in rule fst, snd must be absent
     ,globalProgress :: IO Progress -- ^ Request current progress state
     ,globalUserRules :: Map.HashMap TypeRep UserRule_
+    ,globalSHACache :: IORef (Map.HashMap Key String) -- ^ SHA cache for memoization
     }
 
 -- local variables of Action