[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:                      
------------------------------------------+---------------------------------

Comment(by ezyang):

 Diff botched, here is a formatted one:

 {{{
 ezyang at javelin:~/Dev/ghc-master$ git show
 commit 5a9aee5e1d5a4d140f451aef6c57ab065c428966
 Author: Edward Z. Yang <ezyang at mit.edu>
 Date:   Mon Sep 17 18:28:49 2012 +0200

     Better implementation for fixing #367.

     Signed-off-by: Edward Z. Yang <ezyang at mit.edu>

 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
 }}}

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