git.iko.soy/elk
on bfae985 help sign in
elk/src/AST/Expression/Optimized.hs
221 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 Data.Binary
12import qualified Data.Set as Set
13import Data.Text (Text)
15import qualified AST.Effects as Effects
16import qualified AST.Expression.Canonical as Can
17import qualified AST.Literal as Literal
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Type as Type
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 ModuleName.Canonical Text
54 | List [Expr]
55 | Binop ModuleName.Canonical Text 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 Type.Canonical
70 | IncomingPort Text Type.Canonical
71 | Program Can.Main Expr
72 | GLShader Text
73 | Crash ModuleName.Canonical R.Region (Maybe Expr)
76data Decider a
77 = Leaf a
78 | Chain
79 { _testChain :: [(DT.Path, DT.Test)]
80 , _success :: Decider a
81 , _failure :: Decider a
82 }
83 | FanOut
84 { _path :: DT.Path
85 , _tests :: [(DT.Test, Decider a)]
86 , _fallback :: Decider a
87 }
88 deriving (Eq)
91data Choice
92 = Inline Expr
93 | Jump Int
97-- BINARY
100instance Binary Decl where
101 get =
102 Decl <$> get <*> get <*> get
104 put (Decl deps fx body) =
105 put deps >> put fx >> put body
108instance Binary Def where
109 get =
110 do word <- getWord8
111 case word of
112 0 -> Def <$> get
113 1 -> TailDef <$> get <*> get
114 _ -> error "problem getting Opt.Def binary"
116 put def =
117 case def of
118 Def body ->
119 putWord8 0 >> put body
121 TailDef args body ->
122 putWord8 1 >> put args >> put body
125instance Binary Expr where
126 get =
127 do word <- getWord8
128 case word of
129 0 -> Literal <$> get
130 1 -> VarLocal <$> get
131 2 -> VarGlobal <$> get <*> get
132 3 -> List <$> get
133 4 -> Binop <$> get <*> get <*> get <*> get
134 5 -> Function <$> get <*> get
135 6 -> Call <$> get <*> get
136 7 -> TailCall <$> get <*> get <*> get
137 8 -> If <$> get <*> get
138 9 -> Let <$> get <*> get
139 10 -> Case <$> get <*> get <*> get
140 11 -> Ctor <$> get <*> get
141 12 -> CtorAccess <$> get <*> get
142 13 -> Access <$> get <*> get
143 14 -> Update <$> get <*> get
144 15 -> Record <$> get
145 16 -> Cmd <$> get <*> get
146 17 -> Sub <$> get <*> get
147 18 -> OutgoingPort <$> get <*> get
148 19 -> IncomingPort <$> get <*> get
149 20 -> Program <$> get <*> get
150 21 -> GLShader <$> get
151 22 -> Crash <$> get <*> get <*> get
152 _ -> error "problem getting Opt.Expr binary"
154 put expr =
155 case expr of
156 Literal a -> putWord8 0 >> put a
157 VarLocal a -> putWord8 1 >> put a
158 VarGlobal a b -> putWord8 2 >> put a >> put b
159 List a -> putWord8 3 >> put a
160 Binop a b c d -> putWord8 4 >> put a >> put b >> put c >> put d
161 Function a b -> putWord8 5 >> put a >> put b
162 Call a b -> putWord8 6 >> put a >> put b
163 TailCall a b c -> putWord8 7 >> put a >> put b >> put c
164 If a b -> putWord8 8 >> put a >> put b
165 Let a b -> putWord8 9 >> put a >> put b
166 Case a b c -> putWord8 10 >> put a >> put b >> put c
167 Ctor a b -> putWord8 11 >> put a >> put b
168 CtorAccess a b -> putWord8 12 >> put a >> put b
169 Access a b -> putWord8 13 >> put a >> put b
170 Update a b -> putWord8 14 >> put a >> put b
171 Record a -> putWord8 15 >> put a
172 Cmd a b -> putWord8 16 >> put a >> put b
173 Sub a b -> putWord8 17 >> put a >> put b
174 OutgoingPort a b -> putWord8 18 >> put a >> put b
175 IncomingPort a b -> putWord8 19 >> put a >> put b
176 Program a b -> putWord8 20 >> put a >> put b
177 GLShader a -> putWord8 21 >> put a
178 Crash a b c -> putWord8 22 >> put a >> put b >> put c
181instance (Binary a) => Binary (Decider a) where
182 get =
183 do word <- getWord8
184 case word of
185 0 -> Leaf <$> get
186 1 -> Chain <$> get <*> get <*> get
187 2 -> FanOut <$> get <*> get <*> get
188 _ -> error "problem getting Opt.Decider binary"
190 put decider =
191 case decider of
192 Leaf a ->
193 do putWord8 0
194 put a
196 Chain testChain success failure ->
197 do putWord8 1
198 put testChain
199 put success
200 put failure
202 FanOut path tests fallback ->
203 do putWord8 2
204 put path
205 put tests
206 put fallback
209instance Binary Choice where
210 put choice =
211 case choice of
212 Inline expr -> putWord8 0 >> put expr
213 Jump index -> putWord8 1 >> put index
215 get =
216 do word <- getWord8
217 case word of
218 0 -> Inline <$> get
219 1 -> Jump <$> get
220 _ -> error "problem getting Opt.Choice binary"