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

Improve performance of type-class dict lookup

commitfedeee22bfa5474bad0460c2c8094b5b89ec3250 authorPhil Freeman <paf31@cantab.net> dateWed 10 Jun 2015, 20:38 (11 years ago) parent57f0976eb1018c
4 files changed+14−9
compare with golang
unifiedsplit
src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/Environment.hs+1−1 src/Language/PureScript/TypeChecker.hs+3−4 src/Language/PureScript/TypeChecker/Monad.hs+9−3
src/Language/PureScript/CodeGen/Externs.hs+1−1
@@ -107,7 +107,7 @@ moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWri
107107
108108 exportToPs (TypeInstanceRef ident) = do
109109 let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
110− fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) $ M.elems $ typeClassDictionaries env
110+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) . maybe [] M.elems . M.lookup (Just moduleName) $ typeClassDictionaries env
111111 let constraintsText = case fromMaybe [] deps of
112112 [] -> ""
113113 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
src/Language/PureScript/Environment.hs+1−1
@@ -49,7 +49,7 @@ data Environment = Environment {
4949 -- |
5050 -- Available type class dictionaries
5151 --
52− , typeClassDictionaries :: M.Map (Qualified Ident, Maybe ModuleName) TypeClassDictionaryInScope
52+ , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)
5353 -- |
5454 -- Type classes
5555 --
src/Language/PureScript/TypeChecker.hs+3−4
@@ -90,8 +90,8 @@ addTypeClass moduleName pn args implies ds =
9090
9191addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
9292addTypeClassDictionaries entries =
93− let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
94− in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
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 } }
9595
9696checkDuplicateTypeArguments :: [String] -> Check ()
9797checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
@@ -223,8 +223,7 @@ typeCheckAll mainModuleName moduleName exps = go
223223 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
224224 return $ d : ds
225225 go (d@(ImportDeclaration importedModule _ _) : rest) = do
226− tcds <- getTypeClassDictionaries
227− let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds
226+ instances <- lookupTypeClassDictionaries $ Just importedModule
228227 addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
229228 | tcd <- instances
230229 , tcdExported tcd
src/Language/PureScript/TypeChecker/Monad.hs+9−3
@@ -69,8 +69,8 @@ withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified
6969withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
7070withTypeClassDictionaries entries action = do
7171 orig <- get
72− let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
73− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
72+ let mentries = M.fromListWith (M.union) [ (mn, M.singleton (canonicalizeDictionary entry) entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
73+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.union) (typeClassDictionaries . checkEnv $ st) mentries } }
7474 a <- action
7575 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
7676 return a
@@ -79,7 +79,13 @@ withTypeClassDictionaries entries action = do
7979-- Get the currently available list of type class dictionaries
8080--
8181getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
82−getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
82+getTypeClassDictionaries = (>>= M.elems) . M.elems . typeClassDictionaries . checkEnv <$> get
83+
84+-- |
85+-- Lookup type class dictionaries in a module.
86+--
87+lookupTypeClassDictionaries :: (Functor m, MonadState CheckState m) => Maybe ModuleName -> m [TypeClassDictionaryInScope]
88+lookupTypeClassDictionaries mn = maybe [] M.elems . M.lookup mn . typeClassDictionaries . checkEnv <$> get
8389
8490-- |
8591-- Temporarily bind a collection of names to local variables