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

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 576763e..350148c 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
@@ -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
@@ -926,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
@@ -935,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
@@ -955,6 +954,7 @@ mkDummyLiteral pr
         NonPtrArg -> MachWord 0
         DoubleArg -> MachDouble 0
         FloatArg  -> MachFloat 0
+        LongArg   -> MachWord64 0
         _         -> moan64 "mkDummyLiteral" (ppr pr)
 
 
@@ -1102,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)
@@ -1314,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))
@@ -1351,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