Handle LongArg's in the FFI on x86

[ghc-hetmet.git] / compiler / ghci / ByteCodeGen.lhs

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index be068d2..350148c 100644 (file)
--- 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
@@ -164,14 +165,12 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
                -- don't do stack checks at return points;
                -- everything is aggregated up to the top BCO
                -- (which must be a function)
-           | stack_overest >= 65535
-           = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" 
-                      (int stack_overest)
            | stack_overest >= iNTERP_STACK_CHECK_THRESH
            = STKCHECK stack_overest : peep_d
            | otherwise
            = peep_d    -- the supposedly common case
              
+        -- We assume that this sum doesn't wrap
         stack_overest = sum (map bciStackUse peep_d)
 
         -- Merge local pushes
@@ -726,7 +725,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 +749,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 +925,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 +934,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
@@ -946,6 +954,7 @@ mkDummyLiteral pr
         NonPtrArg -> MachWord 0
         DoubleArg -> MachDouble 0
         FloatArg  -> MachFloat 0
+        LongArg   -> MachWord64 0
         _         -> moan64 "mkDummyLiteral" (ppr pr)
 
 
@@ -1093,7 +1102,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 +1314,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 +1353,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