src/Symantic/Parser/Grammar/Observations.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DerivingStrategies #-}
   3 {-# LANGUAGE ExistentialQuantification #-}
   4 {-# LANGUAGE MagicHash #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE MultiWayIf #-}
   7 {-# LANGUAGE UndecidableInstances #-}
   8 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
   9 module Symantic.Parser.Grammar.Observations where
  10
  11 import Control.Monad (Monad(..), mapM_, when)
  12 -- import Data.String (String)
  13 -- import Data.Array (Ix)
  14 -- import Data.Bool
  15 -- import Data.Dependent.Map (DMap)
  16 import Data.Eq (Eq(..))
  17 import Data.Function (($), id)
  18 import Data.Functor (Functor(..))
  19 -- import Data.Functor.Identity (Identity(..))
  20 -- import Data.GADT.Compare (GEq, GCompare, gcompare, geq, GOrdering(..))
  21 import Data.HashMap.Strict (HashMap)
  22 import Data.HashSet (HashSet)
  23 import Data.Hashable (Hashable, hashWithSalt, hash)
  24 -- import Data.IORef (IORef, newIORef, readIORef, writeIORef)
  25 -- import Data.Kind (Type)
  26 -- import Data.Functor.Constant (Constant(..))
  27 -- import Data.Functor.Compose (Compose(..))
  28 import Data.Maybe (Maybe(..), isNothing, maybe)
  29 import Data.Monoid (Monoid(..))
  30 import Data.Ord (Ord(..))
  31 -- import Data.Set (Set, foldr)
  32 -- import Data.Typeable ((:~:)(Refl))
  33 -- import Data.Word (Word64)
  34 -- import Debug.Trace (trace)
  35 import GHC.Exts (Int(..))
  36 import GHC.Prim (StableName#, unsafeCoerce#)
  37 import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
  38 import Numeric (showHex)
  39 import Prelude ((+))
  40 -- import Prelude (Num(..), Enum(..))
  41 import System.IO.Unsafe (unsafePerformIO)
  42 import Text.Show (Show(..))
  43 -- import Unsafe.Coerce (unsafeCoerce)
  44 -- import Prelude (undefined)
  45 import qualified Control.Monad.Trans.Class as T
  46 import qualified Control.Monad.Trans.Reader as R
  47 -- import qualified Control.Monad.Trans.Writer as W
  48 import qualified Control.Monad.Trans.State as S
  49
  50 -- import qualified Data.Dependent.Map  as DMap
  51 import qualified Data.HashMap.Strict as HM
  52 import qualified Data.HashSet        as HS
  53 --import qualified Data.Map            as Map
  54 --import qualified Data.Set            as Set
  55
  56 import Symantic.Base.Univariant
  57 import qualified Symantic.Parser.Grammar.Combinators as P
  58 --import qualified Symantic.Parser.Staging as P
  59
  60 {-
  61 newtype IMVar = IMVar Word64 deriving newtype (Ord, Eq, Num, Enum, Show, Ix)
  62 newtype MVar (a :: Type) = MVar IMVar
  63 instance Show (MVar a) where show (MVar m) = "m" <> show m
  64
  65 instance GEq MVar where
  66   geq (MVar u) (MVar v)
  67     | u == v    = Just (unsafeCoerce Refl)
  68     | otherwise = Nothing
  69 instance GCompare MVar where
  70   gcompare m1@(MVar u) m2@(MVar v) =
  71     case compare u v of
  72       LT -> GLT
  73       EQ -> case geq m1 m2 of Just Refl -> GEQ
  74       GT -> GGT
  75 -}
  76
  77 -- * Type 'ParserName'
  78 data ParserName = forall a. ParserName (StableName# a)
  79 makeParserName :: repr a -> ParserName
  80 -- Force evaluation of p to ensure that the stableName is correct first time
  81 makeParserName !p = unsafePerformIO $ fmap (\(StableName name) -> ParserName name) (makeStableName p)
  82 instance Eq ParserName where
  83   (ParserName n) == (ParserName m) = eqStableName (StableName n) (StableName m)
  84 instance Hashable ParserName where
  85   hash (ParserName n) = hashStableName (StableName n)
  86   hashWithSalt salt (ParserName n) = hashWithSalt salt (StableName n)
  87
  88 instance Show ParserName where showsPrec _ (ParserName n) = showHex (I# (unsafeCoerce# n))
  89
  90 -- * Type 'Lets'
  91 -- | Interpret combinators as 'ParserName'
  92 newtype Lets a = Lets { unLets :: R.ReaderT (HashSet ParserName) (S.State LetsState) () }
  93
  94 lets :: Lets a -> (HashSet ParserName, HashSet ParserName)
  95 lets (Lets m) =
  96   let st = S.execState (R.runReaderT m mempty) emptyLetsState in
  97   ( HM.keysSet (HM.filter (> 1) (lets_preds st))
  98   , lets_recs st
  99   )
 100
 101 letsNode :: Lets a -> Lets a
 102 letsNode (Lets m) = Lets $ do
 103   let name = makeParserName m
 104   st <- T.lift S.get
 105   let (before, preds) = HM.alterF (\v -> (v, Just (maybe 1 (+ 1) v))) name (lets_preds st)
 106   seen <- R.ask
 107   if --trace (ind<>"at:    "<>show name) $
 108     HS.member name seen
 109   then --trace (ind<>"skipR: "<>show name) $
 110     T.lift $ S.put st
 111      { lets_preds = preds
 112      , lets_recs = HS.insert name (lets_recs st)
 113      }
 114   else do
 115     T.lift $ S.put st{ lets_preds = preds }
 116     when (isNothing before) $
 117       R.local (HS.insert name) m
 118     {-
 119     if trace (ind<>"b?:    "<>show name) $ before /= Nothing
 120      then trace (ind<>"SKIPB: "<>show name) $ return ()
 121      else trace (ind<>"first: "<>show name) $
 122         R.local (\(m,i) -> (HS.insert name m, ind<>"  ")) r
 123     -}
 124
 125 -- | This is an uncommon 'Unlift' definition which unlifts nothing,
 126 -- but it enables to leverage default definitions.
 127 type instance Unlift Lets = Lets
 128 instance Liftable Lets where
 129   lift _x = letsNode (Lets (return ()))
 130   lift1 _f x = letsNode (Lets (unLets x))
 131   lift2 _f x y = letsNode (Lets (unLets x >> unLets y))
 132   lift3 _f x y z = letsNode (Lets (unLets x >> unLets y >> unLets z))
 133 instance Unliftable Lets where
 134   unlift = id
 135 instance P.Applicable Lets
 136 instance P.Alternable Lets
 137 instance P.Selectable Lets
 138 instance P.Matchable Lets where
 139   -- Here the default definition does not fit since there is no lift* for its type and thus handles 'bs' itself, which is not the transformation wanted.
 140   conditional _cs bs a b =
 141     letsNode (Lets (mapM_ unLets bs >> unLets a >> unLets b))
 142 instance P.Foldable Lets
 143 instance P.Charable Lets
 144 instance P.Lookable Lets
 145
 146 -- ** Type 'LetsState'
 147 data LetsState = LetsState
 148  { lets_preds :: HashMap ParserName Int
 149  , lets_recs  :: HashSet ParserName
 150  } deriving (Show)
 151
 152 emptyLetsState :: LetsState
 153 emptyLetsState = LetsState
 154  { lets_preds = HM.empty
 155  , lets_recs  = HS.empty
 156  }
 157
 158
 159
 160 {-
 161 type Binding o a x = Fix4 (Instr o) '[] One x a
 162 data LetBinding o a x = forall rs. LetBinding (Binding o a x) (Regs rs)
 163 deriving instance Show (LetBinding o a x)
 164
 165 makeLetBinding :: Binding o a x -> Set IΣVar -> LetBinding o a x
 166 makeLetBinding m rs = LetBinding m (unsafeMakeRegs rs)
 167
 168 data Regs (rs :: [Type]) where
 169   NoRegs :: Regs '[]
 170   FreeReg :: ΣVar r -> Regs rs -> Regs (r : rs)
 171 deriving instance Show (Regs rs)
 172
 173 unsafeMakeRegs :: Set IΣVar -> Regs rs
 174 unsafeMakeRegs =  foldr (\σ rs -> unsafeCoerce (FreeReg (ΣVar σ) rs)) (unsafeCoerce NoRegs)
 175
 176 compile :: forall compiled a. Parser a -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set IΣVar -> IMVar -> IΣVar -> compiled x) -> (compiled a, DMap MVar compiled)
 177 compile (Parser p) codeGen = trace ("COMPILING NEW PARSER WITH " ++ show (DMap.size μs') ++ " LET BINDINGS") $ (codeGen' Nothing p', DMap.mapWithKey (codeGen' . Just) μs')
 178   where
 179     (p', μs, maxV) = preprocess p
 180     (μs', frs, maxΣ) = dependencyAnalysis p' μs
 181
 182     freeRegs :: Maybe (MVar x) -> Set IΣVar
 183     freeRegs = maybe Set.empty (\(MVar v) -> frs Map.! v)
 184
 185     codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x
 186     codeGen' letBound p = codeGen letBound (analyse (emptyFlags {letBound = isJust letBound}) p) (freeRegs letBound) (maxV + 1) (maxΣ + 1)
 187
 188 preprocess :: Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
 189 preprocess p =
 190   let q = tagParser p
 191       (lets, recs) = findLets q
 192       (p', μs, maxV) = letInsertion lets recs q
 193   in (p', μs, maxV)
 194
 195 data Tag t f (k :: Type -> Type) a = Tag {tag :: t, tagged :: f k a}
 196
 197 tagParser :: Fix (Combinator :+: ScopeRegister) a -> Fix (Tag ParserName Combinator) a
 198 tagParser p = cata' tagAlg p
 199   where
 200     tagAlg p = In . Tag (makeParserName p) . (id \/ descope)
 201     descope (ScopeRegister p f) = freshReg regMaker (\(reg@(Reg σ)) -> MakeRegister σ p (f reg))
 202     regMaker :: IORef IΣVar
 203     regMaker = newRegMaker p
 204
 205
 206 newtype LetInserter a =
 207   LetInserter {
 208       doLetInserter :: HFreshT IMVar
 209                        (State ( HashMap ParserName IMVar
 210                               , DMap MVar (Fix Combinator)))
 211                        (Fix Combinator a)
 212     }
 213 letInsertion :: HashSet ParserName -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
 214 letInsertion lets recs p = (p', μs, μMax)
 215   where
 216     m = cata alg p
 217     ((p', μMax), (_, μs)) = runState (runFreshT (doLetInserter m) 0) (HashMap.empty, DMap.empty)
 218     alg :: Tag ParserName Combinator LetInserter a -> LetInserter a
 219     alg p = LetInserter $ do
 220       let name = tag p
 221       let q = tagged p
 222       (vs, μs) <- get
 223       let bound = HashSet.member name lets
 224       let recu = HashSet.member name recs
 225       if bound || recu then case HashMap.lookup name vs of
 226         Just v  -> let μ = MVar v in return $! optimise (Let recu μ (μs DMap.! μ))
 227         Nothing -> mdo
 228           v <- newVar
 229           let μ = MVar v
 230           put (HashMap.insert name v vs, DMap.insert μ q' μs)
 231           q' <- doLetInserter (postprocess q)
 232           return $! optimise (Let recu μ q')
 233       else do doLetInserter (postprocess q)
 234
 235 postprocess :: Combinator LetInserter a -> LetInserter a
 236 postprocess = LetInserter . fmap optimise . traverseCombinator doLetInserter
 237
 238 getBefore :: MonadState LetsState m => m (HashSet ParserName)
 239 getBefore = gets before
 240
 241
 242
 243
 244
 245
 246
 247
 248 makeParserName :: Fix (Combinator :+: ScopeRegister) a -> ParserName
 249 -- Force evaluation of p to ensure that the stableName is correct first time
 250 makeParserName !p = unsafePerformIO (fmap (\(StableName name) -> ParserName name) (makeStableName p))
 251
 252 -- The argument here stops GHC from floating it out, it should be provided something from the scope
 253 {-# NOINLINE newRegMaker #-}
 254 newRegMaker :: a -> IORef IΣVar
 255 newRegMaker x = x `seq` unsafePerformIO (newIORef 0)
 256
 257 {-# NOINLINE freshReg #-}
 258 freshReg :: IORef IΣVar -> (forall r. Reg r a -> x) -> x
 259 freshReg maker scope = scope $ unsafePerformIO $ do
 260   x <- readIORef maker
 261   writeIORef maker (x + 1)
 262   return $! Reg (ΣVar x)
 263
 264 instance IFunctor f => IFunctor (Tag t f) where
 265   imap f (Tag t k) = Tag t (imap f k)
 266
 267 instance Eq ParserName where
 268   (ParserName n) == (ParserName m) = eqStableName (StableName n) (StableName m)
 269 instance Hashable ParserName where
 270   hash (ParserName n) = hashStableName (StableName n)
 271   hashWithSalt salt (ParserName n) = hashWithSalt salt (StableName n)
 272
 273 -- There is great evil in this world, and I'm probably responsible for half of it
 274 instance Show ParserName where showsPrec _ (ParserName n) = showHex (I# (unsafeCoerce# n))
 275 -}