Compiler.hs

{-# OPTIONS_GHC -fno-hpc #-}
{-# LANGUAGE AllowAmbiguousTypes,
             ImplicitParams,
             MagicHash,
             MultiParamTypeClasses,
             UndecidableInstances #-}
{-|
Module      : Parsley.Internal.Frontend.Compiler
Description : Compile and analyse a parser
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

Exposes `compile` which is used to detect recursion, let-bindings and compile them
into another representation with a code generation function.

@since 1.0.0.0
-}
module Parsley.Internal.Frontend.Compiler (compile) where

import Prelude hiding (pred)
import Data.Dependent.Map                  (DMap)
import Data.Hashable                       (Hashable, hashWithSalt, hash)
import Data.HashMap.Strict                 (HashMap)
import Data.HashSet                        (HashSet)
import Data.IORef                          (IORef, newIORef, readIORef, writeIORef)
import Data.Kind                           (Type)
import Data.Set                            (Set)
import Control.Arrow                       (first, second)
import Control.Monad                       (void, when, guard)
import Control.Monad.Reader                (ReaderT, runReaderT, local, ask, MonadReader)
import GHC.Exts                            (Int(..), unsafeCoerce#)
import GHC.Prim                            (StableName#)
import GHC.StableName                      (StableName(..), makeStableName, hashStableName, eqStableName)
import Numeric                             (showHex)
import Parsley.Internal.Core.CombinatorAST (Combinator(..), ScopeRegister(..), Reg(..), Parser(..), traverseCombinator)
import Parsley.Internal.Core.Identifiers   (IMVar, MVar(..), IΣVar, ΣVar(..), SomeΣVar)
import Parsley.Internal.Common.Fresh       (HFreshT, newVar, runFreshT)
import Parsley.Internal.Common.Indexed     (Fix(In), cata, cata', IFunctor(imap), (:+:)(..), (\/), Const1(..))
import Parsley.Internal.Common.State       (State, get, gets, runState, execState, modify', MonadState)
import Parsley.Internal.Frontend.Optimiser (optimise)
import Parsley.Internal.Frontend.Analysis  (analyse, emptyFlags, dependencyAnalysis, inliner)
import Parsley.Internal.Trace              (Trace(trace))
import System.IO.Unsafe                    (unsafePerformIO)

import qualified Data.Dependent.Map   as DMap    ((!), empty, insert, mapWithKey, size)
import qualified Data.HashMap.Strict  as HashMap (member, lookup, insert, empty, insertWith, (!), filter)
import qualified Data.HashSet         as HashSet (member, insert, empty)
import qualified Data.Map             as Map     ((!))
import qualified Data.Set             as Set     (empty)
import qualified Parsley.Internal.Opt as Opt

{-|
Given a user's parser, this will analyse it, extract bindings and then compile them with a given function
provided with the information that has been distilled about each binding. Returns all the prepared bindings
along with the top-level definition.

@since 1.0.0.0
-}
{-# INLINEABLE compile #-}
compile :: forall compiled a. (Trace, ?flags :: Opt.Flags)
        => Parser a                                                                              -- ^ The parser to compile.
        -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x) -- ^ How to generate a compiled value with the distilled information.
        -> (compiled a, DMap MVar compiled)                                                      -- ^ The compiled top-level and all of the bindings.
compile (Parser p) codeGen = trace ("COMPILING NEW PARSER WITH " ++ show (DMap.size μs') ++ " LET BINDINGS") (codeGen' Nothing p', DMap.mapWithKey (codeGen' . Just) μs')
  where
    (p', μs, maxV) = preprocess p
    (μs', frs) = dependencyAnalysis p' μs

    freeRegs :: Maybe (MVar x) -> Set SomeΣVar
    freeRegs = maybe Set.empty (\(MVar v) -> frs Map.! v)

    codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x
    codeGen' letBound p = codeGen letBound (analyse emptyFlags p) (freeRegs letBound) (maxV + 1)

preprocess :: (?flags :: Opt.Flags) => Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
preprocess p =
  let q = tagParser p
      (lets, recs) = findLets q
      (p', μs, maxV) = letInsertion lets recs q
  in (p', μs, maxV)

data ParserName = forall a. ParserName (StableName# (Fix (Combinator :+: ScopeRegister) a))
data Tag t f (k :: Type -> Type) a = Tag {tag :: t, tagged :: f k a}

tagParser :: Fix (Combinator :+: ScopeRegister) a -> Fix (Tag ParserName Combinator) a
tagParser p = cata' tagAlg p
  where
    tagAlg p = In . Tag (makeParserName p) . (id \/ descope)
    descope (ScopeRegister p f) = freshReg regMaker (\reg@(Reg σ) -> MakeRegister σ p (f reg))
    regMaker :: IORef IΣVar
    regMaker = newRegMaker p

data LetFinderState = LetFinderState { preds  :: HashMap ParserName Int
                                     , recs   :: HashSet ParserName }
type LetFinderCtx   = HashSet ParserName
newtype LetFinder a = LetFinder { doLetFinder :: ReaderT LetFinderCtx (State LetFinderState) () }

findLets :: Fix (Tag ParserName Combinator) a -> (HashMap ParserName Int, HashSet ParserName)
findLets p = (lets, recs)
  where
    state = LetFinderState HashMap.empty HashSet.empty
    ctx = HashSet.empty
    LetFinderState preds recs = execState (runReaderT (doLetFinder (cata findLetsAlg p)) ctx) state
    lets = HashMap.filter (> 1) preds

findLetsAlg :: Tag ParserName Combinator LetFinder a -> LetFinder a
findLetsAlg p = LetFinder $ do
  let name = tag p
  addPred name
  ifSeen name
    (do addRec name)
    (ifNotProcessedBefore name
      (void (addName name (traverseCombinator (fmap Const1 . doLetFinder) (tagged p)))))

newtype LetInserter a =
  LetInserter {
      doLetInserter :: HFreshT IMVar
                       (State ( HashMap ParserName IMVar
                              , DMap MVar (Fix Combinator)))
                       (Fix Combinator a)
    }
letInsertion :: (?flags :: Opt.Flags) => HashMap ParserName Int -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
letInsertion lets recs p = (p', μs, μMax)
  where
    m = cata alg p
    ((p', μMax), (_, μs)) = runState (runFreshT (doLetInserter m) 0) (HashMap.empty, DMap.empty)
    alg :: Tag ParserName Combinator LetInserter a -> LetInserter a
    alg p = LetInserter $ do
      let name = tag p
      let q = tagged p
      (vs, μs) <- get
      let bound = HashMap.member name lets
      let recu = HashSet.member name recs
      let occs = guard (not recu) *> HashMap.lookup name lets
      if bound || recu then case HashMap.lookup name vs of
        Just v  -> let μ = MVar v in return $! inliner occs μ (μs DMap.! μ)
        Nothing -> do
          v <- newVar
          let μ = MVar v
          modify' (first (HashMap.insert name v))
          q' <- doLetInserter (postprocess q)
          modify' (second (DMap.insert μ q'))
          return $! inliner occs μ q'
      else do doLetInserter (postprocess q)

postprocess :: (?flags :: Opt.Flags) => Combinator LetInserter a -> LetInserter a
postprocess = LetInserter . fmap optimise . traverseCombinator doLetInserter

modifyPreds :: MonadState LetFinderState m => (HashMap ParserName Int -> HashMap ParserName Int) -> m ()
modifyPreds f = modify' (\st -> st {preds = f (preds st)})

modifyRecs :: MonadState LetFinderState m => (HashSet ParserName -> HashSet ParserName) -> m ()
modifyRecs f = modify' (\st -> st {recs = f (recs st)})

addPred :: MonadState LetFinderState m => ParserName -> m ()
addPred k = modifyPreds (HashMap.insertWith (+) k 1)

addRec :: MonadState LetFinderState m => ParserName -> m ()
addRec = modifyRecs . HashSet.insert

ifSeen :: MonadReader LetFinderCtx m => ParserName -> m a -> m a -> m a
ifSeen x yes no = do seen <- ask; if HashSet.member x seen then yes else no

ifNotProcessedBefore :: MonadState LetFinderState m => ParserName -> m () -> m ()
ifNotProcessedBefore x m =
  do oneReference <- gets ((== 1) . (HashMap.! x) . preds)
     when oneReference m

addName :: MonadReader LetFinderCtx m => ParserName -> m b -> m b
addName x = local (HashSet.insert x)

makeParserName :: Fix (Combinator :+: ScopeRegister) a -> ParserName
-- Force evaluation of p to ensure that the stableName is correct first time
makeParserName !p = unsafePerformIO (fmap (\(StableName name) -> ParserName name) (makeStableName p))

-- The argument here stops GHC from floating it out, it should be provided something from the scope
{-# NOINLINE newRegMaker #-}
newRegMaker :: a -> IORef IΣVar
newRegMaker x = x `seq` unsafePerformIO (newIORef 0)

{-# NOINLINE freshReg #-}
freshReg :: IORef IΣVar -> (forall r. Reg r a -> x) -> x
freshReg maker scope = scope $ unsafePerformIO $ do
  x <- readIORef maker
  writeIORef maker (x + 1)
  return $! Reg (ΣVar x)

instance IFunctor f => IFunctor (Tag t f) where
  imap f (Tag t k) = Tag t (imap f k)

instance Eq ParserName where
  (ParserName n) == (ParserName m) = eqStableName (StableName n) (StableName m)
instance Hashable ParserName where
  hash (ParserName n) = hashStableName (StableName n)
  hashWithSalt salt (ParserName n) = hashWithSalt salt (StableName n)

-- There is great evil in this world, and I'm probably responsible for half of it
instance Show ParserName where showsPrec _ (ParserName n) = showHex (I# (unsafeCoerce# n))