X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=519177162f9887e2e400f65a430c9c8f4ebf1f63;hb=2f6ad11fa0c2995d950c91fd4301f23aceeb443b;hp=824cabaacbd51c1468cf5ea6d56c8143c3a5edfc;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 824caba..5191771 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -16,6 +16,7 @@ import CoreUtils	( rhsIsStatic, manifestArity, exprType, findDefault )
 import StgSyn
 
 import Type
+import Coercion         ( mkUnsafeCoercion )
 import TyCon		( isAlgTyCon )
 import Id
 import Var		( Var, globalIdDetails, idType )
@@ -32,8 +33,8 @@ import Maybes		( maybeToBool )
 import Name		( getOccName, isExternalName, nameOccName )
 import OccName		( occNameString, occNameFS )
 import BasicTypes       ( Arity )
-import Packages		( HomeModules )
 import StaticFlags	( opt_RuntimeTypes )
+import PackageConfig	( PackageId )
 import Outputable
 
 infixr 9 `thenLne`
@@ -140,10 +141,10 @@ for x, solely to put in the SRTs lower down.
 %************************************************************************
 
 \begin{code}
-coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding]
-coreToStg hmods pgm
+coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
+coreToStg this_pkg pgm
   = return pgm'
-  where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm
+  where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
 
 coreExprToStg :: CoreExpr -> StgExpr
 coreExprToStg expr 
@@ -151,46 +152,46 @@ coreExprToStg expr
 
 
 coreTopBindsToStg
-    :: HomeModules
+    :: PackageId
     -> IdEnv HowBound		-- environment for the bindings
     -> [CoreBind]
     -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
 
-coreTopBindsToStg hmods env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg hmods env (b:bs)
+coreTopBindsToStg this_pkg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg this_pkg env (b:bs)
   = (env2, fvs2, b':bs')
   where
 	-- env accumulates down the list of binds, fvs accumulates upwards
-	(env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b
-  	(env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs
+	(env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
+  	(env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
 
 
 coreTopBindToStg
-	:: HomeModules
+	:: PackageId
 	-> IdEnv HowBound
 	-> FreeVarsInfo		-- Info about the body
 	-> CoreBind
 	-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
 
-coreTopBindToStg hmods env body_fvs (NonRec id rhs)
+coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
   = let 
 	env' 	  = extendVarEnv env id how_bound
 	how_bound = LetBound TopLet $! manifestArity rhs
 
         (stg_rhs, fvs') = 
 	    initLne env (
-              coreToTopStgRhs hmods body_fvs (id,rhs)	`thenLne` \ (stg_rhs, fvs') ->
+              coreToTopStgRhs this_pkg body_fvs (id,rhs)	`thenLne` \ (stg_rhs, fvs') ->
 	      returnLne (stg_rhs, fvs')
            )
 	
 	bind = StgNonRec id stg_rhs
     in
-    ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
+    ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext SLIT("rhs:")) <+> ppr rhs $$ (ptext SLIT("stg_rhs:"))<+> ppr stg_rhs $$ (ptext SLIT("Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext SLIT("STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
     ASSERT2(consistentCafInfo id bind, ppr id)
 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)
 
-coreTopBindToStg hmods env body_fvs (Rec pairs)
+coreTopBindToStg this_pkg env body_fvs (Rec pairs)
   = let 
 	(binders, rhss) = unzip pairs
 
@@ -200,7 +201,7 @@ coreTopBindToStg hmods env body_fvs (Rec pairs)
 
         (stg_rhss, fvs')
 	  = initLne env' (
-	       mapAndUnzipLne (coreToTopStgRhs hmods body_fvs) pairs
+	       mapAndUnzipLne (coreToTopStgRhs this_pkg body_fvs) pairs
 						`thenLne` \ (stg_rhss, fvss') ->
 	       let fvs' = unionFVInfos fvss' in
 	       returnLne (stg_rhss, fvs')
@@ -232,18 +233,18 @@ consistentCafInfo id bind
 
 \begin{code}
 coreToTopStgRhs
-	:: HomeModules
+	:: PackageId
 	-> FreeVarsInfo		-- Free var info for the scope of the binding
 	-> (Id,CoreExpr)
 	-> LneM (StgRhs, FreeVarsInfo)
 
-coreToTopStgRhs hmods scope_fv_info (bndr, rhs)
+coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
   = coreToStgExpr rhs 		`thenLne` \ (new_rhs, rhs_fvs, _) ->
     freeVarsToLiveVars rhs_fvs	`thenLne` \ lv_info ->
     returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
   where
     bndr_info = lookupFVInfo scope_fv_info bndr
-    is_static = rhsIsStatic hmods rhs
+    is_static = rhsIsStatic this_pkg rhs
 
 mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
 	-> StgRhs
@@ -321,17 +322,21 @@ coreToStgExpr (Note (SCC cc) expr)
     returnLne (StgSCC cc expr2, fvs, escs) )
 
 #ifdef ILX
--- For ILX, convert (__coerce__ to_ty from_ty e) 
---	    into    (coerce to_ty from_ty e)
+-- For ILX, convert (__coerce__ to_ty from_ty e)
+--         into    (coerce to_ty from_ty e)
 -- where coerce is real function
-coreToStgExpr (Note (Coerce to_ty from_ty) expr)
-  = coreToStgExpr (mkApps (Var unsafeCoerceId) 
-			  [Type from_ty, Type to_ty, expr])
+coreToStgExpr (Cast expr co)
+  = let (from_ty, ty_ty) = coercionKind co in
+    coreToStgExpr (mkApps (Var unsafeCoerceId)
+                         [Type from_ty, Type to_ty, expr])
 #endif
 
 coreToStgExpr (Note other_note expr)
   = coreToStgExpr expr
 
+coreToStgExpr (Cast expr co)
+  = coreToStgExpr expr
+
 -- Cases require a little more real work.
 
 coreToStgExpr (Case scrut bndr _ alts)
@@ -1083,6 +1088,7 @@ myCollectBinders expr
   where
     go bs (Lam b e)          = go (b:bs) e
     go bs e@(Note (SCC _) _) = (reverse bs, e) 
+    go bs (Cast e co)        = go bs e
     go bs (Note _ e)         = go bs e
     go bs e	             = (reverse bs, e)
 
@@ -1095,6 +1101,7 @@ myCollectArgs expr
     go (Var v)          as = (v, as)
     go (App f a) as        = go f (a:as)
     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+    go (Cast e co)      as = go e as
     go (Note n e)       as = go e as
     go _		as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 \end{code}