@@ -55,9 +55,9 @@ newDatabase :: (String -> IO ()) -> DBQue -> Dynamic -> TheRules -> IO Database
5555newDatabase dataBaseLogger databaseQueue databaseExtra databaseRules = do
5656 databaseStep <- newTVarIO $ Step 0
5757 databaseThreads <- newTVarIO []
58- databaseValuesLock <- newTVarIO False
58+ databaseValuesLock <- newTVarIO True
5959 databaseValues <- atomically SMap. new
60- databaseReverseDep <- atomically SMap. new
60+ databaseRuntimeRevDep <- atomically SMap. new
6161 pure Database {.. }
6262
6363-- | Increment the step and mark dirty.
@@ -116,92 +116,65 @@ build pk db stack keys = do
116116builder :: (Traversable f ) => Key -> Database -> Stack -> f Key -> IO f (Key , Result ))
117117-- builder _ st kk | traceShow ("builder", st,kk) False = undefined
118118builder pk db stack keys = do
119- waits <- for keys (\ k -> builderOneCoroutine pk skipThread db stack k)
119+ waits <- for keys (\ k -> builderOne pk db stack k)
120120 for waits interpreBuildContinue
121- where skipThread = if length keys == 1 then IsSingleton else NotSingleton
122121
123- data IsSingletonTask = IsSingleton | NotSingleton
124122-- the first run should not block
125- data RunFirst = RunFirst | RunLater deriving stock (Eq , Show )
126123data BuildContinue = BCContinue (IO Key , Result )) | BCStop Key Result
127124
128125interpreBuildContinue :: BuildContinue -> IO Key , Result )
129126interpreBuildContinue (BCStop k v) = return (k, v)
130127interpreBuildContinue (BCContinue ioR) = ioR
131128
132- -- possible improvements:
133- -- suppose it is in the direct dirty set. We have already recorded the parent key as its reverse dep.
134- -- fource possible situation
135- -- running stage1, we have line up the run but it is scheduled after the restart. Clean.
136- -- running stage2, all of it have gone before the restart. Dirty
137- -- clean or exception, we picked old value. Dirty
138- -- dirty, impossible situation, should throw errors.
139-
140- -- stage 1 to stage 2 transition, run in serial
141-
142- -- first we marked we have reached stage2, annotate the current step
143- -- then spawn the thread to do the actual work
144- -- finally, catch any (async) exception and mark the key as exception
145-
146- -- submmittBuildInDb :: Database -> IO a -> IO a
147- -- submmittBuildInDb :: Database -> Stack -> Key -> Maybe Result -> IO ()
148- -- submmittBuildInDb db stack id s = do
149- -- uninterruptibleMask_ $ do
150- -- do
151- -- curStep <- readTVarIO $ databaseStep db
152- -- startBarrier <- newEmptyTMVarIO
153- -- newAsync <-
154- -- async
155- -- (do
156- -- uninterruptibleMask_ $ atomically $ readTMVar startBarrier
157- -- void (refresh db stack id s) `catch` \e@(SomeException _) ->
158- -- atomically $ SMap.focus (updateStatus $ Exception curStep e s) id (databaseValues db)
159- -- )
160- -- -- todo should only update if still at stage 1
161- -- -- atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db)
162- -- atomically $ putTMVar startBarrier ()
163- -- atomically $ modifyTVar' (databaseThreads db) ((newAsync) :)
164-
165- builderOneCoroutine :: Key -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue
166- builderOneCoroutine parentKey isSingletonTask db stack id =
167- builderOneCoroutine' db stack id
168- where
169- builderOneCoroutine' :: Database -> Stack -> Key -> IO BuildContinue
170- builderOneCoroutine' db@ Database {.. } stack id = do
171- traceEvent (" builderOne: " ++ show id ) return ()
172- barrier <- newEmptyMVar
173- liftIO $ atomicallyNamed " builder" $ do
174- -- Spawn the id if needed
175- dbNotLocked db
176- insertDatabaseReverseDepOne id parentKey db
177- -- if a build is running, wait
178- -- it will either be killed or continue
179- -- depending on wether it is marked as dirty
180- status <- SMap. lookup id databaseValues
181- current <- readTVar databaseStep
182- case viewDirty current $ maybe (Dirty Nothing ) keyStatus status of
183- Dirty s -> do
184- -- we need to run serially to avoid summiting run but killed in the middle
185- let wait = readMVar barrier
186- runOneInDataBase (do {
187- status <- atomically (SMap. lookup id databaseValues)
188- ; let cur = fromIntegral $ case keyStatus <$> status of
189- Just (Running entryStep _s _wait RunningStage1 ) -> entryStep
190- _ -> current
191- ; return $ DeliverStatus cur (show (parentKey, id ))}) db
192- (\ adyncH ->
193- -- it is safe from worker thread
194- atomically $ SMap. focus (updateStatus $ Running current s wait (RunningStage2 adyncH) ) id databaseValues)
195- (refresh db stack id s >>= putMVar barrier . (id ,)) $ \ e -> do
196- atomically $ SMap. focus (updateStatus $ Exception current e s) id databaseValues
197- putMVar barrier (throw e)
198- SMap. focus (updateStatus $ Running current s wait RunningStage1 ) id databaseValues
199- return $ BCContinue $ readMVar barrier
200- Clean r -> return $ BCStop id r
201- Running _step _s wait _
202- | memberStack id stack -> throw $ StackException stack
203- | otherwise -> return $ BCContinue wait
204- Exception _ e _s -> throw e
129+ builderOne :: Key -> Database -> Stack -> Key -> IO BuildContinue
130+ builderOne parentKey db@ Database {.. } stack id = do
131+ traceEvent (" builderOne: " ++ show id ) return ()
132+ barrier <- newEmptyMVar
133+ liftIO $ atomicallyNamed " builder" $ do
134+ -- Spawn the id if needed
135+ dbNotLocked db
136+ insertdatabaseRuntimeRevDep id parentKey db
137+ -- if a build is running, wait
138+ -- it will either be killed or continue
139+ -- depending on wether it is marked as dirty
140+ status <- SMap. lookup id databaseValues
141+ current <- readTVar databaseStep
142+ case viewDirty current $ maybe (Dirty Nothing ) keyStatus status of
143+ Dirty s -> do
144+ -- we need to run serially to avoid summiting run but killed in the middle
145+ let wait = readMVar barrier
146+ runOneInDataBase
147+ ( do
148+ status <- atomically (SMap. lookup id databaseValues)
149+ let cur = fromIntegral $ case keyStatus <$> status of
150+ -- this is ensure that we get an bumped up step when not dirty
151+ -- after an restart to skipped an rerun
152+ Just (Running entryStep _s _wait RunningStage1 ) -> entryStep
153+ _ -> current
154+ return $ DeliverStatus cur (show (parentKey, id ))
155+ )
156+ db
157+ ( \ adyncH ->
158+ -- it is safe from worker thread
159+ atomically $ SMap. focus (updateStatus $ Running current s wait (RunningStage2 adyncH)) id databaseValues
160+ )
161+ (refresh db stack id s >>= putMVar barrier . (id ,))
162+ $ \ e -> do
163+ atomically $ SMap. focus (updateStatus $ Exception current e s) id databaseValues
164+ putMVar barrier (throw e)
165+ SMap. focus (updateStatus $ Running current s wait RunningStage1 ) id databaseValues
166+ return $ BCContinue $ readMVar barrier
167+ Clean r -> return $ BCStop id r
168+ Running _step _s wait _
169+ | memberStack id stack -> throw $ StackException stack
170+ | otherwise -> return $ BCContinue wait
171+ Exception _ e _s -> throw e
172+ where
173+ warpLog title a =
174+ bracket_
175+ (dataBaseLogger (" Starting async action: " ++ title))
176+ (dataBaseLogger $ " Finished async action: " ++ title)
177+ a
205178
206179-- | isDirty
207180-- only dirty when it's build time is older than the changed time of one of its dependencies
@@ -285,11 +258,6 @@ updateStatus res = Focus.alter
285258 (Just . maybe (KeyDetails res mempty )
286259 (\ it -> it{keyStatus = res}))
287260
288- -- alterStatus :: Monad m => (Status -> Status) -> Focus.Focus KeyDetails m ()
289- -- alterStatus f = Focus.alter
290- -- (Just . maybe (KeyDetails res mempty)
291- -- (\it -> it{keyStatus = res}))
292-
293261-- | Returns the set of dirty keys annotated with their age (in # of builds)
294262getDirtySet :: Database -> IO Key , Int
295263getDirtySet db = do
0 commit comments