X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=bb9deaadf5d0703a5a7b3e054284b9c6b9cea7cd;hb=f714e6b642fd614a9971717045ae47c3d871275e;hp=f6e4b66b9076c481c75b2cdd0555029eeb99a380;hpb=c9c016973e8b1cf996d0b87f24204b70622dc97f;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index f6e4b66..bb9deaa 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -20,10 +20,8 @@ module SimplUtils (
 
 #include "HsVersions.h"
 
-import CmdLineOpts	( SimplifierSwitch(..),
-			  opt_SimplDoLambdaEtaExpansion, opt_SimplDoEtaReduction,
-			  opt_SimplCaseMerge, opt_UF_UpdateInPlace
-			)
+import CmdLineOpts	( SimplifierSwitch(..), opt_UF_UpdateInPlace,
+			  DynFlag(..), dopt )
 import CoreSyn
 import CoreFVs		( exprFreeVars )
 import CoreUtils	( cheapEqExpr, exprType, exprIsTrivial,
@@ -31,7 +29,7 @@ import CoreUtils	( cheapEqExpr, exprType, exprIsTrivial,
 			  findDefault, exprOkForSpeculation, exprIsValue
 			)
 import qualified Subst	( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id		( Id, idType, idInfo, isDataConId,
+import Id		( Id, idType, idInfo, isDataConWorkId,
 			  mkSysLocal, isDeadBinder, idNewDemandInfo,
 			  idUnfolding, idNewStrictness
 			)
@@ -41,10 +39,11 @@ import Type		( Type, seqType, splitFunTys, dropForAlls, isStrictType,
 			  splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
 			)
 import TcType		( isDictTy )
+import Name		( mkSysTvName )
 import OccName		( EncodedFS )
 import TyCon		( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
 import DataCon		( dataConRepArity, dataConExistentialTyVars, dataConArgTys )
-import Var		( mkSysTyVar, tyVarKind )
+import Var		( tyVarKind, mkTyVar )
 import VarSet
 import Util		( lengthExceeds, mapAccumL )
 import Outputable
@@ -224,6 +223,9 @@ getContArgs chkr fun orig_cont
 	--	* (error "Hello") arg
 	--	* f (error "Hello") where f is strict
 	--	etc
+	-- Then, especially in the first of these cases, we'd like to discard
+	-- the continuation, leaving just the bottoming expression.  But the
+	-- type might not be right, so we may have to add a coerce.
     go acc ss inl cont 
 	| null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
 	| otherwise			  = (reverse acc, cont, 	    inl)
@@ -275,7 +277,7 @@ interestingArg :: OutExpr -> Bool
 interestingArg (Var v)	         = hasSomeUnfolding (idUnfolding v)
 					-- Was: isValueUnfolding (idUnfolding v')
 					-- But that seems over-pessimistic
-				 || isDataConId v
+				 || isDataConWorkId v
 					-- This accounts for an argument like
 					-- () or [], which is definitely interesting
 interestingArg (Type _)	         = False
@@ -501,15 +503,19 @@ Try three things
 
 \begin{code}
 mkLam env bndrs body cont
- | opt_SimplDoEtaReduction,
-   Just etad_lam <- tryEtaReduce bndrs body
- = tick (EtaReduction (head bndrs)) 	`thenSmpl_`
-   returnSmpl (emptyFloats env, etad_lam)
-
- | opt_SimplDoLambdaEtaExpansion,
-   any isRuntimeVar bndrs
- = tryEtaExpansion body		`thenSmpl` \ body' ->
-   returnSmpl (emptyFloats env, mkLams bndrs body')
+ = getDOptsSmpl	 `thenSmpl` \dflags ->
+   mkLam' dflags env bndrs body cont
+ where
+ mkLam' dflags env bndrs body cont
+   | dopt Opt_DoEtaReduction dflags,
+     Just etad_lam <- tryEtaReduce bndrs body
+   = tick (EtaReduction (head bndrs)) 	`thenSmpl_`
+     returnSmpl (emptyFloats env, etad_lam)
+
+   | dopt Opt_DoLambdaEtaExpansion dflags,
+     any isRuntimeVar bndrs
+   = tryEtaExpansion body		`thenSmpl` \ body' ->
+     returnSmpl (emptyFloats env, mkLams bndrs body')
 
 {-	Sept 01: I'm experimenting with getting the
 	full laziness pass to float out past big lambdsa
@@ -522,8 +528,8 @@ mkLam env bndrs body cont
    returnSmpl (floats, mkLams bndrs body')
 -}
 
- | otherwise 
- = returnSmpl (emptyFloats env, mkLams bndrs body)
+   | otherwise 
+   = returnSmpl (emptyFloats env, mkLams bndrs body)
 \end{code}
 
 
@@ -902,7 +908,7 @@ mk_args missing_con inst_tys
     let
 	ex_tyvars   = dataConExistentialTyVars missing_con
 	ex_tyvars'  = zipWith mk tv_uniqs ex_tyvars
-	mk uniq tv  = mkSysTyVar uniq (tyVarKind tv)
+	mk uniq tv  = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
 	arg_tys     = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
 	arg_ids     = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
     in 
@@ -1004,12 +1010,16 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 --------------------------------------------------
 
 mkAlts scrut 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,
-    scruting_same_var scrut_var
+  = getDOptsSmpl   `thenSmpl` \dflags ->
+    mkAlts' dflags scrut outer_bndr outer_alts
+  where
+  mkAlts' dflags scrut outer_bndr outer_alts
+    | dopt Opt_CaseMerge dflags,
+      (outer_alts_without_deflt, maybe_outer_deflt)   <- findDefault outer_alts,
+      Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
+      scruting_same_var scrut_var
 
-  = let	    --  Eliminate any inner alts which are shadowed by the outer ones
+    = let    --  Eliminate any inner alts which are shadowed by the outer ones
     	outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
     
     	munged_inner_alts = [ (con, args, munge_rhs rhs) 
@@ -1030,24 +1040,24 @@ mkAlts scrut outer_bndr outer_alts
 	-- mkCase applied to them, so they won't have a case in their default
 	-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
 	-- in munge_rhs may put a case into the DEFAULT branch!
-  where
+    where
 	-- We are scrutinising the same variable if it's
 	-- the outer case-binder, or if the outer case scrutinises a variable
 	-- (and it's the same).  Testing both allows us not to replace the
 	-- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
-    scruting_same_var = case scrut of
+      scruting_same_var = case scrut of
 			  Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
 			  other		  -> \ v -> v == outer_bndr
 
-    add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
-    add_default Nothing    alts = alts
+      add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
+      add_default Nothing    alts = alts
 
 
 --------------------------------------------------
 --	Catch-all
 --------------------------------------------------
 
-mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+  mkAlts' dflags scrut case_bndr other_alts = returnSmpl other_alts
 \end{code}