projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 1998-12-02 13:17:09 by simonm]
[ghc-hetmet.git] / ghc / compiler / stranal / StrictAnal.lhs
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index 5e83966..1bc8474 100644 (file)
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -1,5 +1,5 @@
 %
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
 \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
 
 %
 \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
 
@@ -7,33 +7,28 @@ The original version(s) of all strictness-analyser code (except the
 Semantique analyser) was written by Andy Gill.
 
 \begin{code}
 Semantique analyser) was written by Andy Gill.
 
 \begin{code}
-#include "HsVersions.h"
-
-module StrictAnal ( saWwTopBinds, saTopBinds ) where
+module StrictAnal ( saWwTopBinds ) where
 
 
-IMPORT_Trace
-import Outputable
-import Pretty
+#include "HsVersions.h"
 
 
-import CmdLineOpts     ( GlobalSwitch(..) )
-import CoreSyn         -- ToDo: get pprCoreBinding straight from PlainCore?
-import Id              ( addIdDemandInfo, isWrapperId, addIdStrictness,
-                         getIdUniType, getIdDemandInfo
-                         IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
+import CmdLineOpts     ( opt_D_dump_stranal, opt_D_simplifier_stats,  opt_D_verbose_core2core )
+import CoreSyn
+import Id              ( idType, setIdStrictness,
+                         getIdDemandInfo, setIdDemandInfo,
+                         Id
                        )
                        )
-import IdEnv
-import IdInfo
-import PlainCore
+import IdInfo          ( mkStrictnessInfo, mkBottomStrictnessInfo )
+import CoreLint                ( beginPass, endPass )
+import ErrUtils                ( dumpIfSet )
 import SaAbsInt
 import SaLib
 import SaAbsInt
 import SaLib
-import SplitUniq
-import Unique
-import Util
+import Demand          ( isStrict )
 import WorkWrap                -- "back-end" of strictness analyser
 import WorkWrap                -- "back-end" of strictness analyser
-import WwLib           ( WwM(..) )
+import UniqSupply       ( UniqSupply )
+import Util            ( zipWith4Equal )
+import Outputable
 \end{code}
 
 \end{code}
 
-
 %************************************************************************
 %*                                                                     *
 \subsection[Thoughts]{Random thoughts}
 %************************************************************************
 %*                                                                     *
 \subsection[Thoughts]{Random thoughts}
@@ -49,12 +44,12 @@ A note about worker-wrappering.  If we have
 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
 
        f = \x -> case x of Int x# -> fw x#
 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
 
        f = \x -> case x of Int x# -> fw x#
-       fw = \x# -> let x = Int x# 
-                   in 
+       fw = \x# -> let x = Int x#
+                   in
                    let v = <expensive>
                    in <body>
 
                    let v = <expensive>
                    in <body>
 
-because this obviously loses laziness, since now <expensive> 
+because this obviously loses laziness, since now <expensive>
 is done each time.  Alas.
 
 WATCH OUT!  This can mean that something is unboxed only to be
 is done each time.  Alas.
 
 WATCH OUT!  This can mean that something is unboxed only to be
