git.iko.soy/elk
on a798228 help sign in
elk/compiler/src/Optimize/Module.hs
373 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.Module.Name as ModuleName
20import qualified AST.Utils.Type as Type
21import qualified Canonicalize.Effects as Effects
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 Name.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 Name.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 Name.Name Can.Alias -> Opt.Graph -> Opt.Graph
88addAliases home aliases graph =
89 Map.foldrWithKey (addAlias home) graph aliases
92addAlias :: ModuleName.Canonical -> Name.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 :: Name.Name -> Can.FieldType -> Map.Map Name.Name Int -> Map.Map Name.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 -> Name.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 Name.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 == 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.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 -> Name.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 /= 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 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 == Name.node ->
263 Result.ok $ addMain $ Names.run $
264 Names.registerKernel Name.virtualDom Opt.Static
266 Can.TType hm nm [flags, _, message] | hm == ModuleName.platform && nm == Name.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 -> Name.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 :: [(Name.Name, Opt.Expr)]
304 , _functions :: [Opt.Def]
305 }
308addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
309addRecDefs home defs (Opt.Graph mains nodes fieldCounts) =
310 let
311 names = reverse (map toName defs)
312 cycleName = Opt.Global home (Name.fromManyNames names)
313 cycle = foldr addValueName Set.empty defs
314 links = foldr (addLink home (Opt.Link cycleName)) Map.empty defs
316 (deps, fields, State values funcs) =
317 Names.run $
318 foldM (addRecDef cycle) (State [] []) defs
319 in
320 Opt.Graph
321 mains
322 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
323 (Map.unionWith (+) fields fieldCounts)
326toName :: Can.Def -> Name.Name
327toName def =
328 case def of
329 Can.Def (A.At _ name) _ _ -> name
330 Can.TypedDef (A.At _ name) _ _ _ _ -> name
333addValueName :: Can.Def -> Set.Set Name.Name -> Set.Set Name.Name
334addValueName def names =
335 case def of
336 Can.Def (A.At _ name) args _ -> if null args then Set.insert name names else names
337 Can.TypedDef (A.At _ name) _ args _ _ -> if null args then Set.insert name names else names
340addLink :: ModuleName.Canonical -> Opt.Node -> Can.Def -> Map.Map Opt.Global Opt.Node -> Map.Map Opt.Global Opt.Node
341addLink home link def links =
342 case def of
343 Can.Def (A.At _ name) _ _ ->
344 Map.insert (Opt.Global home name) link links
346 Can.TypedDef (A.At _ name) _ _ _ _ ->
347 Map.insert (Opt.Global home name) link links
351-- ADD RECURSIVE DEFS
354addRecDef :: Set.Set Name.Name -> State -> Can.Def -> Names.Tracker State
355addRecDef cycle state def =
356 case def of
357 Can.Def (A.At _ name) args body ->
358 addRecDefHelp cycle state name args body
360 Can.TypedDef (A.At _ name) _ args body _ ->
361 addRecDefHelp cycle state name (map fst args) body
364addRecDefHelp :: Set.Set Name.Name -> State -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker State
365addRecDefHelp cycle (State values funcs) name args body =
366 case args of
367 [] ->
368 do obody <- Expr.optimize cycle body
369 pure $ State ((name, obody) : values) funcs
371 _:_ ->
372 do odef <- Expr.optimizePotentialTailCall cycle name args body
373 pure $ State values (odef : funcs)