git.iko.soy/elk
on bb7eb96 help sign in
elk/src/Canonicalize/Sort.hs
223 lines 6.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Sort (definitions) where
4import Control.Monad.State
5import Control.Applicative ((<$>),(<*>))
6import qualified Data.Graph as Graph
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
9import qualified Data.Set as Set
11import AST.Expression.General (Expr'(..), PortImpl(..))
12import qualified AST.Expression.Canonical as Canonical
13import qualified AST.Pattern as P
14import qualified AST.Variable as V
15import qualified Reporting.Annotation as A
18-- STARTING POINT
20definitions :: Canonical.Expr -> Canonical.Expr
21definitions expression =
22 evalState (reorder expression) Set.empty
25free :: String -> State (Set.Set String) ()
26free x =
27 modify (Set.insert x)
30freeIfLocal :: V.Canonical -> State (Set.Set String) ()
31freeIfLocal (V.Canonical home name) =
32 case home of
33 V.Local -> free name
34 V.TopLevel _ -> free name
35 V.BuiltIn -> return ()
36 V.Module _ -> return ()
39-- REORDER EXPRESSIONS
41reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
42reorder (A.A ann expression) =
43 A.A ann <$>
44 case expression of
45 -- Be careful adding and restricting freeVars
46 Var var ->
47 do freeIfLocal var
48 return expression
50 Lambda pattern body ->
51 uncurry Lambda <$> bindingReorder (pattern,body)
53 Binop op leftExpr rightExpr ->
54 do freeIfLocal op
55 Binop op <$> reorder leftExpr <*> reorder rightExpr
57 Case expr cases ->
58 Case <$> reorder expr <*> mapM bindingReorder cases
60 Data name exprs ->
61 do free name
62 Data name <$> mapM reorder exprs
64 -- Just pipe the reorder though
65 Literal _ ->
66 return expression
68 Range lowExpr highExpr ->
69 Range <$> reorder lowExpr <*> reorder highExpr
71 ExplicitList es ->
72 ExplicitList <$> mapM reorder es
74 App func arg ->
75 App <$> reorder func <*> reorder arg
77 If branches finally ->
78 If
79 <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
80 <*> reorder finally
82 Access record field ->
83 Access
84 <$> reorder record
85 <*> return field
87 Update record fields ->
88 Update
89 <$> reorder record
90 <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
92 Record fields ->
93 Record
94 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
96 GLShader _ _ _ ->
97 return expression
99 Port impl ->
100 Port <$>
101 case impl of
102 In _ _ ->
103 return impl
105 Out name expr tipe ->
106 (\e -> Out name e tipe) <$> reorder expr
108 Task name expr tipe ->
109 (\e -> Task name e tipe) <$> reorder expr
111 Crash _ ->
112 return expression
114 -- Actually do some reordering
115 Let defs body ->
116 do body' <- reorder body
118 -- Sort defs into strongly connected components.This
119 -- allows the programmer to write definitions in whatever
120 -- order they please, we can still define things in order
121 -- and generalize polymorphic functions when appropriate.
122 sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
123 let defss = map Graph.flattenSCC sccs
125 -- remove let-bound variables from the context
126 forM_ defs $ \(Canonical.Definition _ pattern _ _) -> do
127 bound pattern
128 mapM free (ctors pattern)
130 let (A.A _ let') =
131 foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
133 return let'
136ctors :: P.CanonicalPattern -> [String]
137ctors (A.A _ pattern) =
138 case pattern of
139 P.Var _ ->
140 []
142 P.Alias _ p ->
143 ctors p
145 P.Record _ ->
146 []
148 P.Anything ->
149 []
151 P.Literal _ ->
152 []
154 P.Data (V.Canonical home name) ps ->
155 case home of
156 V.Local -> name : rest
157 V.TopLevel _ -> name : rest
158 V.BuiltIn -> rest
159 V.Module _ -> rest
160 where
161 rest = concatMap ctors ps
164bound :: P.CanonicalPattern -> State (Set.Set String) ()
165bound pattern =
166 let boundVars = P.boundVarSet pattern
167 in
168 modify (\freeVars -> Set.difference freeVars boundVars)
171bindingReorder
172 :: (P.CanonicalPattern, Canonical.Expr)
173 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
174bindingReorder (pattern, expr) =
175 do expr' <- reorder expr
176 bound pattern
177 mapM_ free (ctors pattern)
178 return (pattern, expr')
181-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
183-- This also reorders the all of the sub-expressions in the Def list.
184buildDefGraph
185 :: [Canonical.Def]
186 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
187buildDefGraph defs =
188 do pdefsDeps <- mapM reorderAndGetDependencies defs
189 return $ realDeps (addKey pdefsDeps)
190 where
191 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
192 addKey =
193 zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
195 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
196 variableToKey (Canonical.Definition _ pattern _ _, key, _) =
197 [ (var, key) | var <- P.boundVarList pattern ]
199 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
200 variableToKeyMap pdefsDeps =
201 Map.fromList (concatMap variableToKey pdefsDeps)
203 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
204 realDeps pdefsDeps =
205 map convert pdefsDeps
206 where
207 varDict = variableToKeyMap pdefsDeps
208 convert (pdef, key, deps) =
209 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
212reorderAndGetDependencies
213 :: Canonical.Def
214 -> State (Set.Set String) (Canonical.Def, [String])
215reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =
216 do globalFrees <- get
217 -- work in a fresh environment
218 put Set.empty
219 expr' <- reorder expr
220 localFrees <- get
221 -- merge with global frees
222 modify (Set.union globalFrees)
223 return (Canonical.Definition facts pattern expr' mType, Set.toList localFrees)