git.iko.soy/elk
on master help sign in
Create module to sort let-blocks into "strongly connected components".
7f43392Evan Czaplicki
compiler/Transform/SortDefinitions.hs+93−26
compare with master
unifiedsplit
@@ -1,11 +1,15 @@
1
1
2−module Transform.SortDefinitions (boundVars) where
2+module Transform.SortDefinitions (sortDefs) where
3
3
4import Control.Monad.State
4import Control.Monad.State
5+import Control.Applicative ((<$>))
5import qualified Data.Set as Set
6import qualified Data.Set as Set
6import qualified Data.Map as Map
7import qualified Data.Map as Map
8+import qualified SourceSyntax.Type as ST
7import SourceSyntax.Everything
9import SourceSyntax.Everything
8−
10+import qualified Data.Graph as Graph
11+import qualified Data.Map as Map
12+import qualified Data.Maybe as Maybe
9
13
10boundVars :: Pattern -> Set.Set String
14boundVars :: Pattern -> Set.Set String
11boundVars pattern =
15boundVars pattern =
@@ -17,38 +21,19 @@ boundVars pattern =
17 PAnything -> Set.empty
21 PAnything -> Set.empty
18 PLiteral _ -> Set.empty
22 PLiteral _ -> Set.empty
19
23
24+free :: String -> State (Set.Set String) ()
20free x = modify (Set.insert x)
25free x = modify (Set.insert x)
26+
27+bound :: Set.Set String -> State (Set.Set String) ()
21bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
28bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
22
29
23−reorderAndGetDependencies pattern expr =
30+sortDefs :: LExpr t v -> LExpr t v
24− do globalFrees <- get
25− expr' <- reorder expr
31+sortDefs expr = evalState (reorder expr) Set.empty
26− localFrees <- get
27− modify (Set.union globalFrees)
28− let addDep var deps = Map.insert var localFrees deps
29− dependencies = Set.foldr addDep Map.empty (boundVars pattern)
30− return (expr', dependencies)
31
32
32reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
33reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
33reorder lexpr@(L a b expr) =
34reorder lexpr@(L a b expr) =
34 L a b `liftM`
35 L a b `liftM`
35 case expr of
36 case expr of
36−{--
37− -- Actually do some reordering
38− Let defs body ->
39− do -- swap in a fresh environment
40−
41− -- swap in the old environment
42− body' <- reorder body
43− bound (boundVars (patterns defs))
44− Let `liftM` defs' `ap` body'
45−
46− where
47− patterns = flip concatMap defs $
48− case def of
49− Def pattern _ -> [pattern]
50− TypeAnnotation _ _ -> []
51−--}
52 -- Be careful adding and restricting freeVars
37 -- Be careful adding and restricting freeVars
53 Var x -> free x >> return expr
38 Var x -> free x >> return expr
54
39
@@ -98,6 +83,35 @@ reorder lexpr@(L a b expr) =
98
83
99 Markdown _ -> return expr
84 Markdown _ -> return expr
100
85
86+ -- Actually do some reordering
87+ Let defs body ->
88+ do body' <- reorder body
89+
90+ -- Sort defs into strongly connected components.This
91+ -- allows the programmer to write definitions in whatever
92+ -- order they please, we can still define things in order
93+ -- and generalize polymorphic functions when appropriate.
94+ sccs <- Graph.stronglyConnComp <$> buildDefDict defs
95+ let defss = map Graph.flattenSCC sccs
96+
97+ -- remove let-bound variables from the context
98+ let getPatterns def =
99+ case def of
100+ Def pattern _ -> pattern
101+ TypeAnnotation name _ -> PVar name
102+ mapM (bound . boundVars . getPatterns) defs
103+
104+ let addDefs ds bod = L a b (Let (concatMap toDefs ds) bod)
105+ where
106+ toDefs (pattern, expr, Nothing) = [ Def pattern expr ]
107+ toDefs (PVar name, expr, Just tipe) =
108+ [ TypeAnnotation name tipe, Def (PVar name) expr ]
109+
110+ L _ _ let' = foldr addDefs body' defss
111+
112+ return let'
113+
114+
101reorderField (label, expr) =
115reorderField (label, expr) =
102 (,) label `liftM` reorder expr
116 (,) label `liftM` reorder expr
103
117
@@ -110,3 +124,56 @@ bindingReorder (pattern,expr) =
110 bound (boundVars pattern)
124 bound (boundVars pattern)
111 return (pattern, expr')
125 return (pattern, expr')
112
126
127+
128+type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
129+
130+reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
131+reorderAndGetDependencies (pattern, expr, mType) =
132+ do globalFrees <- get
133+ -- work in a fresh environment
134+ put Set.empty
135+ expr' <- reorder expr
136+ localFrees <- get
137+ -- merge with global frees
138+ modify (Set.union globalFrees)
139+ return ((pattern, expr', mType), Set.toList localFrees)
140+
141+
142+-- This also reorders the all of the sub-expressions in the Def list.
143+buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
144+buildDefDict defs =
145+ do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
146+ return $ realDeps (addKey pdefsDeps)
147+
148+ where
149+ getPDefs :: [Def t v] -> [PDef t v]
150+ getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $
151+ Map.toList $ go defs Map.empty Map.empty
152+ where
153+ go [] ds ts =
154+ Map.unions [ Map.difference ds ts
155+ , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]
156+
157+ go (def:defs) ds ts =
158+ case def of
159+ Def p e -> go defs (Map.insert p (e, Nothing) ds) ts
160+ TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)
161+
162+ addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
163+ addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
164+
165+ variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
166+ variableToKey ((pattern, _, _), key, _) =
167+ [ (var, key) | var <- Set.toList (boundVars pattern) ]
168+
169+ variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
170+ variableToKeyMap pdefsDeps =
171+ Map.fromList (concatMap variableToKey pdefsDeps)
172+
173+ realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
174+ realDeps pdefsDeps = map convert pdefsDeps
175+ where
176+ varDict = variableToKeyMap pdefsDeps
177+ convert (pdef, key, deps) =
178+ (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
179+
compiler/Type/Constrain/Expression.hs+4−1
@@ -26,6 +26,7 @@ import Parse.Expression
26import Parse.Helpers (iParse)
26import Parse.Helpers (iParse)
27import Type.Solve (solve)
27import Type.Solve (solve)
28import qualified Type.State as TS
28import qualified Type.State as TS
29+import Transform.SortDefinitions
29
30
30test str =
31test str =
31 case iParse expr "" str of
32 case iParse expr "" str of
@@ -33,7 +34,9 @@ test str =
33 Right expression -> do
34 Right expression -> do
34 env <- Env.initialEnvironment
35 env <- Env.initialEnvironment
35 var <- flexibleVar
36 var <- flexibleVar
37+ let expr = sortDefs expression
38+ print (pretty expr)
36− constraint <- constrain env expression (VarN var)
39+ constraint <- constrain env expr (VarN var)
37 print =<< extraPretty constraint
40 print =<< extraPretty constraint
38 (env,_,_,errors) <- execStateT (solve constraint) TS.initialState
41 (env,_,_,errors) <- execStateT (solve constraint) TS.initialState
39 forM (Map.toList env) $ \(n,t) -> do
42 forM (Map.toList env) $ \(n,t) -> do