git.iko.soy/elk
on cb3a2fa help sign in
elk/src/Canonicalize/Sort.hs
232 lines 6.5 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.BuiltIn -> return ()
35 V.Module _ -> return ()
38-- REORDER EXPRESSIONS
40reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
41reorder (A.A ann expression) =
42 A.A ann <$>
43 case expression of
44 -- Be careful adding and restricting freeVars
45 Var var ->
46 do freeIfLocal var
47 return expression
49 Lambda pattern body ->
50 uncurry Lambda <$> bindingReorder (pattern,body)
52 Binop op leftExpr rightExpr ->
53 do freeIfLocal op
54 Binop op <$> reorder leftExpr <*> reorder rightExpr
56 Case expr cases ->
57 Case <$> reorder expr <*> mapM bindingReorder cases
59 Data name exprs ->
60 do free name
61 Data name <$> mapM reorder exprs
63 -- Just pipe the reorder though
64 Literal _ ->
65 return expression
67 Range lowExpr highExpr ->
68 Range <$> reorder lowExpr <*> reorder highExpr
70 ExplicitList es ->
71 ExplicitList <$> mapM reorder es
73 App func arg ->
74 App <$> reorder func <*> reorder arg
76 MultiIf branches finally ->
77 MultiIf
78 <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
79 <*> reorder finally
81 Access record field ->
82 Access
83 <$> reorder record
84 <*> return field
86 Remove record field ->
87 Remove
88 <$> reorder record
89 <*> return field
91 Insert record field expr ->
92 Insert
93 <$> reorder record
94 <*> return field
95 <*> reorder expr
97 Modify record fields ->
98 Modify
99 <$> reorder record
100 <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
102 Record fields ->
103 Record
104 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
106 GLShader _ _ _ ->
107 return expression
109 Port impl ->
110 Port <$>
111 case impl of
112 In _ _ ->
113 return impl
115 Out name expr tipe ->
116 (\e -> Out name e tipe) <$> reorder expr
118 Task name expr tipe ->
119 (\e -> Task name e tipe) <$> reorder expr
121 Crash _ ->
122 return expression
124 -- Actually do some reordering
125 Let defs body ->
126 do body' <- reorder body
128 -- Sort defs into strongly connected components.This
129 -- allows the programmer to write definitions in whatever
130 -- order they please, we can still define things in order
131 -- and generalize polymorphic functions when appropriate.
132 sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
133 let defss = map Graph.flattenSCC sccs
135 -- remove let-bound variables from the context
136 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
137 bound pattern
138 mapM free (ctors pattern)
140 let (A.A _ let') =
141 foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
143 return let'
146ctors :: P.CanonicalPattern -> [String]
147ctors (A.A _ pattern) =
148 case pattern of
149 P.Var _ ->
150 []
152 P.Alias _ p ->
153 ctors p
155 P.Record _ ->
156 []
158 P.Anything ->
159 []
161 P.Literal _ ->
162 []
164 P.Data (V.Canonical home name) ps ->
165 case home of
166 V.Local -> name : rest
167 V.BuiltIn -> rest
168 V.Module _ -> rest
169 where
170 rest = concatMap ctors ps
173bound :: P.CanonicalPattern -> State (Set.Set String) ()
174bound pattern =
175 let boundVars = P.boundVarSet pattern
176 in
177 modify (\freeVars -> Set.difference freeVars boundVars)
180bindingReorder
181 :: (P.CanonicalPattern, Canonical.Expr)
182 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
183bindingReorder (pattern, expr) =
184 do expr' <- reorder expr
185 bound pattern
186 mapM_ free (ctors pattern)
187 return (pattern, expr')
190-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
192-- This also reorders the all of the sub-expressions in the Def list.
193buildDefGraph
194 :: [Canonical.Def]
195 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
196buildDefGraph defs =
197 do pdefsDeps <- mapM reorderAndGetDependencies defs
198 return $ realDeps (addKey pdefsDeps)
199 where
200 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
201 addKey =
202 zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
204 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
205 variableToKey (Canonical.Definition pattern _ _, key, _) =
206 [ (var, key) | var <- P.boundVarList pattern ]
208 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
209 variableToKeyMap pdefsDeps =
210 Map.fromList (concatMap variableToKey pdefsDeps)
212 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
213 realDeps pdefsDeps =
214 map convert pdefsDeps
215 where
216 varDict = variableToKeyMap pdefsDeps
217 convert (pdef, key, deps) =
218 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
221reorderAndGetDependencies
222 :: Canonical.Def
223 -> State (Set.Set String) (Canonical.Def, [String])
224reorderAndGetDependencies (Canonical.Definition pattern expr mType) =
225 do globalFrees <- get
226 -- work in a fresh environment
227 put Set.empty
228 expr' <- reorder expr
229 localFrees <- get
230 -- merge with global frees
231 modify (Set.union globalFrees)
232 return (Canonical.Definition pattern expr' mType, Set.toList localFrees)