git.iko.soy/elk
on 9b0c310 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.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 ->
77 MultiIf <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
79 Access record field ->
80 Access <$> reorder record <*> return field
82 Remove record field ->
83 Remove <$> reorder record <*> return field
85 Insert record field expr ->
86 Insert <$> reorder record <*> return field <*> reorder expr
88 Modify record fields ->
89 Modify
90 <$> reorder record
91 <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
93 Record fields ->
94 Record
95 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
97 GLShader _ _ _ ->
98 return expression
100 Port impl ->
101 Port <$>
102 case impl of
103 In _ _ ->
104 return impl
106 Out name expr tipe ->
107 (\e -> Out name e tipe) <$> reorder expr
109 Task name expr tipe ->
110 (\e -> Task name e tipe) <$> reorder expr
112 -- Actually do some reordering
113 Let defs body ->
114 do body' <- reorder body
116 -- Sort defs into strongly connected components.This
117 -- allows the programmer to write definitions in whatever
118 -- order they please, we can still define things in order
119 -- and generalize polymorphic functions when appropriate.
120 sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
121 let defss = map Graph.flattenSCC sccs
123 -- remove let-bound variables from the context
124 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
125 bound pattern
126 mapM free (ctors pattern)
128 let (A.A _ let') =
129 foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
131 return let'
134ctors :: P.CanonicalPattern -> [String]
135ctors (A.A _ pattern) =
136 case pattern of
137 P.Var _ ->
138 []
140 P.Alias _ p ->
141 ctors p
143 P.Record _ ->
144 []
146 P.Anything ->
147 []
149 P.Literal _ ->
150 []
152 P.Data (V.Canonical home name) ps ->
153 case home of
154 V.Local -> 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 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 pattern expr' mType, Set.toList localFrees)