git.iko.soy/elk
on master help sign in
Switch from sets of constraints to lists of constraints. This should have a positive performance impact, in that list insertion should be asymptotically faster than set insertion.
ad0f1f1evancz
compiler/Types/Constrain.hs+46−52
compare with master
unifiedsplit
@@ -55,9 +55,9 @@ findAmbiguous hints assumptions continue =
55 _ -> continue
55 _ -> continue
56
56
57mergeSchemes :: [Map.Map String Scheme]
57mergeSchemes :: [Map.Map String Scheme]
58− -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
58+ -> GuidCounter (TVarMap, Constraints, Map.Map String Scheme)
59mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
59mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
60− return (Map.unions ass, Set.unions css, Map.unions sss)
60+ return (Map.unions ass, concat css, Map.unions sss)
61 where
61 where
62 kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
62 kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
63 split (k,vs) =
63 split (k,vs) =
@@ -67,15 +67,15 @@ mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
67 in do xs <- mapM (\_ -> guid) vs
67 in do xs <- mapM (\_ -> guid) vs
68 return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
68 return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
69 , case xs of
69 , case xs of
70− t:ts -> Set.fromList $ zipWith eq (t:ts) ts
70+ t:ts -> zipWith eq xs ts
71− [] -> Set.empty
71+ [] -> []
72 , Map.fromList ps )
72 , Map.fromList ps )
73
73
74constrain typeHints (Module _ _ imports stmts) = do
74constrain typeHints (Module _ _ imports stmts) = do
75 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
75 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
76 aliasHints <- getAliases imports `liftM` typeHints
76 aliasHints <- getAliases imports `liftM` typeHints
77 (as', cs', schemes) <- mergeSchemes schemess
77 (as', cs', schemes) <- mergeSchemes schemess
78− let constraints = Set.unions (cs':css)
78+ let constraints = concat (cs':css)
79 as = unionsA (as':ass)
79 as = unionsA (as':ass)
80 allHints = Map.union schemes (Map.fromList aliasHints)
80 allHints = Map.union schemes (Map.fromList aliasHints)
81 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
81 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
@@ -86,30 +86,29 @@ constrain typeHints (Module _ _ imports stmts) = do
86 escapees = Map.keys $ Map.difference assumptions allHints
86 escapees = Map.keys $ Map.difference assumptions allHints
87 msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
87 msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
88 return $ case escapees of
88 return $ case escapees of
89− [] -> Right (Set.toList constraints ++ cs)
89+ [] -> Right (constraints ++ cs)
90− _ -> unsafePerformIO (putStrLn msg) `seq` Right (Set.toList constraints ++ cs)
90+ _ -> unsafePerformIO (putStrLn msg) `seq` Right (constraints ++ cs)
91 --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
91 --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
92
92
93type TVarMap = Map.Map String [X]
93type TVarMap = Map.Map String [X]
94−type ConstraintSet = Set.Set (Located Constraint)
94+type Constraints = [Located Constraint]
95
95
96loc e span = L (Just $ show e) span
96loc e span = L (Just $ show e) span
97
97
98−gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)
98+gen :: CExpr -> GuidCounter (TVarMap, Constraints, Type)
99gen (L _ span expr) =
99gen (L _ span expr) =
100 let loc' = L (Just $ show expr) span in
100 let loc' = L (Just $ show expr) span in
101 case expr of
101 case expr of
102 Var x ->
102 Var x ->
103 do b <- guid
103 do b <- guid
104− return (Map.singleton x [b], Set.empty, VarT b)
104+ return (Map.singleton x [b], [], VarT b)
105
105
106 App e1 e2 ->
106 App e1 e2 ->
107 do (a1,c1,t1) <- gen e1
107 do (a1,c1,t1) <- gen e1
108 (a2,c2,t2) <- gen e2
108 (a2,c2,t2) <- gen e2
109 b <- beta
109 b <- beta
110 return ( unionA a1 a2
110 return ( unionA a1 a2
111− , Set.unions [c1,c2
112− ,Set.singleton . loc' $ t1 :=: (LambdaT t2 b)]
111+ , c1 ++ c2 ++ [loc' $ t1 :=: (LambdaT t2 b)]
113 , b )
112 , b )
114
113
115 Lambda x e ->
114 Lambda x e ->
@@ -117,8 +116,7 @@ gen (L _ span expr) =
117 b <- beta
116 b <- beta
118 v <- guid
117 v <- guid
119 return ( Map.delete x a
118 return ( Map.delete x a
120− , Set.union c . Set.fromList .
121− map (\x -> loc' $ VarT x :=: b) $
119+ , (++) c . map (\x -> loc' $ VarT x :=: b) $
122 Map.findWithDefault [v] x a
120 Map.findWithDefault [v] x a
123 , LambdaT b t )
121 , LambdaT b t )
124
122
@@ -136,7 +134,7 @@ gen (L _ span expr) =
136 return $ map (\x -> loc name span $ x :<<: s) vs
134 return $ map (\x -> loc name span $ x :<<: s) vs
137 cs' <- zipWithM genCs names schemes
135 cs' <- zipWithM genCs names schemes
138 return ( foldr Map.delete assumptions names
136 return ( foldr Map.delete assumptions names
139− , Set.union (Set.fromList . concat $ cs') cs
137+ , concat cs' ++ cs
140 , t )
138 , t )
141
139
142 Case e cases ->
140 Case e cases ->
@@ -146,8 +144,8 @@ gen (L _ span expr) =
146 , let cases' = map snd cases
144 , let cases' = map snd cases
147 locs = zipWith epos cases' (tail cases')
145 locs = zipWith epos cases' (tail cases')
148 csts = zipWith (:=:) ts (tail ts)
146 csts = zipWith (:=:) ts (tail ts)
149− cs' = Set.fromList (zipWith ($) locs csts)
147+ cs' = zipWith ($) locs csts
150− in Set.unions $ cs' : cs : css
148+ in concat $ cs' : cs : css
151 , head ts)
149 , head ts)
152
150
153 If e1 e2 e3 ->
151 If e1 e2 e3 ->
@@ -155,9 +153,7 @@ gen (L _ span expr) =
155 (a2,c2,t2) <- gen e2
153 (a2,c2,t2) <- gen e2
156 (a3,c3,t3) <- gen e3
154 (a3,c3,t3) <- gen e3
157 return ( unionsA [a1,a2,a3]
155 return ( unionsA [a1,a2,a3]
158− , let c4 = Set.fromList [ loc e1 span (t1 :=: bool)
156+ , c1 ++ c2 ++ c3 ++ [ loc e1 span (t1 :=: bool), loc' (t2 :=: t3) ]
159− , loc' (t2 :=: t3) ]
160− in Set.unions [c1,c2,c3,c4]
161 , t2 )
157 , t2 )
162
158
163 Data name es ->
159 Data name es ->
@@ -172,20 +168,20 @@ gen (L _ span expr) =
172 rtype' <- beta
168 rtype' <- beta
173 let fs = Map.singleton label [t]
169 let fs = Map.singleton label [t]
174 c = (loc' (RecordT fs rtype' :=: rtype))
170 c = (loc' (RecordT fs rtype' :=: rtype))
175− return (as, Set.insert c cs, t)
171+ return (as, c:cs, t)
176
172
177 Remove e x ->
173 Remove e x ->
178 do (as,cs,rtype) <- gen e
174 do (as,cs,rtype) <- gen e
179 t <- beta
175 t <- beta
180 rtype' <- beta
176 rtype' <- beta
181 let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
177 let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
182− return (as, Set.insert c cs, rtype')
178+ return (as, c:cs, rtype')
183
179
184 Insert e x v ->
180 Insert e x v ->
185 do (eas,ecs,etype) <- gen e
181 do (eas,ecs,etype) <- gen e
186 (vas,vcs,vtype) <- gen v
182 (vas,vcs,vtype) <- gen v
187 return ( unionA eas vas
183 return ( unionA eas vas
188− , Set.union ecs vcs
184+ , ecs ++ vcs
189 , RecordT (Map.singleton x [vtype]) etype )
185 , RecordT (Map.singleton x [vtype]) etype )
190
186
191 Modify record fields ->
187 Modify record fields ->
@@ -194,8 +190,8 @@ gen (L _ span expr) =
194 oldTs <- mapM (\_ -> beta) fields
190 oldTs <- mapM (\_ -> beta) fields
195 rtype' <- beta
191 rtype' <- beta
196 let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
192 let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
197− c = Set.singleton (loc' (rtype :=: rT oldTs))
193+ c = [ loc' (rtype :=: rT oldTs) ]
198− return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )
194+ return ( unionsA (ras:ass), concat (c : rcs : css), rT newTs )
199
195
200 Record fields ->
196 Record fields ->
201 let insert label tipe = Map.insertWith (++) label [tipe]
197 let insert label tipe = Map.insertWith (++) label [tipe]
@@ -204,30 +200,28 @@ gen (L _ span expr) =
204 return (as, cs, insert label tipe)
200 return (as, cs, insert label tipe)
205 in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
201 in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
206 return ( unionsA ass
202 return ( unionsA ass
207− , Set.fromList (concat css)
203+ , concat css
208 , RecordT (foldr ($) Map.empty fs) EmptyRecord )
204 , RecordT (foldr ($) Map.empty fs) EmptyRecord )
209
205
210 Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->
206 Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->
211 do (a1,c1,t1) <- gen e1
207 do (a1,c1,t1) <- gen e1
212 (a2,c2,t2) <- gen e2
208 (a2,c2,t2) <- gen e2
213 return ( unionsA [a1,a2]
209 return ( unionsA [a1,a2]
214− , Set.unions [ c1, c2, Set.fromList [ L w1 s1 (t1 :=: int)
215− , L w1 s2 (t2 :=: int) ] ]
210+ , c1 ++ c2 ++ [ L w1 s1 (t1 :=: int), L w1 s2 (t2 :=: int) ]
216 , listOf int )
211 , listOf int )
217
212
218 MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
213 MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
219− let cs = Set.fromList (map (loc' . (t :=:)) ts)
214+ let cs = map (loc' . (t :=:)) ts
220− return (unionsA ass, Set.unions (cs:css), t)
215+ return (unionsA ass, concat (cs:css), t)
221 where genPair (b@(L t s _),e) = do
216 where genPair (b@(L t s _),e) = do
222 (a1,c1,t1) <- gen b
217 (a1,c1,t1) <- gen b
223 (a2,c2,t2) <- gen e
218 (a2,c2,t2) <- gen e
224 return ( unionsA [a1,a2]
219 return ( unionsA [a1,a2]
225− , Set.unions [ c1, c2
226− , Set.singleton (L t s (t1 :=: bool)) ]
220+ , c1 ++ c2 ++ [ L t s (t1 :=: bool) ]
227 , t2 )
221 , t2 )
228
222
229 IntNum _ -> do t <- beta
223 IntNum _ -> do t <- beta
230− return (Map.empty, Set.singleton (loc' $ t :<: number), t)
224+ return (Map.empty, [loc' $ t :<: number], t)
231
225
232 FloatNum _ -> primitive float
226 FloatNum _ -> primitive float
233 Chr _ -> primitive char
227 Chr _ -> primitive char
@@ -236,38 +230,38 @@ gen (L _ span expr) =
236 Markdown _ -> primitive element
230 Markdown _ -> primitive element
237
231
238
232
239−primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)
233+primitive :: Type -> GuidCounter (TVarMap, Constraints, Type)
240−primitive t = return (Map.empty, Set.empty, t)
234+primitive t = return (Map.empty, [], t)
241
235
242caseGen :: Type
236caseGen :: Type
243 -> (Pattern, CExpr)
237 -> (Pattern, CExpr)
244− -> GuidCounter (TVarMap, ConstraintSet, Type)
238+ -> GuidCounter (TVarMap, Constraints, Type)
245caseGen tipe (p, ce@(L _ span e)) = do
239caseGen tipe (p, ce@(L _ span e)) = do
246 (as ,cs ,t) <- gen ce
240 (as ,cs ,t) <- gen ce
247 (as',cs',_) <- patternGen (loc p span) tipe as p
241 (as',cs',_) <- patternGen (loc p span) tipe as p
248− return ( as', Set.union cs cs', t )
242+ return ( as', cs ++ cs', t )
249
243
250patternGen :: (Constraint -> Located Constraint)
244patternGen :: (Constraint -> Located Constraint)
251 -> Type -- Type of e in `case e of ...`
245 -> Type -- Type of e in `case e of ...`
252 -> TVarMap
246 -> TVarMap
253 -> Pattern
247 -> Pattern
254− -> GuidCounter (TVarMap, ConstraintSet, Type)
248+ -> GuidCounter (TVarMap, Constraints, Type)
255patternGen loc tipe as pattern =
249patternGen loc tipe as pattern =
256 case pattern of
250 case pattern of
257− PAnything -> do b <- beta ; return ( as, Set.empty, b )
251+ PAnything -> do b <- beta ; return ( as, [], b )
258 PVar v -> do
252 PVar v -> do
259 b <- beta
253 b <- beta
260 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
254 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
261− return ( Map.delete v as, Set.fromList (loc (b :=: tipe) : cs), b )
255+ return ( Map.delete v as, loc (b :=: tipe) : cs, b )
262 PData name ps -> do
256 PData name ps -> do
263 constr <- guid
257 constr <- guid
264 output <- beta
258 output <- beta
265 let step (as,cs,tipe) p = do b <- beta
259 let step (as,cs,tipe) p = do b <- beta
266 (as',cs',t) <- patternGen loc b as p
260 (as',cs',t) <- patternGen loc b as p
267− return (as', Set.union cs cs', t ==> tipe)
261+ return (as', cs ++ cs', t ==> tipe)
268− (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)
262+ (as',cs, t) <- foldM step (as,[],tipe) (reverse ps)
269 return ( Map.insert name [constr] as'
263 return ( Map.insert name [constr] as'
270− , Set.insert (loc (VarT constr :=: t)) cs
264+ , loc (VarT constr :=: t) : cs
271 , output )
265 , output )
272 PRecord fs ->
266 PRecord fs ->
273 do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
267 do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
@@ -276,7 +270,7 @@ patternGen loc tipe as pattern =
276 mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)
270 mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)
277 (Map.findWithDefault [] name as)
271 (Map.findWithDefault [] name as)
278 return ( foldr Map.delete as fs
272 return ( foldr Map.delete as fs
279− , Set.fromList (loc (t :=: tipe) : concatMap mkCs pairs)
273+ , loc (t :=: tipe) : concatMap mkCs pairs
280 , t )
274 , t )
281
275
282
276
@@ -289,7 +283,7 @@ defGen def = case def of
289 OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
283 OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
290 TypeAnnotation name tipe -> do
284 TypeAnnotation name tipe -> do
291 schm <- Subs.generalize [] =<< Subs.superize name tipe
285 schm <- Subs.generalize [] =<< Subs.superize name tipe
292− return (Map.empty, Set.empty, (name, schm))
286+ return (Map.empty, [], (name, schm))
293
287
294defGenHelp name args e = do
288defGenHelp name args e = do
295 argDict <- mapM (\a -> liftM ((,) a) guid) args
289 argDict <- mapM (\a -> liftM ((,) a) guid) args
@@ -302,12 +296,12 @@ defGenHelp name args e = do
302 return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'
296 return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'
303 cs' <- concat `liftM` mapM genCs argDict
297 cs' <- concat `liftM` mapM genCs argDict
304 scheme <- Subs.generalize (concat $ Map.elems as') $
298 scheme <- Subs.generalize (concat $ Map.elems as') $
305− Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
299+ Forall (map snd argDict) (cs' ++ cs) tipe
306− return ( as', Set.empty, (name, scheme) )
300+ return ( as', [], (name, scheme) )
307
301
308
302
309stmtGen :: Statement
303stmtGen :: Statement
310− -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
304+ -> GuidCounter (TVarMap, Constraints, Map.Map String Scheme)
311stmtGen stmt =
305stmtGen stmt =
312 case stmt of
306 case stmt of
313 Definition def -> do (as,cs,hint) <- defGen def
307 Definition def -> do (as,cs,hint) <- defGen def
@@ -315,18 +309,18 @@ stmtGen stmt =
315
309
316 Datatype name xs tcs ->
310 Datatype name xs tcs ->
317 let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
311 let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
318− in return (Map.empty, Set.empty, Map.fromList (map (second toScheme) tcs))
312+ in return (Map.empty, [], Map.fromList (map (second toScheme) tcs))
319
313
320 ExportEvent js elm tipe ->
314 ExportEvent js elm tipe ->
321 do x <- guid
315 do x <- guid
322 return ( Map.singleton elm [x]
316 return ( Map.singleton elm [x]
323− , Set.singleton . loc elm NoSpan $ VarT x :=: tipe
317+ , [ loc elm NoSpan $ VarT x :=: tipe ]
324 , Map.empty )
318 , Map.empty )
325
319
326 ImportEvent js e@(L txt span base) elm tipe ->
320 ImportEvent js e@(L txt span base) elm tipe ->
327 do (as,cs,t) <- gen e
321 do (as,cs,t) <- gen e
328 return ( as
322 return ( as
329− , Set.insert (L txt span (signalOf t :=: tipe)) cs
323+ , L txt span (signalOf t :=: tipe) : cs
330 , Map.singleton elm (Forall [] [] tipe) )
324 , Map.singleton elm (Forall [] [] tipe) )
331
325
332− TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)
326+ TypeAlias _ _ _ -> return (Map.empty, [], Map.empty)