X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=f61b513084b92b9188f6bb0b555e2c4c3c93f6b0;hb=506278ab5a4591626aa4bd2d45983da6f06be727;hp=dd1f86a3403fcc0d046d327a7454d35709101348;hpb=0b62f53e6da34769aa1bf8409d9987a5311bb516;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index dd1f86a..f61b513 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -5,9 +5,9 @@
 
 \begin{code}
 module SimplUtils (
-	simplBinder, simplBinders, simplIds,
+	simplBinder, simplBinders, simplRecIds, simplLetId,
 	tryRhsTyLam, tryEtaExpansion,
-	mkCase, findAlt, findDefault,
+	mkCase,
 
 	-- The continuation type
 	SimplCont(..), DupFlag(..), contIsDupable, contResultType,
@@ -23,11 +23,15 @@ import CmdLineOpts	( switchIsOn, SimplifierSwitch(..),
 			  opt_UF_UpdateInPlace
 			)
 import CoreSyn
-import CoreUtils	( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, etaExpand, exprEtaExpandArity, bindNonRec )
-import Subst		( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
+import CoreUtils	( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, 
+			  etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
+			  findDefault
+			)
+import Subst		( InScopeSet, mkSubst, substExpr )
+import qualified Subst	( simplBndrs, simplBndr, simplLetId )
 import Id		( idType, idName, 
 			  idUnfolding, idStrictness,
-			  mkVanillaId, idInfo
+			  mkLocalId, idInfo
 			)
 import IdInfo		( StrictnessInfo(..) )
 import Maybes		( maybeToBool, catMaybes )
@@ -42,7 +46,7 @@ import Type		( Type, mkForAllTys, seqType, repType,
 import TyCon		( tyConDataConsIfAvailable )
 import DataCon		( dataConRepArity )
 import VarEnv		( SubstEnv )
-import Util		( lengthExceeds )
+import Util		( lengthExceeds, mapAccumL )
 import Outputable
 \end{code}
 
@@ -425,7 +429,7 @@ simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 simplBinders bndrs thing_inside
   = getSubst		`thenSmpl` \ subst ->
     let
-	(subst', bndrs') = substBndrs subst bndrs
+	(subst', bndrs') = Subst.simplBndrs subst bndrs
     in
     seqBndrs bndrs'	`seq`
     setSubst subst' (thing_inside bndrs')
@@ -434,23 +438,29 @@ simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
 simplBinder bndr thing_inside
   = getSubst		`thenSmpl` \ subst ->
     let
-	(subst', bndr') = substBndr subst bndr
+	(subst', bndr') = Subst.simplBndr subst bndr
     in
     seqBndr bndr'	`seq`
     setSubst subst' (thing_inside bndr')
 
 
--- Same semantics as simplBinders, but a little less 
--- plumbing and hence a little more efficient.
--- Maybe not worth the candle?
-simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
-simplIds ids thing_inside
+simplRecIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
+simplRecIds ids thing_inside
   = getSubst		`thenSmpl` \ subst ->
     let
-	(subst', bndrs') = substIds subst ids
+	(subst', ids') = mapAccumL Subst.simplLetId subst ids
     in
-    seqBndrs bndrs'	`seq`
-    setSubst subst' (thing_inside bndrs')
+    seqBndrs ids'	`seq`
+    setSubst subst' (thing_inside ids')
+
+simplLetId :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
+simplLetId id thing_inside
+  = getSubst		`thenSmpl` \ subst ->
+    let
+	(subst', id') = Subst.simplLetId subst id
+    in
+    seqBndr id'	`seq`
+    setSubst subst' (thing_inside id')
 
 seqBndrs [] = ()
 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
@@ -536,8 +546,8 @@ as we would normally do.
 tryRhsTyLam :: OutExpr -> SimplM ([OutBind], OutExpr)
 
 tryRhsTyLam rhs 			-- Only does something if there's a let
-  | null tyvars || not (worth_it body)	-- inside a type lambda, and a WHNF inside that
-  = returnSmpl ([], rhs)
+  | null tyvars || not (worth_it body)	-- inside a type lambda, 
+  = returnSmpl ([], rhs)		-- and a WHNF inside that
 
   | otherwise
   = go (\x -> x) body		`thenSmpl` \ (binds, body') ->
@@ -546,8 +556,10 @@ tryRhsTyLam rhs 			-- Only does something if there's a let
   where
     (tyvars, body) = collectTyBinders rhs
 
-    worth_it (Let _ e)	     = whnf_in_middle e
-    worth_it other     	     = False
+    worth_it e@(Let _ _) = whnf_in_middle e
+    worth_it e		 = False
+
+    whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
     whnf_in_middle (Let _ e) = whnf_in_middle e
     whnf_in_middle e	     = exprIsCheap e
 
@@ -603,7 +615,7 @@ tryRhsTyLam rhs 			-- Only does something if there's a let
 	let
 	    poly_name = setNameUnique (idName var) uniq		-- Keep same name
 	    poly_ty   = mkForAllTys tyvars_here (idType var)	-- But new type of course
-	    poly_id   = mkVanillaId poly_name poly_ty 
+	    poly_id   = mkLocalId poly_name poly_ty 
 
 		-- In the olden days, it was crucial to copy the occInfo of the original var, 
 		-- because we were looking at occurrence-analysed but as yet unsimplified code!
@@ -787,14 +799,28 @@ and similar friends.
 mkCase scrut case_bndr alts
   | all identity_alt alts
   = tick (CaseIdentity case_bndr)		`thenSmpl_`
-    returnSmpl scrut
+    returnSmpl (re_note scrut)
   where
-    identity_alt (DEFAULT, [], Var v)     = v == case_bndr
-    identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
-					  		(mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
-    identity_alt other		          = False
-
-    arg_tys = tyConAppArgs (idType case_bndr)
+    identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
+
+    identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
+    identity_rhs (LitAlt lit)  _    = Lit lit
+    identity_rhs DEFAULT       _    = Var case_bndr
+
+    arg_tys = map Type (tyConAppArgs (idType case_bndr))
+
+	-- We've seen this:
+	--	case coerce T e of x { _ -> coerce T' x }
+	-- And we definitely want to eliminate this case!
+	-- So we throw away notes from the RHS, and reconstruct
+	-- (at least an approximation) at the other end
+    de_note (Note _ e) = de_note e
+    de_note e	       = e
+
+	-- re_note wraps a coerce if it might be necessary
+    re_note scrut = case head alts of
+			(_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut
+			other		      -> scrut
 \end{code}
 
 The catch-all case
@@ -805,22 +831,3 @@ mkCase other_scrut case_bndr other_alts
 \end{code}
 
 
-\begin{code}
-findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
-findDefault []				= ([], Nothing)
-findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args ) 
-					  ([], Just rhs)
-findDefault (alt : alts) 	        = case findDefault alts of 
-					    (alts', deflt) -> (alt : alts', deflt)
-
-findAlt :: AltCon -> [CoreAlt] -> CoreAlt
-findAlt con alts
-  = go alts
-  where
-    go [] 	    = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
-    go (alt : alts) | matches alt = alt
-    		    | otherwise   = go alts
-
-    matches (DEFAULT, _, _) = True
-    matches (con1, _, _)    = con == con1
-\end{code}