X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=4d68228f100c8685aeab5038a7bafb443aee3ba9;hb=cf8adb9e5e64e2bbe24e50e3c57b0cfe39ec41e5;hp=21ebaa6c65505496dfe6e4b82d6a6395956ef45c;hpb=f659cb97f97051c2a5fa443e2baaa13fb5db87b9;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 21ebaa6..4d68228 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -5,7 +5,8 @@
 
 \begin{code}
 module SimplUtils (
-	simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
+	simplBinder, simplBinders, simplRecBndrs, simplLetBndr, 
+	simplLamBndrs, simplTopBndrs,
 	newId, mkLam, mkCase,
 
 	-- The continuation type
@@ -29,7 +30,7 @@ import CoreUtils	( cheapEqExpr, exprType,
 			  findDefault, exprOkForSpeculation, exprIsValue
 			)
 import qualified Subst	( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id		( Id, idType, idInfo,
+import Id		( Id, idType, idInfo, isLocalId,
 			  mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
 			  idUnfolding, idNewStrictness
 			)
@@ -40,7 +41,7 @@ import Type		( Type, seqType,
 			  splitRepFunTys, isStrictType
 			)
 import OccName		( UserFS )
-import TyCon		( tyConDataConsIfAvailable, isDataTyCon )
+import TyCon		( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon )
 import DataCon		( dataConRepArity, dataConSig, dataConArgTys )
 import Var		( mkSysTyVar, tyVarKind )
 import Util		( lengthExceeds, mapAccumL )
@@ -438,30 +439,41 @@ simplBinder env bndr
     returnSmpl (setSubst env subst', bndr')
 
 
-simplLamBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplLamBinders env bndrs
-  = let
-	(subst', bndrs') = mapAccumL Subst.simplLamBndr (getSubst env) bndrs
-    in
-    seqBndrs bndrs'	`seq`
-    returnSmpl (setSubst env subst', bndrs')
-
-simplRecIds :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplRecIds env ids
-  = let
-	(subst', ids') = mapAccumL Subst.simplLetId (getSubst env) ids
-    in
-    seqBndrs ids'	`seq`
-    returnSmpl (setSubst env subst', ids')
-
-simplLetId :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplLetId env id
+simplLetBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplLetBndr env id
   = let
 	(subst', id') = Subst.simplLetId (getSubst env) id
     in
     seqBndr id'		`seq`
     returnSmpl (setSubst env subst', id')
 
+simplTopBndrs, simplLamBndrs, simplRecBndrs 
+	:: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplTopBndrs = simplBndrs simplTopBinder
+simplRecBndrs = simplBndrs Subst.simplLetId
+simplLamBndrs = simplBndrs Subst.simplLamBndr
+
+-- For top-level binders, don't use simplLetId for GlobalIds. 
+-- There are some of these, notably consructor wrappers, and we don't
+-- want to clone them or fiddle with them at all.  
+-- Rather tiresomely, the specialiser may float a use of a constructor
+-- wrapper to before its definition (which shouldn't really matter)
+-- because it doesn't see the constructor wrapper as free in the binding
+-- it is floating (because it's a GlobalId).
+-- Then the simplifier brings all top level Ids into scope at the
+-- beginning, and we don't want to lose the IdInfo on the constructor
+-- wrappers.  It would also be Bad to clone it!
+simplTopBinder subst bndr
+  | isLocalId bndr = Subst.simplLetId subst bndr
+  | otherwise	   = (subst, bndr)
+
+simplBndrs simpl_bndr env bndrs
+  = let
+	(subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
+    in
+    seqBndrs bndrs'	`seq`
+    returnSmpl (setSubst env subst', bndrs')
+
 seqBndrs [] = ()
 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 
@@ -779,10 +791,10 @@ tryRhsTyLam env tyvars body 		-- Only does something if there's a let
 mkCase puts a case expression back together, trying various transformations first.
 
 \begin{code}
-mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
+mkCase :: OutExpr -> [AltCon] -> OutId -> [OutAlt] -> SimplM OutExpr
 
-mkCase scrut case_bndr alts
-  = mkAlts scrut case_bndr alts	`thenSmpl` \ better_alts ->
+mkCase scrut handled_cons case_bndr alts
+  = mkAlts scrut handled_cons case_bndr alts	`thenSmpl` \ better_alts ->
     mkCase1 scrut case_bndr better_alts
 \end{code}
 
@@ -857,7 +869,7 @@ and similarly in cascade for all the join points!
 --------------------------------------------------
 --	1. Merge identical branches
 --------------------------------------------------
-mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
+mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
   | all isDeadBinder bndrs1,			-- Remember the default 
     length filtered_alts < length con_alts	-- alternative comes first
   = tick (AltMerge case_bndr)			`thenSmpl_`
@@ -872,13 +884,20 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 --	2. Fill in missing constructor
 --------------------------------------------------
 
-mkAlts scrut case_bndr alts
-  | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
-    isDataTyCon tycon,			-- It's a data type
-    (alts_no_deflt, Just rhs) <- findDefault alts,
-		-- There is a DEFAULT case
-    [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
-		-- There is just one missing constructor!
+mkAlts scrut handled_cons case_bndr alts
+  | (alts_no_deflt, Just rhs) <- findDefault alts,
+			-- There is a DEFAULT case
+
+    Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
+    isAlgTyCon tycon,		-- It's a data type, tuple, or unboxed tuples.  
+    not (isNewTyCon tycon),	-- We can have a newtype, if we are just doing an eval:
+				-- 	case x of { DEFAULT -> e }
+				-- and we don't want to fill in a default for them!
+
+    [missing_con] <- [con | con <- tyConDataConsIfAvailable tycon,
+			    not (con `elem` handled_data_cons)]
+			-- There is just one missing constructor!
+
   = tick (FillInCaseDefault case_bndr)	`thenSmpl_`
     getUniquesSmpl 			`thenSmpl` \ tv_uniqs ->
     getUniquesSmpl 			`thenSmpl` \ id_uniqs ->
@@ -892,16 +911,13 @@ mkAlts scrut case_bndr alts
     in
     returnSmpl better_alts
   where
-    impossible_cons   = otherCons (idUnfolding case_bndr)
-    handled_data_cons = [data_con | DataAlt data_con         <- impossible_cons] ++
-			[data_con | (DataAlt data_con, _, _) <- alts]
-    is_missing con    = not (con `elem` handled_data_cons)
+    handled_data_cons = [data_con | DataAlt data_con <- handled_cons]
 
 --------------------------------------------------
 --	3.  Merge nested cases
 --------------------------------------------------
 
-mkAlts scrut outer_bndr outer_alts
+mkAlts scrut handled_cons outer_bndr outer_alts
   | opt_SimplCaseMerge,
     (outer_alts_without_deflt, maybe_outer_deflt)   <- findDefault outer_alts,
     Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
@@ -945,7 +961,7 @@ mkAlts scrut outer_bndr outer_alts
 --	Catch-all
 --------------------------------------------------
 
-mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+mkAlts scrut handled_cons case_bndr other_alts = returnSmpl other_alts
 \end{code}