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