git.iko.soy/elk
on cadeba6 help sign in
elk/src/Canonicalize/Sort.hs
234 lines 6.6 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 MultiIf branches finally ->
78 MultiIf
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 Remove record field ->
88 Remove
89 <$> reorder record
90 <*> return field
92 Insert record field expr ->
93 Insert
94 <$> reorder record
95 <*> return field
96 <*> reorder expr
98 Modify record fields ->
99 Modify
100 <$> reorder record
101 <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
103 Record fields ->
104 Record
105 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
107 GLShader _ _ _ ->
108 return expression
110 Port impl ->
111 Port <$>
112 case impl of
113 In _ _ ->
114 return impl
116 Out name expr tipe ->
117 (\e -> Out name e tipe) <$> reorder expr
119 Task name expr tipe ->
120 (\e -> Task name e tipe) <$> reorder expr
122 Crash _ ->
123 return expression
125 -- Actually do some reordering
126 Let defs body ->
127 do body' <- reorder body
129 -- Sort defs into strongly connected components.This
130 -- allows the programmer to write definitions in whatever
131 -- order they please, we can still define things in order
132 -- and generalize polymorphic functions when appropriate.
133 sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
134 let defss = map Graph.flattenSCC sccs
136 -- remove let-bound variables from the context
137 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
138 bound pattern
139 mapM free (ctors pattern)
141 let (A.A _ let') =
142 foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
144 return let'
147ctors :: P.CanonicalPattern -> [String]
148ctors (A.A _ pattern) =
149 case pattern of
150 P.Var _ ->
151 []
153 P.Alias _ p ->
154 ctors p
156 P.Record _ ->
157 []
159 P.Anything ->
160 []
162 P.Literal _ ->
163 []
165 P.Data (V.Canonical home name) ps ->
166 case home of
167 V.Local -> name : rest
168 V.TopLevel _ -> name : rest
169 V.BuiltIn -> rest
170 V.Module _ -> rest
171 where
172 rest = concatMap ctors ps
175bound :: P.CanonicalPattern -> State (Set.Set String) ()
176bound pattern =
177 let boundVars = P.boundVarSet pattern
178 in
179 modify (\freeVars -> Set.difference freeVars boundVars)
182bindingReorder
183 :: (P.CanonicalPattern, Canonical.Expr)
184 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
185bindingReorder (pattern, expr) =
186 do expr' <- reorder expr
187 bound pattern
188 mapM_ free (ctors pattern)
189 return (pattern, expr')
192-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
194-- This also reorders the all of the sub-expressions in the Def list.
195buildDefGraph
196 :: [Canonical.Def]
197 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
198buildDefGraph defs =
199 do pdefsDeps <- mapM reorderAndGetDependencies defs
200 return $ realDeps (addKey pdefsDeps)
201 where
202 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
203 addKey =
204 zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
206 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
207 variableToKey (Canonical.Definition pattern _ _, key, _) =
208 [ (var, key) | var <- P.boundVarList pattern ]
210 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
211 variableToKeyMap pdefsDeps =
212 Map.fromList (concatMap variableToKey pdefsDeps)
214 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
215 realDeps pdefsDeps =
216 map convert pdefsDeps
217 where
218 varDict = variableToKeyMap pdefsDeps
219 convert (pdef, key, deps) =
220 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
223reorderAndGetDependencies
224 :: Canonical.Def
225 -> State (Set.Set String) (Canonical.Def, [String])
226reorderAndGetDependencies (Canonical.Definition pattern expr mType) =
227 do globalFrees <- get
228 -- work in a fresh environment
229 put Set.empty
230 expr' <- reorder expr
231 localFrees <- get
232 -- merge with global frees
233 modify (Set.union globalFrees)
234 return (Canonical.Definition pattern expr' mType, Set.toList localFrees)