git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1173 from puffnfresh/perf/dictionary-lookup

Improve performance of module dictionary collection

commitc334a04561d37d851448a06c6e9b6a442db34281 authorPhil Freeman <paf31@cantab.net> dateTue 16 Jun 2015, 16:41 (11 years ago) parentbfb4c0ec3b4444
3 files changed+15−18
compare with golang
unifiedsplit
src/Language/PureScript/TypeChecker.hs+6−10 src/Language/PureScript/TypeChecker/Entailment.hs+7−6 src/Language/PureScript/TypeChecker/Monad.hs+2−2
src/Language/PureScript/TypeChecker.hs+6−10
@@ -88,10 +88,9 @@ addTypeClass moduleName pn args implies ds =
8888 toPair (PositionedDeclaration _ _ d) = toPair d
8989 toPair _ = error "Invalid declaration in TypeClassDeclaration"
9090
91−addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
92−addTypeClassDictionaries entries =
93− let mentries = M.fromListWith (M.union) [ (mn, M.singleton (canonicalizeDictionary entry) entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
94− in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.union) (typeClassDictionaries . checkEnv $ st) mentries } }
91+addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified Ident) TypeClassDictionaryInScope -> Check ()
92+addTypeClassDictionaries mn entries =
93+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.insertWith M.union mn entries (typeClassDictionaries . checkEnv $ st) } }
9594
9695checkDuplicateTypeArguments :: [String] -> Check ()
9796checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
@@ -224,11 +223,7 @@ typeCheckAll mainModuleName moduleName exps = go
224223 return $ d : ds
225224 go (d@(ImportDeclaration importedModule _ _) : rest) = do
226225 instances <- lookupTypeClassDictionaries $ Just importedModule
227− addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
228− | tcd <- instances
229− , tcdExported tcd
230− , let (Qualified _ ident) = tcdName tcd
231− ]
226+ addTypeClassDictionaries (Just moduleName) instances
232227 ds <- go rest
233228 return $ d : ds
234229 go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
@@ -247,7 +242,8 @@ typeCheckAll mainModuleName moduleName exps = go
247242 goInstance d dictName deps className tys rest = do
248243 mapM_ (checkTypeClassInstance moduleName) tys
249244 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
250− addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]
245+ let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
246+ addTypeClassDictionaries (Just moduleName) $ M.singleton (canonicalizeDictionary dict) dict
251247 ds <- go rest
252248 return $ d : ds
253249
src/Language/PureScript/TypeChecker/Entailment.hs+7−6
@@ -48,8 +48,11 @@ newtype Work = Work Integer deriving (Show, Eq, Ord, Num)
4848-- return a type class dictionary reference.
4949--
5050entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
51−entails env moduleName context = solve (sortedNubBy canonicalizeDictionary dictsInScope)
51+entails env moduleName context = solve
5252 where
53+ byClassName :: M.Map (Qualified ProperName) [TypeClassDictionaryInScope]
54+ byClassName = M.fromListWith (++) $ (\tcd -> (tcdClassName tcd, [tcd])) <$> sortedNubBy canonicalizeDictionary dictsInScope
55+
5356 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
5457 sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
5558
@@ -59,8 +62,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary dicts
5962 findDicts :: Maybe ModuleName -> [TypeClassDictionaryInScope]
6063 findDicts = fromMaybe [] . flip M.lookup context
6164
62− solve :: [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
63− solve context' (className, tys) trySuperclasses = do
65+ solve :: Constraint -> Bool -> Check Expr
66+ solve (className, tys) trySuperclasses = do
6467 let dicts = flip evalStateT (Work 0) $ go trySuperclasses className tys
6568 checkOverlaps dicts
6669 where
@@ -73,9 +76,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary dicts
7376 where
7477 directInstances :: StateT Work [] DictionaryValue
7578 directInstances = do
76− tcd <- lift context'
77− -- Make sure the type class name matches the one we are trying to satisfy
78− guard $ className' == tcdClassName tcd
79+ tcd <- lift . fromMaybe [] $ M.lookup className' byClassName
7980 -- Make sure the type unifies with the type in the type instance definition
8081 subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
8182 -- Solve any necessary subgoals
src/Language/PureScript/TypeChecker/Monad.hs+2−2
@@ -84,8 +84,8 @@ getTypeClassDictionaries = fmap M.elems . typeClassDictionaries . checkEnv <$> g
8484-- |
8585-- Lookup type class dictionaries in a module.
8686--
87−lookupTypeClassDictionaries :: (Functor m, MonadState CheckState m) => Maybe ModuleName -> m [TypeClassDictionaryInScope]
88−lookupTypeClassDictionaries mn = maybe [] M.elems . M.lookup mn . typeClassDictionaries . checkEnv <$> get
87+lookupTypeClassDictionaries :: (Functor m, MonadState CheckState m) => Maybe ModuleName -> m (M.Map (Qualified Ident) TypeClassDictionaryInScope)
88+lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get
8989
9090-- |
9191-- Temporarily bind a collection of names to local variables