[prev in list] [next in list] [prev in thread] [next in thread]
List: haskell-jhc
Subject: [jhc] darcs patch: create a better relation representation,
From: John Meacham <john () repetae ! net>
Date: 2010-08-09 1:07:04
Message-ID: 20100809010704.42F9F641F5 () sliver ! repetae ! net
[Download RAW message or body]
Fri Aug 6 01:26:22 PDT 2010 John Meacham <john@repetae.net>
* create a better relation representation, speed up export chasing signif=
igantly
Fri Aug 6 02:03:49 PDT 2010 John Meacham <john@repetae.net>
* split type environment into concrete and mutable sets, to avoid retrave=
rsing the concrete imported types
Fri Aug 6 02:28:15 PDT 2010 John Meacham <john@repetae.net>
* further seperate out concrete types to speed up checking
Fri Aug 6 04:17:03 PDT 2010 John Meacham <john@repetae.net>
* speed up name choosing a little
Fri Aug 6 04:28:20 PDT 2010 John Meacham <john@repetae.net>
* clean ups
["create-a-better-relation-representation_-speed-up-export-chasing-signifigantly.dpatch" (text/x-darcs-patch)]
New patches:
[create a better relation representation, speed up export chasing signifigantly
John Meacham <john@repetae.net>**20100806082622
Ignore-this: 9f49871e33348bbfc4e8fd2ee9fa71b8
] hunk ./src/FrontEnd/Exports.hs 21
import FrontEnd.HsSyn
import Name.Name as Name
import Options
+import Util.SetLike as SL
import Util.Relation as R
import FrontEnd.Warning
hunk ./src/FrontEnd/Exports.hs 72
determineExports' :: [(Name,[Name])] -> [(Module,[Name])] -> [ModInfo] -> IO \
[ModInfo] determineExports' owns doneMods todoMods = mdo
rs <- solve Nothing mempty [ x |(_,_,x) <- ms]
- let lf m = maybe (fail $ "determineExports'.lf: " ++ show m) return $ \
Map.lookup m $ dmodMap `mappend` Map.fromList [ (modInfoName x,Set.fromList \
[(toUnqualified x,x) | x <- modInfoExport x]) | x <- xs] + let lf m = maybe \
(fail $ "determineExports'.lf: " ++ show m) return $ Map.lookup m $ dmodMap \
`mappend` Map.fromList [ (modInfoName x,fromList [(toUnqualified x,x) | x <- \
modInfoExport x]) | x <- xs] let g (mi,ne) = do
ne' <- ce mi ne
return mi { modInfoExport = ne', modInfoImport = toRelationList $ \
runIdentity $ getImports mi lf } hunk ./src/FrontEnd/Exports.hs 80
return xs
where
ms = [ (i,mi, getExports mi le ) | mi <- todoMods | i <- [0..]]
- dmodMap = Map.fromList [ ( x,Set.fromList [(toUnqualified n,n) | n <- xs]) | \
(x,xs) <- doneMods ] + dmodMap = Map.fromList [ ( x,fromList [(toUnqualified n,n) \
| n <- xs]) | (x,xs) <- doneMods ]
modMap = fmap return dmodMap `mappend` (Map.fromList [ (modInfoName n,getVal i) \
| (i,n,_) <- ms]) ownsMap = Map.fromList owns
le m = runIdentity $ maybe (fail $ "determineExports'.le: " ++ show m) return $ \
Map.lookup m modMap hunk ./src/FrontEnd/Exports.hs 93
getExports mi@ModInfo { modInfoHsModule = m@HsModule { hsModuleExports = Nothing \
} } _ = return $ defsToRel (modInfoDefs mi)
getExports mi le | HsModule { hsModuleExports = Just es } <- modInfoHsModule mi \
= do is <- getImports mi le
- let f (HsEModuleContents m) = mapDomain g unqs `R.intersection` qs where
+ let f (HsEModuleContents m) = mapDomain g unqs `intersection` qs where
(qs,unqs) = partitionDomain (isJust . getModule ) is
g x = Name.qualifyName m x
f z = entSpec False is z
hunk ./src/FrontEnd/Exports.hs 97
- return $ mapDomain toUnqualified (R.unions $ map f es)
+ return $ mapDomain toUnqualified (unions $ map f es)
-- | determine what is visible in a module
getImports :: Monad m => ModInfo -> (Module -> m (Rel Name Name)) -> m (Rel Name \
Name) hunk ./src/FrontEnd/Exports.hs 109
Nothing -> return es -- return $ (mapDomain ((Name.qualifyName as)) \
es `mappend` if hsImportDeclQualified x then mempty else es) Just (isHiding,xs) -> \
do
let listed = mconcat $ map (entSpec isHiding es . \
importToExport) xs
- return $ if isHiding then es Set.\\ listed else listed
+ return $ if isHiding then es SL.\\ listed else listed
return $ (mapDomain ((Name.qualifyName as)) es' `mappend` if \
hsImportDeclQualified x then mempty else es') is = modInfoModImports mi
hunk ./src/FrontEnd/Exports.hs 112
- ls = R.fromList $ concat [ [(toUnqualified z,z),(z,z)]| (z, _, _) <- \
modInfoDefs mi] + ls = fromList $ concat [ [(toUnqualified z,z),(z,z)]| (z, \
_, _) <- modInfoDefs mi]
entSpec ::
Bool -- ^ is it a hiding import?
hunk ./src/FrontEnd/Exports.hs 119
-> Rel Name Name -- ^ the original relation
-> HsExportSpec -- ^ the specification
-> Rel Name Name -- ^ the subset satisfying the specification
- entSpec isHiding rel (HsEVar n) = restrictDomain (== toName Val n) rel
- entSpec isHiding rel (HsEAbs n) = restrictDomain (`elem` [ toName x n | x <- \
ts]) rel where + entSpec isHiding rel (HsEVar n) = restrictDomainS (toName Val n) \
rel + entSpec isHiding rel (HsEAbs n) = restrictDomainSet (Set.fromList [ toName x \
n | x <- ts]) rel where
ts = TypeConstructor:ClassName:if isHiding then [DataConstructor] else []
hunk ./src/FrontEnd/Exports.hs 122
- entSpec isHiding rel (HsEThingWith n xs) = restrictDomain (\x -> x `elem` concat \
(ct:(map (cd) xs))) rel where + entSpec isHiding rel (HsEThingWith n xs) = \
restrictDomainSet (fromList (concat (ct:(map cd xs)))) rel where ct = [toName \
TypeConstructor n, toName ClassName n]
cd n = [toName DataConstructor n, toName Val n, toName FieldLabel n ]
hunk ./src/FrontEnd/Exports.hs 125
- entSpec isHiding rel (HsEThingAll n) = restrictDomain (`elem` ct ) rel `mappend` \
restrictRange (`elem` ss) rel where + entSpec isHiding rel (HsEThingAll n) = rdl \
`mappend` restrictRange (`elem` ss) rel where ct = [toName TypeConstructor n, toName \
ClassName n] hunk ./src/FrontEnd/Exports.hs 127
- ss = concat $ concat [ maybeToList (Map.lookup x ownsMap) | x <- Set.toList \
$ range (restrictDomain (`elem` ct) rel)]
- cd n = [toName DataConstructor n, toName Val n, toName FieldLabel n ]
+ ss = concat $ concat [ maybeToList (Map.lookup x ownsMap) | x <- Set.toList \
$ range rdl ] + cd n = [toName DataConstructor n, toName Val n, toName \
FieldLabel n ] + rdl = (restrictDomain (`elem` ct) rel)
hunk ./src/FrontEnd/Exports.hs 132
-defsToRel xs = R.fromList $ map f xs where
+defsToRel xs = fromList $ map f xs where
f (n,_,_) = (toUnqualified n,n)
importToExport :: HsImportSpec -> HsExportSpec
hunk ./src/Ho/Library.hs 21
import Data.Monoid
import Data.Version
import System.Directory
-import System.IO
import Text.Printf
import qualified Data.Map as Map
import qualified Data.Set as Set
hunk ./src/Ho/Library.hs 103
listLibraries = do
(_,byhashes) <- fetchAllLibraries
let libs = Map.toList byhashes
- if not verbose then putStr $ showYAML (map (libName . snd) libs) else do
+ if not verbose then putStr $ showYAML (sort $ map (libName . snd) libs) else do
let f (h,l) = (show h,[
("Name",toNode (libName l)),
("BaseName",toNode (libBaseName l)),
hunk ./src/Util/Relation.hs 4
-- | extend Data.Set with relation operations
-module Util.Relation(module Util.Relation, module Set) where
+module Util.Relation where
hunk ./src/Util/Relation.hs 6
+import Data.Monoid
import Data.Set as Set hiding(map)
hunk ./src/Util/Relation.hs 8
-import qualified Data.Set as Set (map)
+import Util.SetLike
+import qualified Data.Set as Set
+import qualified Data.Map as Map
hunk ./src/Util/Relation.hs 12
-type Rel a b = Set (a,b)
+newtype Rel a b = Rel (Map.Map a (Set b))
+ deriving(Eq)
+
+instance (Ord a,Ord b) => Monoid (Rel a b) where
+ mempty = Rel mempty
+ mappend (Rel r1) (Rel r2) = Rel $ Map.unionWith Set.union r1 r2
+
+instance (Ord a,Ord b) => Unionize (Rel a b) where
+ difference (Rel r1) (Rel r2) = Rel $ Map.differenceWith f r1 r2 where
+ f r1 r2 = if Set.null rs then Nothing else Just rs where
+ rs = Set.difference r1 r2
+ intersection (Rel r1) (Rel r2) = prune $ Map.intersectionWith Set.intersection \
r1 r2 +
+instance (Ord a,Ord b) => Collection (Rel a b) where
+ fromList xs = Rel $ Map.fromListWith Set.union [ (x,Set.singleton y) | (x,y) <- \
xs ] + toList (Rel r) = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys]
+
+prune r = Rel $ Map.mapMaybe f r where
+ f s = if Set.null s then Nothing else Just s
+
+
+type instance Elem (Rel a b) = (a,b)
+type instance Key (Rel a b) = (a,b)
domain :: (Ord a,Ord b) => Rel a b -> Set a
hunk ./src/Util/Relation.hs 38
-domain r = Set.map fst r
+domain (Rel r) = Map.keysSet r
range :: (Ord a,Ord b) => Rel a b -> Set b
hunk ./src/Util/Relation.hs 41
-range r = Set.map snd r
+range (Rel r) = Set.unions $ Map.elems r
hunk ./src/Util/Relation.hs 43
-flipRelation :: (Ord a, Ord b) => Rel a b -> Rel b a
-flipRelation = Set.map (\ (x,y) -> (y,x))
+--flipRelation :: (Ord a, Ord b) => Rel a b -> Rel b a
+--flipRelation (Rel r) = Rel $ Set.map (\ (x,y) -> (y,x)) r
restrictDomain :: (Ord a, Ord b) => (a -> Bool) -> Rel a b -> Rel a b
hunk ./src/Util/Relation.hs 47
-restrictDomain f r = Set.filter (f . fst) r
+restrictDomain f (Rel r) = Rel $ Map.filterWithKey (\k _ -> f k) r
hunk ./src/Util/Relation.hs 49
-restrictRange :: (Ord a, Ord b) => (b -> Bool) -> Rel a b -> Rel a b
-restrictRange f r = Set.filter (f . snd) r
+restrictDomainS :: (Ord a, Ord b) => a -> Rel a b -> Rel a b
+restrictDomainS x (Rel r) = case Map.lookup x r of
+ Nothing -> Rel mempty
+ Just v -> Rel $ Map.singleton x v
hunk ./src/Util/Relation.hs 54
+restrictDomainSet :: (Ord a, Ord b) => Set a -> Rel a b -> Rel a b
+restrictDomainSet s (Rel r) = Rel $ Map.filterWithKey (\k _ -> k `Set.member` s) r
+
+restrictRange :: (Ord a, Ord b) => (b -> Bool) -> Rel a b -> Rel a b
+restrictRange f (Rel r) = Rel $ Map.mapMaybe g r where
+ g s = if Set.null ss then Nothing else Just ss where
+ ss = Set.filter f s
mapDomain :: (Ord a, Ord b, Ord c) => (a -> c) -> Rel a b -> Rel c b
hunk ./src/Util/Relation.hs 63
-mapDomain f r = Set.map (\ (x,y) -> (f x,y)) r
+mapDomain f (Rel r) = Rel $ Map.mapKeys f r
mapRange :: (Ord a, Ord b, Ord c) => (b -> c) -> Rel a b -> Rel a c
hunk ./src/Util/Relation.hs 66
-mapRange f r = Set.map (\ (x,y) -> (x,f y)) r
+mapRange f (Rel r) = Rel $ Map.map (Set.map f) r
+
+partitionDomain f (Rel r) = case Map.partitionWithKey (\k _ -> f k) r of
+ (x,y) -> (Rel x,Rel y)
hunk ./src/Util/Relation.hs 71
-partitionDomain f r = Set.partition (f . fst) r
+--partitionRange f (Rel r) = Rel $ Set.partition (f . snd) r
hunk ./src/Util/Relation.hs 73
-partitionRange f r = Set.partition (f . snd) r
+--applyRelation :: (Ord a, Ord b) => Rel a b -> a -> [b]
+--applyRelation r a = Prelude.map snd (Set.toList . unRel $ restrictDomain (== a) r)
hunk ./src/Util/Relation.hs 76
-applyRelation :: (Ord a, Ord b) => Rel a b -> a -> [b]
-applyRelation r a = Prelude.map snd (toList $ restrictDomain (== a) r)
+unRel (Rel r) = r
toRelationList :: (Ord a, Ord b) => Rel a b -> [(a,[b])]
hunk ./src/Util/Relation.hs 79
-toRelationList rel = [ (x, applyRelation rel x) | x <- toList (domain rel)]
+toRelationList (Rel r) = Map.toList (Map.map Set.toList r)
+--toRelationList :: (Ord a, Ord b) => Rel a b -> [(a,[b])]
+--toRelationList rel = [ (x, applyRelation rel x) | x <- Set.toList (domain rel)]
[split type environment into concrete and mutable sets, to avoid retraversing the \
concrete imported types John Meacham <john@repetae.net>**20100806090349
Ignore-this: c276618b4b968d9149e6b3dfc36d162a
] hunk ./src/FrontEnd/Tc/Monad.hs 101
tcVarnum :: {-# UNPACK #-} !(IORef Int),
tcCollectedEnv :: {-# UNPACK #-} !(IORef (Map.Map Name Sigma)),
tcCollectedCoerce :: {-# UNPACK #-} !(IORef (Map.Map Name CoerceTerm)),
- tcCurrentEnv :: Map.Map Name Sigma,
+ tcConcreteEnv :: Map.Map Name Sigma,
+ tcMutableEnv :: Map.Map Name Sigma,
tcCurrentScope :: Set.Set MetaVar,
tcRecursiveCalls :: Set.Set Name,
tcInstanceEnv :: InstanceEnv,
hunk ./src/FrontEnd/Tc/Monad.hs 111
{-! derive: update !-}
data Output = Output {
- collectedPreds :: Preds,
- existentialPreds :: Preds,
- constraints :: Seq.Seq Constraint,
- checkedRules :: Seq.Seq Rule,
+ collectedPreds :: !Preds,
+ existentialPreds :: !Preds,
+ constraints :: !(Seq.Seq Constraint),
+ checkedRules :: !(Seq.Seq Rule),
existentialVars :: [Tyvar],
hunk ./src/FrontEnd/Tc/Monad.hs 116
- tcWarnings :: Seq.Seq Warning,
+ tcWarnings :: !(Seq.Seq Warning),
outKnots :: [(Name,Name)]
}
{-! derive: update, Monoid !-}
hunk ./src/FrontEnd/Tc/Monad.hs 141
te' <- mapM (\ (x,y) -> do y <- flattenType y; return (x,y)) (Map.toList te)
if any isBoxy (snds te') then
fail $ "localEnv error!\n" ++ show te
- else local (tcCurrentEnv_u (Map.fromList te' `Map.union`)) act
+ else local (tcMutableEnv_u (Map.fromList te' `Map.union`)) act
-- | add to the collected environment which will be used to annotate uses of \
variables with their instantiated types.
-- should contain @-aliases for each use of a polymorphic variable or pattern match.
hunk ./src/FrontEnd/Tc/Monad.hs 181
(a,out) <- runWriterT $ runReaderT tim TcEnv {
tcCollectedEnv = ce,
tcCollectedCoerce = cc,
- tcCurrentEnv = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo,
+ tcConcreteEnv = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo,
+ tcMutableEnv = mempty,
tcVarnum = vn,
tcDiagnostics = [Msg Nothing $ "Compilation of module: " ++ tcInfoModName \
tcInfo], tcInfo = tcInfo,
hunk ./src/FrontEnd/Tc/Monad.hs 226
getModName = asks ( tcInfoModName . tcInfo)
+askCurrentEnv = do
+ env1 <- asks tcConcreteEnv
+ env2 <- asks tcMutableEnv
+ return (env2 `Map.union` env1)
dConScheme :: Name -> Tc Sigma
dConScheme conName = do
hunk ./src/FrontEnd/Tc/Monad.hs 233
- env <- asks tcCurrentEnv
+ env <- askCurrentEnv
case Map.lookup conName env of
Just s -> return s
Nothing -> error $ "dConScheme: constructor not found: " ++ show conName ++
hunk ./src/FrontEnd/Tc/Monad.hs 260
lookupName :: Name -> Tc Sigma
lookupName n = do
- env <- asks tcCurrentEnv
+ env <- askCurrentEnv
case Map.lookup n env of
Just x -> freshSigma x
Nothing | Just 0 <- fromUnboxedNameTuple n -> do
hunk ./src/FrontEnd/Tc/Monad.hs 398
freeMetaVarsEnv :: Tc (Set.Set MetaVar)
freeMetaVarsEnv = do
- env <- asks tcCurrentEnv
+ env <- asks tcMutableEnv
xs <- flip mapM (Map.elems env) $ \ x -> do
x <- flattenType x
return $ freeMetaVars x
hunk ./src/FrontEnd/Tc/Type.hs 145
-data UnVarOpt = UnVarOpt {
- openBoxes :: {-# UNPACK #-} !Bool,
- failEmptyMetaVar :: {-# UNPACK #-} !Bool
+newtype UnVarOpt = UnVarOpt {
+ failEmptyMetaVar :: Bool
}
{-# SPECIALIZE flattenType :: MonadIO m => Type -> m Type #-}
hunk ./src/FrontEnd/Tc/Type.hs 151
flattenType :: (MonadIO m, UnVar t) => t -> m t
-flattenType t = unVar UnVarOpt { openBoxes = True, failEmptyMetaVar = False } t
+flattenType t = unVar UnVarOpt { failEmptyMetaVar = False } t
hunk ./src/FrontEnd/Tc/Type.hs 230
freeMetaVars :: Type -> S.Set MetaVar
freeMetaVars (TMetaVar mv) = S.singleton mv
freeMetaVars t = tickleCollect freeMetaVars t
--}
freeMetaVars :: Type -> S.Set MetaVar
freeMetaVars t = worker t S.empty
where worker :: Type -> (S.Set MetaVar -> S.Set MetaVar)
hunk ./src/FrontEnd/Tc/Type.hs 243
worker2 :: Pred -> (S.Set MetaVar -> S.Set MetaVar)
worker2 (IsIn c t) = worker t
worker2 (IsEq t1 t2) = worker t1 . worker t2
+-}
+
+freeMetaVars :: Type -> S.Set MetaVar
+freeMetaVars t = f t where
+ f (TMetaVar mv) = S.singleton mv
+ f (TAp l r) = f l `S.union` f r
+ f (TArrow l r) = f l `S.union` f r
+ f (TAssoc c cas eas) = S.unions (map f cas ++ map f eas)
+ f (TForAll ta (ps :=> t)) = S.unions (f t:map f2 ps)
+ f (TExists ta (ps :=> t)) = S.unions (f t:map f2 ps)
+ f _ = S.empty
+ f2 (IsIn c t) = f t
+ f2 (IsEq t1 t2) = f t1 `S.union` f t2
instance FreeVars Type [Tyvar] where
[further seperate out concrete types to speed up checking
John Meacham <john@repetae.net>**20100806092815
Ignore-this: f992ced583042d3c7797d4de93e3e3a8
] hunk ./src/FrontEnd/Tc/Monad.hs 54
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Writer.Strict
+import qualified Control.Applicative as T
import qualified Data.Traversable as T
import qualified Data.Foldable as T
import qualified Data.Sequence as Seq
hunk ./src/FrontEnd/Tc/Monad.hs 139
-- | run a computation with a local environment
localEnv :: TypeEnv -> Tc a -> Tc a
localEnv te act = do
- te' <- mapM (\ (x,y) -> do y <- flattenType y; return (x,y)) (Map.toList te)
- if any isBoxy (snds te') then
- fail $ "localEnv error!\n" ++ show te
- else local (tcMutableEnv_u (Map.fromList te' `Map.union`)) act
+ te' <- T.mapM flattenType te
+ let (cenv,menv) = Map.partition (Set.null . freeMetaVars) te'
+ --if any isBoxy (Map.elems te') then
+ -- fail $ "localEnv error!\n" ++ show te
+ local (tcConcreteEnv_u (cenv `Map.union`) . tcMutableEnv_u ((menv `Map.union`) . \
Map.filterWithKey (\k _ -> k `Map.notMember` cenv))) act
-- | add to the collected environment which will be used to annotate uses of \
variables with their instantiated types.
-- should contain @-aliases for each use of a polymorphic variable or pattern match.
hunk ./src/FrontEnd/Tc/Type.hs 151
{-# SPECIALIZE flattenType :: MonadIO m => Type -> m Type #-}
flattenType :: (MonadIO m, UnVar t) => t -> m t
-flattenType t = unVar UnVarOpt { failEmptyMetaVar = False } t
+flattenType t = liftIO $ unVar' t
hunk ./src/FrontEnd/Tc/Type.hs 156
class UnVar t where
- unVar' :: UnVarOpt -> t -> IO t
-
-unVar :: (UnVar t, MonadIO m) => UnVarOpt -> t -> m t
-unVar opt t = liftIO (unVar' opt t)
+ unVar' :: t -> IO t
instance UnVar t => UnVar [t] where
hunk ./src/FrontEnd/Tc/Type.hs 159
- unVar' opt xs = mapM (unVar' opt) xs
+ unVar' xs = mapM unVar' xs
instance UnVar Pred where
hunk ./src/FrontEnd/Tc/Type.hs 162
- unVar' opt (IsIn c t) = IsIn c `liftM` unVar' opt t
- unVar' opt (IsEq t1 t2) = liftM2 IsEq (unVar' opt t1) (unVar' opt t2)
+ unVar' (IsIn c t) = IsIn c `liftM` unVar' t
+ unVar' (IsEq t1 t2) = liftM2 IsEq (unVar' t1) (unVar' t2)
instance (UnVar a,UnVar b) => UnVar (a,b) where
hunk ./src/FrontEnd/Tc/Type.hs 166
- unVar' opt (a,b) = do
- a <- unVar' opt a
- b <- unVar' opt b
+ unVar' (a,b) = do
+ a <- unVar' a
+ b <- unVar' b
return (a,b)
instance UnVar t => UnVar (Qual t) where
hunk ./src/FrontEnd/Tc/Type.hs 172
- unVar' opt (ps :=> t) = liftM2 (:=>) (unVar' opt ps) (unVar' opt t)
+ unVar' (ps :=> t) = liftM2 (:=>) (unVar' ps) (unVar' t)
instance UnVar Type where
hunk ./src/FrontEnd/Tc/Type.hs 175
- unVar' opt tv = do
+ unVar' tv = do
let ft (TForAll vs qt) = do
hunk ./src/FrontEnd/Tc/Type.hs 177
- qt' <- unVar' opt qt
+ qt' <- unVar' qt
return $ TForAll vs qt'
ft (TExists vs qt) = do
hunk ./src/FrontEnd/Tc/Type.hs 180
- qt' <- unVar' opt qt
+ qt' <- unVar' qt
return $ TExists vs qt'
ft (TAp (TAp (TCon arr) a1) a2) | tyconName arr == tc_Arrow = ft (TArrow \
a1 a2) hunk ./src/FrontEnd/Tc/Type.hs 183
- ft t@(TMetaVar _) = if failEmptyMetaVar opt then fail $ "empty meta var" \
++ prettyPrintType t else return t
- ft t = tickleM (unVar' opt . (id :: Type -> Type)) t
+ ft t@(TMetaVar _) = return t
+ ft t = tickleM (unVar' . (id :: Type -> Type)) t
tv' <- findType tv
ft tv'
hunk ./src/FrontEnd/Tc/Type.hs 353
instance UnVar Type => UnVar CoerceTerm where
- unVar' opt (CTAp ts) = CTAp `liftM` unVar' opt ts
- unVar' opt (CTFun ct) = CTFun `liftM` unVar' opt ct
- unVar' opt (CTCompose c1 c2) = liftM2 CTCompose (unVar' opt c1) (unVar' opt c2)
- unVar' _ x = return x
+ unVar' (CTAp ts) = CTAp `liftM` unVar' ts
+ unVar' (CTFun ct) = CTFun `liftM` unVar' ct
+ unVar' (CTCompose c1 c2) = liftM2 CTCompose (unVar' c1) (unVar' c2)
+ unVar' x = return x
[speed up name choosing a little
John Meacham <john@repetae.net>**20100806111703
Ignore-this: ac159eeb0d34a7d26ad74253d00386ae
] hunk ./src/E/SSimplify.hs 1029
-----------------------
data SmState = SmState {
+ idsSeed :: {-# UNPACK #-} !Int,
idsUsed :: !IdSet,
idsBound :: !IdSet
}
hunk ./src/E/SSimplify.hs 1034
-smState = SmState { idsUsed = mempty, idsBound = mempty }
+smState = SmState { idsSeed = 1, idsUsed = mempty, idsBound = mempty }
newtype SM a = SM (RWS Env Stats.Stat SmState a)
deriving(Monad,Functor,MonadReader Env, MonadState SmState)
hunk ./src/E/SSimplify.hs 1077
putIds (insert nn used, insert nn bound)
return nn
newName = do
- (used,bound) <- getIds
- newNameFrom $ candidateIds (size used + 10000*size bound)
+ seed <- gets idsSeed
+ modify (\e -> e { idsSeed = seed + 1 })
+-- (used,bound) <- getIds
+ newNameFrom $ candidateIds seed -- (size used + 10000*size bound)
smUsedNames = SM $ gets idsUsed
smBoundNames = SM $ gets idsBound
hunk ./src/Name/Id.hs 41
import Data.Bits
import Data.Foldable
import Data.Int
+import Data.Word
import Data.Monoid
import Data.Traversable
import Data.Typeable
hunk ./src/Name/Id.hs 219
return nn
newName = IdNameT $ do
(used,bound) <- get
- fromIdNameT $ newNameFrom (candidateIds (size used `xor` size bound))
+ fromIdNameT $ newNameFrom (candidateIds (size used `xor` 128 * size bound))
addNamesIdSet nset = IdNameT $ do
modify (\ (used,bound) -> (nset `union` used, bound) )
hunk ./src/Name/Id.hs 289
-- generate a list of candidate anonymous ids based on a seed value
candidateIds :: Int -> [Id]
-candidateIds seed = map mask $ randoms (mkStdGen seed) where
- mask x = Id $ x .&. 0x0FFFFFFE
+candidateIds !seed = f (2 + (mask $ hashInt seed)) where
+ mask x = x .&. 0x0FFFFFFE
+ f !x = Id x:f (x + 2)
--mask x = trace ("candidate " ++ show seed) $ Id $ x .&. 0x0FFFFFFE
hunk ./src/Name/Id.hs 294
+hashInt :: Int -> Int
+hashInt x = fromIntegral $ f (fromIntegral x) where
+ f :: Word -> Word
+ f a = a''''' where
+ !a' = (a `xor` 61) `xor` (a `shiftR` 16)
+ !a'' = a' + (a' `shiftL` 3)
+ !a''' = a'' `xor` (a'' `shiftR` 4)
+ !a'''' = a''' * 0x27d4eb2d
+ !a''''' = a'''' `xor` (a'''' `shiftR` 15)
toId :: Name -> Id
toId x = Id $ fromAtom (toAtom x)
[clean ups
John Meacham <john@repetae.net>**20100806112820
Ignore-this: 64c0ae0922073b65fc0dac4bd35ba968
] hunk ./src/E/Main.hs 9
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Writer
-import Data.Monoid
import System.Mem
import qualified Data.Map as Map
import qualified Data.Set as Set
hunk ./src/E/SSimplify.hs 15
import Util.RWS
import Control.Monad.Identity
-import Control.Monad.Writer
import Control.Monad.Reader
import Data.Typeable
import Data.Monoid
Context:
[fix a few minor bugs in libraries found by better error reporting
John Meacham <john@repetae.net>**20100806045809
Ignore-this: e7d43927c9e11b05de455a5d0ebd1017
]
[check export lists for unknown names
John Meacham <john@repetae.net>**20100806045759
Ignore-this: 4b3ff8381117f2acae34dd6b936c8e8d
]
[ret rid of seperate subtable and errortable in favor of unified namemap
John Meacham <john@repetae.net>**20100806032455
Ignore-this: 9e8fbd31f988d77614bd49fc23cefae
]
[treat () the same as tuples when renaming
John Meacham <john@repetae.net>**20100806023948
Ignore-this: defa66a11f1081a4582a5301cff217e4
]
[move selector creation from desugar to renamer, detect multiply defined top level \
values and report an error properly. John Meacham <john@repetae.net>**20100806021241
Ignore-this: 507bce69ec8ffe0085c3a72ffc0ec571
]
[add initial version of jhc-prim
John Meacham <john@repetae.net>**20100806000900
Ignore-this: 44a9f14db168b28d731fd750bba0fee9
]
[clean up preprocessing a little
John Meacham <john@repetae.net>**20100803073754
Ignore-this: c1064468bed864231c2d5fb3a68bbeaf
]
[utilize preprocessor rather than ./configure to handle System.Info
John Meacham <john@repetae.net>**20100802100036
Ignore-this: 76681affa5b0269621974deeccda019b
]
[fix some warnings
John Meacham <john@repetae.net>**20100801083507
Ignore-this: fd350fd02d0ad5a611ee1811de28bce5
]
[fix build problem for tarball
John Meacham <john@repetae.net>**20100801082137
Ignore-this: 33671b52398eef61afa670eb031ef575
]
[update strictness and UNPACK annotations
John Meacham <john@repetae.net>**20100801080035
Ignore-this: e598a6098143c1a62373a443865b3cfb
]
[add announcement for 0.7.6
John Meacham <john@repetae.net>**20100731111353
Ignore-this: 111c27548d94bdfe0042d61b02fe5728
]
[TAG 0.7.6
John Meacham <john@repetae.net>**20100731104908
Ignore-this: d5edc6edd6d300cbae451f0e056ee018
]
Patch bundle hash:
e064684f36ea42fb486811f22ab5558ad4eb69fc
_______________________________________________
jhc mailing list
jhc@haskell.org
http://www.haskell.org/mailman/listinfo/jhc
.
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic