git.iko.soy/elk
on fdf2d75 help sign in
elk/compiler/src/Optimize/Module.hs
379 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 name index numArgs
77 Can.Unbox -> Opt.Box name
78 Can.Enum -> Opt.Enum name 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 _ _ maybeFields) graph@(Opt.Graph mains nodes fieldCounts) =
94 case maybeFields of
95 Nothing ->
96 graph
98 Just fields ->
99 let
100 function =
101 Opt.Function (map fst fields) $ Opt.Record $
102 Map.fromList $ map toPair fields
104 node =
105 Opt.Define function Set.empty
106 in
107 Opt.Graph
108 mains
109 (Map.insert (Opt.Global home name) node nodes)
110 (foldr addRecordCtorField fieldCounts fields)
113toPair :: (N.Name, Can.Type) -> (N.Name, Opt.Expr)
114toPair (field, _) =
115 ( field, Opt.VarLocal field )
118addRecordCtorField :: (N.Name, Can.Type) -> Map.Map N.Name Int -> Map.Map N.Name Int
119addRecordCtorField (name, _) fields =
120 Map.insertWith (+) name 1 fields
124-- ADD EFFECTS
127addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
128addEffects home effects graph@(Opt.Graph mains nodes fields) =
129 case effects of
130 Can.NoEffects ->
131 graph
133 Can.Ports ports ->
134 Map.foldrWithKey (addPort home) graph ports
136 Can.Manager _ _ _ manager ->
137 let
138 fx = Opt.Global home "$fx$"
139 cmd = Opt.Global home "command"
140 sub = Opt.Global home "subscription"
141 link = Opt.Link fx
142 newNodes =
143 case manager of
144 Can.Cmd _ ->
145 Map.insert cmd link $
146 Map.insert fx (Opt.Manager Opt.Cmd) nodes
148 Can.Sub _ ->
149 Map.insert sub link $
150 Map.insert fx (Opt.Manager Opt.Sub) nodes
152 Can.Fx _ _ ->
153 Map.insert cmd link $
154 Map.insert sub link $
155 Map.insert fx (Opt.Manager Opt.Fx) nodes
156 in
157 Opt.Graph mains newNodes fields
160addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Opt.Graph -> Opt.Graph
161addPort home name port_ graph =
162 case port_ of
163 Can.Incoming _ payloadType _ ->
164 let
165 (deps, fields, decoder) = Names.run (Port.toDecoder payloadType)
166 node = Opt.PortIncoming decoder deps
167 in
168 addToGraph (Opt.Global home name) node fields graph
170 Can.Outgoing _ payloadType _ ->
171 let
172 (deps, fields, encoder) = Names.run (Port.toEncoder payloadType)
173 node = Opt.PortOutgoing encoder deps
174 in
175 addToGraph (Opt.Global home name) node fields graph
179-- HELPER
182addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Opt.Graph -> Opt.Graph
183addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =
184 Opt.Graph
185 mains
186 (Map.insert name node nodes)
187 (Map.unionWith (+) fields fieldCounts)
191-- ADD DECLS
194addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph
195addDecls home annotations decls graph =
196 case decls of
197 Can.Declare def subDecls ->
198 addDecls home annotations subDecls =<< addDef home annotations def graph
200 Can.DeclareRec defs subDecls ->
201 case findMain defs of
202 Nothing ->
203 addDecls home annotations subDecls (addRecDefs home defs graph)
205 Just region ->
206 Result.throw $ E.BadCycle region (map defToName defs)
208 Can.SaveTheEnvironment ->
209 Result.ok graph
212findMain :: [Can.Def] -> Maybe R.Region
213findMain defs =
214 case defs of
215 [] ->
216 Nothing
218 def:rest ->
219 case def of
220 Can.Def (A.At region name) _ _ ->
221 if name == N.main then Just region else findMain rest
223 Can.TypedDef (A.At region name) _ _ _ _ ->
224 if name == N.main then Just region else findMain rest
227defToName :: Can.Def -> N.Name
228defToName def =
229 case def of
230 Can.Def (A.At _ name) _ _ -> name
231 Can.TypedDef (A.At _ name) _ _ _ _ -> name
235-- ADD DEFS
238addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.Graph -> Result i [W.Warning] Opt.Graph
239addDef home annotations def graph =
240 case def of
241 Can.Def (A.At region name) args body ->
242 do let (Can.Forall _ tipe) = annotations ! name
243 Result.warn $ W.MissingTypeAnnotation region name tipe
244 addDefHelp region annotations home name args body graph
246 Can.TypedDef (A.At region name) _ typedArgs body _ ->
247 addDefHelp region annotations home name (map fst typedArgs) body graph
250addDefHelp :: R.Region -> Annotations -> ModuleName.Canonical -> N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph
251addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =
252 if name /= N.main then
253 Result.ok (addDefNode home name args body Set.empty graph)
254 else
255 let
256 (Can.Forall _ tipe) = annotations ! name
258 addMain (deps, fields, main) =
259 let
260 newMains = Map.insert home main mains
261 newFields = Map.unionWith (+) fields fieldCounts
262 in
263 addDefNode home name args body deps $
264 Opt.Graph newMains nodes newFields
265 in
266 case Type.deepDealias tipe of
267 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == N.node ->
268 Result.ok $ addMain $ Names.run $
269 Names.registerKernel N.browser Opt.Static
271 Can.TType hm nm [flags, message, _] | hm == ModuleName.platform && nm == N.program ->
272 case Effects.checkPayload flags of
273 Right () ->
274 Result.ok $ addMain $ Names.run $
275 Opt.Dynamic message <$> Port.toFlagsDecoder flags
277 Left (subType, invalidPayload) ->
278 Result.throw (E.BadFlags region subType invalidPayload)
280 _ ->
281 Result.throw (E.BadType region tipe)
284addDefNode :: ModuleName.Canonical -> N.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph
285addDefNode home name args body mainDeps graph =
286 let
287 (deps, fields, def) =
288 Names.run $
289 case args of
290 [] ->
291 Expr.optimize Set.empty body
293 _ ->
294 do (argNames, destructors) <- Expr.destructArgs args
295 obody <- Expr.optimize Set.empty body
296 pure $ Opt.Function argNames $
297 foldr Opt.Destruct obody destructors
298 in
299 addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph
303-- ADD RECURSIVE DEFS
306data State =
307 State
308 { _values :: [(N.Name, Opt.Expr)]
309 , _graph :: Opt.Graph
310 }
313addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
314addRecDefs home defs graph =
315 let
316 cycleValues = foldr addValueName Set.empty defs
317 dummyName = Opt.Global home (N.toCompositeName (Set.toList cycleValues))
319 (deps, fields, State cyclicValuePairs newGraph) =
320 Names.run $
321 foldM (addRecDef home dummyName cycleValues) (State [] graph) defs
322 in
323 addToGraph dummyName (Opt.Cycle cyclicValuePairs deps) fields newGraph
326addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name
327addValueName def valueNames =
328 case def of
329 Can.Def (A.At _ name) [] _ ->
330 Set.insert name valueNames
332 Can.TypedDef (A.At _ name) _ [] _ _ ->
333 Set.insert name valueNames
335 _ ->
336 valueNames
340-- ADD RECURSIVE DEFS
343addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State
344addRecDef home dummyName cycle state@(State values graph) def =
345 case def of
346 Can.Def (A.At _ name) [] body ->
347 addRecValue home dummyName cycle name body state
349 Can.TypedDef (A.At _ name) _ [] body _ ->
350 addRecValue home dummyName cycle name body state
352 _ ->
353 let
354 (deps, fields, odef) =
355 Names.run (Expr.optimizePotentialTailCall cycle def)
356 in
357 pure $ State values $
358 case odef of
359 Opt.Def name body ->
360 let node = Opt.Define body deps in
361 addToGraph (Opt.Global home name) node fields graph
363 Opt.TailDef name args body ->
364 let node = Opt.DefineTailFunc args body deps in
365 addToGraph (Opt.Global home name) node fields graph
368addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State
369addRecValue home dummyName cycle name body (State values (Opt.Graph mains nodes fields)) =
370 do obody <- Expr.optimize cycle body
372 let global = Opt.Global home name
373 let node = Opt.Link dummyName
375 pure $
376 State
377 { _values = (name, obody) : values
378 , _graph = Opt.Graph mains (Map.insert global node nodes) fields
379 }