git.iko.soy/elk
on 2c1b2e8 help sign in
elk/src/Optimize/Module.hs
314 lines 8.0 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.Map as Map
13import qualified Data.Set as Set
15import qualified AST.Canonical as Can
16import qualified AST.Optimized as Opt
17import qualified AST.Module.Name as ModuleName
18import qualified Elm.Name as N
19import qualified Optimize.Expression as Expr
20import qualified Optimize.Names as Names
21import qualified Optimize.Port as Port
22import qualified Reporting.Annotation as A
26-- OPTIMIZE
29data Graph =
30 Graph
31 { _fields :: Map.Map N.Name Int
32 , _nodes :: Nodes
33 }
36type Nodes =
37 Map.Map Opt.Global Opt.Node
40optimize :: Can.Module -> Graph
41optimize (Can.Module home _ _ decls unions aliases _ effects) =
42 addEffects home effects $
43 addUnions home unions $
44 addAliases home aliases $
45 addDecls home decls $
46 Graph Map.empty Map.empty
50-- UNION
53addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Graph -> Graph
54addUnions home unions (Graph fields nodes) =
55 Graph fields $
56 Map.foldr (addUnion home) nodes unions
59addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
60addUnion home (Can.Union _ ctors) nodes =
61 foldr (addCtor home) nodes ctors
64addCtor :: ModuleName.Canonical -> (N.Name, [t]) -> Nodes -> Nodes
65addCtor home (ctor, args) nodes =
66 let
67 argNames =
68 map N.localFromInt [ 1 .. length args ]
70 function =
71 Opt.Function argNames $
72 Opt.Ctor ctor (map Opt.VarLocal argNames)
74 node =
75 Opt.Define function Set.empty Set.empty
76 in
77 Map.insert (Opt.Global home ctor) node nodes
81-- ALIAS
84addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Graph -> Graph
85addAliases home aliases graph =
86 Map.foldrWithKey (addAlias home) graph aliases
89addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Graph -> Graph
90addAlias home name (Can.Alias _ _ maybeFields) graph@(Graph fieldCounts nodes) =
91 case maybeFields of
92 Nothing ->
93 graph
95 Just fields ->
96 let
97 function =
98 Opt.Function fields $ Opt.Record $
99 Map.fromList $ map toPair fields
101 node =
102 Opt.Define function Set.empty Set.empty
103 in
104 Graph
105 (foldr addOne fieldCounts fields)
106 (Map.insert (Opt.Global home name) node nodes)
109toPair :: N.Name -> (N.Name, Opt.Expr)
110toPair field =
111 ( field, Opt.VarLocal field )
114addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
115addOne name fields =
116 Map.insertWith (+) name 1 fields
120-- ADD EFFECTS
123addEffects :: ModuleName.Canonical -> Can.Effects -> Graph -> Graph
124addEffects home effects graph@(Graph fields nodes) =
125 case effects of
126 Can.NoEffects ->
127 graph
129 Can.Ports ports ->
130 Map.foldrWithKey (addPort home) graph ports
132 Can.Manager _ _ _ manager ->
133 Graph fields $
134 let
135 fx = Opt.Global home "$fx$"
136 cmd = Opt.Global home "command"
137 sub = Opt.Global home "subscription"
138 link = Opt.Link fx
139 in
140 case manager of
141 Can.Cmd _ ->
142 Map.insert cmd link $
143 Map.insert fx (Opt.Manager Opt.Cmd) nodes
145 Can.Sub _ ->
146 Map.insert sub link $
147 Map.insert fx (Opt.Manager Opt.Sub) nodes
149 Can.Fx _ _ ->
150 Map.insert cmd link $
151 Map.insert sub link $
152 Map.insert fx (Opt.Manager Opt.Fx) nodes
156addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Graph -> Graph
157addPort home name port_ graph =
158 case port_ of
159 Can.Incoming _ tipe ->
160 let
161 (kernels, globals, fields, decoder) = Names.run (Port.toDecoder tipe)
162 node = Opt.PortIncoming decoder kernels globals
163 in
164 addToGraph (Opt.Global home name) node fields graph
166 Can.Outgoing _ tipe ->
167 let
168 (kernels, globals, fields, encoder) = Names.run (Port.toEncoder tipe)
169 node = Opt.PortOutgoing encoder kernels globals
170 in
171 addToGraph (Opt.Global home name) node fields graph
175-- ADD DECLS
178addDecls :: ModuleName.Canonical -> Can.Decls -> Graph -> Graph
179addDecls home decls graph =
180 case decls of
181 Can.Declare def subDecls ->
182 addDecls home subDecls (addDef home def graph)
184 Can.DeclareRec defs subDecls ->
185 addDecls home subDecls (addRecDefs home defs graph)
187 Can.SaveTheEnvironment ->
188 graph
192-- ADD DEFS
195addDef :: ModuleName.Canonical -> Can.Def -> Graph -> Graph
196addDef home def graph =
197 case def of
198 Can.Def (A.At _ name) args body ->
199 addDefHelp (Opt.Global home name) args body graph
201 Can.TypedDef (A.At _ name) _ typedArgs body _ ->
202 addDefHelp (Opt.Global home name) (map fst typedArgs) body graph
205addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Graph -> Graph
206addDefHelp name args body graph =
207 case args of
208 [] ->
209 let
210 (kernels, globals, fields, value) =
211 Names.run (Expr.optimize Set.empty body)
212 in
213 addToGraph name (Opt.Define value kernels globals) fields graph
215 _ ->
216 let
217 (kernels, globals, fields, function) =
218 Names.run $
219 do (argNames, defss) <- Expr.destructArgs args
220 obody <- Expr.optimize Set.empty body
221 pure $ Opt.Function argNames $
222 foldr Opt.Let obody (concat defss)
223 in
224 addToGraph name (Opt.Define function kernels globals) fields graph
227addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Graph -> Graph
228addToGraph name node fields (Graph fieldCounts nodes) =
229 Graph
230 (Map.unionWith (+) fields fieldCounts)
231 (Map.insert name node nodes)
235-- ADD RECURSIVE DEFS
238addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Graph -> Graph
239addRecDefs home defs graph =
240 let
241 cycleValues =
242 foldr addValueName Set.empty defs
244 dummyName =
245 Opt.Global home (N.toCompositeName cycleValues)
247 (kernels, globals, fields, State cyclicValuePairs newGraph) =
248 Names.run $
249 foldM (addRecDef home dummyName cycleValues) (State [] graph) defs
251 node =
252 Opt.Cycle cyclicValuePairs kernels globals
253 in
254 addToGraph dummyName node fields newGraph
257addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name
258addValueName def valueNames =
259 case def of
260 Can.Def (A.At _ name) [] _ ->
261 Set.insert name valueNames
263 Can.TypedDef (A.At _ name) _ [] _ _ ->
264 Set.insert name valueNames
266 _ ->
267 valueNames
271-- ADD RECURSIVE DEFS
274data State =
275 State
276 { _values :: [(N.Name, Opt.Expr)]
277 , _graph :: Graph
278 }
281addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State
282addRecDef home dummyName cycle state@(State values graph) def =
283 case def of
284 Can.Def (A.At _ name) [] body ->
285 addRecValue home dummyName cycle name body state
287 Can.TypedDef (A.At _ name) _ [] body _ ->
288 addRecValue home dummyName cycle name body state
290 _ ->
291 let
292 (kernels, globals, fields, odef) =
293 Names.run (Expr.optimizePotentialTailCall Set.empty def)
294 in
295 pure $ State values $
296 case odef of
297 Opt.Def name body ->
298 let node = Opt.Define body kernels globals in
299 addToGraph (Opt.Global home name) node fields graph
301 Opt.TailDef name args body ->
302 let node = Opt.DefineTailFunc args body kernels globals in
303 addToGraph (Opt.Global home name) node fields graph
306addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
307addRecValue home dummyName cycle name body (State values (Graph fields nodes)) =
308 do obody <- Expr.optimize cycle body
309 pure $
310 State
311 { _values = (name, obody) : values
312 , _graph = Graph fields $
313 Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes
314 }