[project @ 2001-10-23 08:58:30 by simonpj]

[ghc-hetmet.git] / ghc / compiler / stranal / DmdAnal.lhs

diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index 82106c2..a28b4b5 100644 (file)
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -20,8 +20,8 @@ import PprCore
 import CoreUtils       ( exprIsValue, exprArity )
 import DataCon         ( dataConTyCon )
 import TyCon           ( isProductTyCon, isRecursiveTyCon )
-import Id              ( Id, idType, idDemandInfo, idArity,
-                         isDataConId, isImplicitId, isGlobalId,
+import Id              ( Id, idType, idDemandInfo, 
+                         isDataConId, isGlobalId, idArity,
                          idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness,
                          idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld )
 import IdInfo          ( newDemand )
@@ -78,9 +78,6 @@ dmdAnalTopBind :: SigEnv
               -> CoreBind 
               -> (SigEnv, CoreBind)
 dmdAnalTopBind sigs (NonRec id rhs)
-  | isImplicitId id            -- Don't touch the info on constructors, selectors etc
-  = (sigs, NonRec id rhs)      -- It's pre-computed in MkId.lhs
-  | otherwise
   = let
        (sigs', _, (id', rhs')) = dmdAnalRhs TopLevel sigs (id, rhs)
     in
@@ -161,7 +158,7 @@ dmdAnal sigs dmd (App fun (Type ty))
 
 -- Lots of the other code is there to make this
 -- beautiful, compositional, application rule :-)
-dmdAnal sigs dmd (App fun arg) -- Non-type arguments
+dmdAnal sigs dmd e@(App fun arg)       -- Non-type arguments
   = let                                -- [Type arg handled above]
        (fun_ty, fun')    = dmdAnal sigs (Call dmd) fun
        (arg_ty, arg')    = dmdAnal sigs arg_dmd arg
@@ -475,7 +472,7 @@ splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
 splitDmdTy ty@(DmdType fv [] TopRes)      = (Lazy, ty)
 splitDmdTy ty@(DmdType fv [] BotRes)      = (Bot,  ty)
        -- NB: Bot not Abs
-splitDmdTy (DmdType fv [] RetCPR)        = panic "splitDmdTy"
+splitDmdTy ty@(DmdType fv [] RetCPR)             = panic "splitDmdTy"
        -- We should not be applying a product as a function!
 \end{code}
 
@@ -589,18 +586,25 @@ dmdTransform sigs var dmd
 
 ------         DATA CONSTRUCTOR
   | isDataConId var,           -- Data constructor
-    Seq k ds <- res_dmd,       -- and the demand looks inside its fields
-    let StrictSig dmd_ty = idNewStrictness var,        -- It must have a strictness sig
-    let DmdType _ _ con_res = dmd_ty
-  = if idArity var == call_depth then          -- Saturated, so unleash the demand
-       -- ds can be empty, when we are just seq'ing the thing
+    Seq k ds <- res_dmd                -- and the demand looks inside its fields
+  = let 
+       StrictSig dmd_ty    = idNewStrictness var       -- It must have a strictness sig
+       DmdType _ _ con_res = dmd_ty
+       arity               = idArity var
+    in
+    if arity == call_depth then                -- Saturated, so unleash the demand
        let 
+               -- ds can be empty, when we are just seq'ing the thing
+               -- If so we must make up a suitable bunch of demands
+          dmd_ds | null ds   = replicate arity Abs
+                 | otherwise = ASSERT( length ds == arity ) ds
+
           arg_ds = case k of
-                       Keep  -> bothLazy_s ds
-                       Drop  -> ds
+                       Keep  -> bothLazy_s dmd_ds
+                       Drop  -> dmd_ds
                        Defer -> pprTrace "dmdTransform: surprising!" (ppr var) 
                                        -- I don't think this can happen
-                                ds
+                                dmd_ds
                -- Important!  If we Keep the constructor application, then
                -- we need the demands the constructor places (always lazy)
                -- If not, we don't need to.  For example:
@@ -787,6 +791,7 @@ lub :: Demand -> Demand -> Demand
 lub Bot d = d
 
 lub Err Bot = Err 
+lub Err Abs = Lazy     -- E.g. f x = if ... then True else error x
 lub Err d   = d 
 
 lub Lazy d = Lazy
@@ -902,8 +907,7 @@ 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) 
-  | isImplicitId id = empty  -- We don't look inside these
-  | otherwise      = get_changes_var id $$ get_changes_expr rhs
+  = get_changes_var id $$ get_changes_expr rhs
 
 get_changes_var var
   | isId var  = get_changes_str var $$ get_changes_dmd var