git.iko.soy/elk
on fc4d628 help sign in
elk/src/Canonicalize/Sort.hs
220 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 -- Actually do some reordering
112 Let defs body ->
113 do body' <- reorder body
115 -- Sort defs into strongly connected components.This
116 -- allows the programmer to write definitions in whatever
117 -- order they please, we can still define things in order
118 -- and generalize polymorphic functions when appropriate.
119 sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
120 let defss = map Graph.flattenSCC sccs
122 -- remove let-bound variables from the context
123 forM_ defs $ \(Canonical.Definition _ pattern _ _) -> do
124 bound pattern
125 mapM free (ctors pattern)
127 let (A.A _ let') =
128 foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
130 return let'
133ctors :: P.CanonicalPattern -> [String]
134ctors (A.A _ pattern) =
135 case pattern of
136 P.Var _ ->
137 []
139 P.Alias _ p ->
140 ctors p
142 P.Record _ ->
143 []
145 P.Anything ->
146 []
148 P.Literal _ ->
149 []
151 P.Data (V.Canonical home name) ps ->
152 case home of
153 V.Local -> name : rest
154 V.TopLevel _ -> name : rest
155 V.BuiltIn -> rest
156 V.Module _ -> rest
157 where
158 rest = concatMap ctors ps
161bound :: P.CanonicalPattern -> State (Set.Set String) ()
162bound pattern =
163 let boundVars = P.boundVarSet pattern
164 in
165 modify (\freeVars -> Set.difference freeVars boundVars)
168bindingReorder
169 :: (P.CanonicalPattern, Canonical.Expr)
170 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
171bindingReorder (pattern, expr) =
172 do expr' <- reorder expr
173 bound pattern
174 mapM_ free (ctors pattern)
175 return (pattern, expr')
178-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
180-- This also reorders the all of the sub-expressions in the Def list.
181buildDefGraph
182 :: [Canonical.Def]
183 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
184buildDefGraph defs =
185 do pdefsDeps <- mapM reorderAndGetDependencies defs
186 return $ realDeps (addKey pdefsDeps)
187 where
188 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
189 addKey =
190 zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
192 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
193 variableToKey (Canonical.Definition _ pattern _ _, key, _) =
194 [ (var, key) | var <- P.boundVarList pattern ]
196 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
197 variableToKeyMap pdefsDeps =
198 Map.fromList (concatMap variableToKey pdefsDeps)
200 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
201 realDeps pdefsDeps =
202 map convert pdefsDeps
203 where
204 varDict = variableToKeyMap pdefsDeps
205 convert (pdef, key, deps) =
206 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
209reorderAndGetDependencies
210 :: Canonical.Def
211 -> State (Set.Set String) (Canonical.Def, [String])
212reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =
213 do globalFrees <- get
214 -- work in a fresh environment
215 put Set.empty
216 expr' <- reorder expr
217 localFrees <- get
218 -- merge with global frees
219 modify (Set.union globalFrees)
220 return (Canonical.Definition facts pattern expr' mType, Set.toList localFrees)