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
22
23
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
30
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
41
42
43
44-- EXPRESSIONS
45
46
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)
75
76
77data Global = Global ModuleName.Canonical Name
78
79
80
81-- DEFINITIONS
82
83
84data Def
85  = Def Name Expr
86  | TailDef Name [Name] Expr
87
88
89data Destructor =
90  Destructor Name Path
91
92
93data Path
94  = Index Index.ZeroBased Path
95  | Field Name Path
96  | Unbox Path
97  | Root Name
98
99
100
101-- BRANCHING
102
103
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)
117
118
119data Choice
120  = Inline Expr
121  | Jump Int
122
123
124
125-- OBJECT GRAPH
126
127
128data GlobalGraph =
129  GlobalGraph
130    { _g_nodes :: Map.Map Global Node
131    , _g_fields :: Map.Map Name Int
132    }
133
134
135data LocalGraph =
136  LocalGraph
137    { _l_main :: Maybe Main
138    , _l_nodes :: Map.Map Global Node  -- PERF profile switching Global to Name
139    , _l_fields :: Map.Map Name Int
140    }
141
142
143data Main
144  = Static
145  | Dynamic
146      { _message :: Can.Type
147      , _decoder :: Expr
148      }
149
150
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)
163
164
165data EffectsType = Cmd | Sub | Fx
166
167
168
169-- GRAPHS
170
171
172{-# NOINLINE empty #-}
173empty :: GlobalGraph
174empty =
175  GlobalGraph Map.empty Map.empty
176
177
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    }
184
185
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    }
192
193
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    }
204
205
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
217
218
219toKernelGlobal :: Name.Name -> Global
220toKernelGlobal shortName =
221  Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar
222
223
224
225-- INSTANCES
226
227
228instance Eq Global where
229  (==) (Global home1 name1) (Global home2 name2) =
230    name1 == name2 && home1 == home2
231
232
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
239
240
241
242-- BINARY
243
244
245instance Binary Global where
246  get = liftM2 Global get get
247  put (Global a b) = put a >> put b
248
249
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
280
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          _  -> fail "problem getting Opt.Expr binary"
312
313
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
319
320  get =
321    do  word <- getWord8
322        case word of
323          0 -> liftM2 Def get get
324          1 -> liftM3 TailDef get get get
325          _ -> fail "problem getting Opt.Def binary"
326
327
328instance Binary Destructor where
329  get = liftM2 Destructor get get
330  put (Destructor a b) = put a >> put b
331
332
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
340
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          _ -> fail "problem getting Opt.Path binary"
349
350
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
357
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          _ -> fail "problem getting Opt.Decider binary"
365
366
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
372
373  get =
374    do  word <- getWord8
375        case word of
376          0 -> liftM Inline get
377          1 -> liftM Jump get
378          _ -> fail "problem getting Opt.Choice binary"
379
380
381
382instance Binary GlobalGraph where
383  get = liftM2 GlobalGraph get get
384  put (GlobalGraph a b) = put a >> put b
385
386
387instance Binary LocalGraph where
388  get = liftM3 LocalGraph get get get
389  put (LocalGraph a b c) = put a >> put b >> put c
390
391
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
397
398  get =
399    do  word <- getWord8
400        case word of
401          0 -> return Static
402          1 -> liftM2 Dynamic get get
403          _ -> fail "problem getting Opt.Main binary"
404
405
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
420
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          _  -> fail "problem getting Opt.Node binary"
436
437
438instance Binary EffectsType where
439  put effectsType =
440    case effectsType of
441      Cmd -> putWord8 0
442      Sub -> putWord8 1
443      Fx  -> putWord8 2
444
445  get =
446    do  word <- getWord8
447        case word of
448          0 -> return Cmd
449          1 -> return Sub
450          2 -> return Fx
451          _ -> fail "problem getting Opt.EffectsType binary"
452