@@ -81,52 +76,29 @@ Alas and alack.
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-saWwTopBinds :: SplitUniqSupply
-            -> (GlobalSwitch -> Bool)
-            -> [PlainCoreBinding]
-            -> [PlainCoreBinding]
+saWwTopBinds :: UniqSupply
+            -> [CoreBind]
+            -> IO [CoreBind]
 
 
-saWwTopBinds us switch_chker binds
-  = let
-       strflags = (switch_chker AllStrict, switch_chker NumbersStrict)
+saWwTopBinds us binds
+  = do {
+       beginPass "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 switch_chker D_dump_stranal
-     then pprTrace "Strictness:\n" (ppAboves (
-          map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness))
-     else id
-    )
-    -- possibly show how many things we marked as demanded...
-    ((if switch_chker D_simplifier_stats
+       -- Mark each binder with its strictness
 #ifndef OMIT_STRANAL_STATS
 #ifndef OMIT_STRANAL_STATS
-     then pp_stats sa_stats
+       let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
+       dumpIfSet opt_D_simplifier_stats "Strictness analysis statistics"
+                 (pp_stats sa_stats);
 #else
 #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 switch_chker))
-#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
 #endif
+
+       -- Create worker/wrappers, and mark binders with their
+       -- "strictness info" [which encodes their worker/wrapper-ness]
+       let { binds' = workersAndWrappers us binds_w_strictness };
+
+       endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds'
+    }
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -151,19 +123,11 @@ environment which maps @Id@s to their abstract values (i.e., an
 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
 
 \begin{code}
 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
 
 \begin{code}
-saTopBinds   :: StrAnalFlags -> [PlainCoreBinding] -> [PlainCoreBinding]     -- exported
-sa_top_binds :: StrAnalFlags -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
-
-saTopBinds strflags binds
-#ifndef OMIT_STRANAL_STATS
-  = fst (sa_top_binds strflags binds nullSaStats)
-#else
-  = sa_top_binds strflags binds
-#endif
+saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
 
 
-sa_top_binds strflags binds
+saTopBinds binds
   = let
   = let
-       starting_abs_env = nullAbsValEnv strflags
+       starting_abs_env = nullAbsValEnv
     in
     do_it starting_abs_env starting_abs_env binds
   where
     in
     do_it starting_abs_env starting_abs_env binds
   where
@@ -181,25 +145,22 @@ be used; we can't turn top-level @let@s into @case@s.
 
 \begin{code}
 saTopBind :: StrictEnv -> AbsenceEnv
 
 \begin{code}
 saTopBind :: StrictEnv -> AbsenceEnv
-         -> PlainCoreBinding
-         -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
+         -> CoreBind
+         -> SaM (StrictEnv, AbsenceEnv, CoreBind)
 
 
-saTopBind str_env abs_env (CoNonRec binder rhs)
+saTopBind str_env abs_env (NonRec binder rhs)
   = saExpr str_env abs_env rhs         `thenSa` \ new_rhs ->
     let
   = saExpr 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
 
        widened_str_rhs = widen StrAnal str_rhs
        widened_abs_rhs = widen AbsAnal abs_rhs
                -- The widening above is done for efficiency reasons.
        str_rhs = absEval StrAnal rhs str_env
        abs_rhs = absEval AbsAnal rhs abs_env
 
        widened_str_rhs = widen StrAnal str_rhs
        widened_abs_rhs = widen AbsAnal abs_rhs
                -- The widening above is done for efficiency reasons.
-               -- See notes on CoLet case in SaAbsInt.lhs
+               -- See notes on Let case in SaAbsInt.lhs
 
        new_binder
          = addStrictnessInfoToId
 
        new_binder
          = addStrictnessInfoToId
-               strflags
                widened_str_rhs widened_abs_rhs
                binder
                rhs
                widened_str_rhs widened_abs_rhs
                binder
                rhs
@@ -209,25 +170,24 @@ saTopBind str_env abs_env (CoNonRec binder rhs)
        new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
        new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
     in
        new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
        new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
     in
-    returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs)
+    returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
 
 
-saTopBind str_env abs_env (CoRec pairs)
+saTopBind str_env abs_env (Rec pairs)
   = let
   = 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)
        (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 = zipWith4 (addStrictnessInfoToId strflags)
-                               str_rhss abs_rhss binders rhss
+       new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId
+                                   str_rhss abs_rhss binders rhss
     in
     mapSa (saExpr new_str_env new_abs_env) rhss        `thenSa` \ new_rhss ->
     let
        new_pairs   = new_binders `zip` new_rhss
     in
     in
     mapSa (saExpr 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, CoRec new_pairs)
+    returnSa (new_str_env, new_abs_env, Rec new_pairs)
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -240,67 +200,49 @@ saTopBind str_env abs_env (CoRec pairs)
 environment.
 
 \begin{code}
 environment.
 
 \begin{code}
-saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr
+saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
 
 
-saExpr _ _ e@(CoVar _)      = returnSa e
-saExpr _ _ e@(CoLit _)      = returnSa e
-saExpr _ _ e@(CoCon _ _ _)  = returnSa e
-saExpr _ _ e@(CoPrim _ _ _) = returnSa e
+saExpr _ _ e@(Var _)   = returnSa e
+saExpr _ _ e@(Con  _ _)        = returnSa e
+saExpr _ _ e@(Type _)  = returnSa e
 
 
-saExpr str_env abs_env (CoLam args body)
-  = saExpr str_env abs_env body        `thenSa` \ new_body ->
-    let
-       new_args  = addDemandInfoToIds str_env abs_env body args
-    in
-    tickLambdas new_args       `thenSa_` -- stats
-    returnSa (CoLam new_args new_body)
+saExpr 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 str_env abs_env body        `thenSa` \ new_body ->
+    returnSa (Lam bndr new_body)
 
 
-saExpr str_env abs_env (CoTyLam ty expr)
-  = saExpr str_env abs_env expr        `thenSa` \ new_expr ->
-    returnSa (CoTyLam ty new_expr)
-
-saExpr str_env abs_env (CoApp fun arg)
+saExpr str_env abs_env (App fun arg)
   = saExpr str_env abs_env fun `thenSa` \ new_fun ->
   = saExpr str_env abs_env fun `thenSa` \ new_fun ->
-    returnSa (CoApp new_fun arg)
-
-saExpr str_env abs_env (CoTyApp expr ty)
-  = saExpr str_env abs_env expr        `thenSa` \ new_expr ->
-    returnSa (CoTyApp new_expr ty)
+    saExpr str_env abs_env arg `thenSa` \ new_arg ->
+    returnSa (App new_fun new_arg)
 
 
-saExpr str_env abs_env (CoSCC cc expr)
+saExpr str_env abs_env (Note note expr)
   = saExpr str_env abs_env expr        `thenSa` \ new_expr ->
   = saExpr str_env abs_env expr        `thenSa` \ new_expr ->
-    returnSa (CoSCC cc new_expr)
+    returnSa (Note note new_expr)
 
 
-saExpr str_env abs_env (CoCase expr (CoAlgAlts 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 (CoCase new_expr (CoAlgAlts new_alts new_deflt))
+saExpr str_env abs_env (Case expr case_bndr alts)
+  = saExpr str_env abs_env expr                `thenSa` \ new_expr  ->
+    mapSa sa_alt alts                  `thenSa` \ new_alts  ->
+    let
+       new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr
+    in
+    returnSa (Case new_expr new_case_bndr new_alts)
   where
     sa_alt (con, binders, rhs)
       = saExpr str_env abs_env rhs  `thenSa` \ new_rhs ->
        let
   where
     sa_alt (con, binders, rhs)
       = saExpr 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 str_env abs_env rhs bndr
        in
        tickCases new_binders       `thenSa_` -- stats
        returnSa (con, new_binders, new_rhs)
 
        in
        tickCases new_binders       `thenSa_` -- stats
        returnSa (con, new_binders, new_rhs)
 
-saExpr str_env abs_env (CoCase expr (CoPrimAlts 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 (CoCase new_expr (CoPrimAlts 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 (CoLet (CoNonRec binder rhs) body)
+saExpr 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
   =    -- Analyse the RHS in the environment at hand
     saExpr str_env abs_env rhs  `thenSa` \ new_rhs  ->
     let
-       strflags = getStrAnalFlags str_env
-
        -- Bind this binder to the abstract value of the RHS; analyse
        -- the body of the `let' in the extended environment.
        str_rhs_val     = absEval StrAnal rhs str_env
        -- Bind this binder to the abstract value of the RHS; analyse
        -- the body of the `let' in the extended environment.
        str_rhs_val     = absEval StrAnal rhs str_env
@@ -309,25 +251,24 @@ saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body)
        widened_str_rhs = widen StrAnal str_rhs_val
        widened_abs_rhs = widen AbsAnal abs_rhs_val
                -- The widening above is done for efficiency reasons.
        widened_str_rhs = widen StrAnal str_rhs_val
        widened_abs_rhs = widen AbsAnal abs_rhs_val
                -- The widening above is done for efficiency reasons.
-               -- See notes on CoLet case in SaAbsInt.lhs
+               -- See notes on Let case in SaAbsInt.lhs
 
        new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
        new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
 
        -- Now determine the strictness of this binder; use that info
        -- to record DemandInfo/StrictnessInfo in the binder.
 
        new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
        new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
 
        -- 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
     in
     tickLet new_binder                 `thenSa_` -- stats
     saExpr new_str_env new_abs_env body        `thenSa` \ new_body ->
                        widened_str_rhs widened_abs_rhs
                        (addDemandInfoToId str_env abs_env body binder)
                        rhs
     in
     tickLet new_binder                 `thenSa_` -- stats
     saExpr new_str_env new_abs_env body        `thenSa` \ new_body ->
-    returnSa (CoLet (CoNonRec new_binder new_rhs) new_body)
+    returnSa (Let (NonRec new_binder new_rhs) new_body)
 
 
-saExpr str_env abs_env (CoLet (CoRec pairs) body)
+saExpr str_env abs_env (Let (Rec pairs) body)
   = let
   = 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
        (binders,rhss) = unzip pairs
        str_vals       = fixpoint StrAnal binders rhss str_env
        abs_vals       = fixpoint AbsAnal binders rhss abs_env
@@ -339,7 +280,7 @@ saExpr str_env abs_env (CoLet (CoRec pairs) body)
     mapSa (saExpr new_str_env new_abs_env) rhss        `thenSa` \ new_rhss ->
     let
 --     new_binders      = addDemandInfoToIds new_str_env new_abs_env body binders
     mapSa (saExpr 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 CoRec!
+--             DON'T add demand info in a Rec!
 --             a) it's useless: we can't do let-to-case
 --             b) it's incorrect.  Consider
 --                     letrec x = ...y...
 --             a) it's useless: we can't do let-to-case
 --             b) it's incorrect.  Consider
 --                     letrec x = ...y...
@@ -350,28 +291,12 @@ saExpr str_env abs_env (CoLet (CoRec pairs) body)
 --                deciding that y is absent, which is plain wrong!
 --             It's much easier simply not to do this.
 
 --                deciding that y is absent, which is plain wrong!
 --             It's much easier simply not to do this.
 
-       improved_binders = zipWith4 (addStrictnessInfoToId strflags)
-                                   str_vals abs_vals binders rhss
-
-       whiter_than_white_binders = launder improved_binders
+       improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
+                                        str_vals abs_vals binders rhss
 
 
-       new_pairs   = whiter_than_white_binders `zip` new_rhss
+       new_pairs   = improved_binders `zip` new_rhss
     in
     in
-    returnSa (CoLet (CoRec new_pairs) new_body)
-  where
-    launder me = {-still-} me
-\end{code}
-
-\begin{code}
-saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
-
-saDefault str_env abs_env (CoBindDefault 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 (CoBindDefault new_bdr new_rhs)
+    returnSa (Let (Rec new_pairs) new_body)
 \end{code}
 
 
 \end{code}
 
 
@@ -393,44 +318,43 @@ A better idea might be to have some kind of arity analysis to
 tell how many args could safely be grabbed.
 
 \begin{code}
 tell how many args could safely be grabbed.
 
 \begin{code}
-addStrictnessInfoToId 
-       :: StrAnalFlags
-       -> AbsVal               -- Abstract strictness value
+addStrictnessInfoToId
+       :: AbsVal               -- Abstract strictness value
        -> AbsVal               -- Ditto absence
        -> Id                   -- The id
        -> AbsVal               -- Ditto absence
        -> Id                   -- The id
-       -> PlainCoreExpr        -- Its RHS
+       -> CoreExpr     -- Its RHS
        -> Id                   -- Augmented with strictness
 
        -> 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 (digForLambdas body) of { (_, lambda_bounds, rhs) ->
-        let
-               tys        = map getIdUniType lambda_bounds
-               strictness = findStrictness strflags tys str_val abs_val
-       in
-       binder `addIdStrictness` mkStrictnessInfo strictness Nothing
-       }
+addStrictnessInfoToId str_val abs_val binder body
+
+  | isBot str_val
+  = binder `setIdStrictness` mkBottomStrictnessInfo
+
+  | otherwise
+  = case (collectTyAndValBinders body) of
+       (_, [], rhs)            -> binder
+       (_, lambda_bounds, rhs) -> binder `setIdStrictness` 
+                                     mkStrictnessInfo strictness False
+               where
+                   tys        = map idType lambda_bounds
+                   strictness = findStrictness tys str_val abs_val
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-addDemandInfoToId :: StrictEnv -> AbsenceEnv 
-                 -> PlainCoreExpr      -- The scope of the id
-                 -> Id 
+addDemandInfoToId :: StrictEnv -> AbsenceEnv
+                 -> CoreExpr   -- The scope of the id
+                 -> Id
                  -> Id                 -- Id augmented with Demand info
 
 addDemandInfoToId str_env abs_env expr binder
                  -> Id                 -- Id augmented with Demand info
 
 addDemandInfoToId str_env abs_env expr binder
-  = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
+  = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder)
+
+addDemandInfoToCaseBndr str_env abs_env alts binder
+  = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder)
 
 
-addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> [Id] -> [Id]
+addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
 
 
-addDemandInfoToIds str_env abs_env expr binders 
+addDemandInfoToIds str_env abs_env expr binders
   = map (addDemandInfoToId str_env abs_env expr) binders
 \end{code}
 
   = map (addDemandInfoToId str_env abs_env expr) binders
 \end{code}
 
@@ -453,15 +377,13 @@ thenSa          :: SaM a -> (a -> SaM b) -> SaM b
 thenSa_              :: SaM a -> SaM b -> SaM b
 returnSa      :: a -> SaM a
 
 thenSa_              :: SaM a -> SaM b -> SaM b
 returnSa      :: a -> SaM a
 
-#ifdef __GLASGOW_HASKELL__
 {-# INLINE thenSa #-}
 {-# INLINE thenSa_ #-}
 {-# INLINE returnSa #-}
 {-# INLINE thenSa #-}
 {-# INLINE thenSa_ #-}
 {-# INLINE returnSa #-}
-#endif
 
 
-tickLambdas :: [Id] -> SaM ()
-tickCases   :: [Id] -> SaM ()
-tickLet     :: Id   -> SaM ()
+tickLambda :: Id   -> SaM ()
+tickCases  :: [CoreBndr] -> SaM ()
+tickLet    :: Id   -> SaM ()
 
 #ifndef OMIT_STRANAL_STATS
 type SaM a = SaStats -> (a, SaStats)
 
 #ifndef OMIT_STRANAL_STATS
 type SaM a = SaStats -> (a, SaStats)
@@ -476,8 +398,8 @@ thenSa_ expr cont stats
 
 returnSa x stats = (x, stats)
 
 
 returnSa x stats = (x, stats)
 
-tickLambdas vars (SaStats tlam dlam tc dc tlet dlet)
-  = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
+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) }
 
 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
     ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
 
 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
@@ -489,11 +411,19 @@ tickLet var (SaStats tlam dlam tc dc tlet dlet)
     ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
 
 tick_demanded var (tot, demanded)
     ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
 
 tick_demanded var (tot, demanded)
+  | isTyVar var = (tot, demanded)
+  | otherwise
   = (tot + 1,
   = (tot + 1,
-     if (willBeDemanded (getIdDemandInfo var))
+     if (isStrict (getIdDemandInfo var))
      then demanded + 1
      else demanded)
 
      then demanded + 1
      else demanded)
 
+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
 #else {-OMIT_STRANAL_STATS-}
 -- identity monad
 type SaM a = a
@@ -504,9 +434,9 @@ thenSa_ expr cont = cont
 
 returnSa x = x
 
 
 returnSa x = x
 
-tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas"
-tickCases   vars = panic "OMIT_STRANAL_STATS: tickCases"
-tickLet     var  = panic "OMIT_STRANAL_STATS: tickLet"
+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-}
 
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)