do_checks: do not set HpAlloc if the stack check fails

This fixes a very rare heap corruption bug, whereby

 - a context switch is requested, which sets HpLim to zero
   (contextSwitchCapability(), called by the timer signal or
   another Capability).

 - simultaneously a stack check fails, in a code fragment that has
   both a stack and a heap check.

The RTS then assumes that a heap-check failure has occurred and
subtracts HpAlloc from Hp, although in fact it was a stack-check
failure and retreating Hp will overwrite valid heap objects.  The bug
is that HpAlloc should only be set when Hp has been incremented by the
heap check.  See comments in rts/HeapStackCheck.cmm for more details.

This bug is probably incredibly rare in practice, but I happened to be
working on a test that triggers it reliably:
concurrent/should_run/throwto001, compiled with -O -threaded, args 30
300 +RTS -N2, run repeatedly in a loop.

diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
index 65f94d1..23d8852 100644 (file)
--- a/compiler/codeGen/CgHeapery.lhs
+++ b/compiler/codeGen/CgHeapery.lhs
@@ -443,22 +443,32 @@ do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Code
 do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
   = do { doGranAllocate hp_expr
 
-       -- Emit a block for the heap-check-failure code
-       ; blk_id <- forkLabelledCode $ do
-                       { whenC hp_nonzero $
-                               stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
+        -- The failure block: this saves the registers and jumps to
+        -- the appropriate RTS stub.
+        ; exit_blk_id <- forkLabelledCode $ do {
                        ; emitStmts reg_save_code
                        ; stmtC (CmmJump rts_lbl []) }
 
+       -- In the case of a heap-check failure, we must also set
+       -- HpAlloc.  NB. HpAlloc is *only* set if Hp has been
+       -- incremented by the heap check, it must not be set in the
+       -- event that a stack check failed, because the RTS stub will
+       -- retreat Hp by HpAlloc.
+       ; hp_blk_id <- if hp_nonzero
+                          then forkLabelledCode $ do
+                                 stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
+                                 stmtC (CmmBranch exit_blk_id)
+                          else return exit_blk_id
+
        -- Check for stack overflow *FIRST*; otherwise
        -- we might bumping Hp and then failing stack oflo
        ; whenC stk_nonzero
-               (stmtC (CmmCondBranch stk_oflo blk_id))
+               (stmtC (CmmCondBranch stk_oflo exit_blk_id))
 
        ; whenC hp_nonzero
                (stmtsC [CmmAssign hpReg 
                                (cmmOffsetExprB (CmmReg hpReg) hp_expr),
-                       CmmCondBranch hp_oflo blk_id]) 
+                       CmmCondBranch hp_oflo hp_blk_id])
                -- Bump heap pointer, and test for heap exhaustion
                -- Note that we don't move the heap pointer unless the 
                -- stack check succeeds.  Otherwise we might end up