git.iko.soy/elk
on 446c784 help sign in
elk/src/Canonicalize/Sort.hs
214 lines 6.1 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 Update record fields ->
83 Update
84 <$> reorder record
85 <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
87 Record fields ->
88 Record
89 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
91 GLShader _ _ _ ->
92 return expression
94 Port impl ->
95 Port <$>
96 case impl of
97 In _ _ ->
98 return impl
100 Out name expr tipe ->
101 (\e -> Out name e tipe) <$> reorder expr
103 Task name expr tipe ->
104 (\e -> Task name e tipe) <$> reorder expr
106 -- Actually do some reordering
107 Let defs body ->
108 do body' <- reorder body
110 -- Sort defs into strongly connected components.This
111 -- allows the programmer to write definitions in whatever
112 -- order they please, we can still define things in order
113 -- and generalize polymorphic functions when appropriate.
114 sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
115 let defss = map Graph.flattenSCC sccs
117 -- remove let-bound variables from the context
118 forM_ defs $ \(Canonical.Definition pattern _ _) -> do
119 bound pattern
120 mapM free (ctors pattern)
122 let (A.A _ let') =
123 foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
125 return let'
128ctors :: P.CanonicalPattern -> [String]
129ctors (A.A _ pattern) =
130 case pattern of
131 P.Var _ ->
132 []
134 P.Alias _ p ->
135 ctors p
137 P.Record _ ->
138 []
140 P.Anything ->
141 []
143 P.Literal _ ->
144 []
146 P.Data (V.Canonical home name) ps ->
147 case home of
148 V.Local -> name : rest
149 V.BuiltIn -> rest
150 V.Module _ -> rest
151 where
152 rest = concatMap ctors ps
155bound :: P.CanonicalPattern -> State (Set.Set String) ()
156bound pattern =
157 let boundVars = P.boundVarSet pattern
158 in
159 modify (\freeVars -> Set.difference freeVars boundVars)
162bindingReorder
163 :: (P.CanonicalPattern, Canonical.Expr)
164 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
165bindingReorder (pattern, expr) =
166 do expr' <- reorder expr
167 bound pattern
168 mapM_ free (ctors pattern)
169 return (pattern, expr')
172-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
174-- This also reorders the all of the sub-expressions in the Def list.
175buildDefGraph
176 :: [Canonical.Def]
177 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
178buildDefGraph defs =
179 do pdefsDeps <- mapM reorderAndGetDependencies defs
180 return $ realDeps (addKey pdefsDeps)
181 where
182 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
183 addKey =
184 zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
186 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
187 variableToKey (Canonical.Definition pattern _ _, key, _) =
188 [ (var, key) | var <- P.boundVarList pattern ]
190 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
191 variableToKeyMap pdefsDeps =
192 Map.fromList (concatMap variableToKey pdefsDeps)
194 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
195 realDeps pdefsDeps =
196 map convert pdefsDeps
197 where
198 varDict = variableToKeyMap pdefsDeps
199 convert (pdef, key, deps) =
200 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
203reorderAndGetDependencies
204 :: Canonical.Def
205 -> State (Set.Set String) (Canonical.Def, [String])
206reorderAndGetDependencies (Canonical.Definition pattern expr mType) =
207 do globalFrees <- get
208 -- work in a fresh environment
209 put Set.empty
210 expr' <- reorder expr
211 localFrees <- get
212 -- merge with global frees
213 modify (Set.union globalFrees)
214 return (Canonical.Definition pattern expr' mType, Set.toList localFrees)