X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=242a94707430685b8bda5b881909ae633fad4ad3;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=fd4445b6511cc82ae43e6852c4e77c855915b63f;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index fd4445b..242a947 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
 \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
 
@@ -7,38 +7,32 @@ The original version(s) of all strictness-analyser code (except the
 Semantique analyser) was written by Andy Gill.
 
 \begin{code}
-#include "HsVersions.h"
+#ifndef OLD_STRICTNESS
+module StrictAnal ( ) where
 
-module StrictAnal ( saWwTopBinds, saTopBinds ) where
+#else
 
-IMP_Ubiq(){-uitous-}
+module StrictAnal ( saBinds ) where
 
-import CmdLineOpts	( opt_AllStrict, opt_NumbersStrict,
-			  opt_D_dump_stranal, opt_D_simplifier_stats
-			)
+#include "HsVersions.h"
+
+import DynFlags	( DynFlags, DynFlag(..) )
 import CoreSyn
-import Id		( idType, addIdStrictness,
-			  getIdDemandInfo, addIdDemandInfo,
-			  GenId{-instance Outputable-}
-			)
-import IdInfo		( mkStrictnessInfo, mkBottomStrictnessInfo,
-			  mkDemandInfo, willBeDemanded, DemandInfo
+import Id		( setIdStrictness, setInlinePragma, 
+			  idDemandInfo, setIdDemandInfo, isBottomingId,
+			  Id
 			)
-import PprCore		( pprCoreBinding, pprBigCoreBinder )
-import PprStyle		( PprStyle(..) )
-import PprType		( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
-import Pretty		( ppBesides, ppStr, ppInt, ppChar, ppAboves )
+import CoreLint		( showPass, endPass )
+import ErrUtils		( dumpIfSet_dyn )
 import SaAbsInt
 import SaLib
-import TyVar		( GenTyVar{-instance Eq-} )
-import WorkWrap		-- "back-end" of strictness analyser
-import Unique		( Unique{-instance Eq -} )
-import Util		( zipWith4Equal, pprTrace, panic{-ToDo:rm-} )
-
-isWrapperId = panic "StrictAnal.isWrapperId (ToDo)"
+import Demand		( Demand, wwStrict, isStrict, isLazy )
+import Util		( zipWith3Equal, stretchZipWith, compareLength )
+import BasicTypes	( Activation( NeverActive ) )
+import Outputable
+import FastTypes
 \end{code}
 
-
 %************************************************************************
 %*									*
 \subsection[Thoughts]{Random thoughts}
@@ -85,52 +79,28 @@ Alas and alack.
 %*									*
 %************************************************************************
 
-\begin{code}
-saWwTopBinds :: UniqSupply
-	     -> [CoreBinding]
-	     -> [CoreBinding]
+@saBinds@ decorates bindings with strictness info.  A later 
+worker-wrapper pass can use this info to create wrappers and
+strict workers.
 
-saWwTopBinds us binds
-  = let
-	strflags = (opt_AllStrict, opt_NumbersStrict)
+\begin{code}
+saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
+saBinds dflags binds
+  = do {
+	showPass dflags "Strictness analysis";
 
-	-- mark each binder with its strictness
-#ifndef OMIT_STRANAL_STATS
-	(binds_w_strictness, sa_stats)
-	  = sa_top_binds strflags binds nullSaStats
-#else
-	binds_w_strictness
-	  = sa_top_binds strflags binds
-#endif
-    in
-    -- possibly show what we decided about strictness...
-    (if opt_D_dump_stranal
-     then pprTrace "Strictness:\n" (ppAboves (
-	   map (pprCoreBinding PprDebug)  binds_w_strictness))
-     else id
-    )
-    -- possibly show how many things we marked as demanded...
-    ((if opt_D_simplifier_stats
+	-- Mark each binder with its strictness
 #ifndef OMIT_STRANAL_STATS
-     then pp_stats sa_stats
+	let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
+	dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
+		  (pp_stats sa_stats);
 #else
-     then id
-#endif
-     else id
-    )
-	-- create worker/wrappers, and mark binders with their
-	-- "strictness info" [which encodes their
-	-- worker/wrapper-ness]
-    (workersAndWrappers binds_w_strictness us))
-#ifndef OMIT_STRANAL_STATS
-  where
-    pp_stats (SaStats tlam dlam tc dc tlet dlet)
-      = pprTrace "Binders marked demanded: "
-	(ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
-		  ppStr "; Case vars: ",   ppInt IBOX(dc),   ppChar '/', ppInt IBOX(tc),
-		  ppStr "; Let vars: ",    ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet)
-	])
+	let { binds_w_strictness = saTopBindsBinds binds };
 #endif
+
+	endPass dflags "Strictness analysis" Opt_D_dump_stranal
+		binds_w_strictness
+    }
 \end{code}
 
 %************************************************************************
