@@ -18,9 +18,11 @@ import qualified Text.PrettyPrint as P
18-- This sorts variables into the young and old pools accordingly.
18-- This sorts variables into the young and old pools accordingly.
19generalize :: TS.Pool -> StateT TS.SolverState IO ()
19generalize :: TS.Pool -> StateT TS.SolverState IO ()
20generalize youngPool = do
20generalize youngPool = do
21+ youngMark <- TS.uniqueMark
21 let youngRank = TS.maxRank youngPool
22 let youngRank = TS.maxRank youngPool
22 insert dict var = do
23 insert dict var = do
23 desc <- liftIO $ UF.descriptor var
24 desc <- liftIO $ UF.descriptor var
25+ liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
24 return $ Map.insertWith (++) (rank desc) [var] dict
26 return $ Map.insertWith (++) (rank desc) [var] dict
26 -- Sort the youngPool variables by rank.
28 -- Sort the youngPool variables by rank.
@@ -29,42 +31,37 @@ generalize youngPool = do
29 -- get the ranks right for each entry.
31 -- get the ranks right for each entry.
30 -- start at low ranks so that we only have to pass
32 -- start at low ranks so that we only have to pass
31 -- over the information once.
33 -- over the information once.
32− youngMark <- TS.uniqueMark
33 visitedMark <- TS.uniqueMark
34 visitedMark <- TS.uniqueMark
34− Traversable.traverse (mapM (adjustRank youngMark visitedMark youngRank)) rankDict
35+ mapM (\(poolRank, vars) -> mapM (adjustRank youngMark visitedMark poolRank) vars) (Map.toList rankDict)
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
37+ -- For variables that have rank lowerer than youngRank, register them in
38+ -- the old pool if they are not redundant.
40− registerIfNotRedundant var = do
39+ let registerIfNotRedundant var = do
41 isRedundant <- liftIO $ UF.redundant var
40 isRedundant <- liftIO $ UF.redundant var
42 if isRedundant then return var else TS.register var
41 if isRedundant then return var else TS.register var
44− registerIfHigherRank var = do
43+ let rankDict' = Map.delete youngRank rankDict
44+ Traversable.traverse (mapM registerIfNotRedundant) rankDict'
46+ -- For variables with rank youngRank
47+ -- If rank < youngRank: register in oldPool
48+ -- otherwise generalize
49+ let registerIfLowerRank var = do
45 isRedundant <- liftIO $ UF.redundant var
50 isRedundant <- liftIO $ UF.redundant var
46 if isRedundant then return () else do
51 if isRedundant then return () else do
47 desc <- liftIO $ UF.descriptor var
52 desc <- liftIO $ UF.descriptor var
48 if rank desc < youngRank
53 if rank desc < youngRank
49 then TS.register var >> return ()
54 then TS.register var >> return ()
50 else let flex' = if flex desc == Flexible then Rigid else flex desc
55 else let flex' = if flex desc == Flexible then Rigid else flex desc
51− in do liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
56+ in liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
54− Traversable.traverse (mapM registerIfNotRedundant) rankDict
55− Traversable.traverse (mapM registerIfHigherRank) rankDict
57− TS.debug $ print youngMark
58+ mapM registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
58− TS.debug $ print visitedMark
59−-- TS.debug $ mapM print youngVars
64-- adjust the ranks of variables such that ranks never increase as you
63-- 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
64+-- move deeper into a variable.
66−-- deepest variable in the whole type, and we can ignore things at a lower
67−-- rank than the current constraints.
68adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int
65adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int
69adjustRank youngMark visitedMark groupRank variable =
66adjustRank youngMark visitedMark groupRank variable =
70 let adjust = adjustRank youngMark visitedMark groupRank in
67 let adjust = adjustRank youngMark visitedMark groupRank in
@@ -133,19 +130,19 @@ solveScheme scheme =
134 Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
131 Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
135 let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
132 let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
136− currentPool <- TS.getPool
133+ oldPool <- TS.getPool
138 -- fill in a new pool when working on this scheme's constraints
135 -- fill in a new pool when working on this scheme's constraints
139− emptyPool <- TS.nextRankPool
136+ freshPool <- TS.nextRankPool
140− TS.switchToPool emptyPool
137+ TS.switchToPool freshPool
141 mapM TS.introduce quantifiers
138 mapM TS.introduce quantifiers
142 header' <- Traversable.traverse TS.flatten header
139 header' <- Traversable.traverse TS.flatten header
143 solve constraint
140 solve constraint
145 allDistinct rigidQuantifiers
142 allDistinct rigidQuantifiers
146− localPool <- TS.getPool
143+ youngPool <- TS.getPool
147− TS.switchToPool currentPool
144+ TS.switchToPool oldPool
148− generalize localPool
145+ generalize youngPool
149 mapM isGeneric rigidQuantifiers
146 mapM isGeneric rigidQuantifiers
150 return header'
147 return header'