]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Optimize.hs
9f71142b3bbaba8751e33cfe5c0f0f158100fb57
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Optimize.hs
1 {-# LANGUAGE PatternSynonyms #-} -- For Instr
2 {-# LANGUAGE ViewPatterns #-} -- For unSomeInstr
3 -- | Initial encoding with bottom-up optimizations of 'Instr'uctions,
4 -- re-optimizing downward as needed after each optimization.
5 -- There is only one optimization (for 'pushValue') so far,
6 -- but the introspection enabled by the 'Instr' data-type
7 -- is also useful to optimize with more context in the 'Machine'.
8 module Symantic.Parser.Machine.Optimize where
9
10 import Data.Bifunctor (second)
11 import Data.Bool (Bool(..))
12 import Data.Either (Either)
13 import Data.Function ((.))
14 import Data.Kind (Constraint)
15 import Data.Maybe (Maybe(..))
16 import Data.Set (Set)
17 import Data.String (String)
18 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
19 import qualified Data.Functor as Functor
20 import qualified Language.Haskell.TH as TH
21
22 import Symantic.Syntaxes.Derive
23 import Symantic.Parser.Grammar
24 import Symantic.Parser.Machine.Input
25 import Symantic.Parser.Machine.Instructions
26
27 -- * Data family 'Instr'
28 -- | 'Instr'uctions of the 'Machine'.
29 -- This is an extensible data-type.
30 data family Instr
31 (instr :: ReprInstr -> Constraint)
32 :: ReprInstr -> ReprInstr
33 type instance Derived (Instr instr repr inp vs) = repr inp vs
34
35 -- | Convenient utility to pattern-match a 'SomeInstr'.
36 pattern Instr :: Typeable instr =>
37 Instr instr repr inp vs a ->
38 SomeInstr repr inp vs a
39 pattern Instr x <- (unSomeInstr -> Just x)
40
41 -- ** Type 'SomeInstr'
42 -- | Some 'Instr'uction existentialized over the actual instruction symantic class.
43 -- Useful to handle a list of 'Instr'uctions
44 -- without requiring impredicative quantification.
45 -- Must be used by pattern-matching
46 -- on the 'SomeInstr' data-constructor,
47 -- to bring the constraints in scope.
48 --
49 -- As in 'SomeComb', a first pass of optimizations
50 -- is directly applied in it
51 -- to avoid introducing an extra newtype,
52 -- this also gives a more understandable code.
53 data SomeInstr repr inp vs a =
54 forall instr.
55 ( Derivable (Instr instr repr inp vs)
56 , Typeable instr
57 ) => SomeInstr (Instr instr repr inp vs a)
58
59 type instance Derived (SomeInstr repr inp vs) = repr inp vs
60 instance Derivable (SomeInstr repr inp vs) where
61 derive (SomeInstr x) = derive x
62
63 -- | @(unSomeInstr i :: 'Maybe' ('Instr' instr repr inp vs a))@
64 -- extract the data-constructor from the given 'SomeInstr'
65 -- iif. it belongs to the @('Instr' instr repr a)@ data-instance.
66 unSomeInstr ::
67 forall instr repr inp vs a.
68 Typeable instr =>
69 SomeInstr repr inp vs a ->
70 Maybe (Instr instr repr inp vs a)
71 unSomeInstr (SomeInstr (i::Instr i repr inp vs a)) =
72 case typeRep @instr `eqTypeRep` typeRep @i of
73 Just HRefl -> Just i
74 Nothing ->
75 case typeRep @InstrComment `eqTypeRep` typeRep @i of
76 Just HRefl | Comment _msg x <- i -> unSomeInstr x
77 Nothing -> Nothing
78
79 -- InstrComment
80 data instance Instr InstrComment repr inp vs a where
81 Comment ::
82 String ->
83 SomeInstr repr inp vs a ->
84 Instr InstrComment repr inp vs a
85 instance InstrComment repr => Derivable (Instr InstrComment repr inp vs) where
86 derive = \case
87 Comment msg k -> comment msg (derive k)
88 instance InstrComment repr => InstrComment (SomeInstr repr) where
89 comment msg = SomeInstr . Comment msg
90
91 -- InstrValuable
92 data instance Instr InstrValuable repr inp vs a where
93 PushValue ::
94 Splice v ->
95 SomeInstr repr inp (v ': vs) a ->
96 Instr InstrValuable repr inp vs a
97 PopValue ::
98 SomeInstr repr inp vs a ->
99 Instr InstrValuable repr inp (v ': vs) a
100 Lift2Value ::
101 Splice (x -> y -> z) ->
102 SomeInstr repr inp (z : vs) a ->
103 Instr InstrValuable repr inp (y : x : vs) a
104 SwapValue ::
105 SomeInstr repr inp (x ': y ': vs) a ->
106 Instr InstrValuable repr inp (y ': x ': vs) a
107 instance InstrValuable repr => Derivable (Instr InstrValuable repr inp vs) where
108 derive = \case
109 PushValue v k -> pushValue v (derive k)
110 PopValue k -> popValue (derive k)
111 Lift2Value v k -> lift2Value v (derive k)
112 SwapValue k -> swapValue (derive k)
113 instance InstrValuable repr => InstrValuable (SomeInstr repr) where
114 -- 'PopValue' after a 'PushValue' is a no-op.
115 pushValue _v (Instr (PopValue i)) = i
116 pushValue v i = SomeInstr (PushValue v i)
117 popValue = SomeInstr . PopValue
118 lift2Value f = SomeInstr . Lift2Value f
119 swapValue = SomeInstr . SwapValue
120
121 -- InstrExceptionable
122 data instance Instr InstrExceptionable repr inp vs a where
123 Raise ::
124 ExceptionLabel ->
125 Instr InstrExceptionable repr inp vs a
126 Fail ::
127 Set SomeFailure ->
128 Instr InstrExceptionable repr inp vs a
129 Commit ::
130 Exception ->
131 SomeInstr repr inp vs ret ->
132 Instr InstrExceptionable repr inp vs ret
133 Catch ::
134 Exception ->
135 SomeInstr repr inp vs ret ->
136 SomeInstr repr inp (InputPosition inp ': vs) ret ->
137 Instr InstrExceptionable repr inp vs ret
138 instance InstrExceptionable repr => Derivable (Instr InstrExceptionable repr inp vs) where
139 derive = \case
140 Raise exn -> raise exn
141 Fail fs -> fail fs
142 Commit exn k -> commit exn (derive k)
143 Catch exn l r -> catch exn (derive l) (derive r)
144 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
145 raise = SomeInstr . Raise
146 fail = SomeInstr . Fail
147 commit exn = SomeInstr . Commit exn
148 catch exn x = SomeInstr . Catch exn x
149
150 -- InstrBranchable
151 data instance Instr InstrBranchable repr inp vs a where
152 CaseBranch ::
153 SomeInstr repr inp (x ': vs) a ->
154 SomeInstr repr inp (y ': vs) a ->
155 Instr InstrBranchable repr inp (Either x y ': vs) a
156 ChoicesBranch ::
157 [(Splice (v -> Bool), SomeInstr repr inp vs a)] ->
158 SomeInstr repr inp vs a ->
159 Instr InstrBranchable repr inp (v ': vs) a
160 instance InstrBranchable repr => Derivable (Instr InstrBranchable repr inp vs) where
161 derive = \case
162 CaseBranch l r -> caseBranch (derive l) (derive r)
163 ChoicesBranch bs d -> choicesBranch (second derive Functor.<$> bs) (derive d)
164 instance InstrBranchable repr => InstrBranchable (SomeInstr repr) where
165 caseBranch l = SomeInstr . CaseBranch l
166 choicesBranch bs = SomeInstr . ChoicesBranch bs
167
168 -- InstrCallable
169 data instance Instr InstrCallable repr inp vs a where
170 DefLet ::
171 LetBindings TH.Name (SomeInstr repr inp '[]) ->
172 SomeInstr repr inp vs a ->
173 Instr InstrCallable repr inp vs a
174 Call ::
175 Bool ->
176 LetName v ->
177 SomeInstr repr inp (v ': vs) a ->
178 Instr InstrCallable repr inp vs a
179 Ret ::
180 Instr InstrCallable repr inp '[a] a
181 Jump ::
182 Bool ->
183 LetName a ->
184 Instr InstrCallable repr inp '[] a
185 instance InstrCallable repr => Derivable (Instr InstrCallable repr inp vs) where
186 derive = \case
187 DefLet subs k -> defLet ((\(SomeLet sub) -> SomeLet (derive sub)) Functor.<$> subs) (derive k)
188 Jump isRec n -> jump isRec n
189 Call isRec n k -> call isRec n (derive k)
190 Ret -> ret
191 instance InstrCallable repr => InstrCallable (SomeInstr repr) where
192 defLet subs = SomeInstr . DefLet subs
193 jump isRec = SomeInstr . Jump isRec
194 call isRec n = SomeInstr . Call isRec n
195 ret = SomeInstr Ret
196
197 -- InstrJoinable
198 data instance Instr InstrJoinable repr inp vs a where
199 DefJoin ::
200 LetName v ->
201 SomeInstr repr inp (v ': vs) a ->
202 SomeInstr repr inp vs a ->
203 Instr InstrJoinable repr inp vs a
204 RefJoin ::
205 LetName v ->
206 Instr InstrJoinable repr inp (v ': vs) a
207 instance InstrJoinable repr => Derivable (Instr InstrJoinable repr inp vs) where
208 derive = \case
209 DefJoin n sub k -> defJoin n (derive sub) (derive k)
210 RefJoin n -> refJoin n
211 instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
212 defJoin n sub = SomeInstr . DefJoin n sub
213 refJoin = SomeInstr . RefJoin
214
215 -- InstrInputable
216 data instance Instr InstrInputable repr inp vs a where
217 PushInput ::
218 SomeInstr repr inp (InputPosition inp ': vs) a ->
219 Instr InstrInputable repr inp vs a
220 LoadInput ::
221 SomeInstr repr inp vs a ->
222 Instr InstrInputable repr inp (InputPosition inp ': vs) a
223 instance InstrInputable repr => Derivable (Instr InstrInputable repr inp vs) where
224 derive = \case
225 PushInput k -> saveInput (derive k)
226 LoadInput k -> loadInput (derive k)
227 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
228 saveInput = SomeInstr . PushInput
229 loadInput = SomeInstr . LoadInput
230
231 -- InstrReadable
232 data instance Instr (InstrReadable tok) repr inp vs a where
233 Read ::
234 Set SomeFailure ->
235 Splice (InputToken inp -> Bool) ->
236 SomeInstr repr inp (InputToken inp ': vs) a ->
237 Instr (InstrReadable tok) repr inp vs a
238 instance
239 ( InstrReadable tok repr, tok ~ InputToken inp ) =>
240 Derivable (Instr (InstrReadable tok) repr inp vs) where
241 derive = \case
242 Read fs p k -> read fs p (derive k)
243 instance
244 ( InstrReadable tok repr, Typeable tok ) =>
245 InstrReadable tok (SomeInstr repr) where
246 read fs p = SomeInstr . Read fs p
247
248 -- InstrIterable
249 data instance Instr InstrIterable repr inp vs a where
250 Iter ::
251 LetName a ->
252 SomeInstr repr inp '[] a ->
253 SomeInstr repr inp (InputPosition inp ': vs) a ->
254 Instr InstrIterable repr inp vs a
255 instance
256 InstrIterable repr =>
257 Derivable (Instr InstrIterable repr inp vs) where
258 derive = \case
259 Iter n op k -> iter n (derive op) (derive k)
260 instance
261 InstrIterable repr =>
262 InstrIterable (SomeInstr repr) where
263 iter n op = SomeInstr . Iter n op
264
265 -- InstrRegisterable
266 data instance Instr InstrRegisterable repr inp vs a where
267 NewRegister ::
268 UnscopedRegister v ->
269 SomeInstr repr inp vs a ->
270 Instr InstrRegisterable repr inp (v : vs) a
271 ReadRegister ::
272 UnscopedRegister v ->
273 SomeInstr repr inp (v : vs) a ->
274 Instr InstrRegisterable repr inp vs a
275 WriteRegister ::
276 UnscopedRegister v ->
277 SomeInstr repr inp vs a ->
278 Instr InstrRegisterable repr inp (v : vs) a
279 instance
280 InstrRegisterable repr =>
281 Derivable (Instr InstrRegisterable repr inp vs) where
282 derive = \case
283 NewRegister r k -> newRegister r (derive k)
284 ReadRegister r k -> readRegister r (derive k)
285 WriteRegister r k -> writeRegister r (derive k)
286 instance
287 InstrRegisterable repr =>
288 InstrRegisterable (SomeInstr repr) where
289 newRegister r = SomeInstr . NewRegister r
290 readRegister r = SomeInstr . ReadRegister r
291 writeRegister r = SomeInstr . WriteRegister r