% % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Demand]{@Demand@: the amount of demand on a value} \begin{code}

    module Demand(
    	Demand(..),
    	topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
    	isTop, isAbsent, seqDemand,

    	DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
    		dmdTypeDepth, seqDmdType,
    	DmdEnv, emptyDmdEnv,
    	DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,

    	Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,

    	StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
            isTopSig,
    	splitStrictSig, increaseStrictSigArity,
    	pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
         ) where

    #include "HsVersions.h"

    import StaticFlags
    import BasicTypes
    import VarEnv
    import UniqFM
    import Util
    import Outputable

\end{code} %************************************************************************ %* * \subsection{Demands} %* * %************************************************************************ \begin{code}

    data Demand
      = Top			-- T; used for unlifted types too, so that
    			--	A `lub` T = T
      | Abs			-- A

      | Call Demand		-- C(d)

      | Eval Demands	-- U(ds)

      | Defer Demands	-- D(ds)

      | Box Demand		-- B(d)

      | Bot			-- B
      deriving( Eq )
    	-- Equality needed for fixpoints in DmdAnal

    data Demands = Poly Demand	-- Polymorphic case
    	     | Prod [Demand]	-- Product case
    	     deriving( Eq )

    allTop :: Demands -> Bool
    allTop (Poly d)  = isTop d
    allTop (Prod ds) = all isTop ds

    isTop :: Demand -> Bool
    isTop Top = True
    isTop _   = False

    isAbsent :: Demand -> Bool
    isAbsent Abs = True
    isAbsent _   = False

    mapDmds :: (Demand -> Demand) -> Demands -> Demands
    mapDmds f (Poly d)  = Poly (f d)
    mapDmds f (Prod ds) = Prod (map f ds)

    zipWithDmds :: (Demand -> Demand -> Demand)
    	    -> Demands -> Demands -> Demands
    zipWithDmds f (Poly d1)  (Poly d2)  = Poly (d1 `f` d2)
    zipWithDmds f (Prod ds1) (Poly d2)  = Prod [d1 `f` d2 | d1 <- ds1]
    zipWithDmds f (Poly d1)  (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
    zipWithDmds f (Prod ds1) (Prod ds2)
      | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
      | otherwise		     = Poly topDmd
    	-- This really can happen with polymorphism
    	-- \f. case f x of (a,b) -> ...
    	--     case f y of (a,b,c) -> ...
    	-- Here the two demands on f are C(LL) and C(LLL)!

    topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand
    topDmd  = Top			-- The most uninformative demand
    lazyDmd = Box Abs
    seqDmd  = Eval (Poly Abs)	-- Polymorphic seq demand
    evalDmd = Box seqDmd		-- Evaluate and return
    errDmd  = Box Bot		-- This used to be called X

    isStrictDmd :: Demand -> Bool
    isStrictDmd Bot      = True
    isStrictDmd (Eval _) = True
    isStrictDmd (Call _) = True
    isStrictDmd (Box d)  = isStrictDmd d
    isStrictDmd _        = 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'
        ppr Bot  = char 'B'

        ppr (Defer ds)      = char 'D' <> ppr ds
        ppr (Eval ds)       = char 'U' <> ppr ds

        ppr (Box (Eval ds)) = char 'S' <> ppr ds
        ppr (Box Abs)	= char 'L'
        ppr (Box Bot)	= char 'X'
        ppr d@(Box _)	= pprPanic "ppr: Bad boxed demand" (ppr d)

        ppr (Call d)	= char 'C' <> parens (ppr d)

    instance Outputable Demands where
        ppr (Poly Abs) = empty
        ppr (Poly d)   = parens (ppr d <> char '*')
        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} %************************************************************************ %* * \subsection{Demand types} %* * %************************************************************************ \begin{code}

    data DmdType = DmdType
    		    DmdEnv	-- Demand on explicitly-mentioned
    				--	free variables
    		    [Demand]	-- Demand on arguments
    		    DmdResult	-- Nature of result

    	-- 		IMPORTANT INVARIANT
    	-- The default demand on free variables not in the DmdEnv is:
    	-- DmdResult = BotRes        <=>  Bot
    	-- DmdResult = TopRes/ResCPR <=>  Abs

    	-- 		ANOTHER IMPORTANT INVARIANT
    	-- The Demands in the argument list are never
    	--	Bot, Defer d
    	-- Handwavey reason: these don't correspond to calling conventions
    	-- See DmdAnal.funArgDemand for details

    -- This guy lets us switch off CPR analysis
    -- by making sure that everything uses TopRes instead of RetCPR
    -- Assuming, of course, that they don't mention RetCPR by name.
    -- They should onlyu use retCPR
    retCPR :: DmdResult
    retCPR | opt_CprOff = TopRes
           | otherwise  = RetCPR

    seqDmdType :: DmdType -> ()
    seqDmdType (DmdType _env ds res) =
      {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()

    type DmdEnv = VarEnv Demand

    data DmdResult = TopRes	-- Nothing known
    	       | RetCPR	-- Returns a constructed product
    	       | BotRes	-- Diverges or errors
    	       deriving( Eq, Show )
    	-- Equality for fixpoints
    	-- Show needed for Show in Lex.Token (sigh)

    -- Equality needed for fixpoints in DmdAnal
    instance Eq DmdType where
      (==) (DmdType fv1 ds1 res1)
           (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
    			      && ds1 == ds2 && res1 == res2

    instance Outputable DmdType where
      ppr (DmdType fv ds res)
        = hsep [text "DmdType",
    	    hcat (map ppr ds) <> ppr res,
    	    if null fv_elts then empty
    	    else braces (fsep (map pp_elt fv_elts))]
        where
          pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
          fv_elts = ufmToList fv

    instance Outputable DmdResult where
      ppr TopRes = empty	  -- Keep these distinct from Demand letters
      ppr RetCPR = char 'm'	  -- so that we can print strictness sigs as
      ppr BotRes = char 'b'   --    dddr
    			  -- without ambiguity

    emptyDmdEnv :: VarEnv Demand
    emptyDmdEnv = emptyVarEnv

    topDmdType, botDmdType, cprDmdType :: DmdType
    topDmdType = DmdType emptyDmdEnv [] TopRes
    botDmdType = DmdType emptyDmdEnv [] BotRes
    cprDmdType = DmdType emptyVarEnv [] retCPR

    isTopDmdType :: DmdType -> Bool
    -- Only used on top-level types, hence the assert
    isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
    isTopDmdType _                       = False

    isBotRes :: DmdResult -> Bool
    isBotRes BotRes = True
    isBotRes _      = False

    resTypeArgDmd :: DmdResult -> Demand
    -- TopRes and BotRes are polymorphic, so that
    --	BotRes = Bot -> BotRes
    --	TopRes = Top -> TopRes
    -- This function makes that concrete
    -- We can get a RetCPR, because of the way in which we are (now)
    -- giving CPR info to strict arguments.  On the first pass, when
    -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
    resTypeArgDmd TopRes = Top
    resTypeArgDmd RetCPR = Top
    resTypeArgDmd BotRes = Bot

    returnsCPR :: DmdResult -> Bool
    returnsCPR RetCPR = True
    returnsCPR _      = False

    mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
    mkDmdType fv ds res = DmdType fv ds res

    mkTopDmdType :: [Demand] -> DmdResult -> DmdType
    mkTopDmdType ds res = DmdType emptyDmdEnv ds res

    dmdTypeDepth :: DmdType -> Arity
    dmdTypeDepth (DmdType _ ds _) = length ds

\end{code} %************************************************************************ %* * \subsection{Strictness signature %* * %************************************************************************ In a let-bound Id we record its strictness info. In principle, this strictness info is a demand transformer, mapping a demand on the Id into a DmdType, which gives a) the free vars of the Id's value b) the Id's arguments c) an indication of the result of applying the Id to its arguments However, in fact we store in the Id an extremely emascuated demand transfomer, namely a single DmdType (Nevertheless we dignify StrictSig as a distinct type.) This DmdType gives the demands unleashed by the Id when it is applied to as many arguments as are given in by the arg demands in the DmdType. For example, the demand transformer described by the DmdType DmdType {x -> U(LL)} [V,A] Top says that when the function is applied to two arguments, it unleashes demand U(LL) on the free var x, V on the first arg, and A on the second. If this same function is applied to one arg, all we can say is that it uses x with U*(LL), and its arg with demand L. \begin{code}

    newtype StrictSig = StrictSig DmdType
    		  deriving( Eq )

    instance Outputable StrictSig where
       ppr (StrictSig ty) = ppr ty

    instance Show StrictSig where
       show (StrictSig ty) = showSDoc (ppr ty)

    mkStrictSig :: DmdType -> StrictSig
    mkStrictSig dmd_ty = StrictSig dmd_ty

    splitStrictSig :: StrictSig -> ([Demand], DmdResult)
    splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)

    increaseStrictSigArity :: Int -> StrictSig -> StrictSig
    -- Add extra arguments to a strictness signature
    increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
      = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)

    isTopSig :: StrictSig -> Bool
    isTopSig (StrictSig ty) = isTopDmdType ty

    topSig, botSig, cprSig :: StrictSig
    topSig = StrictSig topDmdType
    botSig = StrictSig botDmdType
    cprSig = StrictSig cprDmdType

    -- appIsBottom returns true if an application to n args would diverge
    appIsBottom :: StrictSig -> Int -> Bool
    appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
    appIsBottom _				      _ = False

    isBottomingSig :: StrictSig -> Bool
    isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
    isBottomingSig _				= False

    seqStrictSig :: StrictSig -> ()
    seqStrictSig (StrictSig ty) = seqDmdType ty

    pprIfaceStrictSig :: StrictSig -> SDoc
    -- Used for printing top-level strictness pragmas in interface files
    pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
      = hcat (map ppr dmds) <> ppr res

\end{code}