X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=576763ee8584f49021e4b58346c7de3acd14d5de;hp=be068d25c6e51f5b144e51f188ba523aaedd80f1;hb=b5deeb0f9897f029699d734b82edd172b173cbe2;hpb=ba8b3afc73880f49c3c9a960d3ac8fc3247fa6f8

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index be068d2..576763e 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -726,7 +726,16 @@ doCase d s p (_,scrut)
 	-- things that are pointers, whereas in CgBindery the code builds the
 	-- bitmap from the free slots and unboxed bindings.
 	-- (ToDo: merge?)
-	bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots)
+        --
+        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
+        -- The bitmap must cover the portion of the stack up to the sequel only.
+        -- Previously we were building a bitmap for the whole depth (d), but we
+        -- really want a bitmap up to depth (d-s).  This affects compilation of
+        -- case-of-case expressions, which is the only time we can be compiling a
+        -- case expression with s /= 0.
+        bitmap_size = d-s
+	bitmap = intsToReverseBitmap bitmap_size{-size-} 
+                        (sortLe (<=) (filter (< bitmap_size) rel_slots))
 	  where
 	  binds = fmToList p
 	  rel_slots = concat (map spread binds)
@@ -741,7 +750,7 @@ doCase d s p (_,scrut)
      let 
          alt_bco_name = getName bndr
          alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
-			0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}
+			0{-no arity-} bitmap_size bitmap True{-is alts-}
      -- in
 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 --	     "\n      bitmap = " ++ show bitmap) $ do