Rewrite hls-graph to not use the Shake code #1759
There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,18 +1,49 @@ | ||
|
|
||
| module Development.IDE.Graph.Database( | ||
| ShakeDatabase, | ||
| shakeOpenDatabase, | ||
| shakeRunDatabase, | ||
| shakeProfileDatabase, | ||
| ) where | ||
|
|
||
| import Development.IDE.Graph.Internal.Action | ||
| import Development.IDE.Graph.Internal.Options | ||
| import Development.IDE.Graph.Internal.Rules | ||
| import Development.IDE.Graph.Internal.Types | ||
| import Data.Maybe | ||
| import Data.Dynamic | ||
| import Development.IDE.Graph.Internal.Database | ||
| import GHC.Conc | ||
| import Control.Concurrent.Extra | ||
|
|
||
|
|
||
| data ShakeDatabase = ShakeDatabase !Int !Int [Action ()] Database | ||
|
|
||
| -- Placeholder to be the 'extra' if the user doesn't set it | ||
| data NonExportedType = NonExportedType | ||
|
|
||
| shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ()) | ||
| shakeOpenDatabase opts rules = pure (shakeNewDatabase opts rules, pure ()) | ||
|
|
||
| shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase | ||
| shakeNewDatabase opts rules = do | ||
| let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts | ||
| (theRules, actions) <- runRules extra rules | ||
| db <- newDatabase extra theRules | ||
| let threads = shakeThreads opts | ||
| threads <- if threads /= 0 then pure threads else getNumProcessors | ||
| pure $ ShakeDatabase threads (length actions) actions db | ||
|
|
||
| shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) | ||
| shakeRunDatabase (ShakeDatabase threads lenAs1 as1 db) as2 = withNumCapabilities threads $ do | ||
| incDatabase db | ||
| as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 | ||
| return (as, []) | ||
|
|
||
| -- Only valid if we never pull on the results, which we don't | ||
| unvoid :: Functor m => m () -> m a | ||
| unvoid = fmap undefined | ||
|
|
||
| -- Noop | ||
| shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO () | ||
| shakeProfileDatabase _ file = writeFile file "" | ||
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change | ||||||
|---|---|---|---|---|---|---|---|---|
| @@ -1,38 +1,100 @@ | ||||||||
| {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||||||||
| {-# LANGUAGE TypeFamilies #-} | ||||||||
| {-# LANGUAGE ScopedTypeVariables #-} | ||||||||
|
|
||||||||
| module Development.IDE.Graph.Internal.Action where | ||||||||
|
|
||||||||
| import qualified Development.Shake as Shake | ||||||||
| import Development.Shake.Classes | ||||||||
| import Control.Exception | ||||||||
| import Control.Concurrent.Async | ||||||||
| import System.Exit | ||||||||
| import Control.Monad.IO.Class | ||||||||
| import Control.Monad.Trans.Reader | ||||||||
| import Data.IORef | ||||||||
| import Development.IDE.Graph.Internal.Database | ||||||||
| import Development.IDE.Graph.Internal.Types | ||||||||
| import Control.Monad.Extra | ||||||||
| import Control.Monad.Trans.Class | ||||||||
| import Control.Concurrent.Async | ||||||||
|
|
||||||||
|
|
||||||||
| alwaysRerun :: Action () | ||||||||
| alwaysRerun = do | ||||||||
| ref <- Action $ asks actionDeps | ||||||||
| liftIO $ writeIORef ref Nothing | ||||||||
|
|
||||||||
| -- No-op for now | ||||||||
| reschedule :: Double -> Action () | ||||||||
| reschedule _ = pure () | ||||||||
|
|
||||||||
| parallel :: [Action a] -> Action [a] | ||||||||
| parallel [] = pure [] | ||||||||
| parallel [x] = fmap (:[]) x | ||||||||
| parallel xs = do | ||||||||
| a <- Action ask | ||||||||
| deps <- liftIO $ readIORef $ actionDeps a | ||||||||
| case deps of | ||||||||
| Nothing -> | ||||||||
| -- if we are already in the rerun mode, nothing we do is going to impact our state | ||||||||
| liftIO $ mapConcurrently (ignoreState a) xs | ||||||||
| Just deps -> do | ||||||||
| (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs | ||||||||
| liftIO $ writeIORef (actionDeps a) $ (deps ++) <$> concatMapM id newDeps | ||||||||
| pure res | ||||||||
| where | ||||||||
| ignoreState a x = do | ||||||||
| ref <- newIORef Nothing | ||||||||
| runReaderT (fromAction x) a{actionDeps=ref} | ||||||||
|
|
||||||||
| usingState a x = do | ||||||||
| ref <- newIORef $ Just [] | ||||||||
| res <- runReaderT (fromAction x) a{actionDeps=ref} | ||||||||
| deps <- readIORef ref | ||||||||
| pure (deps, res) | ||||||||
|
|
||||||||
| isAsyncException :: SomeException -> Bool | ||||||||
| isAsyncException e | ||||||||
| | Just (_ :: AsyncCancelled) <- fromException e = True | ||||||||
| | Just (_ :: AsyncException) <- fromException e = True | ||||||||
| | Just (_ :: ExitCode) <- fromException e = True | ||||||||
| | otherwise = False | ||||||||
|
|
||||||||
|
|
||||||||
| actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a | ||||||||
| actionCatch a b = do | ||||||||
| v <- Action ask | ||||||||
| Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v) | ||||||||
| where | ||||||||
| -- Catch only catches exceptions that were caused by this code, not those that | ||||||||
| -- are a result of program termination | ||||||||
| f e | isAsyncException e = Nothing | ||||||||
| | otherwise = fromException e | ||||||||
|
|
||||||||
| actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c | ||||||||
|
There was a problem hiding this comment.
Suggested change
|
||||||||
| actionBracket a b c = do | ||||||||
| v <- Action ask | ||||||||
| Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v) | ||||||||
|
|
||||||||
| actionFinally :: Action a -> IO b -> Action a | ||||||||
| actionFinally a b = do | ||||||||
| v <- Action ask | ||||||||
| Action $ lift $ finally (runReaderT (fromAction a) v) b | ||||||||
|
|
||||||||
| apply1 :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => key -> Action value | ||||||||
| apply1 k = head <$> apply [k] | ||||||||
|
|
||||||||
| apply :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => [key] -> Action [value] | ||||||||
| apply ks = do | ||||||||
| db <- Action $ asks actionDatabase | ||||||||
| (is, vs) <- liftIO $ build db ks | ||||||||
| ref <- Action $ asks actionDeps | ||||||||
| deps <- liftIO $ readIORef ref | ||||||||
| whenJust deps $ \deps -> | ||||||||
| liftIO $ writeIORef ref $ Just $ is ++ deps | ||||||||
| pure vs | ||||||||
|
|
||||||||
| runActions :: Database -> [Action a] -> IO [a] | ||||||||
| runActions db xs = do | ||||||||
| deps <- newIORef Nothing | ||||||||
| runReaderT (fromAction $ parallel xs) $ SAction db deps | ||||||||
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,144 @@ | ||
| -- We deliberately want to ensure the function we add to the rule database | ||
| -- has the constraints we need on it when we get it out. | ||
| {-# OPTIONS_GHC -Wno-redundant-constraints #-} | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE RecordWildCards #-} | ||
| {-# LANGUAGE TypeFamilies #-} | ||
| {-# LANGUAGE TupleSections #-} | ||
| {-# LANGUAGE NamedFieldPuns #-} | ||
|
|
||
| module Development.IDE.Graph.Internal.Database where | ||
|
|
||
| import Development.IDE.Graph.Internal.Intern | ||
| import Development.IDE.Graph.Internal.Types | ||
| import Data.Dynamic | ||
| import qualified Development.IDE.Graph.Internal.Intern as Intern | ||
| import qualified Development.IDE.Graph.Internal.Ids as Ids | ||
| import Control.Concurrent.Extra | ||
| import Data.IORef.Extra | ||
| import Control.Monad | ||
| import Development.Shake.Classes | ||
| import qualified Development.Shake as Shake | ||
| import Data.Maybe | ||
| import Control.Concurrent.Async | ||
| import System.IO.Unsafe | ||
| import Development.IDE.Graph.Internal.Rules | ||
| import qualified Development.Shake.Rule as Shake | ||
| import Control.Exception | ||
| import Control.Monad.Trans.Reader | ||
| import Data.Tuple.Extra | ||
| import Data.Either | ||
|
|
||
| newDatabase :: Dynamic -> TheRules -> IO Database | ||
| newDatabase databaseExtra databaseRules = do | ||
| databaseStep <- newIORef $ Step 0 | ||
| databaseLock <- newLock | ||
| databaseIds <- newIORef Intern.empty | ||
| databaseValues <- Ids.empty | ||
| pure Database{..} | ||
|
|
||
| incDatabase :: Database -> IO () | ||
| incDatabase db = do | ||
| modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1 | ||
| Ids.forMutate (databaseValues db) $ second $ \case | ||
| Clean x -> Dirty (Just x) | ||
| Dirty x -> Dirty x | ||
| Running _ x -> Dirty x | ||
|
|
||
|
|
||
| build | ||
| :: forall key value . (Shake.RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) | ||
| => Database -> [key] -> IO ([Id], [value]) | ||
| build db keys = do | ||
| (ids, vs) <- fmap unzip $ builder db $ map (Right . Key) keys | ||
| pure (ids, map (asV . resultValue) vs) | ||
| where | ||
| asV :: Value -> value | ||
| asV (Value x) = unwrapDynamic x | ||
|
|
||
| builder | ||
| :: Database -> [Either Id Key] -> IO [(Id, Result)] | ||
| builder db@Database{..} keys = do | ||
| -- Async things that I own and am responsible for killing | ||
| ownedAsync <- newIORef [] | ||
| flip onException (cleanupAsync ownedAsync) $ do | ||
|
|
||
| -- Things that I need to force before my results are ready | ||
| toForce <- newIORef [] | ||
|
|
||
| results <- withLock databaseLock $ do | ||
| forM keys $ \idKey -> do | ||
| id <- case idKey of | ||
| Left id -> pure id | ||
| Right key -> do | ||
| ids <- readIORef databaseIds | ||
| case Intern.lookup key ids of | ||
| Just v -> pure v | ||
| Nothing -> do | ||
| (ids, id) <- pure $ Intern.add key ids | ||
| writeIORef' databaseIds ids | ||
| return id | ||
|
|
||
| status <- Ids.lookup databaseValues id | ||
| val <- case fromMaybe (fromRight undefined idKey, Dirty Nothing) status of | ||
| (_, Clean r) -> pure r | ||
| (_, Running act _) -> do | ||
| -- we promise to force everything in todo before reading the results | ||
| -- so the following unsafePerformIO isn't actually unsafe | ||
| let (force, val) = splitIO act | ||
| modifyIORef toForce (force:) | ||
| pure val | ||
| (key, Dirty s) -> do | ||
| -- Important we don't lose any Async things we create | ||
| act <- uninterruptibleMask $ \restore -> do | ||
| -- the child actions should always be spawned unmasked | ||
| -- or they can't be killed | ||
| async <- async $ restore $ check db key id s | ||
|
There was a problem hiding this comment. On IRC, we were discussing if it was possible to make all the book-keeping contention free, by eliminating the locks and running in STM (and using a concurrent map like stm-containers?). This bit seems to be the problematic part, the rest of the computation seem like it can easily be moved into STM. But it might just be possible to make something work using judicious use of |
||
| modifyIORef ownedAsync (async:) | ||
| pure $ wait async | ||
| Ids.insert databaseValues id (key, Running act s) | ||
| let (force, val) = splitIO act | ||
| modifyIORef toForce (force:) | ||
| pure val | ||
|
|
||
| pure (id, val) | ||
|
|
||
| sequence_ =<< readIORef toForce | ||
| pure results | ||
|
|
||
| cleanupAsync :: IORef [Async a] -> IO () | ||
| cleanupAsync ref = mapConcurrently_ uninterruptibleCancel =<< readIORef ref | ||
|
|
||
|
|
||
| -- Check if we need to run the database. | ||
| check :: Database -> Key -> Id -> Maybe Result -> IO Result | ||
| check db key id result@(Just me@Result{resultDeps=Just deps}) = do | ||
| res <- builder db $ map Left deps | ||
| let dirty = all (\(_,dep) -> resultBuilt me < resultChanged dep) res | ||
| let mode = if dirty then Shake.RunDependenciesChanged else Shake.RunDependenciesSame | ||
| spawn db key id mode result | ||
| check db key id result = spawn db key id Shake.RunDependenciesChanged result | ||
|
|
||
|
|
||
| -- Spawn a new computation to run the action. | ||
| spawn :: Database -> Key -> Id -> Shake.RunMode -> Maybe Result -> IO Result | ||
| spawn db@Database{..} key id mode result = do | ||
| let act = runRule databaseRules key (fmap resultData result) mode | ||
| deps <- newIORef $ Just [] | ||
| Shake.RunResult{..} <- runReaderT (fromAction act) $ SAction db deps | ||
| built <- readIORef databaseStep | ||
| deps <- readIORef deps | ||
| let changed = if runChanged == Shake.ChangedRecomputeDiff then built else maybe built resultChanged result | ||
| let res = Result runValue built changed deps runStore | ||
| withLock databaseLock $ | ||
| Ids.insert databaseValues id (key, Clean res) | ||
| pure res | ||
|
|
||
| data Box a = Box {fromBox :: a} | ||
|
|
||
| splitIO :: IO a -> (IO (), a) | ||
| splitIO act = do | ||
| let act2 = Box <$> act | ||
| let res = unsafePerformIO act2 | ||
| (void $ evaluate res, fromBox res) | ||
|
Comment on lines
+142
to
+144
There was a problem hiding this comment. I'm not familiar with this trick. What is the |
||
Oops, something went wrong.
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.