X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FDmdAnal.lhs;h=a36ebbccd075ddccaf8d576fe27208813d2d487f;hb=a32726a14f95b236413410bc6605f9e3cb6adae2;hp=7bb8134fcadf5317bbd656abeb0453051997d39d;hpb=e74067c6d49eafb291f60e8fdec01b256e9c7c9d;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index 7bb8134..a36ebbc 100644
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -40,7 +40,8 @@ import UniqFM		( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
 import Type		( isUnLiftedType )
 import CoreLint		( showPass, endPass )
 import Util		( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
-import BasicTypes	( Arity, TopLevelFlag(..), isTopLevel, isNeverActive )
+import BasicTypes	( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
+			  RecFlag(..), isRec )
 import Maybes		( orElse, expectJust )
 import Outputable
 \end{code}
@@ -89,8 +90,8 @@ dmdAnalTopBind :: SigEnv
 	       -> (SigEnv, CoreBind)
 dmdAnalTopBind sigs (NonRec id rhs)
   = let
-	(    _, _, (_,   rhs1)) = dmdAnalRhs TopLevel sigs (id, rhs)
-	(sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel sigs (id, rhs1)
+	(    _, _, (_,   rhs1)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs)
+	(sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs1)
 		-- Do two passes to improve CPR information
 		-- See comments with ignore_cpr_info in mk_sig_ty
 		-- and with extendSigsWithLam
@@ -264,7 +265,7 @@ dmdAnal sigs dmd (Case scrut case_bndr alts)
 
 dmdAnal sigs dmd (Let (NonRec id rhs) body) 
   = let
-	(sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel sigs (id, rhs)
+	(sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive sigs (id, rhs)
 	(body_ty, body') 	      = dmdAnal sigs' dmd body
 	(body_ty1, id2)    	      = annotateBndr body_ty id1
 	body_ty2		      = addLazyFVs body_ty1 lazy_fv
@@ -358,7 +359,7 @@ dmdFix top_lvl sigs orig_pairs
 	  ((sigs', lazy_fv'), pair')
 	  --	 )
  	where
-	  (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl sigs (id,rhs)
+	  (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs)
 	  lazy_fv'		   = plusUFM_C both lazy_fv lazy_fv1   
 	  -- old_sig   		   = lookup sigs id
 	  -- new_sig  	   	   = lookup sigs' id
@@ -374,20 +375,20 @@ dmdFix top_lvl sigs orig_pairs
 	-- since it is part of the strictness signature
 initialSig id = idNewStrictness_maybe id `orElse` botSig
 
-dmdAnalRhs :: TopLevelFlag 
+dmdAnalRhs :: TopLevelFlag -> RecFlag
 	-> SigEnv -> (Id, CoreExpr)
 	-> (SigEnv,  DmdEnv, (Id, CoreExpr))
 -- Process the RHS of the binding, add the strictness signature
 -- to the Id, and augment the environment with the signature as well.
 
-dmdAnalRhs top_lvl sigs (id, rhs)
+dmdAnalRhs top_lvl rec_flag sigs (id, rhs)
  = (sigs', lazy_fv, (id', rhs'))
  where
   arity		     = idArity id   -- The idArity should be up to date
 				    -- The simplifier was run just beforehand
   (rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
   (lazy_fv, sig_ty)  = WARN( arity /= dmdTypeDepth rhs_dmd_ty, ppr id )
-		       mkSigTy top_lvl id rhs rhs_dmd_ty
+		       mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
   id'		     = id `setIdNewStrictness` sig_ty
   sigs'		     = extendSigEnv top_lvl sigs id sig_ty
 \end{code}
@@ -404,8 +405,8 @@ mkTopSigTy :: CoreExpr -> DmdType -> StrictSig
 	-- NB: not used for never-inline things; hence False
 mkTopSigTy rhs dmd_ty = snd (mk_sig_ty False False rhs dmd_ty)
 
-mkSigTy :: TopLevelFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
-mkSigTy top_lvl id rhs dmd_ty 
+mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
+mkSigTy top_lvl rec_flag id rhs dmd_ty 
   = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
   where
     never_inline = isNeverActive (idInlinePragma id)
@@ -415,6 +416,7 @@ mkSigTy top_lvl id rhs dmd_ty
     thunk_cpr_ok
 	| isTopLevel top_lvl       = False	-- Top level things don't get
 						-- their demandInfo set at all
+	| isRec rec_flag	   = False	-- Ditto recursive things
 	| Just dmd <- maybe_id_dmd = isStrictDmd dmd
 	| otherwise 		   = True	-- Optimistic, first time round
 						-- See notes below