New patches: [Efficient substitutions. Lemmih **20080218232431] { hunk ./E/SSimplify.hs 337 - envCachedSubst :: IdMap (Maybe E), + envCachedSubst :: IdMap E, hunk ./E/SSimplify.hs 353 +insertRange :: Id -> Range -> Env -> Env hunk ./E/SSimplify.hs 362 -insertDoneSubst' t e env = cacheSubst env { envSubst = minsert t (Done e) (envSubst env) } +insertDoneSubst' t e env = insertRange t (Done e) env hunk ./E/SSimplify.hs 375 -applySubst :: Subst -> IdMap a -> IdMap (Maybe OutE) +applySubst :: Subst -> IdMap a -> IdMap OutE hunk ./E/SSimplify.hs 377 - nn' = fmap (const Nothing) s `mappend` fmap (const Nothing) nn - applySubst' s = (tm `mappend` nn') where - tm = fmap g s - g (Done e) = Just e - g (Susp e s' _) = Just $ substMap'' (applySubst' s') e + check n = n `mmember` s || n `mmember` nn + applySubst' s = fmap g s + g (Done e) = e + g (Susp e s' _) = doSubst' False False (applySubst' s') check e hunk ./E/SSimplify.hs 389 -dosub e = ask >>= \inb -> coerceOpt return (substMap'' (envCachedSubst inb) e) +dosub e = ask >>= \inb -> coerceOpt return (doSubst' False False (envCachedSubst inb) (`mmember` envCachedSubst inb) e) hunk ./E/Subst.hs 3 + doSubst', hunk ./E/Subst.hs 29 +import System.Random + +import qualified Data.Set as Set hunk ./E/Subst.hs 80 -doSubst substInVars allShadow bm e = f e bm where - f :: E -> IdMap (Maybe E) -> E +doSubst substInVars allShadow bm e + = doSubst' substInVars allShadow (mapMaybeIdMap id bm) (`mmember` bm) e + +doSubst' :: Bool -> Bool -> IdMap E -> (Id -> Bool) -> E -> E +doSubst' substInVars allShadow bm check e = f e (Set.empty, bm) where + f :: E -> (Set.Set Id, IdMap E) -> E hunk ./E/Subst.hs 87 - mp <- ask + (_,mp) <- ask hunk ./E/Subst.hs 89 - Just (Just v) -> return v + Just v -> return v hunk ./E/Subst.hs 99 - (as,rs) <- liftM unzip $ mapMntvr (fsts dl) + (as,rs) <- mapMntvr (fsts dl) hunk ./E/Subst.hs 109 - (b',r) <- ntvr [] $ eCaseBind ec + (b',r) <- ntvr Set.empty $ eCaseBind ec hunk ./E/Subst.hs 113 - (as,rs) <- liftM unzip $ mapMntvr vs + (as,rs) <- mapMntvr vs hunk ./E/Subst.hs 125 - e' <- local (minsert n Nothing) $ f e + e' <- local (\(s,m) -> (Set.insert n s, mdelete n m)) $ f e hunk ./E/Subst.hs 128 - (tv,r) <- ntvr [] tvr + (tv,r) <- ntvr Set.empty tvr hunk ./E/Subst.hs 132 - f [] xs = return $ reverse xs + f [] xs = return $ unzip $ reverse xs hunk ./E/Subst.hs 136 - vs = [ tvrIdent x | x <- ts ] + vs = Set.fromList [ tvrIdent x | x <- ts ] hunk ./E/Subst.hs 138 - --mapMntvr [] = return [] - --mapMntvr (t:ts) = do - -- (t',r) <- ntvr t - -- ts' <- local r (mapMntvr ts) - -- return ((t',r):ts') - --ntvr :: TVr -> Map Int (Maybe E) -> (TVr, Map Int (Maybe E) -> Map Int (Maybe E)) hunk ./E/Subst.hs 144 - i' <- mnv allShadow xs i + (s,ss) <- ask + let i' = mnv allShadow xs i s ss hunk ./E/Subst.hs 147 - case i == i' of - True -> return (nvr,minsert i (Just $ EVar nvr)) - False -> return (nvr,minsert i (Just $ EVar nvr) . minsert i' Nothing) + return (nvr,\(s,m) -> (Set.insert i' . Set.insert i $ s, minsert i (EVar nvr) . mdelete i' $ m)) hunk ./E/Subst.hs 151 -mnv allShadow xs i ss - | allShadow = nv ss --- | i <= 0 || i `mmember` ss = nv (fromList [ (x,undefined) | x <- xs ] `mappend` ss) - | isInvalidId i || i `mmember` ss = nv (fromList [ (x,undefined) | x <- xs ] `mappend` ss) +mnv allShadow xs i s ss + | allShadow = nv scheck (Set.size xs + Set.size s + size ss) + | isInvalidId i || scheck i = nv check (Set.size xs + Set.size s + size ss) + -- It is very important that we don't check for 'xs' membership in the guard above. hunk ./E/Subst.hs 156 + where scheck n = n `mmember` ss || n `Set.member` s + check n = scheck n || n `Set.member` xs hunk ./E/Subst.hs 159 - -nv ss = v (2 * (size ss + 1)) where - v n | n `mmember` ss = v (n + 2) - v n = n +nv check seed = head $ filter (not . check) $ filter even $ filter (>0) ls + where ls = randoms (mkStdGen seed) hunk ./E/Subst.hs 223 - (b',r) <- ntvr [] $ eCaseBind ec + (b',r) <- ntvr Set.empty $ eCaseBind ec hunk ./E/Subst.hs 242 - (tv,r) <- ntvr [] tvr + (tv,r) <- ntvr Set.empty tvr hunk ./E/Subst.hs 250 - vs = [ tvrIdent x | x <- ts ] + vs = Set.fromList [ tvrIdent x | x <- ts ] hunk ./E/Subst.hs 268 - let i' = mnv False xs i map + let i' = mnv False xs i Set.empty map hunk ./FrontEnd/Tc/Class.hs 43 - let mvs = nub [ v | v <- freeMetaVars r, not $ v `Set.member` fmvenv ] + let mvs = freeMetaVars r `Set.difference` fmvenv hunk ./Name/Id.hs 16 + mapMaybeIdMap, hunk ./Name/Id.hs 64 +mapMaybeIdMap :: (a -> Maybe b) -> IdMap a -> IdMap b +mapMaybeIdMap fn (IdMap m) = IdMap (IM.mapMaybe fn m) + } [Avoid lists. They are the bane of performance if badly used. Lemmih **20080218232646] { hunk ./FrontEnd/Tc/Class.hs 45 - (mvs',nps,rp) <- splitReduce (Set.toList fmvenv) mvs (simplify ch ps) + (mvs',nps,rp) <- splitReduce (Set.toList fmvenv) (Set.toList mvs) (simplify ch ps) hunk ./FrontEnd/Tc/Class.hs 53 -freeMetaVarsPred (IsIn _ t) = freeMetaVars t -freeMetaVarsPred (IsEq t1 t2) = freeMetaVars t1 ++ freeMetaVars t2 +freeMetaVarsPred (IsIn _ t) = Set.toList $ freeMetaVars t +freeMetaVarsPred (IsEq t1 t2) = Set.toList (freeMetaVars t1) ++ Set.toList (freeMetaVars t2) hunk ./FrontEnd/Tc/Main.hs 541 - let vss = Set.fromList $ freeMetaVars mv' + let vss = freeMetaVars mv' hunk ./FrontEnd/Tc/Main.hs 647 - let mvs = snub $ concatMap freeMetaVars (tr:vs) + let mvs = Set.toList $ Set.unions $ map freeMetaVars (tr:vs) hunk ./FrontEnd/Tc/Monad.hs 390 - return (Set.fromList $ concat xs) + return (Set.unions xs) hunk ./FrontEnd/Tc/Monad.hs 450 - when (u `elem` freeMetaVars tt) $ do + when (u `Set.member` freeMetaVars tt) $ do hunk ./FrontEnd/Tc/Type.hs 37 -import List +import Data.List +import Data.Monoid hunk ./FrontEnd/Tc/Type.hs 40 +import qualified Data.Set as S hunk ./FrontEnd/Tc/Type.hs 106 -isTau t = and $ tickleCollect ((:[]) . isTau) t +isTau t = getAll $ tickleCollect (All . isTau) t hunk ./FrontEnd/Tc/Type.hs 110 -isTau' t = and $ tickleCollect ((:[]) . isTau') t +isTau' t = getAll $ tickleCollect (All . isTau') t hunk ./FrontEnd/Tc/Type.hs 114 -isBoxy t = or $ tickleCollect ((:[]) . isBoxy) t +isBoxy t = getAny $ tickleCollect (Any . isBoxy) t hunk ./FrontEnd/Tc/Type.hs 222 -freeMetaVars :: Type -> [MetaVar] -freeMetaVars (TMetaVar mv) = [mv] -freeMetaVars t = foldr union [] $ tickleCollect ((:[]) . freeMetaVars) t +freeMetaVars :: Type -> S.Set MetaVar +freeMetaVars (TMetaVar mv) = S.singleton mv +freeMetaVars t = tickleCollect freeMetaVars t hunk ./FrontEnd/Tc/Type.hs 228 - freeVars (TForAll vs qt) = freeVars qt List.\\ vs - freeVars (TExists vs qt) = freeVars qt List.\\ vs + freeVars (TForAll vs qt) = freeVars qt Data.List.\\ vs + freeVars (TExists vs qt) = freeVars qt Data.List.\\ vs hunk ./FrontEnd/Tc/Type.hs 233 + freeVars t = S.toList $ freeMetaVars t + +instance FreeVars Type (S.Set MetaVar) where hunk ./FrontEnd/Tc/Unify.hs 11 +import qualified Data.Set as Set hunk ./FrontEnd/Tc/Unify.hs 113 - when (u `elem` freeMetaVars tt) $ unificationError (TMetaVar u) tt -- occurs check + when (u `Set.member` freeMetaVars tt) $ unificationError (TMetaVar u) tt -- occurs check hunk ./Ho/Build.hs 219 - = SourceParsed { sourceHash :: SourceHash, sourceDeps :: [Module], sourceModule :: HsModule, sourceFP :: FilePath, sourceHoName :: FilePath } - | SourceRaw { sourceHash :: SourceHash, sourceDeps :: [Module], sourceModName :: Module, sourceLBS :: LBS.ByteString, sourceFP :: FilePath, sourceHoName :: FilePath } + = SourceParsed { sourceHash :: SourceHash, sourceDeps :: [Module] + , sourceModule :: HsModule, sourceFP :: FilePath, sourceHoName :: FilePath } + | SourceRaw { sourceHash :: SourceHash, sourceDeps :: [Module] + , sourceModName :: Module, sourceLBS :: LBS.ByteString, sourceFP :: FilePath, sourceHoName :: FilePath } } [Only use atoms when absolutely necessary. Lemmih **20080218232922] { hunk ./Ho/Build.hs 582 - let pdesc = [(toAtom n, packString v) | (n,v) <- ("jhc-hl-filename",outName):("jhc-description-file",fp):("jhc-compiled-by",versionString):desc, n /= "exposed-modules" ] + let pdesc = [(n, packString v) | (n,v) <- ("jhc-hl-filename",outName):("jhc-description-file",fp):("jhc-compiled-by",versionString):desc, n /= "exposed-modules" ] hunk ./Ho/Build.hs 627 - when (not $ Prelude.null (hohMetaInfo hoh)) $ putStrLn $ "MetaInfo:\n" <> vindent (sort [text (' ':' ':fromAtom k) <> char ':' <+> show v | (k,v) <- hohMetaInfo hoh]) + when (not $ Prelude.null (hohMetaInfo hoh)) $ putStrLn $ "MetaInfo:\n" <> vindent (sort [text (' ':' ':k) <> char ':' <+> show v | (k,v) <- hohMetaInfo hoh]) hunk ./Ho/Type.hs 72 - hohMetaInfo :: [(Atom,PackedString)] + hohMetaInfo :: [(String,PackedString)] } Context: [add parsing of standalone deriving, clean up some code involving names and the parser John Meacham **20080218030815] [rearrange library a bunch more. move 'Read' to Jhc.Text.Read John Meacham **20080218011716] [rearrange prelude some more. add Prelude.CType John Meacham **20080215044413] [fix shortenPath when working on invalid directories John Meacham **20080215040425] [Optimize simple type-checking. Lemmih **20080215142652] [change chos to only build their ho's lazily, so we don't end up with duplicate copies of hos. John Meacham **20080214060556] [rearrange a lot of the library to break more cyclic dependencies John Meacham **20080213072101] [print binding groups again when -dscc-modules is passed to jhc John Meacham **20080213072044] [clean up Atom.hsc some, make the internal name format use pritable characters when creating atoms to aid in debugging. John Meacham **20080213054653] [Fix makefile for jhcp. Lemmih **20080214115032] [TAG bygniettucu John Meacham **20080213051714] Patch bundle hash: a9230e7c16c60d98042899b64bfce0e2fdbb3fae