[GHC] #367: Infinite loops can hang Concurrent Haskell

[GHC]

#367: Infinite loops can hang Concurrent Haskell
------------------------------------------+---------------------------------
  Reporter:  simonpj                      |          Owner:  ezyang              
      Type:  bug                          |         Status:  new                 
  Priority:  lowest                       |      Milestone:  _|_                 
 Component:  Compiler                     |        Version:  6.4.1               
Resolution:  None                         |       Keywords:  scheduler allocation
        Os:  Unknown/Multiple             |   Architecture:  Unknown/Multiple    
   Failure:  Incorrect result at runtime  |     Difficulty:  Unknown             
  Testcase:                               |      Blockedby:                      
  Blocking:                               |        Related:                      
------------------------------------------+---------------------------------
Changes (by ezyang):

  * owner:  => ezyang


Comment:

 It turns out the stupid implementation is actually pretty fast.

 {{{diff --git a/compiler/codeGen/StgCmmHeap.hs
 b/compiler/codeGen/StgCmmHeap.hs
 index fb37391..a70d132 100644
 --- a/compiler/codeGen/StgCmmHeap.hs
 +++ b/compiler/codeGen/StgCmmHeap.hs
 @@ -557,15 +557,22 @@ do_checks checkStack alloc do_gc = do
      hp_oflo = CmmMachOp (mo_wordUGt dflags)
                          [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]

 +    -- Yielding if HpLim == 0
 +    yielding = CmmMachOp (mo_wordEq dflags)
 +                        [CmmReg (CmmGlobal HpLim), CmmLit (zeroCLit
 dflags)]
 +
      alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
    gc_id <- newLabelC

    when checkStack $ do
       emit =<< mkCmmIfGoto sp_oflo gc_id

 -  when (alloc /= 0) $ do
 -     emitAssign hpReg bump_hp
 -     emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
 +  if (alloc /= 0)
 +    then do
 +      emitAssign hpReg bump_hp
 +      emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
 +    else do
 +      emit =<< mkCmmIfThen yielding (alloc_n <*> mkBranch gc_id)

    emitOutOfLine gc_id $
       do_gc -- this is expected to jump back somewhere
 }}}

 A totally unscientific benchmark on

 {{{
 module Main where

 import qualified Data.Vector as U

 main = U.sum (U.enumFromTo 1 (1000000000 :: Int)) `seq` return ()
 }}}

 yields this C--

 {{{
  Main.main1_entry()
          { [(c1Zm,
              Main.main1_info:
                  const 65539;
                  const 0;
                  const 15;),
             (c1Zn,
              block_c1Zn_info:
                  const 0;
                  const 32;)]
          }
      c1Zm:
          if (Sp - 12 < SpLim) goto c1Zv;
          if (HpLim == 0) goto c1Zu;
          I32[Sp - 8] = 0;
          I32[Sp - 12] = 1;
          I32[Sp - 4] = c1Zn;
          Sp = Sp - 12;
          jump Main.main_$s$wfoldlM'_loop_info; // []
      c1Zu:
          HpAlloc = 0;
          goto c1Zv;
      c1Zv:
          R1 = Main.main1_closure;
          jump stg_gc_fun; // [R1]
      c1Zn:
          if (HpLim == 0) goto c1ZC;
          R1 = GHC.Tuple.()_closure+1;
          Sp = Sp + 4;
          jump I32[Sp]; // [R1]
      c1ZC:
          HpAlloc = 0;
          R1 = R1;
          jump stg_gc_unbx_r1; // [R1]
 }}}

 which is only about 10% slower.

 Unfortunately, if you want to guarantee things don't hang, it's not enough
 to compile the untrusted code like this; all the other code needs to have
 this transformation applied too. So we should probably have a -yielding
 flag (like -threaded or -profiling) which allows us to compile "yielding"
 versions of all relevant code.  Unfortunately, the number of combinations
 of such flags exponentially increases...

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