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 Data.String (String)
  27 import qualified Control.Monad.Trans.Class as MT
  28 import qualified Control.Monad.Trans.Reader as MT
  29 import qualified Control.Monad.Trans.State as MT
  30 import qualified Language.Haskell.TH.Syntax as TH
  31
  32 import qualified Data.HashMap.Strict as HM
  33 import qualified Data.HashSet        as HS
  34
  35 import Symantic.Base.Univariant
  36 import qualified Symantic.Parser.Grammar.Combinators as P
  37 import qualified Symantic.Parser.Staging as Hask
  38
  39 -- * Type 'ParserName'
  40 data ParserName = forall a. ParserName (StableName a)
  41 -- Force evaluation of p to ensure that the StableName is correct first time
  42 makeParserName :: repr a -> IO ParserName
  43 makeParserName !p = fmap ParserName (makeStableName p)
  44 instance Eq ParserName where
  45   ParserName n == ParserName m = eqStableName n m
  46 instance Hashable ParserName where
  47   hash (ParserName n) = hashStableName n
  48   hashWithSalt salt (ParserName n) = hashWithSalt salt n
  49
  50 instance Show ParserName where showsPrec _ (ParserName n) = showHex (I# (unsafeCoerce# n))
  51
  52 {-
  53 -- * Type 'ObsDef'
  54 newtype ObsDef repr a = ObsDef { unObsDef :: IO (repr a) }
  55 obsDef :: ObsDef repr a -> ObsDef repr a
  56 obsDef = id
  57 type instance Unlift (ObsDef repr) = repr
  58 instance Sharable repr => Liftable (ObsDef repr) where
  59   lift a = ObsDef $ do
  60     let node = a
  61     name <- show <$> makeParserName node
  62     return $ def name node
  63   lift1 f x = ObsDef $ do
  64     x' <- unObsDef x
  65     let node = f x'
  66     name <- show <$> makeParserName node
  67     return $ def name node
  68   lift2 f x y = ObsDef $ do
  69     x' <- unObsDef x
  70     y' <- unObsDef y
  71     let node = f x' y'
  72     name <- show <$> makeParserName node
  73     return $ def name node
  74   lift3 f x y z = ObsDef $ do
  75     x' <- unObsDef x
  76     y' <- unObsDef y
  77     z' <- unObsDef z
  78     let node = f x' y' z'
  79     name <- show <$> makeParserName node
  80     return $ def name node
  81 instance (P.Applicable repr, Sharable repr) => P.Applicable (ObsDef repr)
  82 instance (P.Alternable repr, Sharable repr) => P.Alternable (ObsDef repr)
  83 instance (P.Selectable repr, Sharable repr) => P.Selectable (ObsDef repr)
  84 instance (P.Matchable repr, Sharable repr) => P.Matchable (ObsDef repr) where
  85   conditional cs bs a b = ObsDef $ do
  86     -- P.conditional cs <$> mapM unObsDef bs <*> unObsDef a <*> unObsDef b
  87     bs' <- mapM unObsDef bs
  88     a' <- unObsDef a
  89     b' <- unObsDef b
  90     let node = P.conditional cs bs' a' b'
  91     name <- show <$> makeParserName node
  92     return $ def name node
  93 instance (P.Charable repr, Sharable repr) => P.Charable (ObsDef repr)
  94 -}
  95
  96 -- * Type 'ObsSharing'
  97 -- | Combinator interpreter detecting (Haskell embedded) @let@ definitions and recursive points in order to replace them with the 'let_' combinator.
  98 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
  99 newtype ObsSharing repr a = ObsSharing { unObsSharing ::
 100   MT.ReaderT (HashSet String)
 101              (MT.StateT ObsSharingState IO)
 102              (repr a) }
 103
 104 runObsSharing :: ObsSharing repr a -> IO (repr a)
 105 runObsSharing (ObsSharing os) = MT.evalStateT (MT.runReaderT os mempty) emptyObsSharingState
 106
 107 -- runObsSharing_ (ObsSharing m) = MT.runStateT (MT.runReaderT m mempty) emptyObsSharingState
 108
 109 -- ** Type 'ObsSharingState'
 110 data ObsSharingState = ObsSharingState
 111  { obsSharing_refs :: HashMap String Int
 112  , obsSharing_recs :: HashSet String
 113  } deriving (Show)
 114
 115 emptyObsSharingState :: ObsSharingState
 116 emptyObsSharingState = ObsSharingState
 117  { obsSharing_refs = HM.empty
 118  , obsSharing_recs = HS.empty
 119  }
 120
 121 -- ** Class 'Sharable'
 122 class Sharable repr where
 123  def :: String -> repr a -> repr a
 124  ref :: Bool -> String -> repr a
 125
 126 --obsSharing :: Sharable repr => ObsSharing repr a -> ObsSharing repr a
 127 obsSharing !m = ObsSharing $ trace "obsSharing" $ do
 128   name <- MT.lift $ MT.lift $ makeParserName m
 129   let pName =  trace ("obsSharing: pName="<>show name) $ show name
 130   st <- MT.lift MT.get
 131   let (before, preds) = HM.alterF (\v -> (v, Just (maybe 1 (+ 1) v))) pName (obsSharing_refs st)
 132   seen <- MT.ask
 133   let ind = ""
 134   if trace (ind<>"at:    "<>show pName) $
 135     HS.member pName seen
 136   then trace (ind<>"skipR: "<>show pName) $ do
 137     -- letName <- MT.lift $ MT.lift $ TH.qNewName ("let"<>show pName)
 138     MT.lift $ MT.put st
 139      { obsSharing_refs = preds
 140      , obsSharing_recs = HS.insert pName (obsSharing_recs st)
 141      }
 142     return $ ref True pName
 143   else do
 144     MT.lift $ MT.put st{ obsSharing_refs = preds }
 145     if trace (ind<>"b?:    "<>show pName) $ isNothing before
 146      then trace (ind<>"first: "<>show pName) $
 147       def pName <$> MT.local (HS.insert pName) (m)
 148      else trace (ind<>"SKIPB: "<>show pName) $
 149       return $ ref False pName
 150
 151 type instance Unlift (ObsSharing repr) = repr
 152 instance Sharable repr => Liftable (ObsSharing repr) where
 153   lift x = obsSharing (return x)
 154   lift1 f x = obsSharing (f <$> unObsSharing x)
 155   lift2 f x y = obsSharing (f <$> unObsSharing x <*> unObsSharing y)
 156   lift3 f x y z = obsSharing (f <$> unObsSharing x <*> unObsSharing y <*> unObsSharing z)
 157 instance (Sharable repr, P.Charable repr) => P.Charable (ObsSharing repr)
 158 instance (Sharable repr, P.Alternable repr) => P.Alternable (ObsSharing repr)
 159 instance (Sharable repr, P.Applicable repr) => P.Applicable (ObsSharing repr)
 160 instance (Sharable repr, P.Selectable repr) => P.Selectable (ObsSharing repr)
 161 instance (Sharable repr, P.Matchable repr) => P.Matchable (ObsSharing repr) where
 162   -- 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.
 163   conditional cs bs a b =
 164     (ObsSharing (P.conditional cs <$> mapM unObsSharing bs <*> unObsSharing a <*> unObsSharing b))
 165 instance (Sharable repr, P.Foldable repr) => P.Foldable (ObsSharing repr)
 166 instance (Sharable repr, P.Lookable repr) => P.Lookable (ObsSharing repr)
 167 {-
 168 instance Sharable repr => Sharable (ObsSharing repr) where
 169   ref isRec defName = ObsSharing $
 170     return $ ref isRec defName
 171   def defName (ObsSharing m) = ObsSharing $ do
 172     st <- MT.lift MT.get
 173     let (before, preds) = HM.alterF (\v -> (v, Just (maybe 1 (+ 1) v))) defName (obsSharing_refs st)
 174     seen <- MT.ask
 175     let ind = ""
 176     if trace (ind<>"at:    "<>show defName) $
 177       HS.member defName seen
 178     then trace (ind<>"skipR: "<>show defName) $ do
 179       -- letName <- MT.lift $ MT.lift $ TH.qNewName ("let"<>show defName)
 180       MT.lift $ MT.put st
 181        { obsSharing_refs = preds
 182        , obsSharing_recs = HS.insert defName (obsSharing_recs st)
 183        }
 184       return $ ref True defName
 185     else do
 186       MT.lift $ MT.put st{ obsSharing_refs = preds }
 187       if trace (ind<>"b?:    "<>show defName) $ isNothing before
 188        then trace (ind<>"first: "<>show defName) $
 189         MT.local (HS.insert defName) (def defName <$> m)
 190        else trace (ind<>"SKIPB: "<>show defName) $
 191         return $ ref False defName
 192 -}
 193
 194 {-
 195 newtype IMVar = IMVar Word64 deriving newtype (Ord, Eq, Num, Enum, Show, Ix)
 196 newtype MVar (a :: Type) = MVar IMVar
 197 instance Show (MVar a) where show (MVar m) = "m" <> show m
 198
 199 instance GEq MVar where
 200   geq (MVar u) (MVar v)
 201     | u == v    = Just (unsafeCoerce Refl)
 202     | otherwise = Nothing
 203 instance GCompare MVar where
 204   gcompare m1@(MVar u) m2@(MVar v) =
 205     case compare u v of
 206       LT -> GLT
 207       EQ -> case geq m1 m2 of Just Refl -> GEQ
 208       GT -> GGT
 209 -}
 210 {-
 211 type Binding o a x = Fix4 (Instr o) '[] One x a
 212 data LetBinding o a x = forall rs. LetBinding (Binding o a x) (Regs rs)
 213 deriving instance Show (LetBinding o a x)
 214
 215 makeLetBinding :: Binding o a x -> Set IΣVar -> LetBinding o a x
 216 makeLetBinding m rs = LetBinding m (unsafeMakeRegs rs)
 217
 218 data Regs (rs :: [Type]) where
 219   NoRegs :: Regs '[]
 220   FreeReg :: ΣVar r -> Regs rs -> Regs (r : rs)
 221 deriving instance Show (Regs rs)
 222
 223 unsafeMakeRegs :: Set IΣVar -> Regs rs
 224 unsafeMakeRegs =  foldr (\σ rs -> unsafeCoerce (FreeReg (ΣVar σ) rs)) (unsafeCoerce NoRegs)
 225
 226 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)
 227 compile (Parser p) codeGen = trace ("COMPILING NEW PARSER WITH " ++ show (DMap.size μs') ++ " LET BINDINGS") $ (codeGen' Nothing p', DMap.mapWithKey (codeGen' . Just) μs')
 228   where
 229     (p', μs, maxV) = preprocess p
 230     (μs', frs, maxΣ) = dependencyAnalysis p' μs
 231
 232     freeRegs :: Maybe (MVar x) -> Set IΣVar
 233     freeRegs = maybe Set.empty (\(MVar v) -> frs Map.! v)
 234
 235     codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x
 236     codeGen' letBound p = codeGen letBound (analyse (emptyFlags {letBound = isJust letBound}) p) (freeRegs letBound) (maxV + 1) (maxΣ + 1)
 237
 238 preprocess :: Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
 239 preprocess p =
 240   let q = tagParser p
 241       (lets, recs) = findObsSharing q
 242       (p', μs, maxV) = letInsertion lets recs q
 243   in (p', μs, maxV)
 244
 245 data Tag t f (k :: Type -> Type) a = Tag {tag :: t, tagged :: f k a}
 246
 247 tagParser :: Fix (Combinator :+: ScopeRegister) a -> Fix (Tag ParserName Combinator) a
 248 tagParser p = cata' tagAlg p
 249   where
 250     tagAlg p = In . Tag (makeParserName p) . (id \/ descope)
 251     descope (ScopeRegister p f) = freshReg regMaker (\(reg@(Reg σ)) -> MakeRegister σ p (f reg))
 252     regMaker :: IORef IΣVar
 253     regMaker = newRegMaker p
 254
 255
 256 newtype LetInserter a =
 257   LetInserter {
 258       doLetInserter :: HFreshT IMVar
 259                        (State ( HashMap ParserName IMVar
 260                               , DMap MVar (Fix Combinator)))
 261                        (Fix Combinator a)
 262     }
 263 letInsertion :: HashSet ParserName -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
 264 letInsertion lets recs p = (p', μs, μMax)
 265   where
 266     m = cata alg p
 267     ((p', μMax), (_, μs)) = runState (runFreshT (doLetInserter m) 0) (HashMap.empty, DMap.empty)
 268     alg :: Tag ParserName Combinator LetInserter a -> LetInserter a
 269     alg p = LetInserter $ do
 270       let name = tag p
 271       let q = tagged p
 272       (vs, μs) <- get
 273       let bound = HashSet.member name lets
 274       let recu = HashSet.member name recs
 275       if bound || recu then case HashMap.lookup name vs of
 276         Just v  -> let μ = MVar v in return $! optimise (Let recu μ (μs DMap.! μ))
 277         Nothing -> mdo
 278           v <- newVar
 279           let μ = MVar v
 280           put (HashMap.insert name v vs, DMap.insert μ q' μs)
 281           q' <- doLetInserter (postprocess q)
 282           return $! optimise (Let recu μ q')
 283       else do doLetInserter (postprocess q)
 284
 285 postprocess :: Combinator LetInserter a -> LetInserter a
 286 postprocess = LetInserter . fmap optimise . traverseCombinator doLetInserter
 287
 288 getBefore :: MonadState ObsSharingState m => m (HashSet ParserName)
 289 getBefore = gets before
 290
 291
 292
 293
 294
 295
 296
 297
 298 makeParserName :: Fix (Combinator :+: ScopeRegister) a -> ParserName
 299 -- Force evaluation of p to ensure that the stableName is correct first time
 300 makeParserName !p = unsafePerformIO (fmap (\(StableName name) -> ParserName name) (makeStableName p))
 301
 302 -- The argument here stops GHC from floating it out, it should be provided something from the scope
 303 {-# NOINLINE newRegMaker #-}
 304 newRegMaker :: a -> IORef IΣVar
 305 newRegMaker x = x `seq` unsafePerformIO (newIORef 0)
 306
 307 {-# NOINLINE freshReg #-}
 308 freshReg :: IORef IΣVar -> (forall r. Reg r a -> x) -> x
 309 freshReg maker scope = scope $ unsafePerformIO $ do
 310   x <- readIORef maker
 311   writeIORef maker (x + 1)
 312   return $! Reg (ΣVar x)
 313
 314 instance IFunctor f => IFunctor (Tag t f) where
 315   imap f (Tag t k) = Tag t (imap f k)
 316
 317 instance Eq ParserName where
 318   (ParserName n) == (ParserName m) = eqStableName (StableName n) (StableName m)
 319 instance Hashable ParserName where
 320   hash (ParserName n) = hashStableName (StableName n)
 321   hashWithSalt salt (ParserName n) = hashWithSalt salt (StableName n)
 322
 323 -- There is great evil in this world, and I'm probably responsible for half of it
 324 instance Show ParserName where showsPrec _ (ParserName n) = showHex (I# (unsafeCoerce# n))
 325 -}