git.iko.soy/elk
on 665d3d9 help sign in
elk/compiler/src/Optimize/Module.hs
374 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 _ opts) nodes =
68 List.foldl' (addCtorNode home opts) nodes ctors
71addCtorNode :: ModuleName.Canonical -> Can.CtorOpts -> Nodes -> Can.Ctor -> Nodes
72addCtorNode home opts nodes (Can.Ctor name index numArgs _) =
73 let
74 node =
75 case opts of
76 Can.Normal -> Opt.Ctor index numArgs
77 Can.Unbox -> Opt.Box
78 Can.Enum -> Opt.Enum index
79 in
80 Map.insert (Opt.Global home name) node nodes
84-- ALIAS
87addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Opt.Graph -> Opt.Graph
88addAliases home aliases graph =
89 Map.foldrWithKey (addAlias home) graph aliases
92addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
93addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains nodes fieldCounts) =
94 case tipe of
95 Can.TRecord fields Nothing ->
96 let
97 function =
98 Opt.Function (map fst (Can.fieldsToList fields)) $ Opt.Record $
99 Map.mapWithKey (\field _ -> Opt.VarLocal field) fields
101 node =
102 Opt.Define function Set.empty
103 in
104 Opt.Graph
105 mains
106 (Map.insert (Opt.Global home name) node nodes)
107 (Map.foldrWithKey addRecordCtorField fieldCounts fields)
109 _ ->
110 graph
113addRecordCtorField :: N.Name -> Can.FieldType -> Map.Map N.Name Int -> Map.Map N.Name Int
114addRecordCtorField name _ fields =
115 Map.insertWith (+) name 1 fields
119-- ADD EFFECTS
122addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
123addEffects home effects graph@(Opt.Graph mains nodes fields) =
124 case effects of
125 Can.NoEffects ->
126 graph
128 Can.Ports ports ->
129 Map.foldrWithKey (addPort home) graph ports
131 Can.Manager _ _ _ manager ->
132 let
133 fx = Opt.Global home "$fx$"
134 cmd = Opt.Global home "command"
135 sub = Opt.Global home "subscription"
136 link = Opt.Link fx
137 newNodes =
138 case manager of
139 Can.Cmd _ ->
140 Map.insert cmd link $
141 Map.insert fx (Opt.Manager Opt.Cmd) nodes
143 Can.Sub _ ->
144 Map.insert sub link $
145 Map.insert fx (Opt.Manager Opt.Sub) nodes
147 Can.Fx _ _ ->
148 Map.insert cmd link $
149 Map.insert sub link $
150 Map.insert fx (Opt.Manager Opt.Fx) nodes
151 in
152 Opt.Graph mains newNodes fields
155addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Opt.Graph -> Opt.Graph
156addPort home name port_ graph =
157 case port_ of
158 Can.Incoming _ payloadType _ ->
159 let
160 (deps, fields, decoder) = Names.run (Port.toDecoder payloadType)
161 node = Opt.PortIncoming decoder deps
162 in
163 addToGraph (Opt.Global home name) node fields graph
165 Can.Outgoing _ payloadType _ ->
166 let
167 (deps, fields, encoder) = Names.run (Port.toEncoder payloadType)
168 node = Opt.PortOutgoing encoder deps
169 in
170 addToGraph (Opt.Global home name) node fields graph
174-- HELPER
177addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Opt.Graph -> Opt.Graph
178addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =
179 Opt.Graph
180 mains
181 (Map.insert name node nodes)
182 (Map.unionWith (+) fields fieldCounts)
186-- ADD DECLS
189addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph
190addDecls home annotations decls graph =
191 case decls of
192 Can.Declare def subDecls ->
193 addDecls home annotations subDecls =<< addDef home annotations def graph
195 Can.DeclareRec defs subDecls ->
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 (map defToName defs)
203 Can.SaveTheEnvironment ->
204 Result.ok graph
207findMain :: [Can.Def] -> Maybe R.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 == N.main then Just region else findMain rest
218 Can.TypedDef (A.At region name) _ _ _ _ ->
219 if name == N.main then Just region else findMain rest
222defToName :: Can.Def -> N.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.Graph -> Result i [W.Warning] Opt.Graph
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 :: R.Region -> Annotations -> ModuleName.Canonical -> N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph
246addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =
247 if name /= N.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 let
255 newMains = Map.insert home main mains
256 newFields = Map.unionWith (+) fields fieldCounts
257 in
258 addDefNode home name args body deps $
259 Opt.Graph newMains nodes newFields
260 in
261 case Type.deepDealias tipe of
262 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == N.node ->
263 Result.ok $ addMain $ Names.run $
264 Names.registerKernel N.virtualDom Opt.Static
266 Can.TType hm nm [flags, message, _] | hm == ModuleName.platform && nm == N.program ->
267 case Effects.checkPayload flags of
268 Right () ->
269 Result.ok $ addMain $ Names.run $
270 Opt.Dynamic message <$> Port.toFlagsDecoder flags
272 Left (subType, invalidPayload) ->
273 Result.throw (E.BadFlags region subType invalidPayload)
275 _ ->
276 Result.throw (E.BadType region tipe)
279addDefNode :: ModuleName.Canonical -> N.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph
280addDefNode home name args body mainDeps graph =
281 let
282 (deps, fields, def) =
283 Names.run $
284 case args of
285 [] ->
286 Expr.optimize Set.empty body
288 _ ->
289 do (argNames, destructors) <- Expr.destructArgs args
290 obody <- Expr.optimize Set.empty body
291 pure $ Opt.Function argNames $
292 foldr Opt.Destruct obody destructors
293 in
294 addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph
298-- ADD RECURSIVE DEFS
301data State =
302 State
303 { _values :: [(N.Name, Opt.Expr)]
304 , _graph :: Opt.Graph
305 }
308addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
309addRecDefs home defs graph =
310 let
311 cycleValues = foldr addValueName Set.empty defs
312 dummyName = Opt.Global home (N.toCompositeName (Set.toList cycleValues))
314 (deps, fields, State cyclicValuePairs newGraph) =
315 Names.run $
316 foldM (addRecDef home dummyName cycleValues) (State [] graph) defs
317 in
318 addToGraph dummyName (Opt.Cycle cyclicValuePairs deps) fields newGraph
321addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name
322addValueName def valueNames =
323 case def of
324 Can.Def (A.At _ name) [] _ ->
325 Set.insert name valueNames
327 Can.TypedDef (A.At _ name) _ [] _ _ ->
328 Set.insert name valueNames
330 _ ->
331 valueNames
335-- ADD RECURSIVE DEFS
338addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State
339addRecDef home dummyName cycle state@(State values graph) def =
340 case def of
341 Can.Def (A.At _ name) [] body ->
342 addRecValue home dummyName cycle name body state
344 Can.TypedDef (A.At _ name) _ [] body _ ->
345 addRecValue home dummyName cycle name body state
347 _ ->
348 let
349 (deps, fields, odef) =
350 Names.run (Expr.optimizePotentialTailCall cycle def)
351 in
352 pure $ State values $
353 case odef of
354 Opt.Def name body ->
355 let node = Opt.Define body deps in
356 addToGraph (Opt.Global home name) node fields graph
358 Opt.TailDef name args body ->
359 let node = Opt.DefineTailFunc args body deps in
360 addToGraph (Opt.Global home name) node fields graph
363addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
364addRecValue home dummyName cycle name body (State values (Opt.Graph mains nodes fields)) =
365 do obody <- Expr.optimize cycle body
367 let global = Opt.Global home name
368 let node = Opt.Link dummyName
370 pure $
371 State
372 { _values = (name, obody) : values
373 , _graph = Opt.Graph mains (Map.insert global node nodes) fields
374 }