@@ -7,6 +7,8 @@ import Control.Monad.Except (ExceptT, liftIO, throwError)
7import qualified Data.Foldable as F
7import qualified Data.Foldable as F
8import qualified Data.Map as Map
8import qualified Data.Map as Map
9import qualified Data.Text as Text
9import qualified Data.Text as Text
10+import qualified Data.Vector as Vector
11+import qualified Data.Vector.Mutable as MVector
11import qualified AST.Module.Name as ModuleName
13import qualified AST.Module.Name as ModuleName
12import qualified Reporting.Annotation as A
14import qualified Reporting.Annotation as A
@@ -23,54 +25,55 @@ import qualified Type.UnionFind as UF
23This sorts variables into the young and old pools accordingly.
25This sorts variables into the young and old pools accordingly.
25generalize :: TS.Pool -> TS.Solver ()
27generalize :: TS.Pool -> TS.Solver ()
26−generalize (TS.Pool youngRank youngInhabitants) =
28+generalize pool@(TS.Pool youngRank _) =
27 {-# SCC elm_compiler_type_generalize #-}
29 {-# SCC elm_compiler_type_generalize #-}
28 do youngMark <- TS.uniqueMark
30 do youngMark <- TS.uniqueMark
29− let insert dict var =
30− {-# SCC elm_compiler_type_insert #-}
31− do descriptor <- UF.descriptor var
32− UF.modifyDescriptor var (\desc -> desc { _mark = youngMark })
33− return $ Map.insertWith (++) (_rank descriptor) [var] dict
35− -- Sort the youngPool variables by rank.
32+ rankTable <- liftIO $ poolToRankTable youngMark pool
36− rankDict <- liftIO $ foldM insert Map.empty youngInhabitants
38 -- get the ranks right for each entry.
34 -- get the ranks right for each entry.
39 -- start at low ranks so that we only have to pass
35 -- start at low ranks so that we only have to pass
40 -- over the information once.
36 -- over the information once.
41 visitedMark <- TS.uniqueMark
37 visitedMark <- TS.uniqueMark
42− liftIO $ forM_ (Map.toList rankDict) $ \(poolRank, vars) ->
38+ let adjust poolRank vars =
43− forM_ vars (adjustRank youngMark visitedMark poolRank)
39+ F.traverse_ (adjustRank youngMark visitedMark poolRank) vars
40+ liftIO $ Vector.imapM_ adjust rankTable
45 -- For variables that have rank lowerer than youngRank, register them in
42 -- For variables that have rank lowerer than youngRank, register them in
46 -- the old pool if they are not redundant.
43 -- the old pool if they are not redundant.
47− let registerIfNotRedundant var =
44+ Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
48− do isRedundant <- liftIO $ UF.redundant var
46+ do isRedundant <- liftIO $ UF.redundant var
49− if isRedundant then return var else TS.register var
47+ if isRedundant then return var else TS.register var
51− let rankDict' = Map.delete youngRank rankDict
52− F.traverse_ (F.traverse_ registerIfNotRedundant) rankDict'
54 -- For variables with rank youngRank
49 -- For variables with rank youngRank
55 -- If rank < youngRank: register in oldPool
50 -- If rank < youngRank: register in oldPool
56 -- otherwise generalize
51 -- otherwise generalize
57− let registerIfLowerRank var =
52+ forM_ (Vector.unsafeLast rankTable) $ \var ->
58− {-# SCC elm_compiler_type_register #-}
53+ {-# SCC elm_compiler_type_register #-}
59− do isRedundant <- liftIO $ UF.redundant var
54+ do isRedundant <- liftIO $ UF.redundant var
60− case isRedundant of
55+ if isRedundant
61− True -> return ()
56+ then return ()
62− False -> do
57+ else do
63− desc <- liftIO $ UF.descriptor var
58+ (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
64− case _rank desc < youngRank of
59+ if rank < youngRank
66− TS.register var >> return ()
61+ TS.register var >> return ()
68− liftIO $ UF.setDescriptor var $ desc
63+ liftIO $ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
70− , _content = rigidify (_content desc)
65+
71− }
66+poolToRankTable :: Int -> TS.Pool -> IO (Vector.Vector [Variable])
72−
67+poolToRankTable youngMark (TS.Pool youngRank youngInhabitants) =
73− mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
68+ do mutableTable <- MVector.replicate (youngRank + 1) []
70+ -- Sort the youngPool variables by rank.
71+ forM_ youngInhabitants $ \var ->
72+ do (Descriptor content rank _ copy) <- UF.descriptor var
73+ UF.setDescriptor var (Descriptor content rank youngMark copy)
74+ MVector.modify mutableTable (var:) rank
76+ Vector.unsafeFreeze mutableTable
76rigidify :: Content -> Content
79rigidify :: Content -> Content