src/Symantic/Parser/Grammar/Observations.hs

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