git.iko.soy/elk
on 46bc422 help sign in
elk/src/AST/Expression/Optimized.hs
222 lines 5.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module AST.Expression.Optimized
3 ( Decl(..)
4 , Def(..)
5 , Expr(..)
6 , Decider(..), Choice(..)
7 )
8 where
11import Control.Monad (liftM, liftM2, liftM3)
12import Data.Binary
13import qualified Data.Set as Set
14import Data.Text (Text)
16import qualified AST.Effects as Effects
17import qualified AST.Expression.Canonical as Can
18import qualified AST.Literal as Literal
19import qualified AST.Module.Name as ModuleName
20import qualified AST.Type as Type
21import qualified AST.Variable as Var
22import qualified Optimize.DecisionTree as DT
23import qualified Reporting.Region as R
27-- TOP LEVEL DECLARATIONS
30data Decl =
31 Decl
32 { _deps :: 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 Type.Canonical
71 | IncomingPort Text Type.Canonical
72 | Program Can.Main Expr
73 | GLShader Text
74 | Crash ModuleName.Canonical R.Region (Maybe Expr)
77data Decider a
78 = Leaf a
79 | Chain
80 { _testChain :: [(DT.Path, DT.Test)]
81 , _success :: Decider a
82 , _failure :: Decider a
83 }
84 | FanOut
85 { _path :: DT.Path
86 , _tests :: [(DT.Test, Decider a)]
87 , _fallback :: Decider a
88 }
89 deriving (Eq)
92data Choice
93 = Inline Expr
94 | Jump Int
98-- BINARY
101instance Binary Decl where
102 get =
103 liftM3 Decl get get get
105 put (Decl deps fx body) =
106 put deps >> put fx >> put body
109instance Binary Def where
110 get =
111 do word <- getWord8
112 case word of
113 0 -> Def <$> get
114 1 -> TailDef <$> get <*> get
115 _ -> error "problem getting Opt.Def binary"
117 put def =
118 case def of
119 Def body ->
120 putWord8 0 >> put body
122 TailDef args body ->
123 putWord8 1 >> put args >> put body
126instance Binary Expr where
127 get =
128 do word <- getWord8
129 case word of
130 0 -> liftM Literal get
131 1 -> liftM VarLocal get
132 2 -> liftM VarGlobal get
133 3 -> liftM List get
134 4 -> liftM3 Binop get get get
135 5 -> liftM2 Function get get
136 6 -> liftM2 Call get get
137 7 -> liftM3 TailCall get get get
138 8 -> liftM2 If get get
139 9 -> liftM2 Let get get
140 10 -> liftM3 Case get get get
141 11 -> liftM2 Ctor get get
142 12 -> liftM2 CtorAccess get get
143 13 -> liftM2 Access get get
144 14 -> liftM2 Update get get
145 15 -> liftM Record get
146 16 -> liftM2 Cmd get get
147 17 -> liftM2 Sub get get
148 18 -> liftM2 OutgoingPort get get
149 19 -> liftM2 IncomingPort get get
150 20 -> liftM2 Program get get
151 21 -> liftM GLShader get
152 22 -> liftM3 Crash get get get
153 _ -> error "problem getting Opt.Expr binary"
155 put expr =
156 case expr of
157 Literal a -> putWord8 0 >> put a
158 VarLocal a -> putWord8 1 >> put a
159 VarGlobal a -> putWord8 2 >> put a
160 List a -> putWord8 3 >> put a
161 Binop a b c -> putWord8 4 >> put a >> put b >> put c
162 Function a b -> putWord8 5 >> put a >> put b
163 Call a b -> putWord8 6 >> put a >> put b
164 TailCall a b c -> putWord8 7 >> put a >> put b >> put c
165 If a b -> putWord8 8 >> put a >> put b
166 Let a b -> putWord8 9 >> put a >> put b
167 Case a b c -> putWord8 10 >> put a >> put b >> put c
168 Ctor a b -> putWord8 11 >> put a >> put b
169 CtorAccess a b -> putWord8 12 >> put a >> put b
170 Access a b -> putWord8 13 >> put a >> put b
171 Update a b -> putWord8 14 >> put a >> put b
172 Record a -> putWord8 15 >> put a
173 Cmd a b -> putWord8 16 >> put a >> put b
174 Sub a b -> putWord8 17 >> put a >> put b
175 OutgoingPort a b -> putWord8 18 >> put a >> put b
176 IncomingPort a b -> putWord8 19 >> put a >> put b
177 Program a b -> putWord8 20 >> put a >> put b
178 GLShader a -> putWord8 21 >> put a
179 Crash a b c -> putWord8 22 >> put a >> put b >> put c
182instance (Binary a) => Binary (Decider a) where
183 get =
184 do word <- getWord8
185 case word of
186 0 -> liftM Leaf get
187 1 -> liftM3 Chain get get get
188 2 -> liftM3 FanOut get get get
189 _ -> error "problem getting Opt.Decider binary"
191 put decider =
192 case decider of
193 Leaf a ->
194 do putWord8 0
195 put a
197 Chain testChain success failure ->
198 do putWord8 1
199 put testChain
200 put success
201 put failure
203 FanOut path tests fallback ->
204 do putWord8 2
205 put path
206 put tests
207 put fallback
210instance Binary Choice where
211 put choice =
212 case choice of
213 Inline expr -> putWord8 0 >> put expr
214 Jump index -> putWord8 1 >> put index
216 get =
217 do word <- getWord8
218 case word of
219 0 -> liftM Inline get
220 1 -> liftM Jump get
221 _ -> error "problem getting Opt.Choice binary"