[project @ 2005-08-10 11:09:05 by simonpj]
[ghc-hetmet.git] / ghc / compiler / stranal / DmdAnal.lhs
index 2c6f394..f0dcc00 100644 (file)
@@ -13,11 +13,12 @@ module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs,
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlags, DynFlag(..), opt_MaxWorkerArgs )
+import DynFlags                ( DynFlags, DynFlag(..) )
+import StaticFlags     ( opt_MaxWorkerArgs )
 import NewDemand       -- All of it
 import CoreSyn
 import PprCore 
-import CoreUtils       ( exprIsValue, exprIsTrivial, exprArity )
+import CoreUtils       ( exprIsHNF, exprIsTrivial, exprArity )
 import DataCon         ( dataConTyCon )
 import TyCon           ( isProductTyCon, isRecursiveTyCon )
 import Id              ( Id, idType, idInlinePragma,
@@ -39,7 +40,7 @@ import TysWiredIn     ( unboxedPairDataCon )
 import TysPrim         ( realWorldStatePrimTy )
 import UniqFM          ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
                          keysUFM, minusUFM, ufmToList, filterUFM )
-import Type            ( isUnLiftedType, eqType )
+import Type            ( isUnLiftedType, coreEqType )
 import CoreLint                ( showPass, endPass )
 import Util            ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
 import BasicTypes      ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
@@ -204,7 +205,7 @@ dmdAnal sigs dmd (Lam var body)
     in
     (deferType lam_ty, Lam var' body')
 
-dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)])
+dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
   | let tycon = dataConTyCon dc,
     isProductTyCon tycon,
     not (isRecursiveTyCon tycon)
@@ -250,16 +251,16 @@ dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)])
 
        (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
     in
-    (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' [alt'])
+    (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
 
-dmdAnal sigs dmd (Case scrut case_bndr alts)
+dmdAnal sigs dmd (Case scrut case_bndr ty alts)
   = let
        (alt_tys, alts')        = mapAndUnzip (dmdAnalAlt sigs dmd) alts
        (scrut_ty, scrut')      = dmdAnal sigs evalDmd scrut
        (alt_ty, case_bndr')    = annotateBndr (foldr1 lubType alt_tys) case_bndr
     in
 --    pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
-    (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' alts')
+    (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
 
 dmdAnal sigs dmd (Let (NonRec id rhs) body) 
   = let
@@ -325,7 +326,7 @@ dmdAnalAlt sigs dmd (con,bndrs,rhs)
        --         ; print len }
 
        io_hack_reqd = con == DataAlt unboxedPairDataCon &&
-                      idType (head bndrs) `eqType` realWorldStatePrimTy
+                      idType (head bndrs) `coreEqType` realWorldStatePrimTy
     in 
     (final_alt_ty, (con, bndrs', rhs'))
 \end{code}
@@ -592,7 +593,7 @@ mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res)
     res' = case res of
                RetCPR | ignore_cpr_info -> TopRes
                other                    -> res
-    ignore_cpr_info = not (exprIsValue rhs || thunk_cpr_ok)
+    ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
 \end{code}
 
 The unpack strategy determines whether we'll *really* unpack the argument,
@@ -887,7 +888,7 @@ argDemand d     = d
 -------------------------
 -- Consider (if x then y else []) with demand V
 -- Then the first branch gives {y->V} and the second
--- *implicitly* has {y->A}.  So we must put {y->(V `lub` A)}
+--  *implicitly* has {y->A}.  So we must put {y->(V `lub` A)}
 -- in the result env.
 lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
   = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)