git.iko.soy/elk
on e00a3f3 help sign in
elk/src/AST/Expression/Optimized.hs
244 lines 6.1 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, liftM4)
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 { _direct :: Set.Set Var.Global
32 , _indirect :: Set.Set Var.Global
33 , _effects :: Maybe Effects.ManagerType
34 , _body :: !Def
35 }
39-- DEFINITIONS
42data Def
43 = Def Expr
44 | TailDef [Text] Expr
48-- EXPRESSIONS
51data Expr
52 = Literal Literal.Literal
53 | VarLocal Text
54 | VarGlobal Var.Global
55 | List [Expr]
56 | Binop Var.Global Expr Expr
57 | Function [Text] Expr
58 | Call Expr [Expr]
59 | TailCall Text [Text] [Expr]
60 | If [(Expr, Expr)] Expr
61 | Let [(Text, Def)] Expr
62 | Case Text (Decider Choice) [(Int, Expr)]
63 | Ctor Text [Expr]
64 | CtorAccess Expr Int
65 | Access Expr Text
66 | Update Expr [(Text, Expr)]
67 | Record [(Text, Expr)]
68 | Cmd ModuleName.Canonical Effects.ManagerType
69 | Sub ModuleName.Canonical Effects.ManagerType
70 | OutgoingPort Text Expr
71 | IncomingPort Text Expr
72 | Program Main Expr
73 | GLShader Text
74 | Crash ModuleName.Canonical R.Region (Maybe Expr)
77data Main
78 = VDom
79 | NoFlags
80 | Flags Expr
83data Decider a
84 = Leaf a
85 | Chain
86 { _testChain :: [(DT.Path, DT.Test)]
87 , _success :: Decider a
88 , _failure :: Decider a
89 }
90 | FanOut
91 { _path :: DT.Path
92 , _tests :: [(DT.Test, Decider a)]
93 , _fallback :: Decider a
94 }
95 deriving (Eq)
98data Choice
99 = Inline Expr
100 | Jump Int
104-- BINARY
107instance Binary Decl where
108 get =
109 liftM4 Decl get get get get
111 put (Decl direct indirect fx body) =
112 put direct >> put indirect >> put fx >> put body
115instance Binary Def where
116 get =
117 do word <- getWord8
118 case word of
119 0 -> Def <$> get
120 1 -> TailDef <$> get <*> get
121 _ -> error "problem getting Opt.Def binary"
123 put def =
124 case def of
125 Def body ->
126 putWord8 0 >> put body
128 TailDef args body ->
129 putWord8 1 >> put args >> put body
132instance Binary Expr where
133 get =
134 do word <- getWord8
135 case word of
136 0 -> liftM Literal get
137 1 -> liftM VarLocal get
138 2 -> liftM VarGlobal get
139 3 -> liftM List get
140 4 -> liftM3 Binop get get get
141 5 -> liftM2 Function get get
142 6 -> liftM2 Call get get
143 7 -> liftM3 TailCall get get get
144 8 -> liftM2 If get get
145 9 -> liftM2 Let get get
146 10 -> liftM3 Case get get get
147 11 -> liftM2 Ctor get get
148 12 -> liftM2 CtorAccess get get
149 13 -> liftM2 Access get get
150 14 -> liftM2 Update get get
151 15 -> liftM Record get
152 16 -> liftM2 Cmd get get
153 17 -> liftM2 Sub get get
154 18 -> liftM2 OutgoingPort get get
155 19 -> liftM2 IncomingPort get get
156 20 -> liftM2 Program get get
157 21 -> liftM GLShader get
158 22 -> liftM3 Crash get get get
159 _ -> error "problem getting Opt.Expr binary"
161 put expr =
162 case expr of
163 Literal a -> putWord8 0 >> put a
164 VarLocal a -> putWord8 1 >> put a
165 VarGlobal a -> putWord8 2 >> put a
166 List a -> putWord8 3 >> put a
167 Binop a b c -> putWord8 4 >> put a >> put b >> put c
168 Function a b -> putWord8 5 >> put a >> put b
169 Call a b -> putWord8 6 >> put a >> put b
170 TailCall a b c -> putWord8 7 >> put a >> put b >> put c
171 If a b -> putWord8 8 >> put a >> put b
172 Let a b -> putWord8 9 >> put a >> put b
173 Case a b c -> putWord8 10 >> put a >> put b >> put c
174 Ctor a b -> putWord8 11 >> put a >> put b
175 CtorAccess a b -> putWord8 12 >> put a >> put b
176 Access a b -> putWord8 13 >> put a >> put b
177 Update a b -> putWord8 14 >> put a >> put b
178 Record a -> putWord8 15 >> put a
179 Cmd a b -> putWord8 16 >> put a >> put b
180 Sub a b -> putWord8 17 >> put a >> put b
181 OutgoingPort a b -> putWord8 18 >> put a >> put b
182 IncomingPort a b -> putWord8 19 >> put a >> put b
183 Program a b -> putWord8 20 >> put a >> put b
184 GLShader a -> putWord8 21 >> put a
185 Crash a b c -> putWord8 22 >> put a >> put b >> put c
188instance Binary Main where
189 put main =
190 case main of
191 VDom -> putWord8 0
192 NoFlags -> putWord8 1
193 Flags expr -> putWord8 2 >> put expr
195 get =
196 do word <- getWord8
197 case word of
198 0 -> pure VDom
199 1 -> pure NoFlags
200 2 -> liftM Flags get
201 _ -> error "problem getting Can.Main binary"
204instance (Binary a) => Binary (Decider a) where
205 get =
206 do word <- getWord8
207 case word of
208 0 -> liftM Leaf get
209 1 -> liftM3 Chain get get get
210 2 -> liftM3 FanOut get get get
211 _ -> error "problem getting Opt.Decider binary"
213 put decider =
214 case decider of
215 Leaf a ->
216 do putWord8 0
217 put a
219 Chain testChain success failure ->
220 do putWord8 1
221 put testChain
222 put success
223 put failure
225 FanOut path tests fallback ->
226 do putWord8 2
227 put path
228 put tests
229 put fallback
232instance Binary Choice where
233 put choice =
234 case choice of
235 Inline expr -> putWord8 0 >> put expr
236 Jump index -> putWord8 1 >> put index
238 get =
239 do word <- getWord8
240 case word of
241 0 -> liftM Inline get
242 1 -> liftM Jump get
243 _ -> error "problem getting Opt.Choice binary"