git.iko.soy/elk
on 8a89c86 help sign in
elk/src/Optimize/Module.hs
305 lines 7.9 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 Data.Index as Index
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 Map.union nodes $
63 Map.fromList (Index.indexedMap (ctorToNode home) ctors)
66ctorToNode :: ModuleName.Canonical -> Index.ZeroBased -> (N.Name, [t]) -> (Opt.Global, Opt.Node)
67ctorToNode home index (name, args) =
68 ( Opt.Global home name, Opt.Ctor name index (length args) )
72-- ALIAS
75addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Graph -> Graph
76addAliases home aliases graph =
77 Map.foldrWithKey (addAlias home) graph aliases
80addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Graph -> Graph
81addAlias home name (Can.Alias _ _ maybeFields) graph@(Graph fieldCounts nodes) =
82 case maybeFields of
83 Nothing ->
84 graph
86 Just fields ->
87 let
88 function =
89 Opt.Function fields $ Opt.Record $
90 Map.fromList $ map toPair fields
92 node =
93 Opt.Define function Set.empty Set.empty
94 in
95 Graph
96 (foldr addOne fieldCounts fields)
97 (Map.insert (Opt.Global home name) node nodes)
100toPair :: N.Name -> (N.Name, Opt.Expr)
101toPair field =
102 ( field, Opt.VarLocal field )
105addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
106addOne name fields =
107 Map.insertWith (+) name 1 fields
111-- ADD EFFECTS
114addEffects :: ModuleName.Canonical -> Can.Effects -> Graph -> Graph
115addEffects home effects graph@(Graph fields nodes) =
116 case effects of
117 Can.NoEffects ->
118 graph
120 Can.Ports ports ->
121 Map.foldrWithKey (addPort home) graph ports
123 Can.Manager _ _ _ manager ->
124 Graph fields $
125 let
126 fx = Opt.Global home "$fx$"
127 cmd = Opt.Global home "command"
128 sub = Opt.Global home "subscription"
129 link = Opt.Link fx
130 in
131 case manager of
132 Can.Cmd _ ->
133 Map.insert cmd link $
134 Map.insert fx (Opt.Manager Opt.Cmd) nodes
136 Can.Sub _ ->
137 Map.insert sub link $
138 Map.insert fx (Opt.Manager Opt.Sub) nodes
140 Can.Fx _ _ ->
141 Map.insert cmd link $
142 Map.insert sub link $
143 Map.insert fx (Opt.Manager Opt.Fx) nodes
147addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Graph -> Graph
148addPort home name port_ graph =
149 case port_ of
150 Can.Incoming _ tipe ->
151 let
152 (kernels, globals, fields, decoder) = Names.run (Port.toDecoder tipe)
153 node = Opt.PortIncoming decoder kernels globals
154 in
155 addToGraph (Opt.Global home name) node fields graph
157 Can.Outgoing _ tipe ->
158 let
159 (kernels, globals, fields, encoder) = Names.run (Port.toEncoder tipe)
160 node = Opt.PortOutgoing encoder kernels globals
161 in
162 addToGraph (Opt.Global home name) node fields graph
166-- ADD DECLS
169addDecls :: ModuleName.Canonical -> Can.Decls -> Graph -> Graph
170addDecls home decls graph =
171 case decls of
172 Can.Declare def subDecls ->
173 addDecls home subDecls (addDef home def graph)
175 Can.DeclareRec defs subDecls ->
176 addDecls home subDecls (addRecDefs home defs graph)
178 Can.SaveTheEnvironment ->
179 graph
183-- ADD DEFS
186addDef :: ModuleName.Canonical -> Can.Def -> Graph -> Graph
187addDef home def graph =
188 case def of
189 Can.Def (A.At _ name) args body ->
190 addDefHelp (Opt.Global home name) args body graph
192 Can.TypedDef (A.At _ name) _ typedArgs body _ ->
193 addDefHelp (Opt.Global home name) (map fst typedArgs) body graph
196addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Graph -> Graph
197addDefHelp name args body graph =
198 case args of
199 [] ->
200 let
201 (kernels, globals, fields, value) =
202 Names.run (Expr.optimize Set.empty body)
203 in
204 addToGraph name (Opt.Define value kernels globals) fields graph
206 _ ->
207 let
208 (kernels, globals, fields, function) =
209 Names.run $
210 do (argNames, defss) <- Expr.destructArgs args
211 obody <- Expr.optimize Set.empty body
212 pure $ Opt.Function argNames $
213 foldr Opt.Let obody (concat defss)
214 in
215 addToGraph name (Opt.Define function kernels globals) fields graph
218addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Graph -> Graph
219addToGraph name node fields (Graph fieldCounts nodes) =
220 Graph
221 (Map.unionWith (+) fields fieldCounts)
222 (Map.insert name node nodes)
226-- ADD RECURSIVE DEFS
229addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Graph -> Graph
230addRecDefs home defs graph =
231 let
232 cycleValues =
233 foldr addValueName Set.empty defs
235 dummyName =
236 Opt.Global home (N.toCompositeName cycleValues)
238 (kernels, globals, fields, State cyclicValuePairs newGraph) =
239 Names.run $
240 foldM (addRecDef home dummyName cycleValues) (State [] graph) defs
242 node =
243 Opt.Cycle cyclicValuePairs kernels globals
244 in
245 addToGraph dummyName node fields newGraph
248addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name
249addValueName def valueNames =
250 case def of
251 Can.Def (A.At _ name) [] _ ->
252 Set.insert name valueNames
254 Can.TypedDef (A.At _ name) _ [] _ _ ->
255 Set.insert name valueNames
257 _ ->
258 valueNames
262-- ADD RECURSIVE DEFS
265data State =
266 State
267 { _values :: [(N.Name, Opt.Expr)]
268 , _graph :: Graph
269 }
272addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State
273addRecDef home dummyName cycle state@(State values graph) def =
274 case def of
275 Can.Def (A.At _ name) [] body ->
276 addRecValue home dummyName cycle name body state
278 Can.TypedDef (A.At _ name) _ [] body _ ->
279 addRecValue home dummyName cycle name body state
281 _ ->
282 let
283 (kernels, globals, fields, odef) =
284 Names.run (Expr.optimizePotentialTailCall Set.empty def)
285 in
286 pure $ State values $
287 case odef of
288 Opt.Def name body ->
289 let node = Opt.Define body kernels globals in
290 addToGraph (Opt.Global home name) node fields graph
292 Opt.TailDef name args body ->
293 let node = Opt.DefineTailFunc args body kernels globals in
294 addToGraph (Opt.Global home name) node fields graph
297addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
298addRecValue home dummyName cycle name body (State values (Graph fields nodes)) =
299 do obody <- Expr.optimize cycle body
300 pure $
301 State
302 { _values = (name, obody) : values
303 , _graph = Graph fields $
304 Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes
305 }