microopt: store the RDeps in an IORef

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

@@ -37,6 +37,7 @@ import Data.List.Extra
 import Data.Either.Extra
 import System.Time.Extra
 import qualified Data.HashSet as HashSet
+import Data.IORef.Extra (atomicModifyIORef_, IORef, newIORef)
 
 
 ---------------------------------------------------------------------
@@ -145,18 +146,16 @@ updateReverseDeps myId db prev new = do
     where
         doOne f id = do
             kv <- liftIO $ getKeyValueFromId db id
-            whenJust kv $ \(k,v) ->
-                setMem db id k $ updateResult (\it -> it{rdepends = f $ rdepends it}) v
+            whenJust kv $ \(k,v) -> do
+                whenJust (getRDepsFromResult v) $ \r ->
+                    liftIO $ atomicModifyIORef_ r f
 
-        addDep :: Result a -> Result a
-        addDep it = it{rdepends = HashSet.insert myId (rdepends it)}
-
-        updateResult :: (forall a. Result a -> Result a) -> Status -> Status
-        updateResult f (Ready r) = Ready $ f r
-        updateResult f (Failed e r) = Failed e (fmap f r)
-        updateResult f (Loaded r) = Loaded $ f r
-        updateResult _ Running{} = error "Running: can this happen?"
-        updateResult _ Missing{} = error "Missing: can this happen?"
+        getRDepsFromResult :: Status -> Maybe (IORef (HashSet.HashSet Id))
+        getRDepsFromResult (Ready r) = rdepends r
+        getRDepsFromResult (Failed e r) = rdepends =<< r
+        getRDepsFromResult (Loaded r) = rdepends r
+        getRDepsFromResult Running{} = error "Running: can this happen?"
+        getRDepsFromResult Missing{} = error "Missing: can this happen?"
 
 -- | Compute the value for a given RunMode and a restore function to run
 buildRunMode :: Global -> Stack -> Database -> Id -> Maybe (Result a) -> Wait Locked RunMode
@@ -258,12 +257,13 @@ runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode continue
                     dur <- time
                     let (cr, c) | Just r <- r, runChanged == ChangedRecomputeSame = (ChangedRecomputeSame, changed r)
                                 | otherwise = (ChangedRecomputeDiff, globalStep)
+                    rdepnds <- maybe (newIORef mempty) pure (rdepends =<< r)
                     continue $ Right $ RunResult cr runStore Result
                         {result = mkResult runValue runStore
                         ,changed = c
                         ,built = globalStep
                         ,depends = flattenDepends localDepends
-                        ,rdepends = maybe mempty rdepends r
+                        ,rdepends = Just rdepnds
                         ,execution = doubleToFloat $ dur - localDiscount
                         ,traces = flattenTraces localTraces}
             where

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

@@ -206,7 +206,7 @@ computeDirtySet diag database (Just keys) = do
             if x `Set.member` seen then pure () else do
                 Just (_, Loaded result) <- liftIO $ getKeyValueFromId database x
                 State.put (Set.insert x seen)
-                let next = rdepends result
+                next <- liftIO $ maybe (pure mempty) readIORef $ rdepends result
                 traverse_ loop next
     transitive <- flip State.execStateT Set.empty $ traverse_ loop ids
 
@@ -372,7 +372,7 @@ incrementStep db = runLocked db $ do
     pure step
 
 toStepResult :: Step -> Result (Value, BS_Store)
-toStepResult i = Result (newValue i, runBuilder $ putEx i) i i [] mempty 0 []
+toStepResult i = Result (newValue i, runBuilder $ putEx i) i i [] Nothing 0 []
 
 fromStepResult :: Result BS_Store -> Step
 fromStepResult = getEx . result
@@ -387,7 +387,7 @@ recordRoot step locals (doubleToFloat -> end) db = runLocked db $ do
             ,changed = step
             ,built = step
             ,depends = flattenDepends $ localDepends local
-            ,rdepends = mempty
+            ,rdepends = Nothing
             ,execution = 0
             ,traces = flattenTraces $ addTrace (localTraces local) $ Trace BS.empty end end}
     setMem db rootId rootKey $ Ready rootRes
@@ -413,8 +413,8 @@ loadSharedCloud var opts owitness = do
 
 
 putDatabase :: (Key -> Builder) -> ((Key, Status) -> Builder)
-putDatabase putKey (key, Loaded (Result x1 x2 x3 x4 x5 x6 x7)) =
-    putExN (putKey key) <> putExN (putEx x1) <> putEx x2 <> putEx x3 <> putEx x6 <> putExN (putEx x4) <> putExN (putEx $ Depends $ Set.toList x5) <> putEx x7
+putDatabase putKey (key, Loaded (Result x1 x2 x3 x4 _x5 x6 x7)) =
+    putExN (putKey key) <> putExN (putEx x1) <> putEx x2 <> putEx x3 <> putEx x6 <> putExN (putEx x4) <> putEx x7
 putDatabase _ (_, x) = throwImpure $ errorInternal $ "putWith, Cannot write Status with constructor " ++ statusType x
 
 
@@ -426,4 +426,4 @@ getDatabase getKey bs
     , (x4, x57) <- getExN bs
     , (x5, x7) <- getExN x57
     , Depends rdeps <- getEx x5
-    = (getKey key, Loaded (Result x1 x2 x3 (getEx x4) (Set.fromList rdeps) x6 (getEx x7)))
+    = (getKey key, Loaded (Result x1 x2 x3 (getEx x4) Nothing x6 (getEx x7)))

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

@@ -234,10 +234,13 @@ data Result a = Result
     ,built :: {-# UNPACK #-} !Step -- ^ when it was actually run
     ,changed :: {-# UNPACK #-} !Step -- ^ the step for deciding if it's valid
     ,depends :: ![Depends] -- ^ dependencies (don't run them early)
-    ,rdepends :: !(HashSet Id) -- ^ reverse dependencies
+    ,rdepends :: Maybe (IORef (HashSet Id)) -- ^ reverse dependencies
     ,execution :: {-# UNPACK #-} !Float -- ^ how long it took when it was last run (seconds)
     ,traces :: ![Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run)
-    } deriving (Show,Functor)
+    } deriving (Functor)
+
+instance Show (Result a) where
+    show _ = "<result>"
 
 instance NFData a => NFData (Result a) where
     -- ignore unpacked fields