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 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.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 comb =>
  36   Instr comb 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 undestandable 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' 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 ->
  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     Set SomeFailure ->
 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 (Cursor 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 ((\(p,b) -> (p, derive b)) 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 (Cursor inp ': vs) a ->
 218     Instr InstrInputable repr inp vs a
 219   LoadInput ::
 220     SomeInstr repr inp vs a ->
 221     Instr InstrInputable repr inp (Cursor inp ': vs) a
 222 instance InstrInputable repr => Derivable (Instr InstrInputable repr inp vs) where
 223   derive = \case
 224     PushInput k -> pushInput (derive k)
 225     LoadInput k -> loadInput (derive k)
 226 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
 227   pushInput = SomeInstr . PushInput
 228   loadInput = SomeInstr . LoadInput
 229
 230 -- InstrReadable
 231 data instance Instr (InstrReadable tok) repr inp vs a where
 232   Read ::
 233     Set SomeFailure ->
 234     Splice (InputToken inp -> Bool) ->
 235     SomeInstr repr inp (InputToken inp ': vs) a ->
 236     Instr (InstrReadable tok) repr inp vs a
 237 instance
 238   ( InstrReadable tok repr, tok ~ InputToken inp ) =>
 239   Derivable (Instr (InstrReadable tok) repr inp vs) where
 240   derive = \case
 241     Read fs p k -> read fs p (derive k)
 242 instance
 243   ( InstrReadable tok repr, Typeable tok ) =>
 244   InstrReadable tok (SomeInstr repr) where
 245   read fs p = SomeInstr . Read fs p
 246
 247 -- InstrIterable
 248 data instance Instr InstrIterable repr inp vs a where
 249   Iter ::
 250     LetName a ->
 251     SomeInstr repr inp '[] a ->
 252     SomeInstr repr inp (Cursor inp ': vs) a ->
 253     Instr InstrIterable repr inp vs a
 254 instance
 255   InstrIterable repr =>
 256   Derivable (Instr InstrIterable repr inp vs) where
 257   derive = \case
 258     Iter n op k -> iter n (derive op) (derive k)
 259 instance
 260   InstrIterable repr =>
 261   InstrIterable (SomeInstr repr) where
 262   iter n op = SomeInstr . Iter n op
 263
 264 -- InstrRegisterable
 265 data instance Instr InstrRegisterable repr inp vs a where
 266   NewRegister ::
 267     UnscopedRegister v ->
 268     SomeInstr repr inp vs a ->
 269     Instr InstrRegisterable repr inp (v : vs) a
 270   ReadRegister ::
 271     UnscopedRegister v ->
 272     SomeInstr repr inp (v : vs) a ->
 273     Instr InstrRegisterable repr inp vs a
 274   WriteRegister ::
 275     UnscopedRegister v ->
 276     SomeInstr repr inp vs a ->
 277     Instr InstrRegisterable repr inp (v : vs) a
 278 instance
 279   InstrRegisterable repr =>
 280   Derivable (Instr InstrRegisterable repr inp vs) where
 281   derive = \case
 282     NewRegister r k -> newRegister r (derive k)
 283     ReadRegister r k -> readRegister r (derive k)
 284     WriteRegister r k -> writeRegister r (derive k)
 285 instance
 286   InstrRegisterable repr =>
 287   InstrRegisterable (SomeInstr repr) where
 288   newRegister r = SomeInstr . NewRegister r
 289   readRegister r = SomeInstr . ReadRegister r
 290   writeRegister r = SomeInstr . WriteRegister r