git.iko.soy/elk
on 60f4e71 help sign in
elk/src/AST/Expression/Optimized.hs
243 lines 6.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module AST.Expression.Optimized
3 ( Decl(..)
4 , Def(..)
5 , Expr(..)
6 , Main(..)
7 , Decider(..), Choice(..)
8 )
9 where
12import Control.Monad (liftM, liftM2, liftM3)
13import Data.Binary
14import qualified Data.Set as Set
15import Data.Text (Text)
17import qualified AST.Effects as Effects
18import qualified AST.Literal as Literal
19import qualified AST.Module.Name as ModuleName
20import qualified AST.Variable as Var
21import qualified Optimize.DecisionTree as DT
22import qualified Reporting.Region as R
26-- TOP LEVEL DECLARATIONS
29data Decl =
30 Decl
31 { _deps :: Set.Set Var.Global
32 , _effects :: Maybe Effects.ManagerType
33 , _body :: !Def
34 }
38-- DEFINITIONS
41data Def
42 = Def Expr
43 | TailDef [Text] Expr
47-- EXPRESSIONS
50data Expr
51 = Literal Literal.Literal
52 | VarLocal Text
53 | VarGlobal Var.Global
54 | List [Expr]
55 | Binop Var.Global Expr Expr
56 | Function [Text] Expr
57 | Call Expr [Expr]
58 | TailCall Text [Text] [Expr]
59 | If [(Expr, Expr)] Expr
60 | Let [(Text, Def)] Expr
61 | Case Text (Decider Choice) [(Int, Expr)]
62 | Ctor Text [Expr]
63 | CtorAccess Expr Int
64 | Access Expr Text
65 | Update Expr [(Text, Expr)]
66 | Record [(Text, Expr)]
67 | Cmd ModuleName.Canonical Effects.ManagerType
68 | Sub ModuleName.Canonical Effects.ManagerType
69 | OutgoingPort Text Expr
70 | IncomingPort Text Expr
71 | Program Main Expr
72 | GLShader Text
73 | Crash ModuleName.Canonical R.Region (Maybe Expr)
76data Main
77 = VDom
78 | NoFlags
79 | Flags Expr
82data Decider a
83 = Leaf a
84 | Chain
85 { _testChain :: [(DT.Path, DT.Test)]
86 , _success :: Decider a
87 , _failure :: Decider a
88 }
89 | FanOut
90 { _path :: DT.Path
91 , _tests :: [(DT.Test, Decider a)]
92 , _fallback :: Decider a
93 }
94 deriving (Eq)
97data Choice
98 = Inline Expr
99 | Jump Int
103-- BINARY
106instance Binary Decl where
107 get =
108 liftM3 Decl get get get
110 put (Decl deps fx body) =
111 put deps >> put fx >> put body
114instance Binary Def where
115 get =
116 do word <- getWord8
117 case word of
118 0 -> Def <$> get
119 1 -> TailDef <$> get <*> get
120 _ -> error "problem getting Opt.Def binary"
122 put def =
123 case def of
124 Def body ->
125 putWord8 0 >> put body
127 TailDef args body ->
128 putWord8 1 >> put args >> put body
131instance Binary Expr where
132 get =
133 do word <- getWord8
134 case word of
135 0 -> liftM Literal get
136 1 -> liftM VarLocal get
137 2 -> liftM VarGlobal get
138 3 -> liftM List get
139 4 -> liftM3 Binop get get get
140 5 -> liftM2 Function get get
141 6 -> liftM2 Call get get
142 7 -> liftM3 TailCall get get get
143 8 -> liftM2 If get get
144 9 -> liftM2 Let get get
145 10 -> liftM3 Case get get get
146 11 -> liftM2 Ctor get get
147 12 -> liftM2 CtorAccess get get
148 13 -> liftM2 Access get get
149 14 -> liftM2 Update get get
150 15 -> liftM Record get
151 16 -> liftM2 Cmd get get
152 17 -> liftM2 Sub get get
153 18 -> liftM2 OutgoingPort get get
154 19 -> liftM2 IncomingPort get get
155 20 -> liftM2 Program get get
156 21 -> liftM GLShader get
157 22 -> liftM3 Crash get get get
158 _ -> error "problem getting Opt.Expr binary"
160 put expr =
161 case expr of
162 Literal a -> putWord8 0 >> put a
163 VarLocal a -> putWord8 1 >> put a
164 VarGlobal a -> putWord8 2 >> put a
165 List a -> putWord8 3 >> put a
166 Binop a b c -> putWord8 4 >> put a >> put b >> put c
167 Function a b -> putWord8 5 >> put a >> put b
168 Call a b -> putWord8 6 >> put a >> put b
169 TailCall a b c -> putWord8 7 >> put a >> put b >> put c
170 If a b -> putWord8 8 >> put a >> put b
171 Let a b -> putWord8 9 >> put a >> put b
172 Case a b c -> putWord8 10 >> put a >> put b >> put c
173 Ctor a b -> putWord8 11 >> put a >> put b
174 CtorAccess a b -> putWord8 12 >> put a >> put b
175 Access a b -> putWord8 13 >> put a >> put b
176 Update a b -> putWord8 14 >> put a >> put b
177 Record a -> putWord8 15 >> put a
178 Cmd a b -> putWord8 16 >> put a >> put b
179 Sub a b -> putWord8 17 >> put a >> put b
180 OutgoingPort a b -> putWord8 18 >> put a >> put b
181 IncomingPort a b -> putWord8 19 >> put a >> put b
182 Program a b -> putWord8 20 >> put a >> put b
183 GLShader a -> putWord8 21 >> put a
184 Crash a b c -> putWord8 22 >> put a >> put b >> put c
187instance Binary Main where
188 put main =
189 case main of
190 VDom -> putWord8 0
191 NoFlags -> putWord8 1
192 Flags expr -> putWord8 2 >> put expr
194 get =
195 do word <- getWord8
196 case word of
197 0 -> pure VDom
198 1 -> pure NoFlags
199 2 -> liftM Flags get
200 _ -> error "problem getting Can.Main binary"
203instance (Binary a) => Binary (Decider a) where
204 get =
205 do word <- getWord8
206 case word of
207 0 -> liftM Leaf get
208 1 -> liftM3 Chain get get get
209 2 -> liftM3 FanOut get get get
210 _ -> error "problem getting Opt.Decider binary"
212 put decider =
213 case decider of
214 Leaf a ->
215 do putWord8 0
216 put a
218 Chain testChain success failure ->
219 do putWord8 1
220 put testChain
221 put success
222 put failure
224 FanOut path tests fallback ->
225 do putWord8 2
226 put path
227 put tests
228 put fallback
231instance Binary Choice where
232 put choice =
233 case choice of
234 Inline expr -> putWord8 0 >> put expr
235 Jump index -> putWord8 1 >> put index
237 get =
238 do word <- getWord8
239 case word of
240 0 -> liftM Inline get
241 1 -> liftM Jump get
242 _ -> error "problem getting Opt.Choice binary"