X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fstranal%2FDmdAnal.lhs;h=2414aead51a27954da1e8acf511464aae5bd707a;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hp=127fa7800faf1527875b7e648d53fd7081098998;hpb=302265d525004c7870864549f7a07a5759d32912;p=ghc-hetmet.git

diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 127fa78..2414aea 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -7,6 +7,13 @@
 			-----------------
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs, 
 		 both {- needed by WwLib -}
    ) where
@@ -15,38 +22,36 @@ module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs,
 
 import DynFlags		( DynFlags, DynFlag(..) )
 import StaticFlags	( opt_MaxWorkerArgs )
-import NewDemand	-- All of it
+import Demand	-- All of it
 import CoreSyn
 import PprCore	
-import CoreUtils	( exprIsHNF, exprIsTrivial, exprArity )
+import CoreUtils	( exprIsHNF, exprIsTrivial )
+import CoreArity	( exprArity )
 import DataCon		( dataConTyCon )
 import TyCon		( isProductTyCon, isRecursiveTyCon )
-import Id		( Id, idType, idInlinePragma,
+import Id		( Id, idType, idInlineActivation,
 			  isDataConWorkId, isGlobalId, idArity,
-#ifdef OLD_STRICTNESS
-			  idDemandInfo,  idStrictness, idCprInfo, idName,
-#endif
-			  idNewStrictness, idNewStrictness_maybe,
-			  setIdNewStrictness, idNewDemandInfo,
-			  idNewDemandInfo_maybe,
-			  setIdNewDemandInfo
+			  idStrictness, idStrictness_maybe,
+			  setIdStrictness, idDemandInfo,
+			  idDemandInfo_maybe,
+			  setIdDemandInfo
 			)
-#ifdef OLD_STRICTNESS
-import IdInfo 		( newStrictnessFromOld, newDemand )
-#endif
 import Var		( Var )
 import VarEnv
 import TysWiredIn	( unboxedPairDataCon )
 import TysPrim		( realWorldStatePrimTy )
 import UniqFM		( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
 			  keysUFM, minusUFM, ufmToList, filterUFM )
-import Type		( isUnLiftedType, coreEqType )
-import CoreLint		( showPass, endPass )
-import Util		( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
+import Type		( isUnLiftedType, coreEqType, splitTyConApp_maybe )
+import Coercion         ( coercionKind )
+import Util		( mapAndUnzip, lengthIs )
 import BasicTypes	( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
 			  RecFlag(..), isRec )
 import Maybes		( orElse, expectJust )
+import ErrUtils		( showPass )
 import Outputable
+
+import Data.List
 \end{code}
 
 To think about
@@ -67,17 +72,7 @@ To think about
 dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
 dmdAnalPgm dflags binds
   = do {
-	showPass dflags "Demand analysis" ;
 	let { binds_plus_dmds = do_prog binds } ;
-
-	endPass dflags "Demand analysis" 
-	 	Opt_D_dump_stranal binds_plus_dmds ;
-#ifdef OLD_STRICTNESS
-	-- Only if OLD_STRICTNESS is on, because only then is the old
-	-- strictness analyser run
-	let { dmd_changes = get_changes binds_plus_dmds } ;
-	printDump (text "Changes in demands" $$ dmd_changes) ;
-#endif
 	return binds_plus_dmds
     }
   where
@@ -164,16 +159,25 @@ dmdAnal sigs dmd (Lit lit)
 dmdAnal sigs dmd (Var var)
   = (dmdTransform sigs var dmd, Var var)
 
+dmdAnal sigs dmd (Cast e co)
+  = (dmd_ty, Cast e' co)
+  where
+    (dmd_ty, e') = dmdAnal sigs dmd' e
+    to_co        = snd (coercionKind co)
+    dmd'
+      | Just (tc, args) <- splitTyConApp_maybe to_co
+      , isRecursiveTyCon tc = evalDmd
+      | otherwise           = dmd
+	-- This coerce usually arises from a recursive
+        -- newtype, and we don't want to look inside them
+	-- for exactly the same reason that we don't look
+	-- inside recursive products -- we might not reach
+	-- a fixpoint.  So revert to a vanilla Eval demand
+
 dmdAnal sigs dmd (Note n e)
   = (dmd_ty, Note n e')
   where
-    (dmd_ty, e') = dmdAnal sigs dmd' e	
-    dmd' = case n of
-	     Coerce _ _ -> evalDmd  -- This coerce usually arises from a recursive
-	     other	-> dmd 	    -- newtype, and we don't want to look inside them
-				    -- for exactly the same reason that we don't look
-				    -- inside recursive products -- we might not reach
-				    -- a fixpoint.  So revert to a vanilla Eval demand
+    (dmd_ty, e') = dmdAnal sigs dmd e	
 
 dmdAnal sigs dmd (App fun (Type ty))
   = (fun_ty, App fun' (Type ty))
@@ -241,7 +245,7 @@ dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
 	--	x = (a, absent-error)
 	-- and that'll crash.
 	-- So at one stage I had:
-	--	dead_case_bndr		 = isAbsentDmd (idNewDemandInfo case_bndr')
+	--	dead_case_bndr		 = isAbsentDmd (idDemandInfo case_bndr')
 	--	keepity | dead_case_bndr = Drop
 	--		| otherwise	 = Keep		
 	--
@@ -252,9 +256,9 @@ dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
 	-- The insight is, of course, that a demand on y is a demand on the
 	-- scrutinee, so we need to `both` it with the scrut demand
 
-        scrut_dmd 	   = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
-				   `both`
-			     idNewDemandInfo case_bndr'
+	alt_dmd 	   = Eval (Prod [idDemandInfo b | b <- bndrs', isId b])
+        scrut_dmd 	   = alt_dmd `both`
+			     idDemandInfo case_bndr'
 
 	(scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
     in
@@ -409,7 +413,7 @@ dmdFix top_lvl sigs orig_pairs
 	-- of the fixpoint algorithm.  (Cunning plan.)
 	-- Note that the cunning plan extends to the DmdEnv too,
 	-- since it is part of the strictness signature
-initialSig id = idNewStrictness_maybe id `orElse` botSig
+initialSig id = idStrictness_maybe id `orElse` botSig
 
 dmdAnalRhs :: TopLevelFlag -> RecFlag
 	-> SigEnv -> (Id, CoreExpr)
@@ -427,7 +431,7 @@ dmdAnalRhs top_lvl rec_flag sigs (id, rhs)
 				-- The RHS can be eta-reduced to just a variable, 
 				-- in which case we should not complain. 
 		       mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
-  id'		     = id `setIdNewStrictness` sig_ty
+  id'		     = id `setIdStrictness` sig_ty
   sigs'		     = extendSigEnv top_lvl sigs id sig_ty
 \end{code}
 
@@ -447,8 +451,8 @@ mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, Stri
 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)
-    maybe_id_dmd = idNewDemandInfo_maybe id
+    never_inline = isNeverActive (idInlineActivation id)
+    maybe_id_dmd = idDemandInfo_maybe id
 	-- Is Nothing the first time round
 
     thunk_cpr_ok
@@ -464,7 +468,27 @@ The thunk_cpr_ok stuff [CPR-AND-STRICTNESS]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If the rhs is a thunk, we usually forget the CPR info, because
 it is presumably shared (else it would have been inlined, and 
-so we'd lose sharing if w/w'd it into a function.
+so we'd lose sharing if w/w'd it into a function).  E.g.
+
+	let r = case expensive of
+		  (a,b) -> (b,a)
+	in ...
+
+If we marked r as having the CPR property, then we'd w/w into
+
+	let $wr = \() -> case expensive of
+			    (a,b) -> (# b, a #)
+	    r = case $wr () of
+		  (# b,a #) -> (b,a)
+	in ...
+
+But now r is a thunk, which won't be inlined, so we are no further ahead.
+But consider
+
+	f x = let r = case expensive of (a,b) -> (b,a)
+	      in if foo r then r else (x,x)
+
+Does f have the CPR property?  Well, no.
 
 However, if the strictness analyser has figured out (in a previous 
 iteration) that it's strict, then we DON'T need to forget the CPR info.
@@ -528,9 +552,47 @@ in the case where t turns out to be not-demanded.  This is handled
 by dmdAnalTopBind.
 
 
+Note [NOINLINE and strictness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The strictness analyser used to have a HACK which ensured that NOINLNE
+things were not strictness-analysed.  The reason was unsafePerformIO. 
+Left to itself, the strictness analyser would discover this strictness 
+for unsafePerformIO:
+	unsafePerformIO:  C(U(AV))
+But then consider this sub-expression
+	unsafePerformIO (\s -> let r = f x in 
+			       case writeIORef v r s of (# s1, _ #) ->
+			       (# s1, r #)
+The strictness analyser will now find that r is sure to be eval'd,
+and may then hoist it out.  This makes tests/lib/should_run/memo002
+deadlock.
+
+Solving this by making all NOINLINE things have no strictness info is overkill.
+In particular, it's overkill for runST, which is perfectly respectable.
+Consider
+	f x = runST (return x)
+This should be strict in x.
+
+So the new plan is to define unsafePerformIO using the 'lazy' combinator:
+
+	unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
+
+Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is 
+magically NON-STRICT, and is inlined after strictness analysis.  So
+unsafePerformIO will look non-strict, and that's what we want.
+
+Now we don't need the hack in the strictness analyser.  HOWEVER, this
+decision does mean that even a NOINLINE function is not entirely
+opaque: some aspect of its implementation leaks out, notably its
+strictness.  For example, if you have a function implemented by an
+error stub, but which has RULES, you may want it not to be eliminated
+in favour of error!
+
+
 \begin{code}
 mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res) 
   = (lazy_fv, mkStrictSig dmd_ty)
+	-- Re unused never_inline, see Note [NOINLINE and strictness]
   where
     dmd_ty = DmdType strict_fv final_dmds res'
 
@@ -617,15 +679,6 @@ nonAbsentArgs (d   : ds) = 1 + nonAbsentArgs ds
 %************************************************************************
 
 \begin{code}
-splitDmdTy :: DmdType -> (Demand, DmdType)
--- Split off one function argument
--- We already have a suitable demand on all
--- free vars, so no need to add more!
-splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
-splitDmdTy ty@(DmdType fv [] res_ty)      = (resTypeArgDmd res_ty, ty)
-\end{code}
-
-\begin{code}
 unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
 
 addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
@@ -669,17 +722,22 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var)
 -- No effect on the argument demands
 annotateBndr dmd_ty@(DmdType fv ds res) var
   | isTyVar var = (dmd_ty, var)
-  | otherwise   = (DmdType fv' ds res, setIdNewDemandInfo var dmd)
+  | otherwise   = (DmdType fv' ds res, setIdDemandInfo var dmd)
   where
     (fv', dmd) = removeFV fv var res
 
 annotateBndrs = mapAccumR annotateBndr
 
+annotateLamIdBndr :: DmdType 	-- Demand type of body
+		  -> Id 	-- Lambda binder
+		  -> (DmdType, 	-- Demand type of lambda
+		      Id)	-- and binder annotated with demand	
+
 annotateLamIdBndr dmd_ty@(DmdType fv ds res) id
 -- For lambdas we add the demand to the argument demands
 -- Only called for Ids
   = ASSERT( isId id )
-    (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
+    (DmdType fv' (hacked_dmd:ds) res, setIdDemandInfo id hacked_dmd)
   where
     (fv', dmd) = removeFV fv id res
     hacked_dmd = argDemand dmd
@@ -745,7 +803,7 @@ extendSigsWithLam :: SigEnv -> Id -> SigEnv
 -- CPR results (e.g. from \x -> x!).
 
 extendSigsWithLam sigs id
-  = case idNewDemandInfo_maybe id of
+  = case idDemandInfo_maybe id of
 	Nothing	              -> extendVarEnv sigs id (cprSig, NotTopLevel)
 		-- Optimistic in the Nothing case;
 		-- See notes [CPR-AND-STRICTNESS]
@@ -765,7 +823,7 @@ dmdTransform sigs var dmd
 ------ 	DATA CONSTRUCTOR
   | isDataConWorkId var		-- Data constructor
   = let 
-	StrictSig dmd_ty    = idNewStrictness var	-- It must have a strictness sig
+	StrictSig dmd_ty    = idStrictness var	-- It must have a strictness sig
 	DmdType _ _ con_res = dmd_ty
 	arity		    = idArity var
     in
@@ -796,7 +854,7 @@ dmdTransform sigs var dmd
 
 ------ 	IMPORTED FUNCTION
   | isGlobalId var,		-- Imported function
-    let StrictSig dmd_ty = idNewStrictness var
+    let StrictSig dmd_ty = idStrictness var
   = if dmdTypeDepth dmd_ty <= call_depth then	-- Saturated, so unleash the demand
 	dmd_ty
     else
@@ -830,6 +888,13 @@ dmdTransform sigs var dmd
 %************************************************************************
 
 \begin{code}
+splitDmdTy :: DmdType -> (Demand, DmdType)
+-- Split off one function argument
+-- We already have a suitable demand on all
+-- free vars, so no need to add more!
+splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
+splitDmdTy ty@(DmdType fv [] res_ty)      = (resTypeArgDmd res_ty, ty)
+
 splitCallDmd :: Demand -> (Int, Demand)
 splitCallDmd (Call d) = case splitCallDmd d of
 			  (n, r) -> (n+1, r)
@@ -844,7 +909,6 @@ deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes
 	-- Notice that we throw away info about both arguments and results
 	-- For example,   f = let ... in \x -> x
 	-- We don't want to get a stricness type V->T for f.
-	-- Peter??
 
 deferEnv :: DmdEnv -> DmdEnv
 deferEnv fv = mapVarEnv defer fv
@@ -961,7 +1025,7 @@ lub d1@(Eval _) d2	          = d2 `lub` d1	-- Bot,Abs,Top,Call,Defer
 lub (Box d1)   (Box d2) = box (d1 `lub` d2)
 lub d1@(Box _)  d2	= d2 `lub` d1
 
-lubs = zipWithDmds lub
+lubs ds1 ds2 = zipWithDmds lub ds1 ds2
 
 ---------------------
 -- box is the smart constructor for Box
@@ -1068,90 +1132,5 @@ both d1@(Eval ds1) d2	       = d2 `both` d1
 both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
 both d1@(Defer ds1) d2	     = d2 `both` d1
  
-boths = zipWithDmds both
-\end{code}
-
-
-
-%************************************************************************
-%*									*
-\subsection{Miscellaneous
-%*									*
-%************************************************************************
-
-
-\begin{code}
-#ifdef OLD_STRICTNESS
-get_changes binds = vcat (map get_changes_bind binds)
-
-get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
-get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
-
-get_changes_pr (id,rhs) 
-  = get_changes_var id $$ get_changes_expr rhs
-
-get_changes_var var
-  | isId var  = get_changes_str var $$ get_changes_dmd var
-  | otherwise = empty
-
-get_changes_expr (Type t)     = empty
-get_changes_expr (Var v)      = empty
-get_changes_expr (Lit l)      = empty
-get_changes_expr (Note n e)   = get_changes_expr e
-get_changes_expr (App e1 e2)  = get_changes_expr e1 $$ get_changes_expr e2
-get_changes_expr (Lam b e)    = {- get_changes_var b $$ -} get_changes_expr e
-get_changes_expr (Let b e)    = get_changes_bind b $$ get_changes_expr e
-get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
-
-get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
-
-get_changes_str id
-  | new_better && old_better = empty
-  | new_better	       	     = message "BETTER"
-  | old_better	       	     = message "WORSE"
-  | otherwise	       	     = message "INCOMPARABLE" 
-  where
-    message word = text word <+> text "strictness for" <+> ppr id <+> info
-    info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
-    new = squashSig (idNewStrictness id)	-- Don't report spurious diffs that the old
-						-- strictness analyser can't track
-    old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
-    old_better = old `betterStrictness` new
-    new_better = new `betterStrictness` old
-
-get_changes_dmd id
-  | isUnLiftedType (idType id) = empty	-- Not useful
-  | new_better && old_better = empty
-  | new_better	       	     = message "BETTER"
-  | old_better	       	     = message "WORSE"
-  | otherwise	       	     = message "INCOMPARABLE" 
-  where
-    message word = text word <+> text "demand for" <+> ppr id <+> info
-    info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
-    new = squashDmd (argDemand (idNewDemandInfo id))	-- To avoid spurious improvements
-							-- A bit of a hack
-    old = newDemand (idDemandInfo id)
-    new_better = new `betterDemand` old 
-    old_better = old `betterDemand` new
-
-betterStrictness :: StrictSig -> StrictSig -> Bool
-betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
-
-betterDmdType t1 t2 = (t1 `lubType` t2) == t2
-
-betterDemand :: Demand -> Demand -> Bool
--- If d1 `better` d2, and d2 `better` d2, then d1==d2
-betterDemand d1 d2 = (d1 `lub` d2) == d2
-
-squashSig (StrictSig (DmdType fv ds res))
-  = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
-  where
-	-- squash just gets rid of call demands
-	-- which the old analyser doesn't track
-squashDmd (Call d)   = evalDmd
-squashDmd (Box d)    = Box (squashDmd d)
-squashDmd (Eval ds)  = Eval (mapDmds squashDmd ds)
-squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)
-squashDmd d          = d
-#endif
+boths ds1 ds2 = zipWithDmds both ds1 ds2
 \end{code}