X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=824cabaacbd51c1468cf5ea6d56c8143c3a5edfc;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=02258a963158b39b81d2cbb27f61bfa762d58b88;hpb=f714e6b642fd614a9971717045ae47c3d871275e;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 02258a9..824caba 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -12,14 +12,14 @@ module CoreToStg ( coreToStg, coreExprToStg ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils	( rhsIsStatic, manifestArity, exprType )
+import CoreUtils	( rhsIsStatic, manifestArity, exprType, findDefault )
 import StgSyn
 
 import Type
 import TyCon		( isAlgTyCon )
 import Id
 import Var		( Var, globalIdDetails, idType )
-import TyCon		( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon )
+import TyCon		( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
 #ifdef ILX
 import MkId		( unsafeCoerceId )
 #endif
@@ -30,9 +30,10 @@ import VarSet
 import VarEnv
 import Maybes		( maybeToBool )
 import Name		( getOccName, isExternalName, nameOccName )
-import OccName		( occNameUserString, occNameFS )
+import OccName		( occNameString, occNameFS )
 import BasicTypes       ( Arity )
-import CmdLineOpts	( DynFlags, opt_RuntimeTypes )
+import Packages		( HomeModules )
+import StaticFlags	( opt_RuntimeTypes )
 import Outputable
 
 infixr 9 `thenLne`
@@ -139,10 +140,10 @@ for x, solely to put in the SRTs lower down.
 %************************************************************************
 
 \begin{code}
-coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
-coreToStg dflags pgm
+coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding]
+coreToStg hmods pgm
   = return pgm'
-  where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
+  where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm
 
 coreExprToStg :: CoreExpr -> StgExpr
 coreExprToStg expr 
@@ -150,33 +151,35 @@ coreExprToStg expr
 
 
 coreTopBindsToStg
-    :: IdEnv HowBound		-- environment for the bindings
+    :: HomeModules
+    -> IdEnv HowBound		-- environment for the bindings
     -> [CoreBind]
     -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
 
-coreTopBindsToStg env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg env (b:bs)
+coreTopBindsToStg hmods env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg hmods env (b:bs)
   = (env2, fvs2, b':bs')
   where
 	-- env accumulates down the list of binds, fvs accumulates upwards
-	(env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
-  	(env2, fvs1, bs') = coreTopBindsToStg env1 bs
+	(env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b
+  	(env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs
 
 
 coreTopBindToStg
-	:: IdEnv HowBound
+	:: HomeModules
+	-> IdEnv HowBound
 	-> FreeVarsInfo		-- Info about the body
 	-> CoreBind
 	-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
 
-coreTopBindToStg env body_fvs (NonRec id rhs)
+coreTopBindToStg hmods env body_fvs (NonRec id rhs)
   = let 
 	env' 	  = extendVarEnv env id how_bound
-	how_bound = LetBound TopLet (manifestArity rhs)
+	how_bound = LetBound TopLet $! manifestArity rhs
 
         (stg_rhs, fvs') = 
 	    initLne env (
-              coreToTopStgRhs body_fvs (id,rhs)	`thenLne` \ (stg_rhs, fvs') ->
+              coreToTopStgRhs hmods body_fvs (id,rhs)	`thenLne` \ (stg_rhs, fvs') ->
 	      returnLne (stg_rhs, fvs')
            )
 	
@@ -187,17 +190,17 @@ coreTopBindToStg env body_fvs (NonRec id rhs)
 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)
 
-coreTopBindToStg env body_fvs (Rec pairs)
+coreTopBindToStg hmods env body_fvs (Rec pairs)
   = let 
 	(binders, rhss) = unzip pairs
 
-	extra_env' = [ (b, LetBound TopLet (manifestArity rhs))
+	extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
 		     | (b, rhs) <- pairs ]
 	env' = extendVarEnvList env extra_env'
 
         (stg_rhss, fvs')
 	  = initLne env' (
-	       mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
+	       mapAndUnzipLne (coreToTopStgRhs hmods body_fvs) pairs
 						`thenLne` \ (stg_rhss, fvss') ->
 	       let fvs' = unionFVInfos fvss' in
 	       returnLne (stg_rhss, fvs')
@@ -229,17 +232,18 @@ consistentCafInfo id bind
 
 \begin{code}
 coreToTopStgRhs
-	:: FreeVarsInfo		-- Free var info for the scope of the binding
+	:: HomeModules
+	-> FreeVarsInfo		-- Free var info for the scope of the binding
 	-> (Id,CoreExpr)
 	-> LneM (StgRhs, FreeVarsInfo)
 
-coreToTopStgRhs scope_fv_info (bndr, rhs)
+coreToTopStgRhs hmods 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 rhs
+    is_static = rhsIsStatic hmods rhs
 
 mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
 	-> StgRhs
@@ -330,7 +334,7 @@ coreToStgExpr (Note other_note expr)
 
 -- Cases require a little more real work.
 
-coreToStgExpr (Case scrut bndr alts)
+coreToStgExpr (Case scrut bndr _ alts)
   = extendVarEnvLne [(bndr, LambdaBound)]	(
 	 mapAndUnzip3Lne vars_alt alts	`thenLne` \ (alts2, fvs_s, escs_s) ->
 	 returnLne ( alts2,
@@ -367,7 +371,7 @@ coreToStgExpr (Case scrut bndr alts)
 		     (getLiveVars alts_lv_info)
 		     bndr'
 		     (mkSRT alts_lv_info)
-		     (mkStgAltType (idType bndr)) 
+		     (mkStgAltType (idType bndr) alts)
 		     alts2,
       scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
       alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
@@ -407,14 +411,29 @@ coreToStgExpr (Let bind body)
 \end{code}
 
 \begin{code}
-mkStgAltType scrut_ty
+mkStgAltType scrut_ty alts
   = case splitTyConApp_maybe (repType scrut_ty) of
 	Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
 		    | isPrimTyCon tc	     -> PrimAlt tc
-		    | isAlgTyCon tc	     -> AlgAlt tc
+		    | isHiBootTyCon tc	     -> look_for_better_tycon
+		    | isAlgTyCon tc 	     -> AlgAlt tc
 		    | isFunTyCon tc	     -> PolyAlt
 		    | otherwise		     -> pprPanic "mkStgAlts" (ppr tc)
 	Nothing				     -> PolyAlt
+
+  where
+   -- Sometimes, the TyCon in the type of the scrutinee is an HiBootTyCon,
+   -- which may not have any constructors inside it.  If so, then we
+   -- can get a better TyCon by grabbing the one from a constructor alternative
+   -- if one exists.
+   look_for_better_tycon
+	| ((DataAlt con, _, _) : _) <- data_alts = 
+		AlgAlt (dataConTyCon con)
+	| otherwise =
+		ASSERT(null data_alts)
+		PolyAlt
+	where
+		(data_alts, _deflt) = findDefault alts
 \end{code}
 
 
@@ -669,7 +688,7 @@ coreToStgLet let_no_escape bind body
 is_join_var :: Id -> Bool
 -- A hack (used only for compiler debuggging) to tell if
 -- a variable started life as a join point ($j)
-is_join_var j = occNameUserString (getOccName j) == "$j"
+is_join_var j = occNameString (getOccName j) == "$j"
 \end{code}
 
 \begin{code}
@@ -1020,12 +1039,12 @@ lookupFVInfo fvs id
 			Just (_,_,info) -> info
 
 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)]	-- Both top level and non-top-level Ids
-allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
+allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id]
 
 -- Non-top-level things only, both type variables and ids
 -- (type variables only if opt_RuntimeTypes)
 getFVs :: FreeVarsInfo -> [Var]	
-getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs, 
+getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, 
 		    not (topLevelBound how_bound) ]
 
 getFVSet :: FreeVarsInfo -> VarSet