From 9e94a1afb46c14539c6efa778541c17a1641d712 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Wed, 5 Dec 2001 11:05:21 +0000
Subject: [PATCH] [project @ 2001-12-05 11:05:21 by simonmar] Add seqDemand,
 seqDemands, seqDmdType and seqStrictSig.

---
 ghc/compiler/basicTypes/NewDemand.lhs |   28 ++++++++++++++++++++++++----
 1 file changed, 24 insertions(+), 4 deletions(-)

diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs
index dcc47e1..df46950 100644
--- 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'
@@ -140,6 +155,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 +291,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))
-- 
1.7.10.4