@@ -77,10 +77,11 @@ updateDirty = Focus.adjust $ \(KeyDetails status rdeps) ->
7777-- | Unwrap and build a list of keys in parallel
7878build
7979 :: forall key value . (RuleResult key ~ value , Typeable key , Show key , Hashable key , Eq key , Typeable value )
80- => Database -> [key ] -> IO Key ], [value ])
81- build db keys = do
80+ => Database -> Stack -> [key ] -> IO Key ], [value ])
81+ -- build _ st k | traceShow ("build", st, k) False = undefined
82+ build db stack keys = do
8283 (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<<
83- builder db (map Key keys)
84+ builder db stack (map Key keys)
8485 pure (ids, map (asV . resultValue) vs)
8586 where
8687 asV :: Value -> value
@@ -90,8 +91,9 @@ build db keys = do
9091-- If none of the keys are dirty, we can return the results immediately.
9192-- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock.
9293builder
93- :: Database -> [Key ] -> AIO (Either Key , Result )] (IO Key , Result )]))
94- builder db@ Database {.. } keys = withRunInIO $ \ (RunInIO run) -> do
94+ :: Database -> Stack -> [Key ] -> AIO (Either Key , Result )] (IO Key , Result )]))
95+ -- builder _ st kk | traceShow ("builder", st,kk) False = undefined
96+ builder db@ Database {.. } stack keys = withRunInIO $ \ (RunInIO run) -> do
9597 -- Things that I need to force before my results are ready
9698 toForce <- liftIO $ newTVarIO []
9799 current <- liftIO $ readTVarIO databaseStep
@@ -103,11 +105,13 @@ builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do
103105 status <- SMap. lookup id databaseValues
104106 val <- case viewDirty current $ maybe (Dirty Nothing ) keyStatus status of
105107 Clean r -> pure r
106- Running _ force val _ -> do
108+ Running _ force val _
109+ | memberStack id stack -> throw $ StackException stack
110+ | otherwise -> do
107111 modifyTVar' toForce (Wait force : )
108112 pure val
109113 Dirty s -> do
110- let act = run (refresh db id s)
114+ let act = run (refresh db stack id s)
111115 (force, val) = splitIO (join act)
112116 SMap. focus (updateStatus $ Running current force val s) id databaseValues
113117 modifyTVar' toForce (Spawn force: )
@@ -127,32 +131,33 @@ builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do
127131-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.
128132-- This assumes that the implementation will be a lookup
129133-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself
130- refresh :: Database -> Key -> Maybe Result -> AIO (IO Result )
131- refresh db key result @ ( Just me @ Result {resultDeps = ResultDeps deps}) = do
132- res <- builder db deps
133- case res of
134- Left res ->
135- if isDirty res
136- then asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result
137- else pure $ compute db key RunDependenciesSame result
138- Right iores -> asyncWithCleanUp $ liftIO $ do
139- res <- iores
140- let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame
141- compute db key mode result
142- where
143- isDirty = any ( \ (_,dep) -> resultBuilt me < resultChanged dep)
144-
145- refresh db key result =
146- asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result
147-
134+ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result )
135+ -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined
136+ refresh db stack key result = case (addStack key stack, result) of
137+ ( Left e, _) -> throw e
138+ ( Right stack, Just me @ Result {resultDeps = ResultDeps deps}) -> do
139+ res <- builder db stack deps
140+ let isDirty = any ( \ (_,dep) -> resultBuilt me < resultChanged dep)
141+ case res of
142+ Left res ->
143+ if isDirty res
144+ then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
145+ else pure $ compute db stack key RunDependenciesSame result
146+ Right iores -> asyncWithCleanUp $ liftIO $ do
147+ res <- iores
148+ let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame
149+ compute db stack key mode result
150+ ( Right stack, _) ->
151+ asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
148152
149153-- | Compute a key.
150- compute :: Database -> Key -> RunMode -> Maybe Result -> IO Result
151- compute db@ Database {.. } key mode result = do
154+ compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result
155+ -- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined
156+ compute db@ Database {.. } stack key mode result = do
152157 let act = runRule databaseRules key (fmap resultData result) mode
153158 deps <- newIORef UnknownDeps
154159 (execution, RunResult {.. }) <-
155- duration $ runReaderT (fromAction act) $ SAction db deps
160+ duration $ runReaderT (fromAction act) $ SAction db deps stack
156161 built <- readTVarIO databaseStep
157162 deps <- readIORef deps
158163 let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result
@@ -165,7 +170,7 @@ compute db@Database{..} key mode result = do
165170 deps | not (null deps)
166171 && runChanged /= ChangedNothing
167172 -> do
168- void $ forkIO $
173+ void $
169174 updateReverseDeps key db
170175 (getResultDepsDefault [] previousDeps)
171176 (HSet. fromList deps)
0 commit comments