git.iko.soy/elk
on master help sign in
Keep a pool stack, not just old and young

The Type.State now holds a stack of pools. This way when Type.Solve.generalize moves things to “old” pools, it can move them as far away as possible. This means if we are moving from rank 4 to rank 1, we will not need to reconsider the variable again in pools 3 and 2. This also moves more code from Solver to IO, so there are fewer liftIO’s sprinkled around. This reduces the memory usage of the solve phase a decent amount, in my testing bringing it from ~18% of total allocation down to ~14%

commit428b0a12f28b9ea8060bca97205786b73cd69e0d authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 17 Jul 2017, 17:05 (9 years ago) parent696ee0a
4 files changed+172−202
compare with master
unifiedsplit
src/Type/Inference.hs+1−1 src/Type/Solve.hs+79−51 src/Type/State.hs+86−149 src/Type/Unify.hs+6−1
src/Type/Inference.hs+1−1
@@ -37,7 +37,7 @@ infer interfaces modul =
3737 state <- Solve.solve constraint
3838
3939 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')
4141
4242 liftIO (traverse T.toSrcType types)
4343
src/Type/Solve.hs+79−51
@@ -4,7 +4,6 @@ module Type.Solve (solve) where
44
55import Control.Monad
66import Control.Monad.Except (ExceptT, liftIO, throwError)
7−import qualified Data.Foldable as F
87import qualified Data.Map as Map
98import qualified Data.Text as Text
109import qualified Data.Vector as Vector
@@ -29,9 +28,10 @@ solve :: Constraint -> ExceptT [A.Located Error.Error] IO TS.State
2928solve constraint =
3029 {-# SCC elm_compiler_type_solve #-}
3130 do state <- liftIO (TS.run (actuallySolve constraint))
32− case TS.sError state of
31+ case TS._errors state of
3332 [] ->
3433 return state
34+
3535 errors ->
3636 throwError errors
3737
@@ -85,6 +85,10 @@ actuallySolve constraint =
8585 unify (Error.Instance name) region freshCopy t
8686
8787
88+
89+-- SOLVE SCHEMES
90+
91+
8892solveScheme :: Scheme -> TS.Solver TS.Env
8993solveScheme scheme =
9094 let
@@ -96,32 +100,56 @@ solveScheme scheme =
96100 do actuallySolve constraint
97101 traverse flatten header
98102
99− Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
100− do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
101− oldPool <- TS.getPool
103+ Scheme rigidQuantifiers flexQuantifiers constraint header ->
104+ -- work in the next pool for this scheme's constraints
105+ solveSchemeHelp rigidQuantifiers flexQuantifiers $
106+ do flatHeader <- traverse flatten header
107+ actuallySolve constraint
108+ return flatHeader
109+
102110
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
109111
110− youngPool <- TS.getPool
111− TS.switchToPool oldPool
112− generalize youngPool
113− mapM_ isGeneric rigidQuantifiers
114− return header'
112+solveSchemeHelp :: [Variable] -> [Variable] -> TS.Solver a -> TS.Solver a
113+solveSchemeHelp rigidQuantifiers flexQuantifiers (TS.Solver stepState) =
114+ TS.Solver $ \state@(TS.SS _ _ rank oldPools _ _) ->
115+ do
116+ -- push pool
117+ let nextRank = rank + 1
118+ let poolsLength = MVector.length oldPools
115119
120+ pools <-
121+ if nextRank < poolsLength
122+ then return oldPools
123+ else MVector.grow oldPools poolsLength
116124
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
117131
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 )
119147
120148
121149-- Check that a variable has rank == noRank, meaning that it can be generalized.
122−isGeneric :: Variable -> TS.Solver ()
150+isGeneric :: Variable -> IO ()
123151isGeneric var =
124− do (Descriptor _ rank _ _) <- liftIO $ UF.descriptor var
152+ do (Descriptor _ rank _ _) <- UF.descriptor var
125153 if rank == noRank
126154 then return ()
127155 else crash "Unable to generalize a type variable. It is not unranked."
@@ -162,50 +190,50 @@ occurs (name, A.A region variable) =
162190{-| Every variable has rank less than or equal to the maxRank of the pool.
163191This sorts variables into the young and old pools accordingly.
164192-}
165−generalize :: TS.Pool -> TS.Solver ()
166−generalize pool@(TS.Pool youngRank _) =
193+generalize :: Mark -> Mark -> Int -> TS.Pools -> IO ()
194+generalize youngMark visitMark youngRank pools =
167195 {-# SCC elm_compiler_type_generalize #-}
168− do youngMark <- TS.uniqueMark
169−
170− rankTable <- liftIO $ poolToRankTable youngMark pool
196+ do
197+ youngVars <- MVector.read pools youngRank
198+ rankTable <- poolToRankTable youngMark youngRank youngVars
171199
172200 -- get the ranks right for each entry.
173201 -- start at low ranks so that we only have to pass
174202 -- over the information once.
175− visitedMark <- TS.uniqueMark
176− let adjust poolRank vars =
177− F.traverse_ (adjustRank youngMark visitedMark poolRank) vars
178− liftIO $ Vector.imapM_ adjust rankTable
203+ Vector.imapM_ (mapM_ . adjustRank youngMark visitMark) rankTable
179204
180205 -- 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.
182207 Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
183208 forM_ vars $ \var ->
184− do isRedundant <- liftIO $ UF.redundant var
185− if isRedundant then return var else TS.register var
209+ do isRedundant <- UF.redundant var
210+ if isRedundant
211+ then return ()
212+ else
213+ do (Descriptor _ rank _ _) <- UF.descriptor var
214+ MVector.modify pools (var:) rank
186215
187216 -- For variables with rank youngRank
188217 -- If rank < youngRank: register in oldPool
189218 -- otherwise generalize
190219 forM_ (Vector.unsafeLast rankTable) $ \var ->
191− {-# SCC elm_compiler_type_register #-}
192− do isRedundant <- liftIO $ UF.redundant var
220+ do isRedundant <- UF.redundant var
193221 if isRedundant
194222 then return ()
195− else do
196− (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
197− if rank < youngRank
198− then
199− TS.register var >> return ()
200− else
201− liftIO $ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
223+ else
224+ do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
225+ if rank < youngRank
226+ then
227+ MVector.modify pools (var:) rank
228+ else
229+ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
202230
203231
204−poolToRankTable :: Mark -> TS.Pool -> IO (Vector.Vector [Variable])
205−poolToRankTable youngMark (TS.Pool youngRank youngInhabitants) =
232+poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])
233+poolToRankTable youngMark youngRank youngInhabitants =
206234 do mutableTable <- MVector.replicate (youngRank + 1) []
207235
208− -- Sort the youngPool variables by rank.
236+ -- Sort the youngPool variables into buckets by rank.
209237 forM_ youngInhabitants $ \var ->
210238 do (Descriptor content rank _ copy) <- UF.descriptor var
211239 UF.setDescriptor var (Descriptor content rank youngMark copy)
@@ -232,30 +260,30 @@ rigidify content =
232260-- This way the outermost rank is representative of the entire structure.
233261--
234262adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
235−adjustRank youngMark visitedMark groupRank var =
263+adjustRank youngMark visitMark groupRank var =
236264 {-# SCC elm_compiler_type_adjust #-}
237265 do (Descriptor content rank mark copy) <- UF.descriptor var
238266 if mark == youngMark then
239267 do -- Set the variable as marked first because it may be cyclic.
240− UF.setDescriptor var $ Descriptor content rank visitedMark copy
241− maxRank <- adjustRankContent youngMark visitedMark groupRank content
242− UF.setDescriptor var $ Descriptor content maxRank visitedMark copy
268+ UF.setDescriptor var $ Descriptor content rank visitMark copy
269+ maxRank <- adjustRankContent youngMark visitMark groupRank content
270+ UF.setDescriptor var $ Descriptor content maxRank visitMark copy
243271 return maxRank
244272
245− else if mark == visitedMark then
273+ else if mark == visitMark then
246274 return rank
247275
248276 else
249277 do let minRank = min groupRank rank
250278 -- 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
252280 return minRank
253281
254282
255283adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
256−adjustRankContent youngMark visitedMark groupRank content =
284+adjustRankContent youngMark visitMark groupRank content =
257285 let
258− go = adjustRank youngMark visitedMark groupRank
286+ go = adjustRank youngMark visitMark groupRank
259287 in
260288 case content of
261289 Error _ ->
src/Type/State.hs+86−149
@@ -1,18 +1,14 @@
11{-# OPTIONS_GHC -Wall #-}
22module Type.State
3− ( Solver
3+ ( Solver(..)
44 , run
55 , State(..)
6− , Pool(..)
6+ , Pools
77 , Env
88 , modifyEnv
99 , addError
10− , switchToPool
11− , getPool
1210 , getEnv
1311 , saveLocalEnv
14− , uniqueMark
15− , nextRankPool
1612 , register
1713 , introduce
1814 , flatten
@@ -21,11 +17,12 @@ module Type.State
2117 where
2218
2319
24−import Control.Monad (liftM, liftM2)
20+import Control.Monad (forM_, liftM, liftM2)
2521import Control.Monad.Trans (MonadIO, liftIO)
2622import qualified Data.Map as Map
2723import Data.Map ((!))
2824import Data.Text (Text)
25+import qualified Data.Vector.Mutable as MVector
2926
3027import qualified Reporting.Annotation as A
3128import qualified Reporting.Error.Type as Error
@@ -42,53 +39,32 @@ newtype Solver a =
4239 Solver { _solve :: State -> IO (a, State) }
4340
4441
45−
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 =
42+data State =
5743 SS
58− { sEnv = Map.empty
59− , sSavedEnv = Map.empty
60− , sPool = Pool outermostRank []
61− , sMark = Type.nextMark noMark -- The mark must never be equal to noMark!
62− , sError = []
44+ { _env :: Env
45+ , _savedEnv :: Env
46+ , _rank :: Int
47+ , _pools :: Pools
48+ , _mark :: Mark
49+ , _errors :: [A.Located Error.Error]
6350 }
6451
6552
53+type Pools = MVector.IOVector [Variable]
6654
67−-- SOLVER STATE
6855
56+type Env = Map.Map Text (A.Located Variable)
6957
70−data State =
71− SS
72− { sEnv :: Env
73− , sSavedEnv :: Env
74− , sPool :: Pool
75− , sMark :: Mark
76− , sError :: [A.Located Error.Error]
77− }
7858
7959
80−{-| A pool holds a bunch of variables
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− }
60+-- RUN SOLVER
8961
9062
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
9268
9369
9470
@@ -99,96 +75,54 @@ type Env = Map.Map Text (A.Located Variable)
9975modifyEnv :: (Env -> Env) -> Solver ()
10076modifyEnv f =
10177 Solver $ \state ->
102− return ( (), state { sEnv = f (sEnv state) } )
103−
104−
105−{-# INLINE modifyPool #-}
106−modifyPool :: (Pool -> Pool) -> Solver ()
107−modifyPool f =
108− Solver $ \state ->
109− return ( (), state { sPool = f (sPool state) } )
78+ return ( (), state { _env = f (_env state) } )
11079
11180
11281{-# INLINE addError #-}
11382addError :: R.Region -> Error.Error -> Solver ()
11483addError region err =
11584 Solver $ \state ->
116− return ( (), state { sError = A.A region err : sError 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 )
85+ return ( (), state { _errors = A.A region err : _errors state } )
13786
13887
13988{-# INLINE getEnv #-}
14089getEnv :: Solver Env
14190getEnv =
14291 Solver $ \state ->
143− return ( sEnv state, state )
92+ return ( _env state, state )
14493
14594
14695{-# INLINE saveLocalEnv #-}
14796saveLocalEnv :: Solver ()
14897saveLocalEnv =
14998 Solver $ \state ->
150− return ( (), state { sSavedEnv = sEnv 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 )
99+ return ( (), state { _savedEnv = _env state } )
165100
166101
167102
168103-- REGISTER VARIABLES
169104
170105
171−{-# INLINE register #-}
172−register :: Variable -> Solver Variable
173−register variable =
174− {-# SCC elm_compiler_type_register #-}
175− Solver $ \state ->
176− let
177− (Pool maxRank inhabitants) =
178− sPool state
179− in
180− return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
106+register :: Variable -> Solver ()
107+register var =
108+ Solver $ \state@(SS _ _ maxRank pools _ _) ->
109+ {-# SCC elm_compiler_type_register #-}
110+ do MVector.modify pools (var:) maxRank
111+ return ( (), state )
181112
182113
183−{-# INLINE introduce #-}
184114introduce :: [Variable] -> Solver ()
185115introduce variables =
186− {-# SCC elm_compiler_type_introduce #-}
187− Solver $ \(SS env savedEnv (Pool maxRank inhabitants) mark errors) ->
188− do let toMaxRank (Descriptor c _ m cp) = Descriptor c maxRank m cp
189− mapM_ (\var -> UF.modifyDescriptor var toMaxRank) variables
190− let newPool = Pool maxRank (variables ++ inhabitants)
191− return ( (), SS env savedEnv newPool mark errors )
116+ Solver $ \state@(SS _ _ maxRank pools _ _) ->
117+ {-# SCC elm_compiler_type_introduce #-}
118+ do
119+ forM_ variables $ \var ->
120+ UF.modifyDescriptor var $ \(Descriptor content _ mark cp) ->
121+ Descriptor content maxRank mark cp
122+
123+ MVector.modify pools (variables++) maxRank
124+
125+ return ( (), state )
192126
193127
194128
@@ -196,47 +130,50 @@ introduce variables =
196130
197131
198132flatten :: Type -> Solver Variable
199−flatten term =
200− {-# SCC elm_compiler_type_flatten #-}
201− do maxRank <- getMaxRank
202− flattenHelp maxRank Map.empty term
133+flatten tipe =
134+ Solver $ \state@(SS _ _ maxRank pools _ _) ->
135+ {-# SCC elm_compiler_type_flatten #-}
136+ do var <- flattenHelp maxRank pools Map.empty tipe
137+ return (var, state)
203138
204139
205−flattenHelp :: Int -> Map.Map Text Variable -> Type -> Solver Variable
206−flattenHelp maxRank aliasDict termN =
207− case termN of
140+flattenHelp :: Int -> Pools -> Map.Map Text Variable -> Type -> IO Variable
141+flattenHelp maxRank pools aliasDict tipe =
142+ case tipe of
208143 PlaceHolder name ->
209144 return (aliasDict ! name)
210145
211146 AliasN name args realType ->
212− do flatArgs <- mapM (traverse (flattenHelp maxRank aliasDict)) args
213− flatVar <- flattenHelp maxRank (Map.fromList flatArgs) realType
214− makeFlatType maxRank (Alias name flatArgs flatVar)
147+ do flatArgs <- mapM (traverse (flattenHelp maxRank pools aliasDict)) args
148+ flatVar <- flattenHelp maxRank pools (Map.fromList flatArgs) realType
149+ registerFlatType maxRank pools (Alias name flatArgs flatVar)
215150
216151 VarN v ->
217152 return v
218153
219154 AppN name args ->
220− do flatArgs <- traverse (flattenHelp maxRank aliasDict) args
221− makeFlatType maxRank (Structure (App1 name flatArgs))
155+ do flatArgs <- traverse (flattenHelp maxRank pools aliasDict) args
156+ registerFlatType maxRank pools (Structure (App1 name flatArgs))
222157
223158 FunN a b ->
224− do flatA <- flattenHelp maxRank aliasDict a
225− flatB <- flattenHelp maxRank aliasDict b
226− makeFlatType maxRank (Structure (Fun1 flatA flatB))
159+ do flatA <- flattenHelp maxRank pools aliasDict a
160+ flatB <- flattenHelp maxRank pools aliasDict b
161+ registerFlatType maxRank pools (Structure (Fun1 flatA flatB))
227162
228163 EmptyRecordN ->
229− makeFlatType maxRank (Structure EmptyRecord1)
164+ registerFlatType maxRank pools (Structure EmptyRecord1)
230165
231166 RecordN fields ext ->
232− do flatFields <- traverse (flattenHelp maxRank aliasDict) fields
233− flatExt <- flattenHelp maxRank aliasDict ext
234− makeFlatType maxRank (Structure (Record1 flatFields flatExt))
167+ do flatFields <- traverse (flattenHelp maxRank pools aliasDict) fields
168+ flatExt <- flattenHelp maxRank pools aliasDict ext
169+ registerFlatType maxRank pools (Structure (Record1 flatFields flatExt))
235170
236171
237−makeFlatType :: Int -> Content -> Solver Variable
238−makeFlatType maxRank content =
239− register =<< liftIO (UF.fresh (Descriptor content maxRank noMark Nothing))
172+registerFlatType :: Int -> Pools -> Content -> IO Variable
173+registerFlatType maxRank pools content =
174+ do var <- UF.fresh (Descriptor content maxRank noMark Nothing)
175+ MVector.modify pools (var:) maxRank
176+ return var
240177
241178
242179
@@ -245,16 +182,16 @@ makeFlatType maxRank content =
245182
246183copy :: Variable -> Solver Variable
247184copy var =
248− {-# SCC elm_compiler_type_copy #-}
249− do maxRank <- getMaxRank
250− copyVar <- copyHelp maxRank var
251− _ <- restore var
252− return copyVar
185+ Solver $ \state@(SS _ _ maxRank pools _ _) ->
186+ {-# SCC elm_compiler_type_copy #-}
187+ do copyVar <- copyHelp maxRank pools var
188+ _ <- restore var
189+ return ( copyVar, state )
253190
254191
255−copyHelp :: Int -> Variable -> Solver Variable
256−copyHelp maxRank variable =
257− do (Descriptor content rank _mark maybeCopy) <- liftIO $ UF.descriptor variable
192+copyHelp :: Int -> Pools -> Variable -> IO Variable
193+copyHelp maxRank pools variable =
194+ do (Descriptor content rank _mark maybeCopy) <- UF.descriptor variable
258195 case maybeCopy of
259196 Just copiedVariable ->
260197 return copiedVariable
@@ -265,15 +202,15 @@ copyHelp maxRank variable =
265202
266203 else
267204 do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing
268− newVar <- liftIO $ UF.fresh $ mkCopyDesc content
269− _ <- register newVar
205+ newVar <- UF.fresh $ mkCopyDesc content
206+ MVector.modify pools (newVar:) maxRank
270207
271208 -- Link the original variable to the new variable. This lets us
272209 -- avoid making multiple copies of the variable we are instantiating.
273210 --
274211 -- Need to do this before recursively copying the content of
275212 -- the variable to avoid looping on cyclic terms.
276− liftIO $ UF.setDescriptor variable $
213+ UF.setDescriptor variable $
277214 Descriptor content rank noMark (Just newVar)
278215
279216 -- Now we recursively copy the content of the variable.
@@ -281,19 +218,19 @@ copyHelp maxRank variable =
281218 -- will not repeat this work or crawl this variable again.
282219 case content of
283220 Structure term ->
284− do newTerm <- traverseFlatType (copyHelp maxRank) term
285− liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
221+ do newTerm <- traverseFlatType (copyHelp maxRank pools) term
222+ UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
286223
287224 Var Rigid maybeSuper maybeName ->
288− liftIO $ UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName
225+ UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName
289226
290227 Var Flex _ _ ->
291228 return ()
292229
293230 Alias name args realType ->
294− do newArgs <- mapM (traverse (copyHelp maxRank)) args
295− newRealType <- copyHelp maxRank realType
296− liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
231+ do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
232+ newRealType <- copyHelp maxRank pools realType
233+ UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
297234
298235 Error _ ->
299236 return ()
@@ -305,21 +242,21 @@ copyHelp maxRank variable =
305242-- RESTORE
306243
307244
308−restore :: Variable -> Solver Variable
245+restore :: Variable -> IO Variable
309246restore variable =
310− do (Descriptor content _rank _mark maybeCopy) <- liftIO $ UF.descriptor variable
247+ do (Descriptor content _rank _mark maybeCopy) <- UF.descriptor variable
311248 case maybeCopy of
312249 Nothing ->
313250 return variable
314251
315252 Just _ ->
316253 do restoredContent <- restoreContent content
317− liftIO $ UF.setDescriptor variable $
254+ UF.setDescriptor variable $
318255 Descriptor restoredContent noRank noMark Nothing
319256 return variable
320257
321258
322−restoreContent :: Content -> Solver Content
259+restoreContent :: Content -> IO Content
323260restoreContent content =
324261 case content of
325262 Structure term ->
@@ -341,7 +278,7 @@ restoreContent content =
341278-- TRAVERSE FLAT TYPE
342279
343280
344−traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType
281+traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
345282traverseFlatType f flatType =
346283 case flatType of
347284 App1 name args ->
src/Type/Unify.hs+6−1
@@ -181,7 +181,10 @@ fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content
181181 do freshVariable <-
182182 liftIO $ UF.fresh $
183183 Descriptor content (min rank1 rank2) noMark Nothing
184− lift (TS.register freshVariable)
184+
185+ lift $ TS.register freshVariable
186+
187+ return freshVariable
185188
186189
187190
@@ -434,6 +437,8 @@ unifyComparableRecursive orientation var =
434437 do (Descriptor _ rank _ _) <- UF.descriptor var
435438 UF.fresh $ Descriptor (Var Flex (Just Comparable) Nothing) rank noMark Nothing
436439
440+ lift $ TS.register compVar
441+
437442 guardedUnify orientation compVar var
438443
439444