git.iko.soy/elk
on c19392f help sign in
elk/src/AST/Expression/Optimized.hs
241 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, 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 = Static
79 | Dynamic 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 liftM4 Decl get get get get
110 put (Decl direct indirect fx body) =
111 put direct >> put indirect >> 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 Static -> putWord8 0
191 Dynamic expr -> putWord8 1 >> put expr
193 get =
194 do word <- getWord8
195 case word of
196 0 -> pure Static
197 1 -> liftM Dynamic get
198 _ -> error "problem getting Opt.Main binary"
201instance (Binary a) => Binary (Decider a) where
202 get =
203 do word <- getWord8
204 case word of
205 0 -> liftM Leaf get
206 1 -> liftM3 Chain get get get
207 2 -> liftM3 FanOut get get get
208 _ -> error "problem getting Opt.Decider binary"
210 put decider =
211 case decider of
212 Leaf a ->
213 do putWord8 0
214 put a
216 Chain testChain success failure ->
217 do putWord8 1
218 put testChain
219 put success
220 put failure
222 FanOut path tests fallback ->
223 do putWord8 2
224 put path
225 put tests
226 put fallback
229instance Binary Choice where
230 put choice =
231 case choice of
232 Inline expr -> putWord8 0 >> put expr
233 Jump index -> putWord8 1 >> put index
235 get =
236 do word <- getWord8
237 case word of
238 0 -> liftM Inline get
239 1 -> liftM Jump get
240 _ -> error "problem getting Opt.Choice binary"