X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=f526ed990789de279838dd866172f648ebb1e9d2;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=59648849e0f1231db042a5ea216bc7c6911d315b;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 5964884..f526ed9 100644
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -15,7 +15,7 @@ import ByteCodeAsm	( CompiledByteCode(..), UnlinkedBCO,
 import ByteCodeLink	( lookupStaticPtr )
 
 import Outputable
-import Name		( Name, getName, mkSystemName )
+import Name		( Name, getName, mkSystemVarName )
 import Id
 import FiniteMap
 import ForeignCall	( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
@@ -30,8 +30,8 @@ import Type		( isUnLiftedType, splitTyConApp_maybe )
 import DataCon		( DataCon, dataConTag, fIRST_TAG, dataConTyCon, 
                           isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
 			  dataConRepArity )
-import TyCon		( tyConFamilySize, isDataTyCon, tyConDataCons,
-			  isUnboxedTupleTyCon )
+import TyCon		( TyCon, tyConFamilySize, isDataTyCon, 
+			  tyConDataCons, isUnboxedTupleTyCon )
 import Class		( Class, classTyCon )
 import Type		( Type, repType, splitFunTys, dropForAlls, pprType )
 import Util
@@ -41,7 +41,7 @@ import VarSet		( VarSet, varSetElems )
 import TysPrim		( arrayPrimTyCon, mutableArrayPrimTyCon,
 			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon
 			)
-import CmdLineOpts	( DynFlags, DynFlag(..) )
+import DynFlags	( DynFlags, DynFlag(..) )
 import ErrUtils		( showPass, dumpIfSet_dyn )
 import Unique		( mkPseudoUniqueE )
 import FastString	( FastString(..), unpackFS )
@@ -53,7 +53,8 @@ import OrdList
 import Constants	( wORD_SIZE )
 
 import Data.List	( intersperse, sortBy, zip4, zip5, partition )
-import Foreign		( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 )
+import Foreign		( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
+			  withForeignPtr )
 import Foreign.C	( CInt )
 import Control.Exception	( throwDyn )
 
@@ -67,13 +68,10 @@ import Data.Char	( ord, chr )
 
 byteCodeGen :: DynFlags
             -> [CoreBind]
-	    -> TypeEnv
+	    -> [TyCon]
             -> IO CompiledByteCode
-byteCodeGen dflags binds type_env
+byteCodeGen dflags binds tycs
    = do showPass dflags "ByteCodeGen"
-        let  local_tycons  = typeEnvTyCons  type_env
-	     local_classes = typeEnvClasses type_env
-	     tycs = local_tycons ++ map classTyCon local_classes
 
         let flatBinds = [ (bndr, freeVars rhs) 
 			| (bndr, rhs) <- flattenBinds binds]
@@ -102,7 +100,7 @@ coreExprToBCOs dflags expr
 
       -- create a totally bogus name for the top-level BCO; this
       -- should be harmless, since it's never used for anything
-      let invented_name  = mkSystemName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
+      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
           invented_id    = mkLocalId invented_name (panic "invented_id's type")
 	  
       (BcM_State final_ctr mallocd, proto_bco) 
@@ -886,7 +884,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
      let
 
          -- Get the arg reps, zapping the leading Addr# in the dynamic case
-         a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
+         a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
                 | is_static = a_reps_pushed_RAW
                 | otherwise = if null a_reps_pushed_RAW 
                               then panic "ByteCodeGen.generateCCall: dyn with no args"
@@ -1087,18 +1085,18 @@ pushAtom d p (AnnLit lit)
         pushStr s 
            = let getMallocvilleAddr
                     = case s of
-                         FastString _ l ba -> 
-                            -- sigh, a string in the heap is no good to us.
-                            -- We need a static C pointer, since the type of 
-                            -- a string literal is Addr#.  So, copy the string 
-                            -- into C land and remember the pointer so we can
-			    -- free it later.
-                            let n = I# l
-                            -- CAREFUL!  Chars are 32 bits in ghc 4.09+
-                            in  ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
+                         FastString _ n _ fp _ -> 
+			    -- we could grab the Ptr from the ForeignPtr,
+			    -- but then we have no way to control its lifetime.
+			    -- In reality it'll probably stay alive long enoungh
+			    -- by virtue of the global FastString table, but
+			    -- 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_`
                                 ioToBc (
-                                   do memcpy ptr ba (fromIntegral n)
+                                   withForeignPtr fp $ \p -> do
+				      memcpy ptr p (fromIntegral n)
 				      pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
                                       return ptr
                                    )
@@ -1113,7 +1111,7 @@ pushAtom d p other
               (pprCoreExpr (deAnnotate (undefined, other)))
 
 foreign import ccall unsafe "memcpy"
- memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
+ memcpy :: Ptr a -> Ptr b -> CInt -> IO ()
 
 
 -- -----------------------------------------------------------------------------
@@ -1121,7 +1119,7 @@ foreign import ccall unsafe "memcpy"
 -- of making a multiway branch using a switch tree.
 -- What a load of hassle!
 
-mkMultiBranch :: Maybe Int	-- # datacons in tycon, if alg alt
+mkMultiBranch :: Maybe Int	--  # datacons in tycon, if alg alt
 				-- a hint; generates better code
 				-- Nothing is always safe
               -> [(Discr, BCInstrList)]