X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=fa244c47e1abc2e0a5f5e037145858fa663261a2;hb=ac704fcac946590eef0ec91ae19f3b47d779a75f;hp=235cdfe5f445088e08d1506bfd19f6a603224671;hpb=c94408e522e5af3b79a5beadc7e6d15cee553ee7;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 235cdfe..fa244c4 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -44,16 +44,14 @@ import Id		( Id, idType, isDataConWorkId, idOccInfo, isDictId,
 			)
 import NewDemand	( isStrictDmd, isBotRes, splitStrictSig )
 import SimplMonad
-import Var              ( tyVarKind, mkTyVar )
 import Name             ( mkSysTvName )
 import Type		( Type, splitFunTys, dropForAlls, isStrictType,
 			  splitTyConApp_maybe, tyConAppArgs, mkTyVarTys ) 
 import Coercion         ( isEqPredTy
 			)
 import Coercion         ( Coercion, mkUnsafeCoercion, coercionKind )
-import TyCon		( tyConDataCons_maybe, isNewTyCon )
-import DataCon		( DataCon, dataConRepArity, dataConExTyVars, 
-                          dataConInstArgTys, dataConTyCon )
+import TyCon		( tyConDataCons_maybe, isClosedNewTyCon )
+import DataCon		( DataCon, dataConRepArity, dataConInstArgTys, dataConTyCon )
 import VarSet
 import BasicTypes	( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
 			  Activation, isAlwaysActive, isActive )
@@ -722,7 +720,8 @@ postInlineUnconditionally
     -> Bool
 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
   | not active		   = False
-  | isLoopBreaker occ_info = False
+  | isLoopBreaker occ_info = False	-- If it's a loop-breaker of any kind, dont' inline
+					-- because it might be referred to "earlier"
   | isExportedId bndr      = False
   | exprIsTrivial rhs 	   = True
   | otherwise
@@ -789,10 +788,10 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 		   SimplPhase n -> isActive n prag
     prag = idInlinePragma bndr
 
-activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
-activeInline env id occ
+activeInline :: SimplEnv -> OutId -> Bool
+activeInline env id
   = case getMode env of
-      SimplGently -> isOneOcc occ && isAlwaysActive prag
+      SimplGently -> False
 	-- No inlining at all when doing gentle stuff,
 	-- except for local things that occur once
 	-- The reason is that too little clean-up happens if you 
@@ -1139,28 +1138,6 @@ tryRhsTyLam env tyvars body 		-- Only does something if there's a let
 %*									*
 %************************************************************************
 
-\begin{code}
-mkDataConAlt :: DataCon -> [OutType] -> InExpr -> SimplM InAlt
--- Make a data-constructor alternative to replace the DEFAULT case
--- NB: there's something a bit bogus here, because we put OutTypes into an InAlt
-mkDataConAlt con inst_tys rhs
-  = ASSERT(not (isNewTyCon (dataConTyCon con)))
-    do 	{ tv_uniqs <- getUniquesSmpl 
-	; arg_uniqs <- getUniquesSmpl
-	; let tv_bndrs  = zipWith mk_tv_bndr (dataConExTyVars con) tv_uniqs
-	      arg_tys   = dataConInstArgTys con (inst_tys ++ mkTyVarTys tv_bndrs)
-	      arg_bndrs = zipWith mk_arg arg_tys arg_uniqs
-	; return (DataAlt con, tv_bndrs ++ arg_bndrs, rhs) }
-  where
-    mk_arg arg_ty uniq	-- Equality predicates get a TyVar
-			-- while dictionaries and others get an Id
-      | isEqPredTy arg_ty = mk_tv arg_ty uniq
-      | otherwise	  = mk_id arg_ty uniq
-
-    mk_tv_bndr tv uniq = mk_tv (tyVarKind tv) uniq
-    mk_tv kind uniq = mkTyVar (mkSysTvName uniq FSLIT("t")) kind
-    mk_id ty   uniq = mkSysLocal FSLIT("a") uniq ty
-\end{code}
 
 mkCase puts a case expression back together, trying various transformations first.
 
@@ -1484,36 +1461,31 @@ mkCase1 scrut case_bndr ty [(con,bndrs,rhs)]
 mkCase1 scrut case_bndr ty alts	-- Identity case
   | all identity_alt alts
   = tick (CaseIdentity case_bndr)		`thenSmpl_`
-    returnSmpl (re_note scrut)
+    returnSmpl (re_cast scrut)
   where
-    identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
+    identity_alt (con, args, rhs) = de_cast rhs `cheapEqExpr` mk_id_rhs con args
 
-    identity_rhs (DataAlt con) args
-      | isNewTyCon (dataConTyCon con) 
-      = wrapNewTypeBody (dataConTyCon con) arg_tys (varToCoreExpr $ head args)
-      | otherwise
-      = mkConApp con (arg_ty_exprs ++ varsToCoreExprs args)
-    identity_rhs (LitAlt lit)  _    = Lit lit
-    identity_rhs DEFAULT       _    = Var case_bndr
+    mk_id_rhs (DataAlt con) args = mkConApp con (arg_tys ++ varsToCoreExprs args)
+    mk_id_rhs (LitAlt lit)  _    = Lit lit
+    mk_id_rhs DEFAULT       _    = Var case_bndr
 
-    arg_tys = (tyConAppArgs (idType case_bndr))
-    arg_ty_exprs = map Type arg_tys
+    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 _ _)) -> 
-                            let co = mkUnsafeCoercion (idType case_bndr) (exprType rhs1) in 
-                               -- this unsafeCoercion is bad, make this better
-                            mkCoerce co scrut
-			other		      -> scrut
+	--	case e of x { _ -> x `cast` c }
+	-- And we definitely want to eliminate this case, to give
+	--	e `cast` c
+	-- So we throw away the cast from the RHS, and reconstruct
+	-- it at the other end.  All the RHS casts must be the same
+	-- if (all identity_alt alts) holds.
+	-- 
+	-- Don't worry about nested casts, because the simplifier combines them
+    de_cast (Cast e _) = e
+    de_cast e	       = e
+
+    re_cast scrut = case head alts of
+			(_,_,Cast _ co) -> Cast scrut co
+			other	        -> scrut