git.iko.soy/elk
on master help sign in
Keep a pool stack, not just old and young
428b0a1Evan Czaplicki
src/Type/Inference.hs+1−1
compare with master
unifiedsplit
@@ -37,7 +37,7 @@ infer interfaces modul =
37 state <- Solve.solve constraint
37 state <- Solve.solve constraint
38
38
39 let header' = Map.delete "::" header
39 let header' = Map.delete "::" header
40− let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')
40+ let types = Map.map A.drop (Map.difference (TS._savedEnv state) header')
41
41
42 liftIO (traverse T.toSrcType types)
42 liftIO (traverse T.toSrcType types)
43
43
src/Type/Solve.hs+79−51
@@ -4,7 +4,6 @@ module Type.Solve (solve) where
4
4
5import Control.Monad
5import Control.Monad
6import Control.Monad.Except (ExceptT, liftIO, throwError)
6import Control.Monad.Except (ExceptT, liftIO, throwError)
7−import qualified Data.Foldable as F
8import qualified Data.Map as Map
7import qualified Data.Map as Map
9import qualified Data.Text as Text
8import qualified Data.Text as Text
10import qualified Data.Vector as Vector
9import qualified Data.Vector as Vector
@@ -29,9 +28,10 @@ solve :: Constraint -> ExceptT [A.Located Error.Error] IO TS.State
29solve constraint =
28solve constraint =
30 {-# SCC elm_compiler_type_solve #-}
29 {-# SCC elm_compiler_type_solve #-}
31 do state <- liftIO (TS.run (actuallySolve constraint))
30 do state <- liftIO (TS.run (actuallySolve constraint))
32− case TS.sError state of
31+ case TS._errors state of
33 [] ->
32 [] ->
34 return state
33 return state
34+
35 errors ->
35 errors ->
36 throwError errors
36 throwError errors
37
37
@@ -85,6 +85,10 @@ actuallySolve constraint =
85 unify (Error.Instance name) region freshCopy t
85 unify (Error.Instance name) region freshCopy t
86
86
87
87
88+
89+-- SOLVE SCHEMES
90+
91+
88solveScheme :: Scheme -> TS.Solver TS.Env
92solveScheme :: Scheme -> TS.Solver TS.Env
89solveScheme scheme =
93solveScheme scheme =
90 let
94 let
@@ -96,32 +100,56 @@ solveScheme scheme =
96 do actuallySolve constraint
100 do actuallySolve constraint
97 traverse flatten header
101 traverse flatten header
98
102
99− Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
103+ Scheme rigidQuantifiers flexQuantifiers constraint header ->
100− do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
104+ -- work in the next pool for this scheme's constraints
101− oldPool <- TS.getPool
105+ solveSchemeHelp rigidQuantifiers flexQuantifiers $
106+ do flatHeader <- traverse flatten header
107+ actuallySolve constraint
108+ return flatHeader
109+
102
110
103− -- fill in a new pool when working on this scheme's constraints
104− freshPool <- TS.nextRankPool
105− TS.switchToPool freshPool
106− TS.introduce quantifiers
107− header' <- traverse flatten header
108− actuallySolve constraint
109
111
110− youngPool <- TS.getPool
112+solveSchemeHelp :: [Variable] -> [Variable] -> TS.Solver a -> TS.Solver a
111− TS.switchToPool oldPool
113+solveSchemeHelp rigidQuantifiers flexQuantifiers (TS.Solver stepState) =
112− generalize youngPool
114+ TS.Solver $ \state@(TS.SS _ _ rank oldPools _ _) ->
113− mapM_ isGeneric rigidQuantifiers
115+ do
114− return header'
116+ -- push pool
117+ let nextRank = rank + 1
118+ let poolsLength = MVector.length oldPools
115
119
120+ pools <-
121+ if nextRank < poolsLength
122+ then return oldPools
123+ else MVector.grow oldPools poolsLength
116
124
125+ -- introduce quantifiers
126+ let allQuantifiers = rigidQuantifiers ++ flexQuantifiers
127+ forM_ allQuantifiers $ \var ->
128+ UF.modifyDescriptor var $ \(Descriptor content _ mark copy) ->
129+ Descriptor content nextRank mark copy
130+ MVector.write pools nextRank allQuantifiers
117
131
118−-- ADDITIONAL CHECKS
132+ -- run solver in next pool
133+ (value, TS.SS env savedEnv _ _ mark errors) <- stepState (state { TS._rank = nextRank })
134+
135+ -- pop pool
136+ let youngMark = mark
137+ let visitMark = nextMark mark
138+ let finalMark = nextMark visitMark
139+ generalize youngMark visitMark nextRank pools
140+ MVector.write pools nextRank []
141+
142+ -- check that things went well
143+ mapM_ isGeneric rigidQuantifiers
144+
145+ -- return result with pool popped
146+ return ( value, TS.SS env savedEnv rank pools finalMark errors )
119
147
120
148
121-- Check that a variable has rank == noRank, meaning that it can be generalized.
149-- Check that a variable has rank == noRank, meaning that it can be generalized.
122−isGeneric :: Variable -> TS.Solver ()
150+isGeneric :: Variable -> IO ()
123isGeneric var =
151isGeneric var =
124− do (Descriptor _ rank _ _) <- liftIO $ UF.descriptor var
152+ do (Descriptor _ rank _ _) <- UF.descriptor var
125 if rank == noRank
153 if rank == noRank
126 then return ()
154 then return ()
127 else crash "Unable to generalize a type variable. It is not unranked."
155 else crash "Unable to generalize a type variable. It is not unranked."
@@ -162,50 +190,50 @@ occurs (name, A.A region variable) =
162{-| Every variable has rank less than or equal to the maxRank of the pool.
190{-| Every variable has rank less than or equal to the maxRank of the pool.
163This sorts variables into the young and old pools accordingly.
191This sorts variables into the young and old pools accordingly.
164-}
192-}
165−generalize :: TS.Pool -> TS.Solver ()
193+generalize :: Mark -> Mark -> Int -> TS.Pools -> IO ()
166−generalize pool@(TS.Pool youngRank _) =
194+generalize youngMark visitMark youngRank pools =
167 {-# SCC elm_compiler_type_generalize #-}
195 {-# SCC elm_compiler_type_generalize #-}
168− do youngMark <- TS.uniqueMark
196+ do
169−
197+ youngVars <- MVector.read pools youngRank
170− rankTable <- liftIO $ poolToRankTable youngMark pool
198+ rankTable <- poolToRankTable youngMark youngRank youngVars
171
199
172 -- get the ranks right for each entry.
200 -- get the ranks right for each entry.
173 -- start at low ranks so that we only have to pass
201 -- start at low ranks so that we only have to pass
174 -- over the information once.
202 -- over the information once.
175− visitedMark <- TS.uniqueMark
203+ Vector.imapM_ (mapM_ . adjustRank youngMark visitMark) rankTable
176− let adjust poolRank vars =
177− F.traverse_ (adjustRank youngMark visitedMark poolRank) vars
178− liftIO $ Vector.imapM_ adjust rankTable
179
204
180 -- For variables that have rank lowerer than youngRank, register them in
205 -- For variables that have rank lowerer than youngRank, register them in
181− -- the old pool if they are not redundant.
206+ -- the appropriate old pool if they are not redundant.
182 Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
207 Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
183 forM_ vars $ \var ->
208 forM_ vars $ \var ->
184− do isRedundant <- liftIO $ UF.redundant var
209+ do isRedundant <- UF.redundant var
185− if isRedundant then return var else TS.register var
210+ if isRedundant
211+ then return ()
212+ else
213+ do (Descriptor _ rank _ _) <- UF.descriptor var
214+ MVector.modify pools (var:) rank
186
215
187 -- For variables with rank youngRank
216 -- For variables with rank youngRank
188 -- If rank < youngRank: register in oldPool
217 -- If rank < youngRank: register in oldPool
189 -- otherwise generalize
218 -- otherwise generalize
190 forM_ (Vector.unsafeLast rankTable) $ \var ->
219 forM_ (Vector.unsafeLast rankTable) $ \var ->
191− {-# SCC elm_compiler_type_register #-}
192− do isRedundant <- liftIO $ UF.redundant var
220+ do isRedundant <- UF.redundant var
193 if isRedundant
221 if isRedundant
194 then return ()
222 then return ()
195− else do
223+ else
196− (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
224+ do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
197− if rank < youngRank
225+ if rank < youngRank
198− then
226+ then
199− TS.register var >> return ()
227+ MVector.modify pools (var:) rank
200− else
228+ else
201− liftIO $ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
229+ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
202
230
203
231
204−poolToRankTable :: Mark -> TS.Pool -> IO (Vector.Vector [Variable])
232+poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])
205−poolToRankTable youngMark (TS.Pool youngRank youngInhabitants) =
233+poolToRankTable youngMark youngRank youngInhabitants =
206 do mutableTable <- MVector.replicate (youngRank + 1) []
234 do mutableTable <- MVector.replicate (youngRank + 1) []
207
235
208− -- Sort the youngPool variables by rank.
236+ -- Sort the youngPool variables into buckets by rank.
209 forM_ youngInhabitants $ \var ->
237 forM_ youngInhabitants $ \var ->
210 do (Descriptor content rank _ copy) <- UF.descriptor var
238 do (Descriptor content rank _ copy) <- UF.descriptor var
211 UF.setDescriptor var (Descriptor content rank youngMark copy)
239 UF.setDescriptor var (Descriptor content rank youngMark copy)
@@ -232,30 +260,30 @@ rigidify content =
232-- This way the outermost rank is representative of the entire structure.
260-- This way the outermost rank is representative of the entire structure.
233--
261--
234adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
262adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
235−adjustRank youngMark visitedMark groupRank var =
263+adjustRank youngMark visitMark groupRank var =
236 {-# SCC elm_compiler_type_adjust #-}
264 {-# SCC elm_compiler_type_adjust #-}
237 do (Descriptor content rank mark copy) <- UF.descriptor var
265 do (Descriptor content rank mark copy) <- UF.descriptor var
238 if mark == youngMark then
266 if mark == youngMark then
239 do -- Set the variable as marked first because it may be cyclic.
267 do -- Set the variable as marked first because it may be cyclic.
240− UF.setDescriptor var $ Descriptor content rank visitedMark copy
268+ UF.setDescriptor var $ Descriptor content rank visitMark copy
241− maxRank <- adjustRankContent youngMark visitedMark groupRank content
269+ maxRank <- adjustRankContent youngMark visitMark groupRank content
242− UF.setDescriptor var $ Descriptor content maxRank visitedMark copy
270+ UF.setDescriptor var $ Descriptor content maxRank visitMark copy
243 return maxRank
271 return maxRank
244
272
245− else if mark == visitedMark then
273+ else if mark == visitMark then
246 return rank
274 return rank
247
275
248 else
276 else
249 do let minRank = min groupRank rank
277 do let minRank = min groupRank rank
250 -- TODO how can minRank ever be groupRank?
278 -- TODO how can minRank ever be groupRank?
251− UF.setDescriptor var $ Descriptor content minRank visitedMark copy
279+ UF.setDescriptor var $ Descriptor content minRank visitMark copy
252 return minRank
280 return minRank
253
281
254
282
255adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
283adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
256−adjustRankContent youngMark visitedMark groupRank content =
284+adjustRankContent youngMark visitMark groupRank content =
257 let
285 let
258− go = adjustRank youngMark visitedMark groupRank
286+ go = adjustRank youngMark visitMark groupRank
259 in
287 in
260 case content of
288 case content of
261 Error _ ->
289 Error _ ->
src/Type/State.hs+86−149
@@ -1,18 +1,14 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Type.State
2module Type.State
3− ( Solver
3+ ( Solver(..)
4 , run
4 , run
5 , State(..)
5 , State(..)
6− , Pool(..)
6+ , Pools
7 , Env
7 , Env
8 , modifyEnv
8 , modifyEnv
9 , addError
9 , addError
10− , switchToPool
11− , getPool
12 , getEnv
10 , getEnv
13 , saveLocalEnv
11 , saveLocalEnv
14− , uniqueMark
15− , nextRankPool
16 , register
12 , register
17 , introduce
13 , introduce
18 , flatten
14 , flatten
@@ -21,11 +17,12 @@ module Type.State
21 where
17 where
22
18
23
19
24−import Control.Monad (liftM, liftM2)
20+import Control.Monad (forM_, liftM, liftM2)
25import Control.Monad.Trans (MonadIO, liftIO)
21import Control.Monad.Trans (MonadIO, liftIO)
26import qualified Data.Map as Map
22import qualified Data.Map as Map
27import Data.Map ((!))
23import Data.Map ((!))
28import Data.Text (Text)
24import Data.Text (Text)
25+import qualified Data.Vector.Mutable as MVector
29
26
30import qualified Reporting.Annotation as A
27import qualified Reporting.Annotation as A
31import qualified Reporting.Error.Type as Error
28import qualified Reporting.Error.Type as Error
@@ -42,53 +39,32 @@ newtype Solver a =
42 Solver { _solve :: State -> IO (a, State) }
39 Solver { _solve :: State -> IO (a, State) }
43
40
44
41
45−
42+data State =
46−-- RUN SOLVER
47−
48−
49−run :: Solver () -> IO State
50−run (Solver solver) =
51− do (_, state) <- solver initialState
52− return state
53−
54−
55−initialState :: State
56−initialState =
57 SS
43 SS
58− { sEnv = Map.empty
44+ { _env :: Env
59− , sSavedEnv = Map.empty
45+ , _savedEnv :: Env
60− , sPool = Pool outermostRank []
46+ , _rank :: Int
61− , sMark = Type.nextMark noMark -- The mark must never be equal to noMark!
47+ , _pools :: Pools
62− , sError = []
48+ , _mark :: Mark
49+ , _errors :: [A.Located Error.Error]
63 }
50 }
64
51
65
52
53+type Pools = MVector.IOVector [Variable]
66
54
67−-- SOLVER STATE
68
55
56+type Env = Map.Map Text (A.Located Variable)
69
57
70−data State =
71− SS
72− { sEnv :: Env
73− , sSavedEnv :: Env
74− , sPool :: Pool
75− , sMark :: Mark
76− , sError :: [A.Located Error.Error]
77− }
78
58
79
59
80−{-| A pool holds a bunch of variables
60+-- RUN SOLVER
81−The rank of each variable is less than or equal to the pool's "maxRank"
82−The young pool exists to make it possible to identify these vars in constant time.
83−-}
84−data Pool =
85− Pool
86− { _maxRank :: Int
87− , _inhabitants :: [Variable]
88− }
89
61
90
62
91−type Env = Map.Map Text (A.Located Variable)
63+run :: Solver () -> IO State
64+run (Solver solver) =
65+ do pools <- MVector.replicate 8 []
66+ (_, state) <- solver (SS Map.empty Map.empty outermostRank pools (Type.nextMark noMark) [])
67+ return state
92
68
93
69
94
70
@@ -99,96 +75,54 @@ type Env = Map.Map Text (A.Located Variable)
99modifyEnv :: (Env -> Env) -> Solver ()
75modifyEnv :: (Env -> Env) -> Solver ()
100modifyEnv f =
76modifyEnv f =
101 Solver $ \state ->
77 Solver $ \state ->
102− return ( (), state { sEnv = f (sEnv state) } )
78+ return ( (), state { _env = f (_env state) } )
103−
104−
105−{-# INLINE modifyPool #-}
106−modifyPool :: (Pool -> Pool) -> Solver ()
107−modifyPool f =
108− Solver $ \state ->
109− return ( (), state { sPool = f (sPool state) } )
110
79
111
80
112{-# INLINE addError #-}
81{-# INLINE addError #-}
113addError :: R.Region -> Error.Error -> Solver ()
82addError :: R.Region -> Error.Error -> Solver ()
114addError region err =
83addError region err =
115 Solver $ \state ->
84 Solver $ \state ->
116− return ( (), state { sError = A.A region err : sError state } )
85+ return ( (), state { _errors = A.A region err : _errors state } )
117−
118−
119−{-# INLINE switchToPool #-}
120−switchToPool :: Pool -> Solver ()
121−switchToPool pool =
122− modifyPool (\_ -> pool)
123−
124−
125−{-# INLINE getPool #-}
126−getPool :: Solver Pool
127−getPool =
128− Solver $ \state ->
129− return ( sPool state, state )
130−
131−
132−{-# INLINE getMaxRank #-}
133−getMaxRank :: Solver Int
134−getMaxRank =
135− Solver $ \state@(SS _ _ (Pool maxRank _) _ _) ->
136− return ( maxRank, state )
137
86
138
87
139{-# INLINE getEnv #-}
88{-# INLINE getEnv #-}
140getEnv :: Solver Env
89getEnv :: Solver Env
141getEnv =
90getEnv =
142 Solver $ \state ->
91 Solver $ \state ->
143− return ( sEnv state, state )
92+ return ( _env state, state )
144
93
145
94
146{-# INLINE saveLocalEnv #-}
95{-# INLINE saveLocalEnv #-}
147saveLocalEnv :: Solver ()
96saveLocalEnv :: Solver ()
148saveLocalEnv =
97saveLocalEnv =
149 Solver $ \state ->
98 Solver $ \state ->
150− return ( (), state { sSavedEnv = sEnv state } )
99+ return ( (), state { _savedEnv = _env state } )
151−
152−
153−{-# INLINE uniqueMark #-}
154−uniqueMark :: Solver Mark
155−uniqueMark =
156− Solver $ \(SS env savedEnv pool mark errors) ->
157− return ( mark, SS env savedEnv pool (Type.nextMark mark) errors )
158−
159−
160−{-# INLINE nextRankPool #-}
161−nextRankPool :: Solver Pool
162−nextRankPool =
163− Solver $ \state@(SS _ _ (Pool maxRank _) _ _) ->
164− return ( Pool (maxRank + 1) [], state )
165
100
166
101
167
102
168-- REGISTER VARIABLES
103-- REGISTER VARIABLES
169
104
170
105
171−{-# INLINE register #-}
172−register :: Variable -> Solver Variable
106+register :: Variable -> Solver ()
173−register variable =
107+register var =
174− {-# SCC elm_compiler_type_register #-}
175− Solver $ \state ->
108+ Solver $ \state@(SS _ _ maxRank pools _ _) ->
176− let
109+ {-# SCC elm_compiler_type_register #-}
177− (Pool maxRank inhabitants) =
110+ do MVector.modify pools (var:) maxRank
178− sPool state
111+ return ( (), state )
179− in
180− return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
181
112
182
113
183−{-# INLINE introduce #-}
184introduce :: [Variable] -> Solver ()
114introduce :: [Variable] -> Solver ()
185introduce variables =
115introduce variables =
116+ Solver $ \state@(SS _ _ maxRank pools _ _) ->
186− {-# SCC elm_compiler_type_introduce #-}
117+ {-# SCC elm_compiler_type_introduce #-}
187− Solver $ \(SS env savedEnv (Pool maxRank inhabitants) mark errors) ->
118+ do
188− do let toMaxRank (Descriptor c _ m cp) = Descriptor c maxRank m cp
119+ forM_ variables $ \var ->
189− mapM_ (\var -> UF.modifyDescriptor var toMaxRank) variables
120+ UF.modifyDescriptor var $ \(Descriptor content _ mark cp) ->
190− let newPool = Pool maxRank (variables ++ inhabitants)
121+ Descriptor content maxRank mark cp
191− return ( (), SS env savedEnv newPool mark errors )
122+
123+ MVector.modify pools (variables++) maxRank
124+
125+ return ( (), state )
192
126
193
127
194
128
@@ -196,47 +130,50 @@ introduce variables =
196
130
197
131
198flatten :: Type -> Solver Variable
132flatten :: Type -> Solver Variable
199−flatten term =
133+flatten tipe =
134+ Solver $ \state@(SS _ _ maxRank pools _ _) ->
200− {-# SCC elm_compiler_type_flatten #-}
135+ {-# SCC elm_compiler_type_flatten #-}
201− do maxRank <- getMaxRank
202− flattenHelp maxRank Map.empty term
136+ do var <- flattenHelp maxRank pools Map.empty tipe
137+ return (var, state)
203
138
204
139
205−flattenHelp :: Int -> Map.Map Text Variable -> Type -> Solver Variable
140+flattenHelp :: Int -> Pools -> Map.Map Text Variable -> Type -> IO Variable
206−flattenHelp maxRank aliasDict termN =
141+flattenHelp maxRank pools aliasDict tipe =
207− case termN of
142+ case tipe of
208 PlaceHolder name ->
143 PlaceHolder name ->
209 return (aliasDict ! name)
144 return (aliasDict ! name)
210
145
211 AliasN name args realType ->
146 AliasN name args realType ->
212− do flatArgs <- mapM (traverse (flattenHelp maxRank aliasDict)) args
147+ do flatArgs <- mapM (traverse (flattenHelp maxRank pools aliasDict)) args
213− flatVar <- flattenHelp maxRank (Map.fromList flatArgs) realType
148+ flatVar <- flattenHelp maxRank pools (Map.fromList flatArgs) realType
214− makeFlatType maxRank (Alias name flatArgs flatVar)
149+ registerFlatType maxRank pools (Alias name flatArgs flatVar)
215
150
216 VarN v ->
151 VarN v ->
217 return v
152 return v
218
153
219 AppN name args ->
154 AppN name args ->
220− do flatArgs <- traverse (flattenHelp maxRank aliasDict) args
155+ do flatArgs <- traverse (flattenHelp maxRank pools aliasDict) args
221− makeFlatType maxRank (Structure (App1 name flatArgs))
156+ registerFlatType maxRank pools (Structure (App1 name flatArgs))
222
157
223 FunN a b ->
158 FunN a b ->
224− do flatA <- flattenHelp maxRank aliasDict a
159+ do flatA <- flattenHelp maxRank pools aliasDict a
225− flatB <- flattenHelp maxRank aliasDict b
160+ flatB <- flattenHelp maxRank pools aliasDict b
226− makeFlatType maxRank (Structure (Fun1 flatA flatB))
161+ registerFlatType maxRank pools (Structure (Fun1 flatA flatB))
227
162
228 EmptyRecordN ->
163 EmptyRecordN ->
229− makeFlatType maxRank (Structure EmptyRecord1)
164+ registerFlatType maxRank pools (Structure EmptyRecord1)
230
165
231 RecordN fields ext ->
166 RecordN fields ext ->
232− do flatFields <- traverse (flattenHelp maxRank aliasDict) fields
167+ do flatFields <- traverse (flattenHelp maxRank pools aliasDict) fields
233− flatExt <- flattenHelp maxRank aliasDict ext
168+ flatExt <- flattenHelp maxRank pools aliasDict ext
234− makeFlatType maxRank (Structure (Record1 flatFields flatExt))
169+ registerFlatType maxRank pools (Structure (Record1 flatFields flatExt))
235
170
236
171
237−makeFlatType :: Int -> Content -> Solver Variable
172+registerFlatType :: Int -> Pools -> Content -> IO Variable
238−makeFlatType maxRank content =
173+registerFlatType maxRank pools content =
239− register =<< liftIO (UF.fresh (Descriptor content maxRank noMark Nothing))
174+ do var <- UF.fresh (Descriptor content maxRank noMark Nothing)
175+ MVector.modify pools (var:) maxRank
176+ return var
240
177
241
178
242
179
@@ -245,16 +182,16 @@ makeFlatType maxRank content =
245
182
246copy :: Variable -> Solver Variable
183copy :: Variable -> Solver Variable
247copy var =
184copy var =
185+ Solver $ \state@(SS _ _ maxRank pools _ _) ->
248− {-# SCC elm_compiler_type_copy #-}
186+ {-# SCC elm_compiler_type_copy #-}
249− do maxRank <- getMaxRank
250− copyVar <- copyHelp maxRank var
187+ do copyVar <- copyHelp maxRank pools var
251− _ <- restore var
188+ _ <- restore var
252− return copyVar
189+ return ( copyVar, state )
253
190
254
191
255−copyHelp :: Int -> Variable -> Solver Variable
192+copyHelp :: Int -> Pools -> Variable -> IO Variable
256−copyHelp maxRank variable =
193+copyHelp maxRank pools variable =
257− do (Descriptor content rank _mark maybeCopy) <- liftIO $ UF.descriptor variable
194+ do (Descriptor content rank _mark maybeCopy) <- UF.descriptor variable
258 case maybeCopy of
195 case maybeCopy of
259 Just copiedVariable ->
196 Just copiedVariable ->
260 return copiedVariable
197 return copiedVariable
@@ -265,15 +202,15 @@ copyHelp maxRank variable =
265
202
266 else
203 else
267 do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing
204 do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing
268− newVar <- liftIO $ UF.fresh $ mkCopyDesc content
205+ newVar <- UF.fresh $ mkCopyDesc content
269− _ <- register newVar
206+ MVector.modify pools (newVar:) maxRank
270
207
271 -- Link the original variable to the new variable. This lets us
208 -- Link the original variable to the new variable. This lets us
272 -- avoid making multiple copies of the variable we are instantiating.
209 -- avoid making multiple copies of the variable we are instantiating.
273 --
210 --
274 -- Need to do this before recursively copying the content of
211 -- Need to do this before recursively copying the content of
275 -- the variable to avoid looping on cyclic terms.
212 -- the variable to avoid looping on cyclic terms.
276− liftIO $ UF.setDescriptor variable $
213+ UF.setDescriptor variable $
277 Descriptor content rank noMark (Just newVar)
214 Descriptor content rank noMark (Just newVar)
278
215
279 -- Now we recursively copy the content of the variable.
216 -- Now we recursively copy the content of the variable.
@@ -281,19 +218,19 @@ copyHelp maxRank variable =
281 -- will not repeat this work or crawl this variable again.
218 -- will not repeat this work or crawl this variable again.
282 case content of
219 case content of
283 Structure term ->
220 Structure term ->
284− do newTerm <- traverseFlatType (copyHelp maxRank) term
221+ do newTerm <- traverseFlatType (copyHelp maxRank pools) term
285− liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
222+ UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
286
223
287 Var Rigid maybeSuper maybeName ->
224 Var Rigid maybeSuper maybeName ->
288− liftIO $ UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName
225+ UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName
289
226
290 Var Flex _ _ ->
227 Var Flex _ _ ->
291 return ()
228 return ()
292
229
293 Alias name args realType ->
230 Alias name args realType ->
294− do newArgs <- mapM (traverse (copyHelp maxRank)) args
231+ do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
295− newRealType <- copyHelp maxRank realType
232+ newRealType <- copyHelp maxRank pools realType
296− liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
233+ UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
297
234
298 Error _ ->
235 Error _ ->
299 return ()
236 return ()
@@ -305,21 +242,21 @@ copyHelp maxRank variable =
305-- RESTORE
242-- RESTORE
306
243
307
244
308−restore :: Variable -> Solver Variable
245+restore :: Variable -> IO Variable
309restore variable =
246restore variable =
310− do (Descriptor content _rank _mark maybeCopy) <- liftIO $ UF.descriptor variable
247+ do (Descriptor content _rank _mark maybeCopy) <- UF.descriptor variable
311 case maybeCopy of
248 case maybeCopy of
312 Nothing ->
249 Nothing ->
313 return variable
250 return variable
314
251
315 Just _ ->
252 Just _ ->
316 do restoredContent <- restoreContent content
253 do restoredContent <- restoreContent content
317− liftIO $ UF.setDescriptor variable $
254+ UF.setDescriptor variable $
318 Descriptor restoredContent noRank noMark Nothing
255 Descriptor restoredContent noRank noMark Nothing
319 return variable
256 return variable
320
257
321
258
322−restoreContent :: Content -> Solver Content
259+restoreContent :: Content -> IO Content
323restoreContent content =
260restoreContent content =
324 case content of
261 case content of
325 Structure term ->
262 Structure term ->
@@ -341,7 +278,7 @@ restoreContent content =
341-- TRAVERSE FLAT TYPE
278-- TRAVERSE FLAT TYPE
342
279
343
280
344−traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType
281+traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
345traverseFlatType f flatType =
282traverseFlatType f flatType =
346 case flatType of
283 case flatType of
347 App1 name args ->
284 App1 name args ->
src/Type/Unify.hs+6−1
@@ -181,7 +181,10 @@ fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content
181 do freshVariable <-
181 do freshVariable <-
182 liftIO $ UF.fresh $
182 liftIO $ UF.fresh $
183 Descriptor content (min rank1 rank2) noMark Nothing
183 Descriptor content (min rank1 rank2) noMark Nothing
184+
184− lift (TS.register freshVariable)
185+ lift $ TS.register freshVariable
186+
187+ return freshVariable
185
188
186
189
187
190
@@ -434,6 +437,8 @@ unifyComparableRecursive orientation var =
434 do (Descriptor _ rank _ _) <- UF.descriptor var
437 do (Descriptor _ rank _ _) <- UF.descriptor var
435 UF.fresh $ Descriptor (Var Flex (Just Comparable) Nothing) rank noMark Nothing
438 UF.fresh $ Descriptor (Var Flex (Just Comparable) Nothing) rank noMark Nothing
436
439
440+ lift $ TS.register compVar
441+
437 guardedUnify orientation compVar var
442 guardedUnify orientation compVar var
438
443
439
444