src/Symantic/Parser/Machine/Optimize.hs

   1 {-# LANGUAGE PatternSynonyms #-} -- For Instr
   2 {-# LANGUAGE ViewPatterns #-} -- For unSomeInstr
   3 {-# LANGUAGE UndecidableInstances #-}
   4 -- | Initial encoding with bottom-up optimizations of 'Instr'uctions,
   5 -- re-optimizing downward as needed after each optimization.
   6 -- There is only one optimization (for 'pushValue') so far,
   7 -- but the introspection enabled by the 'Instr' data-type
   8 -- is also useful to optimize with more context in the 'Machine'.
   9 module Symantic.Parser.Machine.Optimize where
  10
  11 import Data.Bool (Bool(..))
  12 import Data.Either (Either)
  13 import Data.Maybe (Maybe(..))
  14 import Data.Function ((.))
  15 import Data.Kind (Constraint)
  16 import Data.Proxy (Proxy(..))
  17 import GHC.TypeLits (KnownSymbol)
  18 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
  19 import qualified Data.Functor as Functor
  20
  21 import Symantic.Parser.Grammar
  22 import Symantic.Parser.Machine.Input
  23 import Symantic.Parser.Machine.Instructions
  24 import Symantic.Univariant.Trans
  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   (repr :: ReprInstr)
  32   :: ReprInstr
  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 give a more comprehensible code.
  52 data SomeInstr repr inp vs a =
  53   forall instr.
  54   (Trans (Instr instr repr inp vs) (repr inp vs), Typeable instr) =>
  55   SomeInstr (Instr instr repr inp vs a)
  56
  57 instance Trans (SomeInstr repr inp vs) (repr inp vs) where
  58   trans (SomeInstr x) = trans x
  59
  60 -- | @(unSomeInstr i :: 'Maybe' ('Instr' comb repr inp vs a))@
  61 -- extract the data-constructor from the given 'SomeInstr'
  62 -- iif. it belongs to the @('Instr' comb repr a)@ data-instance.
  63 unSomeInstr ::
  64   forall instr repr inp vs a.
  65   Typeable instr =>
  66   SomeInstr repr inp vs a ->
  67   Maybe (Instr instr repr inp vs a)
  68 unSomeInstr (SomeInstr (i::Instr i repr inp vs a)) =
  69   case typeRep @instr `eqTypeRep` typeRep @i of
  70     Just HRefl -> Just i
  71     Nothing -> Nothing
  72
  73 -- InstrValuable
  74 data instance Instr InstrValuable repr inp vs a where
  75   -- | @('PushValue' x k)@ pushes @(x)@ on the 'valueStack'
  76   -- and continues with the next 'Instr'uction @(k)@.
  77   PushValue ::
  78     TermInstr v ->
  79     SomeInstr repr inp (v ': vs) a ->
  80     Instr InstrValuable repr inp vs a
  81   -- | @('PopValue' k)@ pushes @(x)@ on the 'valueStack'.
  82   PopValue ::
  83     SomeInstr repr inp vs a ->
  84     Instr InstrValuable repr inp (v ': vs) a
  85   -- | @('Lift2Value' f k)@ pops two values from the 'valueStack',
  86   -- and pushes the result of @(f)@ applied to them.
  87   Lift2Value ::
  88     TermInstr (x -> y -> z) ->
  89     SomeInstr repr inp (z : vs) a ->
  90     Instr InstrValuable repr inp (y : x : vs) a
  91   -- | @('SwapValue' k)@ pops two values on the 'valueStack',
  92   -- pushes the first popped-out, then the second,
  93   -- and continues with the next 'Instr'uction @(k)@.
  94   SwapValue ::
  95     SomeInstr repr inp (x ': y ': vs) a ->
  96     Instr InstrValuable repr inp (y ': x ': vs) a
  97 instance InstrValuable repr => Trans (Instr InstrValuable repr inp vs) (repr inp vs) where
  98   trans = \case
  99     PushValue x k -> pushValue x (trans k)
 100     PopValue k -> popValue (trans k)
 101     Lift2Value f k -> lift2Value f (trans k)
 102     SwapValue k -> swapValue (trans k)
 103 instance InstrValuable repr => InstrValuable (SomeInstr repr) where
 104   pushValue _v (Instr (PopValue i)) = i
 105   pushValue v i = SomeInstr (PushValue v i)
 106   popValue = SomeInstr . PopValue
 107   lift2Value f = SomeInstr . Lift2Value f
 108   swapValue = SomeInstr . SwapValue
 109
 110 -- InstrExceptionable
 111 data instance Instr InstrExceptionable repr inp vs a where
 112   RaiseException ::
 113     KnownSymbol lbl =>
 114     Proxy lbl ->
 115     [ErrorItem (InputToken inp)] ->
 116     Instr InstrExceptionable repr inp vs a
 117   PopException ::
 118     KnownSymbol lbl =>
 119     Proxy lbl ->
 120     SomeInstr repr inp vs ret ->
 121     Instr InstrExceptionable repr inp vs ret
 122   CatchException ::
 123     KnownSymbol lbl =>
 124     Proxy lbl ->
 125     SomeInstr repr inp vs ret ->
 126     SomeInstr repr inp (Cursor inp ': vs) ret ->
 127     Instr InstrExceptionable repr inp vs ret
 128 instance InstrExceptionable repr => Trans (Instr InstrExceptionable repr inp vs) (repr inp vs) where
 129   trans = \case
 130     RaiseException lbl err -> raiseException lbl err
 131     PopException lbl k -> popException lbl (trans k)
 132     CatchException lbl l r -> catchException lbl (trans l) (trans r)
 133 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
 134   raiseException lbl = SomeInstr . RaiseException lbl
 135   popException lbl = SomeInstr . PopException lbl
 136   catchException lbl x = SomeInstr . CatchException lbl x
 137
 138 -- InstrBranchable
 139 data instance Instr InstrBranchable repr inp vs a where
 140   CaseBranch ::
 141     SomeInstr repr inp (x ': vs) a ->
 142     SomeInstr repr inp (y ': vs) a ->
 143     Instr InstrBranchable repr inp (Either x y ': vs) a
 144   ChoicesBranch ::
 145     [TermInstr (v -> Bool)] ->
 146     [SomeInstr repr inp vs a] ->
 147     SomeInstr repr inp vs a ->
 148     Instr InstrBranchable repr inp (v ': vs) a
 149 instance InstrBranchable repr => Trans (Instr InstrBranchable repr inp vs) (repr inp vs) where
 150   trans = \case
 151     CaseBranch l r -> caseBranch (trans l) (trans r)
 152     ChoicesBranch ps bs d -> choicesBranch ps (trans Functor.<$> bs) (trans d)
 153 instance InstrBranchable repr => InstrBranchable (SomeInstr repr) where
 154   caseBranch l = SomeInstr . CaseBranch l
 155   choicesBranch ps bs = SomeInstr . ChoicesBranch ps bs
 156
 157 -- InstrLetable
 158 data instance Instr InstrLetable repr inp vs a where
 159   DefLet ::
 160     LetName v ->
 161     SomeInstr repr inp '[] v ->
 162     SomeInstr repr inp vs a ->
 163     Instr InstrLetable repr inp vs a
 164   Call ::
 165     LetName v ->
 166     SomeInstr repr inp (v ': vs) a ->
 167     Instr InstrLetable repr inp vs a
 168   Ret ::
 169     Instr InstrLetable repr inp '[a] a
 170   Jump ::
 171     LetName a ->
 172     Instr InstrLetable repr inp '[] a
 173 instance InstrLetable repr => Trans (Instr InstrLetable repr inp vs) (repr inp vs) where
 174   trans = \case
 175     DefLet n sub k -> defLet n (trans sub) (trans k)
 176     Jump n -> jump n
 177     Call n k -> call n (trans k)
 178     Ret -> ret
 179 instance InstrLetable repr => InstrLetable (SomeInstr repr) where
 180   defLet n sub = SomeInstr . DefLet n sub
 181   jump = SomeInstr . Jump
 182   call n = SomeInstr . Call n
 183   ret = SomeInstr Ret
 184
 185 -- InstrJoinable
 186 data instance Instr InstrJoinable repr inp vs a where
 187   DefJoin ::
 188     LetName v ->
 189     SomeInstr repr inp (v ': vs) a ->
 190     SomeInstr repr inp vs a ->
 191     Instr InstrJoinable repr inp vs a
 192   RefJoin ::
 193     LetName v ->
 194     Instr InstrJoinable repr inp (v ': vs) a
 195 instance InstrJoinable repr => Trans (Instr InstrJoinable repr inp vs) (repr inp vs) where
 196   trans = \case
 197     DefJoin n sub k -> defJoin n (trans sub) (trans k)
 198     RefJoin n -> refJoin n
 199 instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
 200   defJoin n sub = SomeInstr . DefJoin n sub
 201   refJoin = SomeInstr . RefJoin
 202
 203 -- InstrInputable
 204 data instance Instr InstrInputable repr inp vs a where
 205   LoadInput ::
 206     SomeInstr repr inp vs a ->
 207     Instr InstrInputable repr inp (Cursor inp : vs) a
 208   PushInput ::
 209     SomeInstr repr inp (Cursor inp ': vs) a ->
 210     Instr InstrInputable repr inp vs a
 211 instance InstrInputable repr => Trans (Instr InstrInputable repr inp vs) (repr inp vs) where
 212   trans = \case
 213     LoadInput k -> loadInput (trans k)
 214     PushInput k -> pushInput (trans k)
 215 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
 216   loadInput = SomeInstr . LoadInput
 217   pushInput = SomeInstr . PushInput
 218
 219 -- InstrReadable
 220 data instance Instr (InstrReadable tok) repr inp vs a where
 221   Read ::
 222     [ErrorItem (InputToken inp)] ->
 223     TermInstr (InputToken inp -> Bool) ->
 224     SomeInstr repr inp (InputToken inp ': vs) a ->
 225     Instr (InstrReadable tok) repr inp vs a
 226 instance
 227   ( InstrReadable tok repr, tok ~ InputToken inp ) =>
 228   Trans (Instr (InstrReadable tok) repr inp vs) (repr inp vs) where
 229   trans = \case
 230     Read es p k -> read es p (trans k)
 231 instance
 232   ( InstrReadable tok repr, Typeable tok ) =>
 233   InstrReadable tok (SomeInstr repr) where
 234   read es p = SomeInstr . Read es p