@@ -18,9 +18,11 @@ import qualified Text.PrettyPrint as P
1818-- This sorts variables into the young and old pools accordingly.
1919generalize :: TS.Pool -> StateT TS.SolverState IO ()
2020generalize youngPool = do
21+ youngMark <- TS.uniqueMark
2122 let youngRank = TS.maxRank youngPool
2223 insert dict var = do
2324 desc <- liftIO $ UF.descriptor var
25+ liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
2426 return $ Map.insertWith (++) (rank desc) [var] dict
2527
2628 -- Sort the youngPool variables by rank.
@@ -29,42 +31,37 @@ generalize youngPool = do
2931 -- get the ranks right for each entry.
3032 -- start at low ranks so that we only have to pass
3133 -- over the information once.
32− youngMark <- TS.uniqueMark
3334 visitedMark <- TS.uniqueMark
34− Traversable.traverse (mapM (adjustRank youngMark visitedMark youngRank)) rankDict
35−
36− -- Move variables out of the young pool if they do not have a young rank.
37− -- We should not generalize things we cannot use.
38− let youngVars = (Map.!) rankDict youngRank
35+ mapM (\(poolRank, vars) -> mapM (adjustRank youngMark visitedMark poolRank) vars) (Map.toList rankDict)
3936
40− registerIfNotRedundant var = do
37+ -- For variables that have rank lowerer than youngRank, register them in
38+ -- the old pool if they are not redundant.
39+ let registerIfNotRedundant var = do
4140 isRedundant <- liftIO $ UF.redundant var
4241 if isRedundant then return var else TS.register var
4342
44− registerIfHigherRank var = do
43+ let rankDict' = Map.delete youngRank rankDict
44+ Traversable.traverse (mapM registerIfNotRedundant) rankDict'
45+
46+ -- For variables with rank youngRank
47+ -- If rank < youngRank: register in oldPool
48+ -- otherwise generalize
49+ let registerIfLowerRank var = do
4550 isRedundant <- liftIO $ UF.redundant var
4651 if isRedundant then return () else do
4752 desc <- liftIO $ UF.descriptor var
4853 if rank desc < youngRank
4954 then TS.register var >> return ()
5055 else let flex' = if flex desc == Flexible then Rigid else flex desc
51− in do liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
52− TS.debug $ print var
53−
54− Traversable.traverse (mapM registerIfNotRedundant) rankDict
55− Traversable.traverse (mapM registerIfHigherRank) rankDict
56+ in liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
5657
57− TS.debug $ print youngMark
58− TS.debug $ print visitedMark
59−-- TS.debug $ mapM print youngVars
58+ mapM registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
6059
6160 return ()
6261
6362
6463-- adjust the ranks of variables such that ranks never increase as you
65−-- move deeper into a variable. This mean the rank actually represents the
66−-- deepest variable in the whole type, and we can ignore things at a lower
67−-- rank than the current constraints.
64+-- move deeper into a variable.
6865adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int
6966adjustRank youngMark visitedMark groupRank variable =
7067 let adjust = adjustRank youngMark visitedMark groupRank in
@@ -133,19 +130,19 @@ solveScheme scheme =
133130
134131 Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
135132 let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
136− currentPool <- TS.getPool
133+ oldPool <- TS.getPool
137134
138135 -- fill in a new pool when working on this scheme's constraints
139− emptyPool <- TS.nextRankPool
140− TS.switchToPool emptyPool
136+ freshPool <- TS.nextRankPool
137+ TS.switchToPool freshPool
141138 mapM TS.introduce quantifiers
142139 header' <- Traversable.traverse TS.flatten header
143140 solve constraint
144141
145142 allDistinct rigidQuantifiers
146− localPool <- TS.getPool
147− TS.switchToPool currentPool
148− generalize localPool
143+ youngPool <- TS.getPool
144+ TS.switchToPool oldPool
145+ generalize youngPool
149146 mapM isGeneric rigidQuantifiers
150147 return header'
151148