Catch too-large allocations and emit an error message (#4505)

This is a temporary measure until we fix the bug properly (which is
somewhat tricky, and we think might be easier in the new code
generator).

For now we get:

ghc-stage2: sorry! (unimplemented feature or known bug)
  (GHC version 7.1 for i386-unknown-linux):
        Trying to allocate more than 1040384 bytes.

See: http://hackage.haskell.org/trac/ghc/ticket/4550
Suggestion: read data from a file instead of having large static data
structures in the code.

diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
index 23d8852..bc3e108 100644 (file)
--- a/compiler/codeGen/CgHeapery.lhs
+++ b/compiler/codeGen/CgHeapery.lhs
@@ -433,6 +433,16 @@ do_checks :: WordOff       -- Stack headroom
          -> CmmExpr    -- Rts address to jump to on failure
          -> Code
 do_checks 0 0 _ _   = nopC
          -> CmmExpr    -- Rts address to jump to on failure
          -> Code
 do_checks 0 0 _ _   = nopC

+
+do_checks _ hp _ _
+  | hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W
+  = sorry (unlines [
+            "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.", 
+            "",
+            "See: http://hackage.haskell.org/trac/ghc/ticket/4550",
+            "Suggestion: read data from a file instead of having large static data",
+            "structures in the code."])
+

 do_checks stk hp reg_save_code rts_lbl
   = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE))) 
               (CmmLit (mkIntCLit (hp*wORD_SIZE)))
 do_checks stk hp reg_save_code rts_lbl
   = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE))) 
               (CmmLit (mkIntCLit (hp*wORD_SIZE)))

diff --git a/includes/HaskellConstants.hs b/includes/HaskellConstants.hs
index 4555b47..51cdcaf 100644 (file)
--- a/includes/HaskellConstants.hs
+++ b/includes/HaskellConstants.hs
@@ -183,6 +183,11 @@ bLOCK_SIZE = BLOCK_SIZE
 bLOCK_SIZE_W :: Int
 bLOCK_SIZE_W = bLOCK_SIZE `quot` wORD_SIZE
 
 bLOCK_SIZE_W :: Int
 bLOCK_SIZE_W = bLOCK_SIZE `quot` wORD_SIZE
 

+-- blocks that fit in an MBlock, leaving space for the block descriptors
+
+bLOCKS_PER_MBLOCK :: Int
+bLOCKS_PER_MBLOCK = BLOCKS_PER_MBLOCK
+

 -- Number of bits to shift a bitfield left by in an info table.
 
 bITMAP_BITS_SHIFT :: Int
 -- Number of bits to shift a bitfield left by in an info table.
 
 bITMAP_BITS_SHIFT :: Int

diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c
index f0e514b..ade104a 100644 (file)
--- a/includes/mkDerivedConstants.c
+++ b/includes/mkDerivedConstants.c
@@ -195,6 +195,8 @@ main(int argc, char *argv[])
 
     printf("#define BLOCK_SIZE   %u\n", BLOCK_SIZE);
     printf("#define MBLOCK_SIZE   %u\n", MBLOCK_SIZE);
 
     printf("#define BLOCK_SIZE   %u\n", BLOCK_SIZE);
     printf("#define MBLOCK_SIZE   %u\n", MBLOCK_SIZE);

+    printf("#define BLOCKS_PER_MBLOCK  %lu\n", (lnat)BLOCKS_PER_MBLOCK);
+    // could be derived, but better to save doing the calculation twice

 
     printf("\n\n");
 #endif
 
     printf("\n\n");
 #endif

diff --git a/rts/Schedule.c b/rts/Schedule.c
index 5169895..bf39c0a 100644 (file)
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -1025,6 +1025,10 @@ scheduleHandleHeapOverflow( Capability *cap, StgTSO *t )
        
        blocks = (lnat)BLOCK_ROUND_UP(cap->r.rHpAlloc) / BLOCK_SIZE;
        
        
        blocks = (lnat)BLOCK_ROUND_UP(cap->r.rHpAlloc) / BLOCK_SIZE;
        

+        if (blocks > BLOCKS_PER_MBLOCK) {
+            barf("allocation of %ld bytes too large (GHC should have complained at compile-time)", (long)cap->r.rHpAlloc);
+        }
+

        debugTrace(DEBUG_sched,
                   "--<< thread %ld (%s) stopped: requesting a large block (size %ld)\n", 
                   (long)t->id, what_next_strs[t->what_next], blocks);
        debugTrace(DEBUG_sched,
                   "--<< thread %ld (%s) stopped: requesting a large block (size %ld)\n", 
                   (long)t->id, what_next_strs[t->what_next], blocks);