Run.hs

module UHC.Light.Compiler.CoreRun.Run
( module Control.Monad.RWS.Strict, module Control.Monad, module Control.Monad.Error
, RunRd (..), emptyRunRd
, RunSt (..), emptyRunSt
, RunSem (..)
, RunT', RunT
, err
, runCoreRun
, modifyIORefM )
where
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Error
import UHC.Light.Compiler.Gam
import UHC.Light.Compiler.Gam.DataGam
import UHC.Light.Compiler.CoreRun
import UHC.Light.Compiler.CoreRun.Prim
import qualified UHC.Util.FastSeq as Seq
import qualified Data.Map as Map
import UHC.Util.Pretty
import Data.Maybe
import Data.Monoid
import Data.IORef
import Control.Monad
import Control.Monad.Error
import Control.Monad.RWS.Strict

{-# LINE 39 "src/ehc/CoreRun/Run.chs" #-}
data RunRd
  = RunRd
      {- cenvLamMp       :: LamMp
      -}

emptyRunRd
  = RunRd

{-# LINE 63 "src/ehc/CoreRun/Run.chs" #-}
data RunSt
  = RunSt
      {- cenvLamMp       :: LamMp
      -}

emptyRunSt
  = RunSt

{-# LINE 73 "src/ehc/CoreRun/Run.chs" #-}
-- | Factored out stuff, not much in it but intended to accomodate variability in running
class (Monad m, MonadIO m, Functor m) => RunSem r s v m a
    -- | r -> a s
    -- , s -> a r
    | r s -> v a
    where
  -- | Provide initial state
  rsemInitial :: m (r,s,a)

  -- | Setup whatever needs to be setup
  rsemSetup :: EHCOpts -> [Mod] -> Mod -> RunT' r s v m ()

  -- | Set tracing on/off
  rsemSetTrace :: Bool -> RunT' r s v m ()
  rsemSetTrace _ = return ()

  -- | Exp
  rsemExp :: Exp -> RunT' r s v m a

  -- | SExp
  rsemSExp :: SExp -> RunT' r s v m a

  -- | Alt
  rsemAlt :: Alt -> RunT' r s v m a
  rsemAlt a = do
    case a of
      Alt_Alt {expr_Alt_Alt=e} -> rsemExp e
  {-# INLINE rsemAlt #-}

  -- | Force evaluation, subsumes rsemDeref
  rsemEvl :: v -> RunT' r s v m a

  -- | Dereference: get rid of intermediate indirections
  rsemDeref :: v -> RunT' r s v m a

  -- | Apply primitive to arguments
  rsemPrim :: RunPrim -> CRArray v -> RunT' r s v m a

  -- | Push, i.e. lift/put from v to internal machinery
  rsemPush :: v -> RunT' r s v m a
  -- | Pop, i.e. lift/get from internal machinery to v
  rsemPop :: a -> RunT' r s v m v
  -- | Construct a data constr/tuple
  rsemNode :: Int -> CRMArray v -> RunT' r s v m v

  -- | GC new level of roots (followed by multiple pushes followed by single pop for all)
  rsemGcEnterRootLevel :: RunT' r s v m ()
  rsemGcEnterRootLevel = return ()
  {-# INLINE rsemGcEnterRootLevel #-}
  -- | GC push as root
  rsemGcPushRoot :: v -> RunT' r s v m ()
  rsemGcPushRoot _ = return ()
  {-# INLINE rsemGcPushRoot #-}
  -- | GC pop as root
  rsemGcLeaveRootLevel :: RunT' r s v m ()
  rsemGcLeaveRootLevel = return ()
  {-# INLINE rsemGcLeaveRootLevel #-}

{-# LINE 136 "src/ehc/CoreRun/Run.chs" #-}
-- type RunT' s m a = ErrorT Err (RWST r w s m) a
-- type RunT        m a = RunT' RunRd RunWr RunSt m a
-- type RunT' s m a = ErrorT Err (StateT s m) a
type RunT' r s v m a = ErrorT Err (RWST r () s m) a
type RunT      v m a = RunT' RunRd RunSt v m a

{-# LINE 148 "src/ehc/CoreRun/Run.chs" #-}
err :: (RunSem r s v m a, PP msg) => msg -> RunT' r s v m b
err msg = throwError $ rngLift emptyRange Err_PP $ pp msg

{-# LINE 158 "src/ehc/CoreRun/Run.chs" #-}
runCoreRun
  :: forall r s v m a .
     (RunSem r s v m a)
  => EHCOpts
     -> [Mod]
     -> Mod
     -> RunT' r s v m a
     -> m (Either Err v) -- RunT' r s v m a
runCoreRun opts modImpL mod m = do
  (r, s, _ :: a) <- rsemInitial
  -- let s = error "runCoreRun.RWS"
  --     r = error "runCoreRun.Reader"
  (e, _, _) <-
    runRWST (runErrorT $ do
              rsemSetup opts modImpL mod
              (m >>= rsemPop >>= rsemDeref >>= rsemPop))
            r s
  return e

{-# LINE 183 "src/ehc/CoreRun/Run.chs" #-}
modifyIORefM :: IORef a -> (a -> IO a) -> IO ()
modifyIORefM r m = readIORef r >>= m >>= writeIORef r
{-# INLINE modifyIORefM #-}