@@ -7,6 +7,8 @@ import Control.Monad.Except (ExceptT, liftIO, throwError)
77import qualified Data.Foldable as F
88import qualified Data.Map as Map
99import qualified Data.Text as Text
10+import qualified Data.Vector as Vector
11+import qualified Data.Vector.Mutable as MVector
1012
1113import qualified AST.Module.Name as ModuleName
1214import qualified Reporting.Annotation as A
@@ -23,54 +25,55 @@ import qualified Type.UnionFind as UF
2325This sorts variables into the young and old pools accordingly.
2426-}
2527generalize :: TS.Pool -> TS.Solver ()
26−generalize (TS.Pool youngRank youngInhabitants) =
28+generalize pool@(TS.Pool youngRank _) =
2729 {-# SCC elm_compiler_type_generalize #-}
2830 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
3431
35− -- Sort the youngPool variables by rank.
36− rankDict <- liftIO $ foldM insert Map.empty youngInhabitants
32+ rankTable <- liftIO $ poolToRankTable youngMark pool
3733
3834 -- get the ranks right for each entry.
3935 -- start at low ranks so that we only have to pass
4036 -- over the information once.
4137 visitedMark <- TS.uniqueMark
42− liftIO $ forM_ (Map.toList rankDict) $ \(poolRank, vars) ->
43− forM_ vars (adjustRank youngMark visitedMark poolRank)
38+ let adjust poolRank vars =
39+ F.traverse_ (adjustRank youngMark visitedMark poolRank) vars
40+ liftIO $ Vector.imapM_ adjust rankTable
4441
4542 -- For variables that have rank lowerer than youngRank, register them in
4643 -- the old pool if they are not redundant.
47− let registerIfNotRedundant var =
48− do isRedundant <- liftIO $ UF.redundant var
49− if isRedundant then return var else TS.register var
50−
51− let rankDict' = Map.delete youngRank rankDict
52− F.traverse_ (F.traverse_ registerIfNotRedundant) rankDict'
44+ Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
45+ forM_ vars $ \var ->
46+ do isRedundant <- liftIO $ UF.redundant var
47+ if isRedundant then return var else TS.register var
5348
5449 -- For variables with rank youngRank
5550 -- If rank < youngRank: register in oldPool
5651 -- otherwise generalize
57− let registerIfLowerRank var =
58− {-# SCC elm_compiler_type_register #-}
59− do isRedundant <- liftIO $ UF.redundant var
60− case isRedundant of
61− True -> return ()
62− False -> do
63− desc <- liftIO $ UF.descriptor var
64− case _rank desc < youngRank of
65− True ->
66− TS.register var >> return ()
67− False ->
68− liftIO $ UF.setDescriptor var $ desc
69− { _rank = noRank
70− , _content = rigidify (_content desc)
71− }
72−
73− mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
52+ forM_ (Vector.unsafeLast rankTable) $ \var ->
53+ {-# SCC elm_compiler_type_register #-}
54+ do isRedundant <- liftIO $ UF.redundant var
55+ if isRedundant
56+ then return ()
57+ else do
58+ (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
59+ if rank < youngRank
60+ then
61+ TS.register var >> return ()
62+ else
63+ liftIO $ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
64+
65+
66+poolToRankTable :: Int -> TS.Pool -> IO (Vector.Vector [Variable])
67+poolToRankTable youngMark (TS.Pool youngRank youngInhabitants) =
68+ do mutableTable <- MVector.replicate (youngRank + 1) []
69+
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
75+
76+ Vector.unsafeFreeze mutableTable
7477
7578
7679rigidify :: Content -> Content