git.iko.soy/elk
on 4953132 help sign in
elk/src/Optimize/Module.hs
372 lines 11 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.List as List
12import qualified Data.Map as Map
13import qualified Data.Set as Set
14import Data.Map ((!))
16import qualified AST.Canonical as Can
17import qualified AST.Optimized as Opt
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Utils.Type as Type
20import qualified Canonicalize.Effects as Effects
21import qualified Elm.Name as N
22import qualified Optimize.Expression as Expr
23import qualified Optimize.Names as Names
24import qualified Optimize.Port as Port
25import qualified Reporting.Annotation as A
26import qualified Reporting.Error.Main as E
27import qualified Reporting.Region as R
28import qualified Reporting.Result as Result
29import qualified Reporting.Warning as W
33-- OPTIMIZE
36type Result i w a =
37 Result.Result i w E.Error a
40type Annotations =
41 Map.Map N.Name Can.Annotation
44optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.Graph
45optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =
46 addDecls home annotations decls $
47 addEffects home effects $
48 addUnions home unions $
49 addAliases home aliases $
50 Opt.Graph Map.empty Map.empty Map.empty
54-- UNION
57type Nodes =
58 Map.Map Opt.Global Opt.Node
61addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Opt.Graph -> Opt.Graph
62addUnions home unions (Opt.Graph mains nodes fields) =
63 Opt.Graph mains (Map.foldr (addUnion home) nodes unions) fields
66addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
67addUnion home (Can.Union _ ctors _ _) nodes =
68 List.foldl' (addCtorNode home) nodes ctors
71addCtorNode :: ModuleName.Canonical -> Nodes -> Can.Ctor -> Nodes
72addCtorNode home nodes (Can.Ctor name index numArgs _) =
73 Map.insert (Opt.Global home name) (Opt.Ctor name index numArgs) nodes
77-- ALIAS
80addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Opt.Graph -> Opt.Graph
81addAliases home aliases graph =
82 Map.foldrWithKey (addAlias home) graph aliases
85addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
86addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph mains nodes fieldCounts) =
87 case maybeFields of
88 Nothing ->
89 graph
91 Just fields ->
92 let
93 function =
94 Opt.Function (map fst fields) $ Opt.Record $
95 Map.fromList $ map toPair fields
97 node =
98 Opt.Define function Set.empty
99 in
100 Opt.Graph
101 mains
102 (Map.insert (Opt.Global home name) node nodes)
103 (foldr addRecordCtorField fieldCounts fields)
106toPair :: (N.Name, Can.Type) -> (N.Name, Opt.Expr)
107toPair (field, _) =
108 ( field, Opt.VarLocal field )
111addRecordCtorField :: (N.Name, Can.Type) -> Map.Map N.Name Int -> Map.Map N.Name Int
112addRecordCtorField (name, _) fields =
113 Map.insertWith (+) name 1 fields
117-- ADD EFFECTS
120addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
121addEffects home effects graph@(Opt.Graph mains nodes fields) =
122 case effects of
123 Can.NoEffects ->
124 graph
126 Can.Ports ports ->
127 Map.foldrWithKey (addPort home) graph ports
129 Can.Manager _ _ _ manager ->
130 let
131 fx = Opt.Global home "$fx$"
132 cmd = Opt.Global home "command"
133 sub = Opt.Global home "subscription"
134 link = Opt.Link fx
135 newNodes =
136 case manager of
137 Can.Cmd _ ->
138 Map.insert cmd link $
139 Map.insert fx (Opt.Manager Opt.Cmd) nodes
141 Can.Sub _ ->
142 Map.insert sub link $
143 Map.insert fx (Opt.Manager Opt.Sub) nodes
145 Can.Fx _ _ ->
146 Map.insert cmd link $
147 Map.insert sub link $
148 Map.insert fx (Opt.Manager Opt.Fx) nodes
149 in
150 Opt.Graph mains newNodes fields
153addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Opt.Graph -> Opt.Graph
154addPort home name port_ graph =
155 case port_ of
156 Can.Incoming _ payloadType _ ->
157 let
158 (deps, fields, decoder) = Names.run (Port.toDecoder payloadType)
159 node = Opt.PortIncoming decoder deps
160 in
161 addToGraph (Opt.Global home name) node fields graph
163 Can.Outgoing _ payloadType _ ->
164 let
165 (deps, fields, encoder) = Names.run (Port.toEncoder payloadType)
166 node = Opt.PortOutgoing encoder deps
167 in
168 addToGraph (Opt.Global home name) node fields graph
172-- HELPER
175addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Opt.Graph -> Opt.Graph
176addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =
177 Opt.Graph
178 mains
179 (Map.insert name node nodes)
180 (Map.unionWith (+) fields fieldCounts)
184-- ADD DECLS
187addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph
188addDecls home annotations decls graph =
189 case decls of
190 Can.Declare def subDecls ->
191 addDecls home annotations subDecls =<< addDef home annotations def graph
193 Can.DeclareRec defs subDecls ->
194 case findMain defs of
195 Nothing ->
196 addDecls home annotations subDecls (addRecDefs home defs graph)
198 Just region ->
199 Result.throw $ E.BadCycle region (map defToName defs)
201 Can.SaveTheEnvironment ->
202 Result.ok graph
205findMain :: [Can.Def] -> Maybe R.Region
206findMain defs =
207 case defs of
208 [] ->
209 Nothing
211 def:rest ->
212 case def of
213 Can.Def (A.At region name) _ _ ->
214 if name == N.main then Just region else findMain rest
216 Can.TypedDef (A.At region name) _ _ _ _ ->
217 if name == N.main then Just region else findMain rest
220defToName :: Can.Def -> N.Name
221defToName def =
222 case def of
223 Can.Def (A.At _ name) _ _ -> name
224 Can.TypedDef (A.At _ name) _ _ _ _ -> name
228-- ADD DEFS
231addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.Graph -> Result i [W.Warning] Opt.Graph
232addDef home annotations def graph =
233 case def of
234 Can.Def (A.At region name) args body ->
235 do let (Can.Forall _ tipe) = annotations ! name
236 Result.warn $ W.MissingTypeAnnotation region name tipe
237 addDefHelp region annotations home name args body graph
239 Can.TypedDef (A.At region name) _ typedArgs body _ ->
240 addDefHelp region annotations home name (map fst typedArgs) body graph
243addDefHelp :: R.Region -> Annotations -> ModuleName.Canonical -> N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph
244addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =
245 if name /= N.main then
246 Result.ok (addDefNode home name args body Set.empty graph)
247 else
248 let
249 (Can.Forall _ tipe) = annotations ! name
251 addMain (deps, fields, main) =
252 let
253 newMains = Map.insert home main mains
254 newFields = Map.unionWith (+) fields fieldCounts
255 in
256 addDefNode home name args body deps $
257 Opt.Graph newMains nodes newFields
258 in
259 case Type.deepDealias tipe of
260 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == N.node ->
261 Result.ok $ addMain $ Names.run $
262 Names.registerKernel N.browser Opt.Static
264 Can.TType hm nm [flags, message, _] | hm == ModuleName.platform && nm == N.program ->
265 case Effects.checkPayload flags of
266 Right () ->
267 Result.ok $ addMain $ Names.run $
268 Opt.Dynamic message <$> Port.toFlagsDecoder flags
270 Left (subType, invalidPayload) ->
271 Result.throw (E.BadFlags region subType invalidPayload)
273 _ ->
274 Result.throw (E.BadType region tipe)
277addDefNode :: ModuleName.Canonical -> N.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph
278addDefNode home name args body mainDeps graph =
279 let
280 (deps, fields, def) =
281 Names.run $
282 case args of
283 [] ->
284 Expr.optimize Set.empty body
286 _ ->
287 do (argNames, destructors) <- Expr.destructArgs args
288 obody <- Expr.optimize Set.empty body
289 pure $ Opt.Function argNames $
290 foldr Opt.Destruct obody destructors
291 in
292 addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph
296-- ADD RECURSIVE DEFS
299data State =
300 State
301 { _values :: [(N.Name, Opt.Expr)]
302 , _graph :: Opt.Graph
303 }
306addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
307addRecDefs home defs graph =
308 let
309 cycleValues = foldr addValueName Set.empty defs
310 dummyName = Opt.Global home (N.toCompositeName cycleValues)
312 (deps, fields, State cyclicValuePairs newGraph) =
313 Names.run $
314 foldM (addRecDef home dummyName cycleValues) (State [] graph) defs
315 in
316 addToGraph dummyName (Opt.Cycle cyclicValuePairs deps) fields newGraph
319addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name
320addValueName def valueNames =
321 case def of
322 Can.Def (A.At _ name) [] _ ->
323 Set.insert name valueNames
325 Can.TypedDef (A.At _ name) _ [] _ _ ->
326 Set.insert name valueNames
328 _ ->
329 valueNames
333-- ADD RECURSIVE DEFS
336addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State
337addRecDef home dummyName cycle state@(State values graph) def =
338 case def of
339 Can.Def (A.At _ name) [] body ->
340 addRecValue home dummyName cycle name body state
342 Can.TypedDef (A.At _ name) _ [] body _ ->
343 addRecValue home dummyName cycle name body state
345 _ ->
346 let
347 (deps, fields, odef) =
348 Names.run (Expr.optimizePotentialTailCall Set.empty def)
349 in
350 pure $ State values $
351 case odef of
352 Opt.Def name body ->
353 let node = Opt.Define body deps in
354 addToGraph (Opt.Global home name) node fields graph
356 Opt.TailDef name args body ->
357 let node = Opt.DefineTailFunc args body deps in
358 addToGraph (Opt.Global home name) node fields graph
361addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
362addRecValue home dummyName cycle name body (State values (Opt.Graph mains nodes fields)) =
363 do obody <- Expr.optimize cycle body
365 let global = Opt.Global home name
366 let node = Opt.Link dummyName
368 pure $
369 State
370 { _values = (name, obody) : values
371 , _graph = Opt.Graph mains (Map.insert global node nodes) fields
372 }