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 v k -> pushValue v (derive k)
  94     PopValue k -> popValue (derive k)
  95     Lift2Value v k -> lift2Value v (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 ((\(p,b) -> (p, derive b)) 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     Bool ->
 160     LetName v ->
 161     SomeInstr repr inp (v ': vs) a ->
 162     Instr InstrCallable repr inp vs a
 163   Ret ::
 164     Instr InstrCallable repr inp '[a] a
 165   Jump ::
 166     Bool ->
 167     LetName a ->
 168     Instr InstrCallable repr inp '[] a
 169 instance InstrCallable repr => Derivable (Instr InstrCallable repr inp vs) where
 170   derive = \case
 171     DefLet subs k -> defLet ((\(SomeLet sub) -> SomeLet (derive sub)) Functor.<$> subs) (derive k)
 172     Jump isRec n -> jump isRec n
 173     Call isRec n k -> call isRec n (derive k)
 174     Ret -> ret
 175 instance InstrCallable repr => InstrCallable (SomeInstr repr) where
 176   defLet subs = SomeInstr . DefLet subs
 177   jump isRec = SomeInstr . Jump isRec
 178   call isRec n = SomeInstr . Call isRec n
 179   ret = SomeInstr Ret
 180
 181 -- InstrJoinable
 182 data instance Instr InstrJoinable repr inp vs a where
 183   DefJoin ::
 184     LetName v ->
 185     SomeInstr repr inp (v ': vs) a ->
 186     SomeInstr repr inp vs a ->
 187     Instr InstrJoinable repr inp vs a
 188   RefJoin ::
 189     LetName v ->
 190     Instr InstrJoinable repr inp (v ': vs) a
 191 instance InstrJoinable repr => Derivable (Instr InstrJoinable repr inp vs) where
 192   derive = \case
 193     DefJoin n sub k -> defJoin n (derive sub) (derive k)
 194     RefJoin n -> refJoin n
 195 instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
 196   defJoin n sub = SomeInstr . DefJoin n sub
 197   refJoin = SomeInstr . RefJoin
 198
 199 -- InstrInputable
 200 data instance Instr InstrInputable repr inp vs a where
 201   PushInput ::
 202     SomeInstr repr inp (Cursor inp ': vs) a ->
 203     Instr InstrInputable repr inp vs a
 204   LoadInput ::
 205     SomeInstr repr inp vs a ->
 206     Instr InstrInputable repr inp (Cursor inp ': vs) a
 207 instance InstrInputable repr => Derivable (Instr InstrInputable repr inp vs) where
 208   derive = \case
 209     PushInput k -> pushInput (derive k)
 210     LoadInput k -> loadInput (derive k)
 211 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
 212   pushInput = SomeInstr . PushInput
 213   loadInput = SomeInstr . LoadInput
 214
 215 -- InstrReadable
 216 data instance Instr (InstrReadable tok) repr inp vs a where
 217   Read ::
 218     Set SomeFailure ->
 219     Splice (InputToken inp -> Bool) ->
 220     SomeInstr repr inp (InputToken inp ': vs) a ->
 221     Instr (InstrReadable tok) repr inp vs a
 222 instance
 223   ( InstrReadable tok repr, tok ~ InputToken inp ) =>
 224   Derivable (Instr (InstrReadable tok) repr inp vs) where
 225   derive = \case
 226     Read fs p k -> read fs p (derive k)
 227 instance
 228   ( InstrReadable tok repr, Typeable tok ) =>
 229   InstrReadable tok (SomeInstr repr) where
 230   read fs p = SomeInstr . Read fs p
 231
 232 -- InstrIterable
 233 data instance Instr InstrIterable repr inp vs a where
 234   Iter ::
 235     LetName a ->
 236     SomeInstr repr inp '[] a ->
 237     SomeInstr repr inp (Cursor inp ': vs) a ->
 238     Instr InstrIterable repr inp vs a
 239 instance
 240   InstrIterable repr =>
 241   Derivable (Instr InstrIterable repr inp vs) where
 242   derive = \case
 243     Iter n op k -> iter n (derive op) (derive k)
 244 instance
 245   InstrIterable repr =>
 246   InstrIterable (SomeInstr repr) where
 247   iter n op = SomeInstr . Iter n op
 248
 249 -- InstrRegisterable
 250 data instance Instr InstrRegisterable repr inp vs a where
 251   NewRegister ::
 252     UnscopedRegister v ->
 253     SomeInstr repr inp vs a ->
 254     Instr InstrRegisterable repr inp (v : vs) a
 255   ReadRegister ::
 256     UnscopedRegister v ->
 257     SomeInstr repr inp (v : vs) a ->
 258     Instr InstrRegisterable repr inp vs a
 259   WriteRegister ::
 260     UnscopedRegister v ->
 261     SomeInstr repr inp vs a ->
 262     Instr InstrRegisterable repr inp (v : vs) a
 263 instance
 264   InstrRegisterable repr =>
 265   Derivable (Instr InstrRegisterable repr inp vs) where
 266   derive = \case
 267     NewRegister r k -> newRegister r (derive k)
 268     ReadRegister r k -> readRegister r (derive k)
 269     WriteRegister r k -> writeRegister r (derive k)
 270 instance
 271   InstrRegisterable repr =>
 272   InstrRegisterable (SomeInstr repr) where
 273   newRegister r = SomeInstr . NewRegister r
 274   readRegister r = SomeInstr . ReadRegister r
 275   writeRegister r = SomeInstr . WriteRegister r