fix up Win32 build

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

diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs
index 7f376fd..50bb0c6 100644 (file)
--- a/ghc/compiler/basicTypes/Demand.lhs
+++ b/ghc/compiler/basicTypes/Demand.lhs
@@ -4,10 +4,14 @@
 \section[Demand]{@Demand@: the amount of demand on a value}
 
 \begin{code}
+#ifndef OLD_STRICTNESS
+module Demand () where
+#else
+
 module Demand(
        Demand(..),
 
-       wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum, 
+       wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, 
        isStrict, isLazy, isPrim,
 
        pprDemands, seqDemand, seqDemands,
@@ -17,12 +21,13 @@ module Demand(
        noStrictnessInfo,
        ppStrictnessInfo, seqStrictnessInfo,
        isBottomingStrictness, appIsBottom,
+
      ) where
 
 #include "HsVersions.h"
 
-import BasicTypes      ( NewOrData(..) )
 import Outputable
+import Util ( listLengthCmp )
 \end{code}
 
 
@@ -37,7 +42,7 @@ data Demand
   = WwLazy             -- Argument is lazy as far as we know
        MaybeAbsent     -- (does not imply worker's existence [etc]).
                        -- If MaybeAbsent == True, then it is
-                       -- *definitely* lazy.  (NB: Absence implies
+                       --  *definitely* lazy.  (NB: Absence implies
                        -- a worker...)
 
   | WwStrict           -- Argument is strict but that's all we know
@@ -45,7 +50,6 @@ data Demand
                        -- calling-convention magic)
 
   | WwUnpack           -- Argument is strict & a single-constructor type
-       NewOrData
        Bool            -- True <=> wrapper unpacks it; False <=> doesn't
        [Demand]        -- Its constituent parts (whose StrictInfos
                        -- are in the list) should be passed
@@ -65,15 +69,14 @@ type MaybeAbsent = Bool -- True <=> not even used
 -- versions that don't worry about Absence:
 wwLazy     = WwLazy      False
 wwStrict    = WwStrict
-wwUnpackData xs = WwUnpack DataType False xs
-wwUnpackNew  x  = WwUnpack NewType  False [x]
+wwUnpack xs = WwUnpack False xs
 wwPrim     = WwPrim
 wwEnum     = WwEnum
 
 seqDemand :: Demand -> ()
-seqDemand (WwLazy a)         = a `seq` ()
-seqDemand (WwUnpack nd b ds) = nd `seq` b `seq` seqDemands ds
-seqDemand other                     = ()
+seqDemand (WwLazy a)      = a `seq` ()
+seqDemand (WwUnpack b ds) = b `seq` seqDemands ds
+seqDemand other                  = ()
 
 seqDemands [] = ()
 seqDemands (d:ds) = seqDemand d `seq` seqDemands ds
@@ -87,25 +90,18 @@ seqDemands (d:ds) = seqDemand d `seq` seqDemands ds
 %************************************************************************
 
 \begin{code}
+isLazy :: Demand -> Bool
+isLazy (WwLazy _) = True
+isLazy _         = False
+
 isStrict :: Demand -> Bool
-isStrict (WwUnpack NewType _ ds) = isStrict (head ds)
-isStrict (WwUnpack other _ _)    = True
-isStrict WwStrict = True
-isStrict WwEnum          = True
-isStrict WwPrim          = True
-isStrict _       = False
+isStrict d = not (isLazy d)
 
 isPrim :: Demand -> Bool
 isPrim WwPrim = True
 isPrim other  = False
 \end{code}
 
-\begin{code}
-isLazy :: Demand -> Bool
-isLazy (WwLazy False) = True   -- NB "Absent" args do *not* count!
-isLazy _             = False   -- (as they imply a worker)
-\end{code}
-
 
 %************************************************************************
 %*                                                                     *
@@ -126,13 +122,9 @@ pprDemand (WwLazy True)     = char 'A'
 pprDemand WwStrict              = char 'S'
 pprDemand WwPrim                = char 'P'
 pprDemand WwEnum                = char 'E'
-pprDemand (WwUnpack nd wu args)  = char ch <> parens (hcat (map pprDemand args))
+pprDemand (WwUnpack wu args)     = char ch <> parens (hcat (map pprDemand args))
                                      where
-                                       ch = case nd of
-                                               DataType | wu        -> 'U'
-                                                        | otherwise -> 'u'
-                                               NewType  | wu        -> 'N'
-                                                        | otherwise -> 'n'
+                                       ch = if wu then 'U' else 'u'
 
 instance Outputable Demand where
     ppr (WwLazy False) = empty
@@ -174,6 +166,7 @@ data StrictnessInfo
                                -- BUT NB: f = \x y. error "urk"
                                --         will have info  SI [SS] True
                                -- but still (f) and (f 2) are not bot; only (f 3 2) is bot
+  deriving( Eq )
 
        -- NOTA BENE: if the arg demands are, say, [S,L], this means that
        --      (f bot) is not necy bot, only (f bot x) is bot
@@ -191,8 +184,11 @@ seqStrictnessInfo other                    = ()
 mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo
 
 mkStrictnessInfo (xs, is_bot)
-  | all isLazy xs && not is_bot        = NoStrictnessInfo              -- Uninteresting
-  | otherwise                  = StrictnessInfo xs is_bot
+  | all totally_boring xs && not is_bot        = NoStrictnessInfo              -- Uninteresting
+  | otherwise                          = StrictnessInfo xs is_bot
+  where
+    totally_boring (WwLazy False) = True
+    totally_boring other         = False
 
 noStrictnessInfo = NoStrictnessInfo
 
@@ -200,11 +196,13 @@ isBottomingStrictness (StrictnessInfo _ bot) = bot
 isBottomingStrictness NoStrictnessInfo       = False
 
 -- appIsBottom returns true if an application to n args would diverge
-appIsBottom (StrictnessInfo ds bot)   n = bot && (n >= length ds)
+appIsBottom (StrictnessInfo ds bot)   n = bot && (listLengthCmp ds n /=GT) -- not more than 'n' elts in 'ds'.
 appIsBottom  NoStrictnessInfo        n = False
 
-ppStrictnessInfo NoStrictnessInfo = empty
-ppStrictnessInfo (StrictnessInfo wrapper_args bot)
-  = hsep [ptext SLIT("__S"), pprDemands wrapper_args bot]
+ppStrictnessInfo NoStrictnessInfo                 = empty
+ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot]
 \end{code}
 
+\begin{code}
+#endif /* OLD_STRICTNESS */
+\end{code}