@@ -155,19 +125,11 @@ environment which maps @Id@s to their abstract values (i.e., an
 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
 
 \begin{code}
-saTopBinds   :: StrAnalFlags -> [CoreBinding] -> [CoreBinding]     -- exported
-sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
+saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
 
-saTopBinds strflags binds
-#ifndef OMIT_STRANAL_STATS
-  = fst (sa_top_binds strflags binds nullSaStats)
-#else
-  = sa_top_binds strflags binds
-#endif
-
-sa_top_binds strflags binds
+saTopBinds binds
   = let
-	starting_abs_env = nullAbsValEnv strflags
+	starting_abs_env = nullAbsValEnv
     in
     do_it starting_abs_env starting_abs_env binds
   where
@@ -185,14 +147,12 @@ be used; we can't turn top-level @let@s into @case@s.
 
 \begin{code}
 saTopBind :: StrictEnv -> AbsenceEnv
-	  -> CoreBinding
-	  -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
+	  -> CoreBind
+	  -> SaM (StrictEnv, AbsenceEnv, CoreBind)
 
 saTopBind str_env abs_env (NonRec binder rhs)
-  = saExpr str_env abs_env rhs 	`thenSa` \ new_rhs ->
+  = saExpr minDemand str_env abs_env rhs 	`thenSa` \ new_rhs ->
     let
-	strflags = getStrAnalFlags str_env
-
 	str_rhs = absEval StrAnal rhs str_env
 	abs_rhs = absEval AbsAnal rhs abs_env
 
@@ -202,11 +162,9 @@ saTopBind str_env abs_env (NonRec binder rhs)
 		-- See notes on Let case in SaAbsInt.lhs
 
 	new_binder
-	  = addStrictnessInfoToId
-		strflags
+	  = addStrictnessInfoToTopId
 		widened_str_rhs widened_abs_rhs
 		binder
-		rhs
 
 	  -- Augment environments with a mapping of the
 	  -- binder to its abstract values, computed by absEval
@@ -217,21 +175,31 @@ saTopBind str_env abs_env (NonRec binder rhs)
 
 saTopBind str_env abs_env (Rec pairs)
   = let
-	strflags    = getStrAnalFlags str_env
 	(binders,rhss) = unzip pairs
 	str_rhss    = fixpoint StrAnal binders rhss str_env
 	abs_rhss    = fixpoint AbsAnal binders rhss abs_env
 		      -- fixpoint returns widened values
       	new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
       	new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
-	new_binders = zipWith4Equal "saTopBind" (addStrictnessInfoToId strflags)
-				    str_rhss abs_rhss binders rhss
+	new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
+				    str_rhss abs_rhss binders
     in
-    mapSa (saExpr new_str_env new_abs_env) rhss	`thenSa` \ new_rhss ->
+    mapSa (saExpr minDemand new_str_env new_abs_env) rhss	`thenSa` \ new_rhss ->
     let
 	new_pairs   = new_binders `zip` new_rhss
     in
     returnSa (new_str_env, new_abs_env, Rec new_pairs)
+
+-- Hack alert!
+-- Top level divergent bindings are marked NOINLINE
+-- This avoids fruitless inlining of top level error functions
+addStrictnessInfoToTopId str_val abs_val bndr
+  = if isBottomingId new_id then
+	new_id `setInlinePragma` NeverActive
+    else
+	new_id
+  where
+    new_id = addStrictnessInfoToId str_val abs_val bndr
 \end{code}
 
 %************************************************************************
@@ -244,66 +212,85 @@ saTopBind str_env abs_env (Rec pairs)
 environment.
 
 \begin{code}
-saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
-
-saExpr _ _ e@(Var _)	= returnSa e
-saExpr _ _ e@(Lit _)	= returnSa e
-saExpr _ _ e@(Con  _ _)	= returnSa e
-saExpr _ _ e@(Prim _ _)	= returnSa e
-
-saExpr str_env abs_env (Lam (ValBinder arg) body)
-  = saExpr str_env abs_env body	`thenSa` \ new_body ->
+saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
+	-- The demand is the least demand we expect on the
+	-- expression.  WwStrict is the least, because we're only
+	-- interested in the expression at all if it's being evaluated,
+	-- but the demand may be more.  E.g.
+	--	f E
+	-- where f has strictness u(LL), will evaluate E with demand u(LL)
+
+minDemand = wwStrict 
+minDemands = repeat minDemand
+
+-- When we find an application, do the arguments
+-- with demands gotten from the function
+saApp str_env abs_env (fun, args)
+  = sequenceSa sa_args				`thenSa` \ args' ->
+    saExpr minDemand str_env abs_env fun	`thenSa` \ fun'  -> 
+    returnSa (mkApps fun' args')
+  where
+    arg_dmds = case fun of
+		 Var var -> case lookupAbsValEnv str_env var of
+				Just (AbsApproxFun ds _) 
+				   | compareLength ds args /= LT 
+				              -- 'ds' is at least as long as 'args'.
+					-> ds ++ minDemands
+				other   -> minDemands
+		 other -> minDemands
+
+    sa_args = stretchZipWith isTypeArg (error "saApp:dmd") 
+			     sa_arg args arg_dmds 
+	-- The arg_dmds are for value args only, we need to skip
+	-- over the type args when pairing up with the demands
+	-- Hence the stretchZipWith
+
+    sa_arg arg dmd = saExpr dmd' str_env abs_env arg
+		   where
+			-- Bring arg demand up to minDemand
+			dmd' | isLazy dmd = minDemand
+			     | otherwise  = dmd
+
+saExpr _ _ _ e@(Var _)	= returnSa e
+saExpr _ _ _ e@(Lit _)	= returnSa e
+saExpr _ _ _ e@(Type _)	= returnSa e
+
+saExpr dmd str_env abs_env (Lam bndr body)
+  =	-- Don't bother to set the demand-info on a lambda binder
+	-- We do that only for let(rec)-bound functions
+    saExpr minDemand str_env abs_env body	`thenSa` \ new_body ->
+    returnSa (Lam bndr new_body)
+
+saExpr dmd str_env abs_env e@(App fun arg)
+  = saApp str_env abs_env (collectArgs e)
+
+saExpr dmd str_env abs_env (Note note expr)
+  = saExpr dmd str_env abs_env expr	`thenSa` \ new_expr ->
+    returnSa (Note note new_expr)
+
+saExpr dmd str_env abs_env (Case expr case_bndr alts)
+  = saExpr minDemand str_env abs_env expr	`thenSa` \ new_expr  ->
+    mapSa sa_alt alts				`thenSa` \ new_alts  ->
     let
-	new_arg = addDemandInfoToId str_env abs_env body arg
+	new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
     in
-    tickLambda new_arg	`thenSa_` -- stats
-    returnSa (Lam (ValBinder new_arg) new_body)
-
-saExpr str_env abs_env (Lam other_binder expr)
-  = saExpr str_env abs_env expr	`thenSa` \ new_expr ->
-    returnSa (Lam other_binder new_expr)
-
-saExpr str_env abs_env (App fun arg)
-  = saExpr str_env abs_env fun	`thenSa` \ new_fun ->
-    returnSa (App new_fun arg)
-
-saExpr str_env abs_env (SCC cc expr)
-  = saExpr str_env abs_env expr	`thenSa` \ new_expr ->
-    returnSa (SCC cc new_expr)
-
-saExpr str_env abs_env (Coerce c ty expr)
-  = saExpr str_env abs_env expr	`thenSa` \ new_expr ->
-    returnSa (Coerce c ty new_expr)
-
-saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
-  = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
-    saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
-    mapSa sa_alt alts		    `thenSa` \ new_alts  ->
-    returnSa (Case new_expr (AlgAlts new_alts new_deflt))
+    returnSa (Case new_expr new_case_bndr new_alts)
   where
     sa_alt (con, binders, rhs)
-      = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
+      = saExpr dmd str_env abs_env rhs  `thenSa` \ new_rhs ->
 	let
-	    new_binders = addDemandInfoToIds str_env abs_env rhs binders
+	    new_binders = map add_demand_info binders
+	    add_demand_info bndr | isTyVar bndr = bndr
+			  	 | otherwise	= addDemandInfoToId dmd str_env abs_env rhs bndr
 	in
 	tickCases new_binders	    `thenSa_` -- stats
 	returnSa (con, new_binders, new_rhs)
 
-saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
-  = saExpr    str_env abs_env expr  `thenSa` \ new_expr  ->
-    saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
-    mapSa sa_alt alts		    `thenSa` \ new_alts  ->
-    returnSa (Case new_expr (PrimAlts new_alts new_deflt))
-  where
-    sa_alt (lit, rhs)
-      = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
-	returnSa (lit, new_rhs)
-
-saExpr str_env abs_env (Let (NonRec binder rhs) body)
+saExpr dmd str_env abs_env (Let (NonRec binder rhs) body)
   =	-- Analyse the RHS in the environment at hand
-    saExpr str_env abs_env rhs  `thenSa` \ new_rhs  ->
     let
-	strflags = getStrAnalFlags str_env
+	-- Find the demand on the RHS
+	rhs_dmd = findDemand dmd str_env abs_env body binder
 
 	-- Bind this binder to the abstract value of the RHS; analyse
 	-- the body of the `let' in the extended environment.
@@ -320,18 +307,17 @@ saExpr str_env abs_env (Let (NonRec binder rhs) body)
 
 	-- Now determine the strictness of this binder; use that info
 	-- to record DemandInfo/StrictnessInfo in the binder.
-	new_binder = addStrictnessInfoToId strflags
+	new_binder = addStrictnessInfoToId
 			widened_str_rhs widened_abs_rhs
-			(addDemandInfoToId str_env abs_env body binder)
-			rhs
+			(binder `setIdDemandInfo` rhs_dmd)
     in
-    tickLet new_binder			`thenSa_` -- stats
-    saExpr new_str_env new_abs_env body	`thenSa` \ new_body ->
+    tickLet new_binder				`thenSa_` -- stats
+    saExpr rhs_dmd str_env abs_env rhs		`thenSa` \ new_rhs  ->
+    saExpr dmd new_str_env new_abs_env body	`thenSa` \ new_body ->
     returnSa (Let (NonRec new_binder new_rhs) new_body)
 
-saExpr str_env abs_env (Let (Rec pairs) body)
+saExpr dmd str_env abs_env (Let (Rec pairs) body)
   = let
-	strflags       = getStrAnalFlags str_env
 	(binders,rhss) = unzip pairs
 	str_vals       = fixpoint StrAnal binders rhss str_env
 	abs_vals       = fixpoint AbsAnal binders rhss abs_env
@@ -339,10 +325,9 @@ saExpr str_env abs_env (Let (Rec pairs) body)
       	new_str_env    = growAbsValEnvList str_env (binders `zip` str_vals)
       	new_abs_env    = growAbsValEnvList abs_env (binders `zip` abs_vals)
     in
-    saExpr new_str_env new_abs_env body		`thenSa` \ new_body ->
-    mapSa (saExpr new_str_env new_abs_env) rhss	`thenSa` \ new_rhss ->
+    saExpr dmd new_str_env new_abs_env body			`thenSa` \ new_body ->
+    mapSa (saExpr minDemand new_str_env new_abs_env) rhss	`thenSa` \ new_rhss ->
     let
---	new_binders      = addDemandInfoToIds new_str_env new_abs_env body binders
 -- 		DON'T add demand info in a Rec!
 --		a) it's useless: we can't do let-to-case
 --		b) it's incorrect.  Consider
@@ -354,28 +339,12 @@ saExpr str_env abs_env (Let (Rec pairs) body)
 --		   deciding that y is absent, which is plain wrong!
 --		It's much easier simply not to do this.
 
-	improved_binders = zipWith4Equal "saExpr" (addStrictnessInfoToId strflags)
-				         str_vals abs_vals binders rhss
-
-	whiter_than_white_binders = launder improved_binders
+	improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
+				         str_vals abs_vals binders
 
-      	new_pairs   = whiter_than_white_binders `zip` new_rhss
+      	new_pairs   = improved_binders `zip` new_rhss
     in
     returnSa (Let (Rec new_pairs) new_body)
-  where
-    launder me = {-still-} me
-\end{code}
-
-\begin{code}
-saDefault str_env abs_env NoDefault = returnSa NoDefault
-
-saDefault str_env abs_env (BindDefault bdr rhs)
-  = saExpr str_env abs_env rhs	`thenSa` \ new_rhs ->
-    let
-	new_bdr = addDemandInfoToId str_env abs_env rhs bdr
-    in
-    tickCases [new_bdr]		`thenSa_` -- stats
-    returnSa (BindDefault new_bdr new_rhs)
 \end{code}
 
 
@@ -398,44 +367,26 @@ tell how many args could safely be grabbed.
 
 \begin{code}
 addStrictnessInfoToId
-	:: StrAnalFlags
-	-> AbsVal 		-- Abstract strictness value
+	:: AbsVal 		-- Abstract strictness value
 	-> AbsVal		-- Ditto absence
 	-> Id 			-- The id
-	-> CoreExpr	-- Its RHS
 	-> Id			-- Augmented with strictness
 
-addStrictnessInfoToId strflags str_val abs_val binder body
-  = if isWrapperId binder then
-	binder	-- Avoid clobbering existing strictness info
-		-- (and, more importantly, worker info).
-		-- Deeply suspicious (SLPJ)
-    else
-    if (isBot str_val) then
-	binder `addIdStrictness` mkBottomStrictnessInfo
-    else
-	case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
-	let
-		tys        = map idType lambda_bounds
-		strictness = findStrictness strflags tys str_val abs_val
-	in
-	binder `addIdStrictness` mkStrictnessInfo strictness Nothing
-	}
+addStrictnessInfoToId str_val abs_val binder
+  = binder `setIdStrictness` findStrictness binder str_val abs_val
 \end{code}
 
 \begin{code}
-addDemandInfoToId :: StrictEnv -> AbsenceEnv
+addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
 		  -> CoreExpr 	-- The scope of the id
 		  -> Id
 		  -> Id			-- Id augmented with Demand info
 
-addDemandInfoToId str_env abs_env expr binder
-  = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
-
-addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
+addDemandInfoToId dmd str_env abs_env expr binder
+  = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
 
-addDemandInfoToIds str_env abs_env expr binders
-  = map (addDemandInfoToId str_env abs_env expr) binders
+addDemandInfoToCaseBndr dmd str_env abs_env alts binder
+  = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
 \end{code}
 
 %************************************************************************
@@ -446,12 +397,12 @@ addDemandInfoToIds str_env abs_env expr binders
 
 \begin{code}
 data SaStats
-  = SaStats FAST_INT FAST_INT	-- total/marked-demanded lambda-bound
-	    FAST_INT FAST_INT	-- total/marked-demanded case-bound
-	    FAST_INT FAST_INT	-- total/marked-demanded let-bound
+  = SaStats FastInt FastInt	-- total/marked-demanded lambda-bound
+	    FastInt FastInt	-- total/marked-demanded case-bound
+	    FastInt FastInt	-- total/marked-demanded let-bound
 				-- (excl. top-level; excl. letrecs)
 
-nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
+nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0)
 
 thenSa	      :: SaM a -> (a -> SaM b) -> SaM b
 thenSa_	      :: SaM a -> SaM b -> SaM b
@@ -462,7 +413,7 @@ returnSa      :: a -> SaM a
 {-# INLINE returnSa #-}
 
 tickLambda :: Id   -> SaM ()
-tickCases  :: [Id] -> SaM ()
+tickCases  :: [CoreBndr] -> SaM ()
 tickLet    :: Id   -> SaM ()
 
 #ifndef OMIT_STRANAL_STATS
@@ -479,24 +430,38 @@ thenSa_ expr cont stats
 returnSa x stats = (x, stats)
 
 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
-  = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
-    ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
+  = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
+    let tot = iUnbox totB ; demanded = iUnbox demandedB 
+    in
+    ((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) }
 
 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
-  = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
-    ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
+  = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
+    let tot = iUnbox totB ; demanded = iUnbox demandedB 
+    in
+    ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) }
 
 tickLet var (SaStats tlam dlam tc dc tlet dlet)
-  = case (tick_demanded var (0,0))        of { (IBOX(tot),IBOX(demanded)) ->
-    ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
+  = case (tick_demanded var (0,0))        of { (totB, demandedB) ->
+    let tot = iUnbox totB ; demanded = iUnbox demandedB 
+    in
+    ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) }
 
 tick_demanded var (tot, demanded)
+  | isTyVar var = (tot, demanded)
+  | otherwise
   = (tot + 1,
-     if (willBeDemanded (getIdDemandInfo var))
+     if (isStrict (idDemandInfo var))
      then demanded + 1
      else demanded)
 
-#else {-OMIT_STRANAL_STATS-}
+pp_stats (SaStats tlam dlam tc dc tlet dlet)
+      = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
+	      ptext SLIT("; Case vars: "), int (iBox dc),   char '/', int (iBox tc),
+	      ptext SLIT("; Let vars: "),  int (iBox dlet), char '/', int (iBox tlet)
+	]
+
+#else /* OMIT_STRANAL_STATS */
 -- identity monad
 type SaM a = a
 
@@ -510,13 +475,20 @@ tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 
-#endif {-OMIT_STRANAL_STATS-}
+#endif /* OMIT_STRANAL_STATS */
 
 mapSa	      :: (a -> SaM b) -> [a] -> SaM [b]
 
 mapSa f []     = returnSa []
-mapSa f (x:xs)
-  = f x		`thenSa` \ r  ->
-    mapSa f xs	`thenSa` \ rs ->
-    returnSa (r:rs)
+mapSa f (x:xs) = f x		`thenSa` \ r  ->
+		 mapSa f xs	`thenSa` \ rs ->
+		 returnSa (r:rs)
+
+sequenceSa :: [SaM a] -> SaM [a]
+sequenceSa []     = returnSa []
+sequenceSa (m:ms) = m		  `thenSa` \ r ->
+		    sequenceSa ms `thenSa` \ rs ->
+		    returnSa (r:rs)
+
+#endif /* OLD_STRICTNESS */
 \end{code}