X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=72ad7df05ce12abc321307969032f833f6a18b9c;hb=7cca410a40cccf0fbeda2155f307baa5619b8130;hp=be068d25c6e51f5b144e51f188ba523aaedd80f1;hpb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;p=ghc-hetmet.git

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index be068d2..72ad7df 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -10,6 +10,7 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
 #include "HsVersions.h"
 
 import ByteCodeInstr
+import ByteCodeItbls
 import ByteCodeFFI
 import ByteCodeAsm
 import ByteCodeLink
@@ -48,7 +49,7 @@ import Constants
 
 import Data.List	( intersperse, sortBy, zip4, zip6, partition )
 import Foreign		( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
-			  withForeignPtr )
+			  withForeignPtr, castFunPtrToPtr )
 import Foreign.C	( CInt )
 import Control.Exception	( throwDyn )
 
@@ -138,7 +139,7 @@ mkProtoBCO
    -> Int
    -> [StgWord]
    -> Bool   	-- True <=> is a return point, rather than a function
-   -> [Ptr ()]
+   -> [BcPtr]
    -> ProtoBCO name
 mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
   is_ret mallocd_blocks
@@ -726,7 +727,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 +751,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
@@ -917,7 +927,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
          ioToBc (mkMarshalCode cconv
                     (r_offW, r_rep) addr_offW
                     (zip args_offW a_reps))	`thenBc` \ addr_of_marshaller ->
-         recordMallocBc addr_of_marshaller	`thenBc_`
+         recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) `thenBc_`
      let
 	 -- Offset of the next stack frame down the stack.  The CCALL
  	 -- instruction needs to describe the chunk of stack containing
@@ -926,7 +936,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
 	 stk_offset   = d_after_r - s
 
          -- do the call
-         do_call      = unitOL (CCALL stk_offset (castPtr addr_of_marshaller))
+         do_call      = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller))
          -- slide and return
          wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
                         `snocOL` RETURN_UBX r_rep
@@ -1093,7 +1103,7 @@ pushAtom d p (AnnLit lit)
 			    -- to be on the safe side we copy the string into
 			    -- a malloc'd area of memory.
                                 ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
-                                recordMallocBc ptr         `thenBc_`
+                                recordMallocBc ptr `thenBc_`
                                 ioToBc (
                                    withForeignPtr fp $ \p -> do
 				      memcpy ptr p (fromIntegral n)
@@ -1305,10 +1315,12 @@ mkStackOffsets original_depth szsw
 -- -----------------------------------------------------------------------------
 -- The bytecode generator's monad
 
+type BcPtr = Either ItblPtr (Ptr ())
+
 data BcM_State 
    = BcM_State { 
 	nextlabel :: Int,		-- for generating local labels
-	malloced  :: [Ptr ()] }		-- ptrs malloced for current BCO
+	malloced  :: [BcPtr] }		-- thunks malloced for current BCO
 					-- Should be free()d when it is GCd
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
@@ -1342,13 +1354,17 @@ instance Monad BcM where
   (>>)  = thenBc_
   return = returnBc
 
-emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
 emitBc bco
   = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
 
 recordMallocBc :: Ptr a -> BcM ()
 recordMallocBc a
-  = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ())
+  = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
+
+recordItblMallocBc :: ItblPtr -> BcM ()
+recordItblMallocBc a
+  = BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
 
 getLabelBc :: BcM Int
 getLabelBc