Run.hs

module UHC.Light.Compiler.CoreRun.Run
( module Control.Monad.RWS.Strict, module Control.Monad, module UHC.Util.Error
, RunRd (..), emptyRunRd
, RunSt (..), emptyRunSt
, RunSem (..)
, rsemTopUpd
, RunT', RunT
, err
, runCoreRun, runCoreRun2
, 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.Base.Trace
import UHC.Light.Compiler.CoreRun as CR
import UHC.Light.Compiler.CoreRun.Prim
import qualified UHC.Util.FastSeq as Seq
import qualified Data.Map as Map
import qualified Data.Set as Set
import UHC.Util.Pretty
import Data.Maybe
import Data.Monoid
import Data.IORef
import System.IO
import Control.Exception
import Control.Monad
import UHC.Util.Error
import Control.Monad.RWS.Strict

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

emptyRunRd
  = RunRd

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

emptyRunSt
  = RunSt

{-# LINE 80 "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 r

  -- | Setup tracing
  rsemSetupTracing :: EHCOpts -> RunT' r s v m ()
  rsemSetupTracing opts = do
        let dotr  = CoreOpt_RunTrace `elem` ehcOptCoreOpts opts
            dotre = CoreOpt_RunTraceExtensive `elem` ehcOptCoreOpts opts
        rsemSetTrace (dotre || dotr) dotre

  -- | Set tracing on/off, 2nd param to tell to do it extensively
  rsemSetTrace :: Bool -> Bool -> RunT' r s v m ()
  rsemSetTrace _ _ = return ()

  -- | On what is being traced
  rsemTraceOnS :: RunT' r s v m (Set.Set TraceOn)
  rsemTraceOnS = return Set.empty

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

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

  -- | Alt
  rsemAlt :: CR.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 151 "src/ehc/CoreRun/Run.chs" #-}
-- | Update the top value of the maintained stack
rsemTopUpd :: RunSem r s v m a => (v -> v) -> a -> RunT' r s v m a
rsemTopUpd upd x = rsemPop x >>= (rsemPush . upd)

{-# LINE 157 "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 169 "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 179 "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
              r' <- rsemSetup opts modImpL mod
              local (const r') $
                (m >>= rsemPop >>= rsemDeref >>= rsemPop))
            r s
  return e

runCoreRun2
  :: forall r s v m a .
     (RunSem r s v IO a)
  => EHCOpts
     -> [Mod]
     -> Mod
     -> RunT' r s v IO a
     -> IO (Either Err v) -- RunT' r s v m a
runCoreRun2 opts modImpL mod m = do
  (r, s, _ :: a) <- rsemInitial
  -- let s = error "runCoreRun.RWS"
  --     r = error "runCoreRun.Reader"
  res <- flip catch (\(e :: SomeException) -> do
      hFlush stdout >> (return $ Left $ strMsg $ "runCoreRun2: " ++ show e)
    ) $ do
    (e, _, _) <-
      runRWST (runErrorT $ do
                r' <- rsemSetup opts modImpL mod
                local (const r') $
                  (m >>= rsemPop >>= rsemDeref >>= rsemPop))
              r s
    return e
  return res

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