X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=fd5f21e5cc50fbea0ec615e0478eadd25029d375;hb=26d2cba2d0cedd5d19e2564503122294d3d7c3a1;hp=4999db59eaa06f4e439614112eb5ccfcb1b0eb39;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 4999db5..fd5f21e 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -21,21 +21,24 @@ module SimplUtils (
 import BinderInfo
 import CmdLineOpts	( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
 import CoreSyn
+import PprCore		( {- instance Outputable Expr -} )
 import CoreUnfold	( isValueUnfolding )
 import CoreFVs		( exprFreeVars )
-import CoreUtils	( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity )
+import CoreUtils	( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
 import Subst		( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
 import Id		( Id, idType, isId, idName, 
 			  idOccInfo, idUnfolding,
-			  idDemandInfo, mkId, idInfo
+			  mkId, idInfo
 			)
 import IdInfo		( arityLowerBound, setOccInfo, vanillaIdInfo )
 import Maybes		( maybeToBool, catMaybes )
 import Name		( isLocalName, setNameUnique )
 import SimplMonad
-import Type		( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
-			  splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
+import Type		( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
+			  splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
 			)
+import PprType		( {- instance Outputable Type -} )
+import DataCon		( dataConRepArity )
 import TysPrim		( statePrimTyCon )
 import Var		( setVarUnique )
 import VarSet
@@ -247,7 +250,7 @@ analyseCont in_scope cont
     analyse_arg subst (Note _ a)	= analyse_arg subst a
     analyse_arg subst other	        = True
 
-    interesting_call_context (Stop _)	     		 = False
+    interesting_call_context (Stop ty)	     		 = canUpdateInPlace ty
     interesting_call_context (InlinePlease _)	         = True
     interesting_call_context (Select _ _ _ _ _)          = True
     interesting_call_context (CoerceIt _ cont)           = interesting_call_context cont
@@ -274,6 +277,22 @@ discardInline :: SimplCont -> SimplCont
 discardInline (InlinePlease cont)  = cont
 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
 discardInline cont		   = cont
+
+-- Consider   let x = <wurble> in ...
+-- If <wurble> returns an explicit constructor, we might be able
+-- to do update in place.  So we treat even a thunk RHS context
+-- as interesting if update in place is possible.  We approximate
+-- this by seeing if the type has a single constructor with a
+-- small arity.  But arity zero isn't good -- we share the single copy
+-- for that case, so no point in sharing.
+
+-- Note the repType: we want to look through newtypes for this purpose
+
+canUpdateInPlace ty = case splitAlgTyConApp_maybe (repType ty) of
+			Just (_, _, [dc]) -> arity == 1 || arity == 2
+					  where
+					     arity = dataConRepArity dc
+			other -> False
 \end{code}