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