[GHC] #7429: Unexplained performance boost with +RTS -h

[GHC]

#7429: Unexplained performance boost with +RTS -h
---------------------------------+------------------------------------------
    Reporter:  simonmar          |       Owner:                         
        Type:  bug               |      Status:  new                    
    Priority:  normal            |   Milestone:  7.8.1                  
   Component:  Compiler          |     Version:  7.6.1                  
    Keywords:                    |          Os:  Unknown/Multiple       
Architecture:  Unknown/Multiple  |     Failure:  Runtime performance bug
  Difficulty:  Unknown           |    Testcase:                         
   Blockedby:                    |    Blocking:                         
     Related:                    |  
---------------------------------+------------------------------------------

Comment(by tomberek):

 Replying to [ticket:7429 simonmar]:


 {{{
 {-# LANGUAGE
         RankNTypes
         ,RecursiveDo
         ,TypeFamilies
         ,GeneralizedNewtypeDeriving
   #-}

 import System.TimeIt
 import Control.Monad.State.Strict
 import Control.Monad.ST.Strict
 import Data.STRef

 -- STO Monad is just StateT with an Int stacked on top of a ST monad.
 newtype STO s a = STO { unSTO :: StateT Int (ST s) a }
     deriving (Functor, Monad)

 runSTO :: (forall s. STO s a) -> a
 runSTO x = runST (evalStateT (unSTO x) 0)

 data CircList s = ConsM {value :: {-# UNPACK #-} !Int
                         ,cons  :: {-# UNPACK #-} !(STRef s (CircList s ))
 }

 -- | Defines a circular list of length 2
 twoItemList :: forall s. ST s (CircList s)
 twoItemList = do
     rec item1 <- liftM (ConsM 0) $ newSTRef item2
         item2 <- liftM (ConsM 1) $ newSTRef item1
     return item1

 -- | I tie a circular list of size 2 and step through it n times.
 main :: IO ()
 main = do
     let n = 633222111 :: Int
     let takeOneStep = switchSTorSTO . readSTRef . cons

     runLine $ switchSTorSTO twoItemList  >>= liftM value . iterateM n
 takeOneStep

 --switchSTorSTO = id
 --runLine = timeIt . print . runST
 --  ****************************  TO SWITCH TO ST: switch between the two
 sets of definitions above and below this line
 switchSTorSTO  = STO . lift
 runLine = timeIt . print . runSTO

 -- I find myself writing this function a lot, did I miss some basic Monad
 helper?
 iterateM :: (Monad m) => Int -> (b -> m b) -> b -> m b
 iterateM n f c = go n c where
     go 0 b = return b
     go ns b = f b >>= go (ns-1)

 }}}

 Here is a simpler version (also attached as Main.hs) that uses a circular
 list of length two. The odd thing is that this runs around 3 seconds when
 I only use the ST monad, or the STO without profiling. But the STO with
 profiling makes it FASTER to 2.6 seconds. The two versions seem to have
 the same GC stats as before. So then why not just use profiling ALL the
 time? I don't know if this difference exists for large 'project sized'
 uses of ST, but it seems a monad transformer on top of it along with
 profiling helps it go faster.

 The STO version produces this core, which looks pretty good to me:

 {{{
 Rec {
 Main.$wa [Occ=LoopBreaker]
   :: forall s_XF2.
      GHC.Prim.Int#
      -> Main.CircList s_XF2
      -> GHC.Types.Int
      -> GHC.Prim.State# s_XF2
      -> (# GHC.Prim.State# s_XF2,
            (Main.CircList s_XF2, GHC.Types.Int) #)
 [GblId, Arity=4, Caf=NoCafRefs, Str=DmdType LLLL]
 Main.$wa =
   \ (@ s_XF2)
     (ww_s1na :: GHC.Prim.Int#)
     (w_s1nc :: Main.CircList s_XF2)
     (w1_s1nd :: GHC.Types.Int)
     (w2_s1ne :: GHC.Prim.State# s_XF2) ->
     case ww_s1na of ds_XFh {
       __DEFAULT ->
         case w_s1nc of _ { Main.ConsM rb_dFC rb1_dFD ->
         case GHC.Prim.readMutVar#
                @ s_XF2 @ (Main.CircList s_XF2) rb1_dFD w2_s1ne
         of _ { (# ipv_aJ9, ipv1_aJa #) ->
         Main.$wa @ s_XF2 (GHC.Prim.-# ds_XFh 1) ipv1_aJa w1_s1nd ipv_aJ9
         }
         };
       0 -> (# w2_s1ne, (w_s1nc, w1_s1nd) #)
     }
 end Rec }
 }}}

 The effect disappears when you switch to using just ST, but the core looks
 almost identical other than the threading of the original Int in the
 StateT. Here is the core produced for the ST version:

 {{{
 Rec {
 Main.$wpoly_a [Occ=LoopBreaker]
   :: forall s_aDw.
      GHC.Prim.Int#
      -> Main.CircList s_aDw
      -> GHC.Prim.State# s_aDw
      -> (# GHC.Prim.State# s_aDw, Main.CircList s_aDw #)
 [GblId, Arity=3, Caf=NoCafRefs, Str=DmdType LLL]
 Main.$wpoly_a =
   \ (@ s_aDw)
     (ww_s1la :: GHC.Prim.Int#)
     (w_s1lc :: Main.CircList s_aDw)
     (w1_s1ld :: GHC.Prim.State# s_aDw) ->
     case ww_s1la of ds_XFl {
       __DEFAULT ->
         case w_s1lc of _ { Main.ConsM rb_dFI rb1_dFJ ->
         case GHC.Prim.readMutVar#
                @ s_aDw @ (Main.CircList s_aDw) rb1_dFJ w1_s1ld
         of _ { (# ipv_aIP, ipv1_aIQ #) ->
         Main.$wpoly_a @ s_aDw (GHC.Prim.-# ds_XFl 1) ipv1_aIQ ipv_aIP
         }
         };
       0 -> (# w1_s1ld, w_s1lc #)
     }
 end Rec }
 }}}

-- 
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/7429#comment:2>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler