git.iko.soy/elk
on 2afa146 help sign in
elk/compiler/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.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.Graph
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.Graph Map.empty 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.Graph -> Opt.Graph
61addUnions home unions (Opt.Graph mains nodes fields) =
62 Opt.Graph mains (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.Graph -> Opt.Graph
87addAliases home aliases graph =
88 Map.foldrWithKey (addAlias home) graph aliases
91addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
92addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains 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.Graph
104 mains
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.Graph -> Opt.Graph
122addEffects home effects graph@(Opt.Graph mains 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.Graph mains newNodes fields
154addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.Graph -> Opt.Graph
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.Graph -> Opt.Graph
177addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =
178 Opt.Graph
179 mains
180 (Map.insert name node nodes)
181 (Map.unionWith (+) fields fieldCounts)
185-- ADD DECLS
188addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph
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 defs subDecls ->
195 case findMain defs of
196 Nothing ->
197 addDecls home annotations subDecls (addRecDefs home defs graph)
199 Just region ->
200 Result.throw $ E.BadCycle region (map defToName defs)
202 Can.SaveTheEnvironment ->
203 Result.ok graph
206findMain :: [Can.Def] -> Maybe A.Region
207findMain defs =
208 case defs of
209 [] ->
210 Nothing
212 def:rest ->
213 case def of
214 Can.Def (A.At region name) _ _ ->
215 if name == Name.main then Just region else findMain rest
217 Can.TypedDef (A.At region name) _ _ _ _ ->
218 if name == Name.main then Just region else findMain rest
221defToName :: Can.Def -> Name.Name
222defToName def =
223 case def of
224 Can.Def (A.At _ name) _ _ -> name
225 Can.TypedDef (A.At _ name) _ _ _ _ -> name
229-- ADD DEFS
232addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.Graph -> Result i [W.Warning] Opt.Graph
233addDef home annotations def graph =
234 case def of
235 Can.Def (A.At region name) args body ->
236 do let (Can.Forall _ tipe) = annotations ! name
237 Result.warn $ W.MissingTypeAnnotation region name tipe
238 addDefHelp region annotations home name args body graph
240 Can.TypedDef (A.At region name) _ typedArgs body _ ->
241 addDefHelp region annotations home name (map fst typedArgs) body graph
244addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph
245addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =
246 if name /= Name.main then
247 Result.ok (addDefNode home name args body Set.empty graph)
248 else
249 let
250 (Can.Forall _ tipe) = annotations ! name
252 addMain (deps, fields, main) =
253 let
254 newMains = Map.insert home main mains
255 newFields = Map.unionWith (+) fields fieldCounts
256 in
257 addDefNode home name args body deps $
258 Opt.Graph newMains nodes newFields
259 in
260 case Type.deepDealias tipe of
261 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->
262 Result.ok $ addMain $ Names.run $
263 Names.registerKernel Name.virtualDom Opt.Static
265 Can.TType hm nm [flags, _, message] | hm == ModuleName.platform && nm == Name.program ->
266 case Effects.checkPayload flags of
267 Right () ->
268 Result.ok $ addMain $ Names.run $
269 Opt.Dynamic message <$> Port.toFlagsDecoder flags
271 Left (subType, invalidPayload) ->
272 Result.throw (E.BadFlags region subType invalidPayload)
274 _ ->
275 Result.throw (E.BadType region tipe)
278addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph
279addDefNode home name args body mainDeps graph =
280 let
281 (deps, fields, def) =
282 Names.run $
283 case args of
284 [] ->
285 Expr.optimize Set.empty body
287 _ ->
288 do (argNames, destructors) <- Expr.destructArgs args
289 obody <- Expr.optimize Set.empty body
290 pure $ Opt.Function argNames $
291 foldr Opt.Destruct obody destructors
292 in
293 addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph
297-- ADD RECURSIVE DEFS
300data State =
301 State
302 { _values :: [(Name.Name, Opt.Expr)]
303 , _functions :: [Opt.Def]
304 }
307addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
308addRecDefs home defs (Opt.Graph mains nodes fieldCounts) =
309 let
310 names = reverse (map toName defs)
311 cycleName = Opt.Global home (Name.fromManyNames names)
312 cycle = foldr addValueName Set.empty defs
313 links = foldr (addLink home (Opt.Link cycleName)) Map.empty defs
315 (deps, fields, State values funcs) =
316 Names.run $
317 foldM (addRecDef cycle) (State [] []) defs
318 in
319 Opt.Graph
320 mains
321 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
322 (Map.unionWith (+) fields fieldCounts)
325toName :: Can.Def -> Name.Name
326toName def =
327 case def of
328 Can.Def (A.At _ name) _ _ -> name
329 Can.TypedDef (A.At _ name) _ _ _ _ -> name
332addValueName :: Can.Def -> Set.Set Name.Name -> Set.Set Name.Name
333addValueName def names =
334 case def of
335 Can.Def (A.At _ name) args _ -> if null args then Set.insert name names else names
336 Can.TypedDef (A.At _ name) _ args _ _ -> if null args then Set.insert name names else names
339addLink :: ModuleName.Canonical -> Opt.Node -> Can.Def -> Map.Map Opt.Global Opt.Node -> Map.Map Opt.Global Opt.Node
340addLink home link def links =
341 case def of
342 Can.Def (A.At _ name) _ _ ->
343 Map.insert (Opt.Global home name) link links
345 Can.TypedDef (A.At _ name) _ _ _ _ ->
346 Map.insert (Opt.Global home name) link links
350-- ADD RECURSIVE DEFS
353addRecDef :: Set.Set Name.Name -> State -> Can.Def -> Names.Tracker State
354addRecDef cycle state def =
355 case def of
356 Can.Def (A.At _ name) args body ->
357 addRecDefHelp cycle state name args body
359 Can.TypedDef (A.At _ name) _ args body _ ->
360 addRecDefHelp cycle state name (map fst args) body
363addRecDefHelp :: Set.Set Name.Name -> State -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker State
364addRecDefHelp cycle (State values funcs) name args body =
365 case args of
366 [] ->
367 do obody <- Expr.optimize cycle body
368 pure $ State ((name, obody) : values) funcs
370 _:_ ->
371 do odef <- Expr.optimizePotentialTailCall cycle name args body
372 pure $ State values (odef : funcs)