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

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 69fc148..be068d2 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -1,7 +1,8 @@
 %
-% (c) The University of Glasgow 2002
+% (c) The University of Glasgow 2002-2006
 %
-\section[ByteCodeGen]{Generate bytecode from Core}
+
+ByteCodeGen: Generate bytecode from Core
 
 \begin{code}
 module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
@@ -9,48 +10,41 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
 #include "HsVersions.h"
 
 import ByteCodeInstr
-import ByteCodeFFI	( mkMarshalCode, moan64 )
-import ByteCodeAsm	( CompiledByteCode(..), UnlinkedBCO, 
-			  assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH )
-import ByteCodeLink	( lookupStaticPtr )
+import ByteCodeFFI
+import ByteCodeAsm
+import ByteCodeLink
 
 import Outputable
-import Name		( Name, getName, mkSystemVarName )
+import Name
 import Id
 import FiniteMap
-import ForeignCall	( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
-import HscTypes		( TypeEnv, typeEnvTyCons, typeEnvClasses )
-import CoreUtils	( exprType )
+import ForeignCall
+import HscTypes
+import CoreUtils
 import CoreSyn
-import PprCore		( pprCoreExpr )
-import Literal		( Literal(..), literalType )
-import PrimOp		( PrimOp(..) )
-import CoreFVs		( freeVars )
-import Type		( isUnLiftedType, splitTyConApp_maybe )
-import DataCon		( DataCon, dataConTag, fIRST_TAG, dataConTyCon, 
-                          isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
-			  dataConRepArity )
-import TyCon		( TyCon, tyConFamilySize, isDataTyCon, 
-			  tyConDataCons, isUnboxedTupleTyCon )
-import Class		( Class, classTyCon )
-import Type		( Type, repType, splitFunTys, dropForAlls, pprType )
+import PprCore
+import Literal
+import PrimOp
+import CoreFVs
+import Type
+import DataCon
+import TyCon
+import Class
+import Type
 import Util
-import DataCon		( dataConRepArity )
-import Var		( isTyVar )
-import VarSet		( VarSet, varSetElems )
-import TysPrim		( arrayPrimTyCon, mutableArrayPrimTyCon,
-			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon
-			)
-import DynFlags	( DynFlags, DynFlag(..) )
-import ErrUtils		( showPass, dumpIfSet_dyn )
-import Unique		( mkPseudoUniqueE )
-import FastString	( FastString(..), unpackFS )
-import Panic		( GhcException(..) )
-import SMRep		( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord, 
-			  CgRep(..), cgRepSizeW, isFollowableArg, idCgRep )
-import Bitmap		( intsToReverseBitmap, mkBitmap )
+import DataCon
+import Var
+import VarSet
+import TysPrim
+import DynFlags
+import ErrUtils
+import Unique
+import FastString
+import Panic
+import SMRep
+import Bitmap
 import OrdList
-import Constants	( wORD_SIZE )
+import Constants
 
 import Data.List	( intersperse, sortBy, zip4, zip6, partition )
 import Foreign		( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
@@ -101,7 +95,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  = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
-          invented_id    = mkLocalId invented_name (panic "invented_id's type")
+          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
 	  
       (BcM_State final_ctr mallocd, proto_bco) 
          <- runBc (schemeTopBind (invented_id, freeVars expr))
@@ -253,6 +247,7 @@ schemeR fvs (nm, rhs)
    = schemeR_wrk fvs nm rhs (collect [] rhs)
 
 collect xs (_, AnnNote note e) = collect xs e
+collect xs (_, AnnCast e _)    = collect xs e
 collect xs (_, AnnLam x e)     = collect (if isTyVar x then xs else (x:xs)) e
 collect xs (_, not_lambda)     = (reverse xs, not_lambda)
 
@@ -427,13 +422,6 @@ schemeE d s p (AnnNote note (_, body))
 schemeE d s p (AnnCast (_, body) _)
    = schemeE d s p body
 
--- XXX - audreyt - After FC landed, this case of explicit eta-reduction
---       seems needed to make "data D = D deriving Typeable" work in GHCi.
---       however, how did AnnLam with a var (LocalId) survive until this place?
-schemeE d s p (AnnLam var (_, AnnApp (_, body) (_, AnnVar inner)))
-   | var == inner
-   = schemeE d s p body
-
 schemeE d s p other
    = pprPanic "ByteCodeGen.schemeE: unhandled case" 
                (pprCoreExpr (deAnnotate' other))
@@ -1117,6 +1105,9 @@ pushAtom d p (AnnLit lit)
                 -- Get the addr on the stack, untaggedly
                    returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
 
+pushAtom d p (AnnCast e _)
+   = pushAtom d p (snd e)
+
 pushAtom d p other
    = pprPanic "ByteCodeGen.pushAtom" 
               (pprCoreExpr (deAnnotate (undefined, other)))
@@ -1278,6 +1269,7 @@ splitApp (AnnApp (_,f) (_,a))
 	       | otherwise    = case splitApp f of 
 				     (f', as) -> (f', a:as)
 splitApp (AnnNote n (_,e))    = splitApp e
+splitApp (AnnCast (_,e) _)    = splitApp e
 splitApp e		      = (e, [])
 
 
@@ -1288,6 +1280,7 @@ isTypeAtom _           = False
 isVoidArgAtom :: AnnExpr' id ann -> Bool
 isVoidArgAtom (AnnVar v)        = typeCgRep (idType v) == VoidArg
 isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e
+isVoidArgAtom (AnnCast (_,e) _) = isVoidArgAtom e
 isVoidArgAtom _ 	        = False
 
 atomRep :: AnnExpr' Id ann -> CgRep
@@ -1296,6 +1289,7 @@ atomRep (AnnLit l)    = typeCgRep (literalType l)
 atomRep (AnnNote n b) = atomRep (snd b)
 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
+atomRep (AnnCast b _) = atomRep (snd b)
 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 
 isPtrAtom :: AnnExpr' Id ann -> Bool