git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/AST/Optimized.hs
451 lines 12 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module AST.Optimized
3 ( Def(..)
4 , Expr(..)
5 , Global(..)
6 , Path(..)
7 , Destructor(..)
8 , Decider(..)
9 , Choice(..)
10 , GlobalGraph(..)
11 , LocalGraph(..)
12 , Main(..)
13 , Node(..)
14 , EffectsType(..)
15 , empty
16 , addGlobalGraph
17 , addLocalGraph
18 , addKernel
19 , toKernelGlobal
20 )
21 where
24import Control.Monad (liftM, liftM2, liftM3, liftM4)
25import Data.Binary (Binary, get, put, getWord8, putWord8)
26import qualified Data.Map as Map
27import qualified Data.Name as Name
28import Data.Name (Name)
29import qualified Data.Set as Set
31import qualified AST.Canonical as Can
32import qualified AST.Utils.Shader as Shader
33import qualified Data.Index as Index
34import qualified Elm.Float as EF
35import qualified Elm.Kernel as K
36import qualified Elm.ModuleName as ModuleName
37import qualified Elm.Package as Pkg
38import qualified Elm.String as ES
39import qualified Optimize.DecisionTree as DT
40import qualified Reporting.Annotation as A
44-- EXPRESSIONS
47data Expr
48 = Bool Bool
49 | Chr ES.String
50 | Str ES.String
51 | Int Int
52 | Float EF.Float
53 | VarLocal Name
54 | VarGlobal Global
55 | VarEnum Global Index.ZeroBased
56 | VarBox Global
57 | VarCycle ModuleName.Canonical Name
58 | VarDebug Name ModuleName.Canonical A.Region (Maybe Name)
59 | VarKernel Name Name
60 | List [Expr]
61 | Function [Name] Expr
62 | Call Expr [Expr]
63 | TailCall Name [(Name, Expr)]
64 | If [(Expr, Expr)] Expr
65 | Let Def Expr
66 | Destruct Destructor Expr
67 | Case Name Name (Decider Choice) [(Int, Expr)]
68 | Accessor Name
69 | Access Expr Name
70 | Update Expr (Map.Map Name Expr)
71 | Record (Map.Map Name Expr)
72 | Unit
73 | Tuple Expr Expr (Maybe Expr)
74 | Shader Shader.Source (Set.Set Name) (Set.Set Name)
77data Global = Global ModuleName.Canonical Name
81-- DEFINITIONS
84data Def
85 = Def Name Expr
86 | TailDef Name [Name] Expr
89data Destructor =
90 Destructor Name Path
93data Path
94 = Index Index.ZeroBased Path
95 | Field Name Path
96 | Unbox Path
97 | Root Name
101-- BRANCHING
104data Decider a
105 = Leaf a
106 | Chain
107 { _testChain :: [(DT.Path, DT.Test)]
108 , _success :: Decider a
109 , _failure :: Decider a
110 }
111 | FanOut
112 { _path :: DT.Path
113 , _tests :: [(DT.Test, Decider a)]
114 , _fallback :: Decider a
115 }
116 deriving (Eq)
119data Choice
120 = Inline Expr
121 | Jump Int
125-- OBJECT GRAPH
128data GlobalGraph =
129 GlobalGraph
130 { _g_nodes :: Map.Map Global Node
131 , _g_fields :: Map.Map Name Int
132 }
135data LocalGraph =
136 LocalGraph
137 { _l_main :: Maybe Main
138 , _l_nodes :: Map.Map Global Node -- TODO profile switching Global to Name
139 , _l_fields :: Map.Map Name Int
140 }
143data Main
144 = Static
145 | Dynamic
146 { _message :: Can.Type
147 , _decoder :: Expr
148 }
151data Node
152 = Define Expr (Set.Set Global)
153 | DefineTailFunc [Name] Expr (Set.Set Global)
154 | Ctor Index.ZeroBased Int
155 | Enum Index.ZeroBased
156 | Box
157 | Link Global
158 | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global)
159 | Manager EffectsType
160 | Kernel [K.Chunk] (Set.Set Global)
161 | PortIncoming Expr (Set.Set Global)
162 | PortOutgoing Expr (Set.Set Global)
165data EffectsType = Cmd | Sub | Fx
169-- GRAPHS
172{-# NOINLINE empty #-}
173empty :: GlobalGraph
174empty =
175 GlobalGraph Map.empty Map.empty
178addGlobalGraph :: GlobalGraph -> GlobalGraph -> GlobalGraph
179addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) =
180 GlobalGraph
181 { _g_nodes = Map.union nodes1 nodes2
182 , _g_fields = Map.union fields1 fields2
183 }
186addLocalGraph :: LocalGraph -> GlobalGraph -> GlobalGraph
187addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) =
188 GlobalGraph
189 { _g_nodes = Map.union nodes1 nodes2
190 , _g_fields = Map.union fields1 fields2
191 }
194addKernel :: Name.Name -> [K.Chunk] -> GlobalGraph -> GlobalGraph
195addKernel shortName chunks (GlobalGraph nodes fields) =
196 let
197 global = toKernelGlobal shortName
198 node = Kernel chunks (foldr addKernelDep Set.empty chunks)
199 in
200 GlobalGraph
201 { _g_nodes = Map.insert global node nodes
202 , _g_fields = Map.union (K.countFields chunks) fields
203 }
206addKernelDep :: K.Chunk -> Set.Set Global -> Set.Set Global
207addKernelDep chunk deps =
208 case chunk of
209 K.JS _ -> deps
210 K.ElmVar home name -> Set.insert (Global home name) deps
211 K.JsVar shortName _ -> Set.insert (toKernelGlobal shortName) deps
212 K.ElmField _ -> deps
213 K.JsField _ -> deps
214 K.JsEnum _ -> deps
215 K.Debug -> deps
216 K.Prod -> deps
219toKernelGlobal :: Name.Name -> Global
220toKernelGlobal shortName =
221 Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar
225-- INSTANCES
228instance Eq Global where
229 (==) (Global home1 name1) (Global home2 name2) =
230 name1 == name2 && home1 == home2
233instance Ord Global where
234 compare (Global home1 name1) (Global home2 name2) =
235 case compare name1 name2 of
236 LT -> LT
237 EQ -> compare home1 home2
238 GT -> GT
242-- BINARY
245instance Binary Global where
246 get = liftM2 Global get get
247 put (Global a b) = put a >> put b
250instance Binary Expr where
251 put expr =
252 case expr of
253 Bool a -> putWord8 0 >> put a
254 Chr a -> putWord8 1 >> put a
255 Str a -> putWord8 2 >> put a
256 Int a -> putWord8 3 >> put a
257 Float a -> putWord8 4 >> put a
258 VarLocal a -> putWord8 5 >> put a
259 VarGlobal a -> putWord8 6 >> put a
260 VarEnum a b -> putWord8 7 >> put a >> put b
261 VarBox a -> putWord8 8 >> put a
262 VarCycle a b -> putWord8 9 >> put a >> put b
263 VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d
264 VarKernel a b -> putWord8 11 >> put a >> put b
265 List a -> putWord8 12 >> put a
266 Function a b -> putWord8 13 >> put a >> put b
267 Call a b -> putWord8 14 >> put a >> put b
268 TailCall a b -> putWord8 15 >> put a >> put b
269 If a b -> putWord8 16 >> put a >> put b
270 Let a b -> putWord8 17 >> put a >> put b
271 Destruct a b -> putWord8 18 >> put a >> put b
272 Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d
273 Accessor a -> putWord8 20 >> put a
274 Access a b -> putWord8 21 >> put a >> put b
275 Update a b -> putWord8 22 >> put a >> put b
276 Record a -> putWord8 23 >> put a
277 Unit -> putWord8 24
278 Tuple a b c -> putWord8 25 >> put a >> put b >> put c
279 Shader a b c -> putWord8 26 >> put a >> put b >> put c
281 get =
282 do word <- getWord8
283 case word of
284 0 -> liftM Bool get
285 1 -> liftM Chr get
286 2 -> liftM Str get
287 3 -> liftM Int get
288 4 -> liftM Float get
289 5 -> liftM VarLocal get
290 6 -> liftM VarGlobal get
291 7 -> liftM2 VarEnum get get
292 8 -> liftM VarBox get
293 9 -> liftM2 VarCycle get get
294 10 -> liftM4 VarDebug get get get get
295 11 -> liftM2 VarKernel get get
296 12 -> liftM List get
297 13 -> liftM2 Function get get
298 14 -> liftM2 Call get get
299 15 -> liftM2 TailCall get get
300 16 -> liftM2 If get get
301 17 -> liftM2 Let get get
302 18 -> liftM2 Destruct get get
303 19 -> liftM4 Case get get get get
304 20 -> liftM Accessor get
305 21 -> liftM2 Access get get
306 22 -> liftM2 Update get get
307 23 -> liftM Record get
308 24 -> pure Unit
309 25 -> liftM3 Tuple get get get
310 26 -> liftM3 Shader get get get
311 _ -> error "problem getting Opt.Expr binary"
314instance Binary Def where
315 put def =
316 case def of
317 Def a b -> putWord8 0 >> put a >> put b
318 TailDef a b c -> putWord8 1 >> put a >> put b >> put c
320 get =
321 do word <- getWord8
322 case word of
323 0 -> liftM2 Def get get
324 1 -> liftM3 TailDef get get get
325 _ -> error "problem getting Opt.Def binary"
328instance Binary Destructor where
329 get = liftM2 Destructor get get
330 put (Destructor a b) = put a >> put b
333instance Binary Path where
334 put destructor =
335 case destructor of
336 Index a b -> putWord8 0 >> put a >> put b
337 Field a b -> putWord8 1 >> put a >> put b
338 Unbox a -> putWord8 2 >> put a
339 Root a -> putWord8 3 >> put a
341 get =
342 do word <- getWord8
343 case word of
344 0 -> liftM2 Index get get
345 1 -> liftM2 Field get get
346 2 -> liftM Unbox get
347 3 -> liftM Root get
348 _ -> error "problem getting Opt.Path binary"
351instance (Binary a) => Binary (Decider a) where
352 put decider =
353 case decider of
354 Leaf a -> putWord8 0 >> put a
355 Chain a b c -> putWord8 1 >> put a >> put b >> put c
356 FanOut a b c -> putWord8 2 >> put a >> put b >> put c
358 get =
359 do word <- getWord8
360 case word of
361 0 -> liftM Leaf get
362 1 -> liftM3 Chain get get get
363 2 -> liftM3 FanOut get get get
364 _ -> error "problem getting Opt.Decider binary"
367instance Binary Choice where
368 put choice =
369 case choice of
370 Inline expr -> putWord8 0 >> put expr
371 Jump index -> putWord8 1 >> put index
373 get =
374 do word <- getWord8
375 case word of
376 0 -> liftM Inline get
377 1 -> liftM Jump get
378 _ -> error "problem getting Opt.Choice binary"
382instance Binary GlobalGraph where
383 get = liftM2 GlobalGraph get get
384 put (GlobalGraph a b) = put a >> put b
387instance Binary LocalGraph where
388 get = liftM3 LocalGraph get get get
389 put (LocalGraph a b c) = put a >> put b >> put c
392instance Binary Main where
393 put main =
394 case main of
395 Static -> putWord8 0
396 Dynamic a b -> putWord8 1 >> put a >> put b
398 get =
399 do word <- getWord8
400 case word of
401 0 -> return Static
402 1 -> liftM2 Dynamic get get
403 _ -> error "problem getting Opt.Main binary"
406instance Binary Node where
407 put node =
408 case node of
409 Define a b -> putWord8 0 >> put a >> put b
410 DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
411 Ctor a b -> putWord8 2 >> put a >> put b
412 Enum a -> putWord8 3 >> put a
413 Box -> putWord8 4
414 Link a -> putWord8 5 >> put a
415 Cycle a b c d -> putWord8 6 >> put a >> put b >> put c >> put d
416 Manager a -> putWord8 7 >> put a
417 Kernel a b -> putWord8 8 >> put a >> put b
418 PortIncoming a b -> putWord8 9 >> put a >> put b
419 PortOutgoing a b -> putWord8 10 >> put a >> put b
421 get =
422 do word <- getWord8
423 case word of
424 0 -> liftM2 Define get get
425 1 -> liftM3 DefineTailFunc get get get
426 2 -> liftM2 Ctor get get
427 3 -> liftM Enum get
428 4 -> return Box
429 5 -> liftM Link get
430 6 -> liftM4 Cycle get get get get
431 7 -> liftM Manager get
432 8 -> liftM2 Kernel get get
433 9 -> liftM2 PortIncoming get get
434 10 -> liftM2 PortOutgoing get get
435 _ -> error "problem getting Opt.Node binary"
438instance Binary EffectsType where
439 put effectsType =
440 case effectsType of
441 Cmd -> putWord8 0
442 Sub -> putWord8 1
443 Fx -> putWord8 2
445 get =
446 do word <- getWord8
447 case word of
448 0 -> return Cmd
449 1 -> return Sub
450 2 -> return Fx
451 _ -> error "problem getting Opt.EffectsType binary"