git.iko.soy/elk
on 884ea20 help sign in
elk/compiler/src/Optimize/Module.hs
369 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.Name as Name
14import qualified Data.Set as Set
15import Data.Map ((!))
17import qualified AST.Canonical as Can
18import qualified AST.Optimized as Opt
19import qualified AST.Utils.Type as Type
20import qualified Canonicalize.Effects as Effects
21import qualified Elm.ModuleName as ModuleName
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.Result as Result
28import qualified Reporting.Warning as W
32-- OPTIMIZE
35type Result i w a =
36 Result.Result i w E.Error a
39type Annotations =
40 Map.Map Name.Name Can.Annotation
43optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph
44optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =
45 addDecls home annotations decls $
46 addEffects home effects $
47 addUnions home unions $
48 addAliases home aliases $
49 Opt.LocalGraph Nothing Map.empty Map.empty
53-- UNION
56type Nodes =
57 Map.Map Opt.Global Opt.Node
60addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph
61addUnions home unions (Opt.LocalGraph main nodes fields) =
62 Opt.LocalGraph main (Map.foldr (addUnion home) nodes unions) fields
65addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
66addUnion home (Can.Union _ ctors _ opts) nodes =
67 List.foldl' (addCtorNode home opts) nodes ctors
70addCtorNode :: ModuleName.Canonical -> Can.CtorOpts -> Nodes -> Can.Ctor -> Nodes
71addCtorNode home opts nodes (Can.Ctor name index numArgs _) =
72 let
73 node =
74 case opts of
75 Can.Normal -> Opt.Ctor index numArgs
76 Can.Unbox -> Opt.Box
77 Can.Enum -> Opt.Enum index
78 in
79 Map.insert (Opt.Global home name) node nodes
83-- ALIAS
86addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph
87addAliases home aliases graph =
88 Map.foldrWithKey (addAlias home) graph aliases
91addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph
92addAlias home name (Can.Alias _ tipe) graph@(Opt.LocalGraph main nodes fieldCounts) =
93 case tipe of
94 Can.TRecord fields Nothing ->
95 let
96 function =
97 Opt.Function (map fst (Can.fieldsToList fields)) $ Opt.Record $
98 Map.mapWithKey (\field _ -> Opt.VarLocal field) fields
100 node =
101 Opt.Define function Set.empty
102 in
103 Opt.LocalGraph
104 main
105 (Map.insert (Opt.Global home name) node nodes)
106 (Map.foldrWithKey addRecordCtorField fieldCounts fields)
108 _ ->
109 graph
112addRecordCtorField :: Name.Name -> Can.FieldType -> Map.Map Name.Name Int -> Map.Map Name.Name Int
113addRecordCtorField name _ fields =
114 Map.insertWith (+) name 1 fields
118-- ADD EFFECTS
121addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.LocalGraph -> Opt.LocalGraph
122addEffects home effects graph@(Opt.LocalGraph main nodes fields) =
123 case effects of
124 Can.NoEffects ->
125 graph
127 Can.Ports ports ->
128 Map.foldrWithKey (addPort home) graph ports
130 Can.Manager _ _ _ manager ->
131 let
132 fx = Opt.Global home "$fx$"
133 cmd = Opt.Global home "command"
134 sub = Opt.Global home "subscription"
135 link = Opt.Link fx
136 newNodes =
137 case manager of
138 Can.Cmd _ ->
139 Map.insert cmd link $
140 Map.insert fx (Opt.Manager Opt.Cmd) nodes
142 Can.Sub _ ->
143 Map.insert sub link $
144 Map.insert fx (Opt.Manager Opt.Sub) nodes
146 Can.Fx _ _ ->
147 Map.insert cmd link $
148 Map.insert sub link $
149 Map.insert fx (Opt.Manager Opt.Fx) nodes
150 in
151 Opt.LocalGraph main newNodes fields
154addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.LocalGraph -> Opt.LocalGraph
155addPort home name port_ graph =
156 case port_ of
157 Can.Incoming _ payloadType _ ->
158 let
159 (deps, fields, decoder) = Names.run (Port.toDecoder payloadType)
160 node = Opt.PortIncoming decoder deps
161 in
162 addToGraph (Opt.Global home name) node fields graph
164 Can.Outgoing _ payloadType _ ->
165 let
166 (deps, fields, encoder) = Names.run (Port.toEncoder payloadType)
167 node = Opt.PortOutgoing encoder deps
168 in
169 addToGraph (Opt.Global home name) node fields graph
173-- HELPER
176addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph
177addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =
178 Opt.LocalGraph
179 main
180 (Map.insert name node nodes)
181 (Map.unionWith (+) fields fieldCounts)
185-- ADD DECLS
188addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
189addDecls home annotations decls graph =
190 case decls of
191 Can.Declare def subDecls ->
192 addDecls home annotations subDecls =<< addDef home annotations def graph
194 Can.DeclareRec d ds subDecls ->
195 let defs = d:ds in
196 case findMain defs of
197 Nothing ->
198 addDecls home annotations subDecls (addRecDefs home defs graph)
200 Just region ->
201 Result.throw $ E.BadCycle region (defToName d) (map defToName ds)
203 Can.SaveTheEnvironment ->
204 Result.ok graph
207findMain :: [Can.Def] -> Maybe A.Region
208findMain defs =
209 case defs of
210 [] ->
211 Nothing
213 def:rest ->
214 case def of
215 Can.Def (A.At region name) _ _ ->
216 if name == Name._main then Just region else findMain rest
218 Can.TypedDef (A.At region name) _ _ _ _ ->
219 if name == Name._main then Just region else findMain rest
222defToName :: Can.Def -> Name.Name
223defToName def =
224 case def of
225 Can.Def (A.At _ name) _ _ -> name
226 Can.TypedDef (A.At _ name) _ _ _ _ -> name
230-- ADD DEFS
233addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
234addDef home annotations def graph =
235 case def of
236 Can.Def (A.At region name) args body ->
237 do let (Can.Forall _ tipe) = annotations ! name
238 Result.warn $ W.MissingTypeAnnotation region name tipe
239 addDefHelp region annotations home name args body graph
241 Can.TypedDef (A.At region name) _ typedArgs body _ ->
242 addDefHelp region annotations home name (map fst typedArgs) body graph
245addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
246addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
247 if name /= Name._main then
248 Result.ok (addDefNode home name args body Set.empty graph)
249 else
250 let
251 (Can.Forall _ tipe) = annotations ! name
253 addMain (deps, fields, main) =
254 addDefNode home name args body deps $
255 Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts)
256 in
257 case Type.deepDealias tipe of
258 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->
259 Result.ok $ addMain $ Names.run $
260 Names.registerKernel Name.virtualDom Opt.Static
262 Can.TType hm nm [flags, _, message] | hm == ModuleName.platform && nm == Name.program ->
263 case Effects.checkPayload flags of
264 Right () ->
265 Result.ok $ addMain $ Names.run $
266 Opt.Dynamic message <$> Port.toFlagsDecoder flags
268 Left (subType, invalidPayload) ->
269 Result.throw (E.BadFlags region subType invalidPayload)
271 _ ->
272 Result.throw (E.BadType region tipe)
275addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph
276addDefNode home name args body mainDeps graph =
277 let
278 (deps, fields, def) =
279 Names.run $
280 case args of
281 [] ->
282 Expr.optimize Set.empty body
284 _ ->
285 do (argNames, destructors) <- Expr.destructArgs args
286 obody <- Expr.optimize Set.empty body
287 pure $ Opt.Function argNames $
288 foldr Opt.Destruct obody destructors
289 in
290 addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph
294-- ADD RECURSIVE DEFS
297data State =
298 State
299 { _values :: [(Name.Name, Opt.Expr)]
300 , _functions :: [Opt.Def]
301 }
304addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.LocalGraph -> Opt.LocalGraph
305addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) =
306 let
307 names = reverse (map toName defs)
308 cycleName = Opt.Global home (Name.fromManyNames names)
309 cycle = foldr addValueName Set.empty defs
310 links = foldr (addLink home (Opt.Link cycleName)) Map.empty defs
312 (deps, fields, State values funcs) =
313 Names.run $
314 foldM (addRecDef cycle) (State [] []) defs
315 in
316 Opt.LocalGraph
317 main
318 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
319 (Map.unionWith (+) fields fieldCounts)
322toName :: Can.Def -> Name.Name
323toName def =
324 case def of
325 Can.Def (A.At _ name) _ _ -> name
326 Can.TypedDef (A.At _ name) _ _ _ _ -> name
329addValueName :: Can.Def -> Set.Set Name.Name -> Set.Set Name.Name
330addValueName def names =
331 case def of
332 Can.Def (A.At _ name) args _ -> if null args then Set.insert name names else names
333 Can.TypedDef (A.At _ name) _ args _ _ -> if null args then Set.insert name names else names
336addLink :: ModuleName.Canonical -> Opt.Node -> Can.Def -> Map.Map Opt.Global Opt.Node -> Map.Map Opt.Global Opt.Node
337addLink home link def links =
338 case def of
339 Can.Def (A.At _ name) _ _ ->
340 Map.insert (Opt.Global home name) link links
342 Can.TypedDef (A.At _ name) _ _ _ _ ->
343 Map.insert (Opt.Global home name) link links
347-- ADD RECURSIVE DEFS
350addRecDef :: Set.Set Name.Name -> State -> Can.Def -> Names.Tracker State
351addRecDef cycle state def =
352 case def of
353 Can.Def (A.At _ name) args body ->
354 addRecDefHelp cycle state name args body
356 Can.TypedDef (A.At _ name) _ args body _ ->
357 addRecDefHelp cycle state name (map fst args) body
360addRecDefHelp :: Set.Set Name.Name -> State -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker State
361addRecDefHelp cycle (State values funcs) name args body =
362 case args of
363 [] ->
364 do obody <- Expr.optimize cycle body
365 pure $ State ((name, obody) : values) funcs
367 _:_ ->
368 do odef <- Expr.optimizePotentialTailCall cycle name args body
369 pure $ State values (odef : funcs)