git.iko.soy/elk
on 8e73b5b help sign in
elk/src/Optimize/Module.hs
306 lines 8.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize.Module
4 ( optimize
5 )
6 where
9import Prelude hiding (cycle)
10import Control.Monad (foldM)
11import qualified Data.Map as Map
12import qualified Data.Set as Set
14import qualified AST.Canonical as Can
15import qualified AST.Optimized as Opt
16import qualified AST.Module.Name as ModuleName
17import qualified Elm.Name as N
18import qualified Optimize.Expression as Expr
19import qualified Optimize.Names as Names
20import qualified Optimize.Port as Port
21import qualified Reporting.Annotation as A
25-- OPTIMIZE
28optimize :: Can.Module -> Opt.Graph
29optimize (Can.Module home _ _ decls unions aliases _ effects) =
30 addEffects home effects $
31 addUnions home unions $
32 addAliases home aliases $
33 addDecls home decls $
34 Opt.Graph Map.empty Map.empty
38-- UNION
41addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Opt.Graph -> Opt.Graph
42addUnions home unions (Opt.Graph fields nodes) =
43 Opt.Graph fields $
44 Map.foldr (addUnion home) nodes unions
47type Nodes =
48 Map.Map Opt.Global Opt.Node
51addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
52addUnion home (Can.Union _ ctors) nodes =
53 foldr (addCtor home) nodes ctors
56addCtor :: ModuleName.Canonical -> (N.Name, [t]) -> Nodes -> Nodes
57addCtor home (ctor, args) nodes =
58 let
59 argNames =
60 map N.localFromInt [ 1 .. length args ]
62 function =
63 Opt.Function argNames $
64 Opt.Ctor ctor (map Opt.VarLocal argNames)
66 node =
67 Opt.Define function Set.empty Set.empty
68 in
69 Map.insert (Opt.Global home ctor) node nodes
73-- ALIAS
76addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Opt.Graph -> Opt.Graph
77addAliases home aliases graph =
78 Map.foldrWithKey (addAlias home) graph aliases
81addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
82addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph fieldCounts nodes) =
83 case maybeFields of
84 Nothing ->
85 graph
87 Just fields ->
88 let
89 function =
90 Opt.Function fields $ Opt.Record $
91 Map.fromList $ map toPair fields
93 node =
94 Opt.Define function Set.empty Set.empty
95 in
96 Opt.Graph
97 (foldr addOne fieldCounts fields)
98 (Map.insert (Opt.Global home name) node nodes)
101toPair :: N.Name -> (N.Name, Opt.Expr)
102toPair field =
103 ( field, Opt.VarLocal field )
106addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
107addOne name fields =
108 Map.insertWith (+) name 1 fields
112-- ADD EFFECTS
115addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
116addEffects home effects graph@(Opt.Graph fields nodes) =
117 case effects of
118 Can.NoEffects ->
119 graph
121 Can.Ports ports ->
122 Map.foldrWithKey (addPort home) graph ports
124 Can.Manager _ _ _ manager ->
125 Opt.Graph fields $
126 let
127 fx = Opt.Global home "$fx$"
128 cmd = Opt.Global home "command"
129 sub = Opt.Global home "subscription"
130 link = Opt.Link fx
131 in
132 case manager of
133 Can.Cmd _ ->
134 Map.insert cmd link $
135 Map.insert fx (Opt.Manager Opt.Cmd) nodes
137 Can.Sub _ ->
138 Map.insert sub link $
139 Map.insert fx (Opt.Manager Opt.Sub) nodes
141 Can.Fx _ _ ->
142 Map.insert cmd link $
143 Map.insert sub link $
144 Map.insert fx (Opt.Manager Opt.Fx) nodes
148addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Opt.Graph -> Opt.Graph
149addPort home name port_ graph =
150 case port_ of
151 Can.Incoming _ tipe ->
152 let
153 (kernels, globals, fields, decoder) = Names.run (Port.toDecoder tipe)
154 node = Opt.PortIncoming decoder kernels globals
155 in
156 addToGraph (Opt.Global home name) node fields graph
158 Can.Outgoing _ tipe ->
159 let
160 (kernels, globals, fields, encoder) = Names.run (Port.toEncoder tipe)
161 node = Opt.PortOutgoing encoder kernels globals
162 in
163 addToGraph (Opt.Global home name) node fields graph
167-- ADD DECLS
170addDecls :: ModuleName.Canonical -> Can.Decls -> Opt.Graph -> Opt.Graph
171addDecls home decls graph =
172 case decls of
173 Can.Declare def subDecls ->
174 addDecls home subDecls (addDef home def graph)
176 Can.DeclareRec defs subDecls ->
177 addDecls home subDecls (addRecDefs home defs graph)
179 Can.SaveTheEnvironment ->
180 graph
184-- ADD DEFS
187addDef :: ModuleName.Canonical -> Can.Def -> Opt.Graph -> Opt.Graph
188addDef home def graph =
189 case def of
190 Can.Def (A.At _ name) args body ->
191 addDefHelp (Opt.Global home name) args body graph
193 Can.TypedDef (A.At _ name) _ typedArgs body _ ->
194 addDefHelp (Opt.Global home name) (map fst typedArgs) body graph
197addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Opt.Graph
198addDefHelp name args body graph =
199 case args of
200 [] ->
201 let
202 (kernels, globals, fields, value) =
203 Names.run (Expr.optimize Set.empty body)
204 in
205 addToGraph name (Opt.Define value kernels globals) fields graph
207 _ ->
208 let
209 (kernels, globals, fields, function) =
210 Names.run $
211 do (argNames, defss) <- Expr.destructArgs args
212 obody <- Expr.optimize Set.empty body
213 pure $ Opt.Function argNames $
214 foldr Opt.Let obody (concat defss)
215 in
216 addToGraph name (Opt.Define function kernels globals) fields graph
219addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Opt.Graph -> Opt.Graph
220addToGraph name node fields (Opt.Graph fieldCounts nodes) =
221 Opt.Graph
222 (Map.unionWith (+) fields fieldCounts)
223 (Map.insert name node nodes)
227-- ADD RECURSIVE DEFS
230addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
231addRecDefs home defs graph =
232 let
233 cycleValues =
234 foldr addValueName Set.empty defs
236 dummyName =
237 Opt.Global home (N.toCompositeName cycleValues)
239 (kernels, globals, fields, State cyclicValuePairs newGraph) =
240 Names.run $
241 foldM (addRecDef home dummyName cycleValues) (State [] graph) defs
243 node =
244 Opt.Cycle cyclicValuePairs kernels globals
245 in
246 addToGraph dummyName node fields newGraph
249addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name
250addValueName def valueNames =
251 case def of
252 Can.Def (A.At _ name) [] _ ->
253 Set.insert name valueNames
255 Can.TypedDef (A.At _ name) _ [] _ _ ->
256 Set.insert name valueNames
258 _ ->
259 valueNames
263-- ADD RECURSIVE DEFS
266data State =
267 State
268 { _values :: [(N.Name, Opt.Expr)]
269 , _graph :: Opt.Graph
270 }
273addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State
274addRecDef home dummyName cycle state@(State values graph) def =
275 case def of
276 Can.Def (A.At _ name) [] body ->
277 addRecValue home dummyName cycle name body state
279 Can.TypedDef (A.At _ name) _ [] body _ ->
280 addRecValue home dummyName cycle name body state
282 _ ->
283 let
284 (kernels, globals, fields, odef) =
285 Names.run (Expr.optimizePotentialTailCall Set.empty def)
286 in
287 pure $ State values $
288 case odef of
289 Opt.Def name body ->
290 let node = Opt.Define body kernels globals in
291 addToGraph (Opt.Global home name) node fields graph
293 Opt.TailDef name args body ->
294 let node = Opt.DefineTailFunc args body kernels globals in
295 addToGraph (Opt.Global home name) node fields graph
298addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
299addRecValue home dummyName cycle name body (State values (Opt.Graph fields nodes)) =
300 do obody <- Expr.optimize cycle body
301 pure $
302 State
303 { _values = (name, obody) : values
304 , _graph = Opt.Graph fields $
305 Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes
306 }