Skip to content

Commit 33815b6

Browse files
layuslayus
committed
Cache hashDerivationModulo results ourselves
Ideally, we would have this cache inside the (h)nix-store, and persist the store connection for the whole session. Consider this a proof of concept that may last.
1 parent b2e6dd0 commit 33815b6

File tree

4 files changed

+37
-27
lines changed

4 files changed

+37
-27
lines changed

‎src/Nix/Effects/Basic.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -225,13 +225,13 @@ findPathM = findPathBy existingPath
225225
pure $ if exists then Just apath else Nothing
226226

227227
defaultImportPath
228-
:: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc) m)
228+
:: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc, b) m)
229229
=> FilePath
230230
-> m (NValue t f m)
231231
defaultImportPath path = do
232232
traceM $ "Importing file " ++ path
233233
withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do
234-
imports <- get
234+
imports <- gets fst
235235
evalExprLoc =<< case M.lookup path imports of
236236
Just expr -> pure expr
237237
Nothing -> do
@@ -242,7 +242,7 @@ defaultImportPath path = do
242242
$ ErrorCall
243243
. show $ fillSep ["Parse during import failed:", err]
244244
Success expr -> do
245-
modify (M.insert path expr)
245+
modify (\(a, b) -> (M.insert path expr a, b))
246246
pure expr
247247

248248
defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath

‎src/Nix/Effects/Derivation.hs

+18-11
Original file line numberDiff line numberDiff line change
@@ -16,9 +16,11 @@ import Prelude hiding ( readFile )
1616
import Control.Arrow ( first, second )
1717
import Control.Monad ( (>=>), forM, when )
1818
import Control.Monad.Writer ( join, lift )
19+
import Control.Monad.State ( MonadState, gets, modify )
1920

2021
import Data.Char ( isAscii, isAlphaNum )
2122
import qualified Data.HashMap.Lazy as M
23+
import qualified Data.HashMap.Strict as MS
2224
import qualified Data.HashSet as S
2325
import Data.List
2426
import qualified Data.Map.Strict as Map
@@ -101,7 +103,7 @@ writeDerivation (drv@Derivation {inputs, name}) = do
101103

