git.iko.soy/elk
on 19ff114 help sign in
elk/src/Optimize/Module.hs
304 lines 7.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize.Module
4 ( Graph(..)
5 , optimize
6 )
7 where
10import Prelude hiding (cycle)
11import Control.Monad (foldM)
12import qualified Data.List as List
13import qualified Data.Map as Map
14import qualified Data.Set as Set
16import qualified AST.Canonical as Can
17import qualified AST.Optimized as Opt
18import qualified AST.Module.Name as ModuleName
19import qualified Elm.Name as N
20import qualified Optimize.Expression as Expr
21import qualified Optimize.Names as Names
22import qualified Optimize.Port as Port
23import qualified Reporting.Annotation as A
27-- OPTIMIZE
30data Graph =
31 Graph
32 { _fields :: Map.Map N.Name Int
33 , _nodes :: Nodes
34 }
37type Nodes =
38 Map.Map Opt.Global Opt.Node
41optimize :: Can.Module -> Graph
42optimize (Can.Module home _ _ decls unions aliases _ effects) =
43 addEffects home effects $
44 addUnions home unions $
45 addAliases home aliases $
46 addDecls home decls $
47 Graph Map.empty Map.empty
51-- UNION
54addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Graph -> Graph
55addUnions home unions (Graph fields nodes) =
56 Graph fields $
57 Map.foldr (addUnion home) nodes unions
60addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
61addUnion home (Can.Union _ ctors _ _) nodes =
62 List.foldl' (addCtorNode home) nodes ctors
65addCtorNode :: ModuleName.Canonical -> Nodes -> Can.Ctor -> Nodes
66addCtorNode home nodes (Can.Ctor name index numArgs _) =
67 Map.insert (Opt.Global home name) (Opt.Ctor name index numArgs) nodes
71-- ALIAS
74addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Graph -> Graph
75addAliases home aliases graph =
76 Map.foldrWithKey (addAlias home) graph aliases
79addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Graph -> Graph
80addAlias home name (Can.Alias _ _ maybeFields) graph@(Graph fieldCounts nodes) =
81 case maybeFields of
82 Nothing ->
83 graph
85 Just fields ->
86 let
87 function =
88 Opt.Function fields $ Opt.Record $
89 Map.fromList $ map toPair fields
91 node =
92 Opt.Define function Set.empty
93 in
94 Graph
95 (foldr addOne fieldCounts fields)
96 (Map.insert (Opt.Global home name) node nodes)
99toPair :: N.Name -> (N.Name, Opt.Expr)
100toPair field =
101 ( field, Opt.VarLocal field )
104addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
105addOne name fields =
106 Map.insertWith (+) name 1 fields
110-- ADD EFFECTS
113addEffects :: ModuleName.Canonical -> Can.Effects -> Graph -> Graph
114addEffects home effects graph@(Graph fields nodes) =
115 case effects of
116 Can.NoEffects ->
117 graph
119 Can.Ports ports ->
120 Map.foldrWithKey (addPort home) graph ports
122 Can.Manager _ _ _ manager ->
123 Graph fields $
124 let
125 fx = Opt.Global home "$fx$"
126 cmd = Opt.Global home "command"
127 sub = Opt.Global home "subscription"
128 link = Opt.Link fx
129 in
130 case manager of
131 Can.Cmd _ ->
132 Map.insert cmd link $
133 Map.insert fx (Opt.Manager Opt.Cmd) nodes
135 Can.Sub _ ->
136 Map.insert sub link $
137 Map.insert fx (Opt.Manager Opt.Sub) nodes
139 Can.Fx _ _ ->
140 Map.insert cmd link $
141 Map.insert sub link $
142 Map.insert fx (Opt.Manager Opt.Fx) nodes
146addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Graph -> Graph
147addPort home name port_ graph =
148 case port_ of
149 Can.Incoming _ tipe ->
150 let
151 (deps, fields, decoder) = Names.run (Port.toDecoder tipe)
152 node = Opt.PortIncoming decoder deps
153 in
154 addToGraph (Opt.Global home name) node fields graph
156 Can.Outgoing _ tipe ->
157 let
158 (deps, fields, encoder) = Names.run (Port.toEncoder tipe)
159 node = Opt.PortOutgoing encoder deps
160 in
161 addToGraph (Opt.Global home name) node fields graph
165-- ADD DECLS
168addDecls :: ModuleName.Canonical -> Can.Decls -> Graph -> Graph
169addDecls home decls graph =
170 case decls of
171 Can.Declare def subDecls ->
172 addDecls home subDecls (addDef home def graph)
174 Can.DeclareRec defs subDecls ->
175 addDecls home subDecls (addRecDefs home defs graph)
177 Can.SaveTheEnvironment ->
178 graph
182-- ADD DEFS
185addDef :: ModuleName.Canonical -> Can.Def -> Graph -> Graph
186addDef home def graph =
187 case def of
188 Can.Def (A.At _ name) args body ->
189 addDefHelp (Opt.Global home name) args body graph
191 Can.TypedDef (A.At _ name) _ typedArgs body _ ->
192 addDefHelp (Opt.Global home name) (map fst typedArgs) body graph
195addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Graph -> Graph
196addDefHelp name args body graph =
197 case args of
198 [] ->
199 let
200 (deps, fields, value) =
201 Names.run (Expr.optimize Set.empty body)
202 in
203 addToGraph name (Opt.Define value deps) fields graph
205 _ ->
206 let
207 (deps, fields, function) =
208 Names.run $
209 do (argNames, destructors) <- Expr.destructArgs args
210 obody <- Expr.optimize Set.empty body
211 pure $ Opt.Function argNames $
212 foldr Opt.Destruct obody destructors
213 in
214 addToGraph name (Opt.Define function deps) fields graph
217addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Graph -> Graph
218addToGraph name node fields (Graph fieldCounts nodes) =
219 Graph
220 (Map.unionWith (+) fields fieldCounts)
221 (Map.insert name node nodes)
225-- ADD RECURSIVE DEFS
228addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Graph -> Graph
229addRecDefs home defs graph =
230 let
231 cycleValues =
232 foldr addValueName Set.empty defs
234 dummyName =
235 Opt.Global home (N.toCompositeName cycleValues)
237 (deps, fields, State cyclicValuePairs newGraph) =
238 Names.run $
239 foldM (addRecDef home dummyName cycleValues) (State [] graph) defs
241 node =
242 Opt.Cycle cyclicValuePairs deps
243 in
244 addToGraph dummyName node fields newGraph
247addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name
248addValueName def valueNames =
249 case def of
250 Can.Def (A.At _ name) [] _ ->
251 Set.insert name valueNames
253 Can.TypedDef (A.At _ name) _ [] _ _ ->
254 Set.insert name valueNames
256 _ ->
257 valueNames
261-- ADD RECURSIVE DEFS
264data State =
265 State
266 { _values :: [(N.Name, Opt.Expr)]
267 , _graph :: Graph
268 }
271addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State
272addRecDef home dummyName cycle state@(State values graph) def =
273 case def of
274 Can.Def (A.At _ name) [] body ->
275 addRecValue home dummyName cycle name body state
277 Can.TypedDef (A.At _ name) _ [] body _ ->
278 addRecValue home dummyName cycle name body state
280 _ ->
281 let
282 (deps, fields, odef) =
283 Names.run (Expr.optimizePotentialTailCall Set.empty def)
284 in
285 pure $ State values $
286 case odef of
287 Opt.Def name body ->
288 let node = Opt.Define body deps in
289 addToGraph (Opt.Global home name) node fields graph
291 Opt.TailDef name args body ->
292 let node = Opt.DefineTailFunc args body deps in
293 addToGraph (Opt.Global home name) node fields graph
296addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
297addRecValue home dummyName cycle name body (State values (Graph fields nodes)) =
298 do obody <- Expr.optimize cycle body
299 pure $
300 State
301 { _values = (name, obody) : values
302 , _graph = Graph fields $
303 Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes
304 }