test0-main.core.hs

a_s2CV :: State# RealWorld -> (# State# RealWorld, () #)
a_s2CV =
  \ (s_X2kt :: State# RealWorld) ->
    letrec {
      a_s2E2
        :: [StateT Int IO Int]
           -> forall r_ao0.
              Int
              -> State# RealWorld
              -> (# State# RealWorld, ([Int] -> Int -> r_ao0) -> r_ao0 #)
      a_s2E2 =
        \ (ds_X2ip :: [StateT Int IO Int])
          (@ r_ao0)
          (eta_B2 :: Int)
          (eta_B1 :: State# RealWorld) ->
          case ds_X2ip of _ {
            [] ->
              (# eta_B1,
                 \ (f_aKp :: [Int] -> Int -> r_ao0) -> f_aKp ([] @ Int) eta_B2 #);
            : y_a2h5 ys_a2h6 ->
              ((a_s2if
                  @ Int
                  @ IO
                  GHC.Base.$fMonadIO
                  @ [Int]
                  @ [Int]
                  ((\ (@ r_Xpy) (eta_X1A :: Int) (eta_X2 :: State# RealWorld) ->
                      case (((y_a2h5
                              `cast` (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <Int>_N
                                      :: StateT Int IO Int
                                         ~R# (forall r_ao0.
                                              Int -> IO ((Int -> Int -> r_ao0) -> r_ao0))))
                               @ (IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy)) eta_X1A)
                            `cast` (NTCo:IO[0]
                                      <(Int
                                        -> Int -> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy))
                                       -> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy)>_R
                                    :: IO
                                         ((Int
                                           -> Int
                                           -> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy))
                                          -> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy))
                                       ~R# (State# RealWorld
                                            -> (# State# RealWorld,
                                                  (Int
                                                   -> Int
                                                   -> IO
                                                        ((([Int] -> [Int]) -> Int -> r_Xpy)
                                                         -> r_Xpy))
                                                  -> IO
                                                       ((([Int] -> [Int]) -> Int -> r_Xpy)
                                                        -> r_Xpy) #))))
                             eta_X2
                      of _ { (# ipv_a2i3, ipv1_a2i4 #) ->
                      ((ipv1_a2i4
                          ((\ (x_aKu :: Int) (s'_aKv :: Int) (eta_X1I :: State# RealWorld) ->
                              let {
                                x_XN9 :: [Int] -> [Int]
                                x_XN9 = : @ Int x_aKu } in
                              (# eta_X1I,
                                 \ (f_aKp :: ([Int] -> [Int]) -> Int -> r_Xpy) ->
                                   f_aKp x_XN9 s'_aKv #))
                           `cast` (<Int>_R
                                   -> <Int>_R
                                   -> Sym
                                        (NTCo:IO[0] <(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy>_R)
                                   :: (Int
                                       -> Int
                                       -> State# RealWorld
                                       -> (# State# RealWorld,
                                             (([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy #))
                                      ~R# (Int
                                           -> Int
                                           -> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy)))))
                       `cast` (NTCo:IO[0] <(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy>_R
                               :: IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy)
                                  ~R# (State# RealWorld
                                       -> (# State# RealWorld,
                                             (([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy #))))
                        ipv_a2i3
                      })
                   `cast` ((forall r_Xpy.
                            <Int>_R
                            -> Sym
                                 (NTCo:IO[0] <(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy>_R))
                           ; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int] -> [Int]>_N)
                           :: (forall r_Xpy.
                               Int
                               -> State# RealWorld
                               -> (# State# RealWorld,
                                     (([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy #))
                              ~R# StateT Int IO ([Int] -> [Int])))
                  ((a_s2E2
                      (ys_a2h6
                       `cast` (Sym
                                 (Nth:0
                                    (<[StateT Int IO Int]>_R
                                     -> (forall r_Xpy.
                                         <Int>_R
                                         -> Sym (NTCo:IO[0] <([Int] -> Int -> r_Xpy) -> r_Xpy>_R))
                                        ; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N)))
                               :: [StateT Int IO Int] ~R# [StateT Int IO Int])))
                   `cast` (Nth:1
                             (<[StateT Int IO Int]>_R
                              -> (forall r_Xpy.
                                  <Int>_R -> Sym (NTCo:IO[0] <([Int] -> Int -> r_Xpy) -> r_Xpy>_R))
                                 ; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N))
                           :: (forall r_Xpy.
                               Int
                               -> State# RealWorld
                               -> (# State# RealWorld, ([Int] -> Int -> r_Xpy) -> r_Xpy #))
                              ~R# StateT Int IO [Int]))
                  @ r_ao0
                  eta_B2)
               `cast` (NTCo:IO[0] <([Int] -> Int -> r_ao0) -> r_ao0>_R
                       :: IO (([Int] -> Int -> r_ao0) -> r_ao0)
                          ~R# (State# RealWorld
                               -> (# State# RealWorld, ([Int] -> Int -> r_ao0) -> r_ao0 #))))
                eta_B1
          }; } in
    case ((((a_s2E2
               ((build
                   @ (StateT Int IO Int)
                   (\ (@ b_a26J)
                      (c_a26K :: StateT Int IO Int -> b_a26J -> b_a26J)
                      (nil_a26L :: b_a26J) ->
                      repeatFB
                        @ (StateT Int IO Int)
                        @ (Int -> b_a26J)
                        (takeFB @ (StateT Int IO Int) @ b_a26J c_a26K nil_a26L)
                        ((\ (@ r_XqO) (eta_X2Q :: Int) (eta_X2T :: State# RealWorld) ->
                            case eta_X2Q of _ { I# x_a28l ->
                            let {
                              ipv_s2gq :: Int#
                              ipv_s2gq = +# x_a28l 1# } in
                            let {
                              s_Xxf :: Int
                              s_Xxf = I# ipv_s2gq } in
                            (# eta_X2T,
                               \ (f_ax9 :: Int -> Int -> r_XqO) -> f_ax9 s_Xxf s_Xxf #)
                            })
                         `cast` ((forall r_XqO.
                                  <Int>_R -> Sym (NTCo:IO[0] <(Int -> Int -> r_XqO) -> r_XqO>_R))
                                 ; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <Int>_N)
                                 :: (forall r_XqO.
                                     Int
                                     -> State# RealWorld
                                     -> (# State# RealWorld, (Int -> Int -> r_XqO) -> r_XqO #))
                                    ~R# StateT Int IO Int))
                        (I# 1000#)))
                `cast` (Sym
                          (Nth:0
                             (<[StateT Int IO Int]>_R
                              -> (forall r_ao0.
                                  <Int>_R -> Sym (NTCo:IO[0] <([Int] -> Int -> r_ao0) -> r_ao0>_R))
                                 ; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N)))
                        :: [StateT Int IO Int] ~R# [StateT Int IO Int])))
            `cast` (Nth:1
                      (<[StateT Int IO Int]>_R
                       -> (forall r_ao0.
                           <Int>_R -> Sym (NTCo:IO[0] <([Int] -> Int -> r_ao0) -> r_ao0>_R))
                          ; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N))
                    ; Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N
                    :: (forall r_ao0.
                        Int
                        -> State# RealWorld
                        -> (# State# RealWorld, ([Int] -> Int -> r_ao0) -> r_ao0 #))
                       ~R# (forall r_ao0. Int -> IO (([Int] -> Int -> r_ao0) -> r_ao0))))
             @ ([Int], Int) (I# 0#))
          `cast` (NTCo:IO[0]
                    <([Int] -> Int -> ([Int], Int)) -> ([Int], Int)>_R
                  :: IO (([Int] -> Int -> ([Int], Int)) -> ([Int], Int))
                     ~R# (State# RealWorld
                          -> (# State# RealWorld,
                                ([Int] -> Int -> ([Int], Int)) -> ([Int], Int) #))))
           s_X2kt
    of _ { (# ipv_a2i3, ipv1_a2i4 #) ->
    hPutStr2
      stdout
      (case ipv1_a2i4 ((,) @ [Int] @ Int) of _ { (x_a27I, ds1_a27J) ->
       showList__ @ Int shows7 x_a27I ([] @ Char)
       })
      True
      ipv_a2i3
    }

main :: IO ()
main =
  a_s2CV
  `cast` (Sym (NTCo:IO[0] <()>_R)
          :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ())

test0.hs

{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}
module Cont8 (main) where
import Prelude

liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
liftM f m1 = do { x1 <- m1; return (f x1) }

ap :: (Monad m) => m (a -> b) -> m a -> m b
ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }

replicateM :: (Monad m) => Int -> m a -> m [a]
replicateM n x = sequence (replicate n x)

modify :: Monad m => (s -> s) -> StateT s m ()
modify f = get >>= put . f

newtype StateT s m a = StateT { getStateTFunc
                                    :: forall r . s -> m ((a -> s -> r) -> r)}

instance Monad m => Functor (StateT s m) where
    fmap = liftM

instance Monad m => Applicative (StateT s m) where
    pure = return
    (<*>) = ap

instance Monad m => Monad (StateT s m) where
    return x = StateT $ \s -> return $ \f -> f x s
    StateT f >>= g = StateT $ \s -> do
        useX <- f s
        useX $ \x s' -> getStateTFunc (g x) s'

runStateT :: Monad m => StateT s m a -> s -> m (a, s)
runStateT f s = do
    useXS <- getStateTFunc f s
    return $ useXS $ \x s' -> (x,s')

get :: Monad m => StateT s m s
get = StateT $ \s -> return $ \f -> f s s

put :: Monad m => s -> StateT s m ()
put s = s `seq` StateT $ \_ -> return $ \f -> f () s

-- benchmark

incrementLevel0 :: LargeState Int
incrementLevel0 = do
    modify inc
    get

inc :: Int -> Int
inc n = n + 1
{-# INLINE inc #-}

type LargeState =  StateT Int IO

runLargeState :: LargeState a -> IO a
runLargeState s = do
    let s0 = liftM fst $ runStateT s 0
    --let s1 = liftM fst $ runStateT s0 0
    --let s2 = liftM fst $ runStateT s1 0
    --let s3 = liftM fst $ runStateT s2 0
    --let s4 = liftM fst $ runStateT s3 0
    --let s5 = liftM fst $ runStateT s4 0
    s0

main :: IO ()
main = do
    s <- runLargeState $ replicateM 1000 incrementLevel0
    putStrLn $ show s