[project @ 2002-01-07 12:26:49 by simonpj]

[ghc-hetmet.git] / ghc / compiler / basicTypes / NewDemand.lhs

diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs
index dcc47e1..ea314d5 100644 (file)
--- a/ghc/compiler/basicTypes/NewDemand.lhs
+++ b/ghc/compiler/basicTypes/NewDemand.lhs
@@ -7,18 +7,18 @@
 module NewDemand(
        Demand(..), 
        topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, 
-       isTop, isAbsent,
+       isTop, isAbsent, seqDemand,
 
        DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, 
-               dmdTypeDepth, dmdTypeRes,
+               dmdTypeDepth, dmdTypeRes, seqDmdType,
        DmdEnv, emptyDmdEnv,
        DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd,
        
-       Demands(..), mapDmds, zipWithDmds, allTop,
+       Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
 
        StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
        splitStrictSig, strictSigResInfo,
-       pprIfaceStrictSig, appIsBottom, isBottomingSig
+       pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
      ) where
 
 #include "HsVersions.h"
@@ -93,6 +93,21 @@ isStrictDmd (Call _) = True
 isStrictDmd (Box d)  = isStrictDmd d
 isStrictDmd other    = False
 
+seqDemand :: Demand -> ()
+seqDemand (Call d)   = seqDemand d
+seqDemand (Eval ds)  = seqDemands ds
+seqDemand (Defer ds) = seqDemands ds
+seqDemand (Box d)    = seqDemand d
+seqDemand _          = ()
+
+seqDemands :: Demands -> ()
+seqDemands (Poly d)  = seqDemand d
+seqDemands (Prod ds) = seqDemandList ds
+
+seqDemandList :: [Demand] -> ()
+seqDemandList [] = ()
+seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
+
 instance Outputable Demand where
     ppr Top  = char 'T'
     ppr Abs  = char 'A'
@@ -111,8 +126,12 @@ instance Outputable Demand where
 instance Outputable Demands where
     ppr (Poly Abs) = empty
     ppr (Poly d)   = parens (ppr d <> char '*')
-    ppr (Prod ds) | all isAbsent ds = empty
-                 | otherwise       = parens (hcat (map ppr ds))
+    ppr (Prod ds)  = parens (hcat (map ppr ds))
+       -- At one time I printed U(AAA) as U, but that
+       -- confuses (Poly Abs) with (Prod AAA), and the
+       -- worker/wrapper generation differs slightly for these two
+       -- [Reason: in the latter case we can avoid passing the arg;
+       --  see notes with WwLib.mkWWstr_one.]
 \end{code}
 
 
@@ -140,6 +159,9 @@ data DmdType = DmdType
        -- Handwavey reason: these don't correspond to calling conventions
        -- See DmdAnal.funArgDemand for details
 
+seqDmdType (DmdType env ds res) = 
+  {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
+
 type DmdEnv = VarEnv Demand
 
 data DmdResult = TopRes        -- Nothing known        
@@ -273,6 +295,8 @@ appIsBottom _                                     _ = False
 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 isBottomingSig _                               = False
 
+seqStrictSig (StrictSig ty) = seqDmdType ty
+
 pprIfaceStrictSig :: StrictSig -> SDoc
 -- Used for printing top-level strictness pragmas in interface files
 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))