102104
-- | Traverse the graph of inputDrvs to replace fixed output derivations with their fixed output hash.
103105
-- this avoids propagating changes to their .drv when the output hash stays the same.
104-
hashDerivationModulo :: (Framed e m, MonadFile m) => Derivation -> m (Store.Digest 'Store.SHA256)
106+
hashDerivationModulo :: (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => Derivation -> m (Store.Digest 'Store.SHA256)
105107
hashDerivationModulo (Derivation {
106108
mFixed = Just (Store.SomeDigest (digest :: Store.Digest hashType)),
107109
outputs,
@@ -115,10 +117,14 @@ hashDerivationModulo (Derivation {
115117
<> ":" <> path
116118
outputsList -> throwError $ ErrorCall $ "This is weird. A fixed output drv should only have one output named 'out'. Got " ++ show outputsList
117119
hashDerivationModulo drv@(Derivation {inputs = (inputSrcs, inputDrvs)}) = do
118-
inputsModulo <- Map.fromList <$> forM (Map.toList inputDrvs) (\(path, outs) -> do
119-
drv' <- readDerivation $ Text.unpack path
120-
hash <- Store.encodeBase16 <$> hashDerivationModulo drv'
121-
return (hash, outs)
120+
cache <- gets snd
121+
inputsModulo <- Map.fromList <$> forM (Map.toList inputDrvs) (\(path, outs) ->
122+
case MS.lookup path cache of
123+
Just hash -> return (hash, outs)
124+
Nothing -> do
125+
drv' <- readDerivation $ Text.unpack path
126+
hash <- Store.encodeBase16 <$> hashDerivationModulo drv'
127+
return (hash, outs)
122128
)
123129
return $ Store.hash @'Store.SHA256 $ Text.encodeUtf8 $ unparseDrv (drv {inputs = (inputSrcs, inputsModulo)})
124130

@@ -214,7 +220,7 @@ derivationParser = do
214220
_ -> (Nothing, Flat)
215221

216222

217-
defaultDerivationStrict :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
223+
defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => NValue t f m -> m (NValue t f m)
218224
defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
219225
(drv, ctx) <- runWithStringContextT' $ buildDerivationWithContext s
220226
drvName <- makeStorePathName $ name drv
@@ -242,13 +248,14 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
242248
, env = if useJson drv then env drv else Map.union outputs' (env drv)
243249
}
244250

245-
drvPath <- writeDerivation drv'
251+
drvPath <- pathToText <$> writeDerivation drv'
246252

247-
-- TODO: memoize this result here.
248-
-- _ <- hashDerivationModulo drv'
253+
-- Memoize here, as it may be our last chance in case of readonly stores.
254+
drvHash <- Store.encodeBase16 <$> hashDerivationModulo drv'
255+
modify (\(a, b) -> (a, MS.insert drvPath drvHash b))
249256

250-
let outputsWithContext = Map.mapWithKey (\out path -> principledMakeNixStringWithSingletonContext path (StringContext (pathToText drvPath) (DerivationOutput out))) (outputs drv')
251-
drvPathWithContext = principledMakeNixStringWithSingletonContext (pathToText drvPath) (StringContext (pathToText drvPath) AllOutputs)
257+
let outputsWithContext = Map.mapWithKey (\out path -> principledMakeNixStringWithSingletonContext path (StringContext drvPath (DerivationOutput out))) (outputs drv')
258+
drvPathWithContext = principledMakeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs)
252259
attrSet = M.map nvStr $ M.fromList $ ("drvPath", drvPathWithContext): Map.toList outputsWithContext
253260
-- TODO: Add location information for all the entries.
254261
-- here --v

‎src/Nix/Reduce.hs

+9-8
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ import Control.Monad.State.Strict
4242
import Data.Fix ( Fix(..), foldFix, foldFixM )
4343
import Data.HashMap.Lazy ( HashMap )
4444
import qualified Data.HashMap.Lazy as M
45+
import qualified Data.HashMap.Strict as MS
4546
import Data.IORef
4647
import Data.List.NonEmpty ( NonEmpty(..) )
4748
import qualified Data.List.NonEmpty as NE
@@ -66,19 +67,19 @@ import System.FilePath
6667

6768
newtype Reducer m a = Reducer
6869
{ runReducer :: ReaderT (Maybe FilePath, Scopes (Reducer m) NExprLoc)
69-
(StateT (HashMap FilePath NExprLoc) m) a }
70+
(StateT (HashMap FilePath NExprLoc, MS.HashMap Text Text) m) a }
7071
deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
7172
MonadFix, MonadIO, MonadFail,
7273
MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc),
73-
MonadState (HashMap FilePath NExprLoc))
74+
MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text))
7475

7576
staticImport
7677
:: forall m
7778
. ( MonadIO m
7879
, Scoped NExprLoc m
7980
, MonadFail m
8081
, MonadReader (Maybe FilePath, Scopes m NExprLoc) m
81-
, MonadState (HashMap FilePath NExprLoc) m
82+
, MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m
8283
)
8384
=> SrcSpan
8485
-> FilePath
@@ -89,7 +90,7 @@ staticImport pann path = do
8990
path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath
9091
(maybe path (\p -> takeDirectory p </> path) mfile)
9192

92-
imports <- get
93+
imports <- gets fst
9394
case M.lookup path' imports of
9495
Just expr -> pure expr
9596
Nothing -> go path'
@@ -108,10 +109,10 @@ staticImport pann path = do
108109
(Fix (NLiteralPath_ pann path))
109110
pos
110111
x' = Fix (NLet_ span [cur] x)
111-
modify (M.insert path x')
112+
modify (\(a, b) -> (M.insert path x' a, b))
112113
local (const (Just path, emptyScopes @m @NExprLoc)) $ do
113114
x'' <- foldFix reduce x'
114-
modify (M.insert path x'')
115+
modify (\(a, b) -> (M.insert path x'' a, b))
115116
return x''
116117

117118
-- gatherNames :: NExprLoc -> HashSet VarName
@@ -122,7 +123,7 @@ staticImport pann path = do
122123
reduceExpr
123124
:: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc
124125
reduceExpr mpath expr =
125-
(`evalStateT` M.empty)
126+
(`evalStateT` (M.empty, MS.empty))
126127
. (`runReaderT` (mpath, emptyScopes))
127128
. runReducer
128129
$ foldFix reduce expr
@@ -133,7 +134,7 @@ reduce
133134
, Scoped NExprLoc m
134135
, MonadFail m
135136
, MonadReader (Maybe FilePath, Scopes m NExprLoc) m
136-
, MonadState (HashMap FilePath NExprLoc) m
137+
, MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text) m
137138
)
138139
=> NExprLocF (m NExprLoc)
139140
-> m NExprLoc

‎src/Nix/Standard.hs

+7-5
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,8 @@ import Control.Monad.Reader
3030
import Control.Monad.Ref
3131
import Control.Monad.State
3232
import Data.HashMap.Lazy ( HashMap )
33+
import qualified Data.HashMap.Strict
34+
import Data.Text ( Text )
3335
import Data.Typeable
3436
import GHC.Generics
3537
import Nix.Cited
@@ -139,7 +141,7 @@ instance ( MonadFix m
139141
, Typeable m
140142
, Scoped (StdValue m) m
141143
, MonadReader (Context m (StdValue m)) m
142-
, MonadState (HashMap FilePath NExprLoc) m
144+
, MonadState (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m
143145
, MonadDataErrorContext (StdThunk m) (StdCited m) m
144146
, MonadThunk (StdThunk m) m (StdValue m)
145147
, MonadValue (StdValue m) m
@@ -192,7 +194,7 @@ instance ( MonadAtomicRef m
192194

193195
newtype StandardTF r m a
194196
= StandardTF (ReaderT (Context r (StdValue r))
195-
(StateT (HashMap FilePath NExprLoc) m) a)
197+
(StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) a)
196198
deriving
197199
( Functor
198200
, Applicative
@@ -206,7 +208,7 @@ newtype StandardTF r m a
206208
, MonadThrow
207209
, MonadMask
208210
, MonadReader (Context r (StdValue r))
209-
, MonadState (HashMap FilePath NExprLoc)
211+
, MonadState (HashMap FilePath NExprLoc, HashMap Text Text)
210212
)
211213

212214
instance MonadTrans (StandardTF r) where
@@ -233,7 +235,7 @@ instance MonadThunkId m => MonadThunkId (Fix1T StandardTF m) where
233235
mkStandardT
234236
:: ReaderT
235237
(Context (StandardT m) (StdValue (StandardT m)))
236-
(StateT (HashMap FilePath NExprLoc) m)
238+
(StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)
237239
a
238240
-> StandardT m a
239241
mkStandardT = Fix1T . StandardTF
@@ -242,7 +244,7 @@ runStandardT
242244
:: StandardT m a
243245
-> ReaderT
244246
(Context (StandardT m) (StdValue (StandardT m)))
245-
(StateT (HashMap FilePath NExprLoc) m)
247+
(StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)
246248
a
247249
runStandardT (Fix1T (StandardTF m)) = m
248250

0 commit comments

Comments
 (0)