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