src/Symantic/Parser/Grammar/Observations.hs

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