[project @ 2006-01-06 16:30:17 by simonmar]

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

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 5964884..f526ed9 100644 (file)
--- 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)]