{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

module IdInfo (
        -- * The IdDetails type
	IdDetails(..), pprIdDetails, coVarDetails,

        -- * The IdInfo type
	IdInfo,		-- Abstract
	vanillaIdInfo, noCafIdInfo,
	seqIdInfo, megaSeqIdInfo,

        -- ** The OneShotInfo type
        OneShotInfo(..),
        oneShotInfo, noOneShotInfo, hasNoOneShotInfo,
        setOneShotInfo, 

	-- ** Zapping various forms of Info
	zapLamInfo, zapFragileInfo,
        zapDemandInfo,

	-- ** The ArityInfo type
	ArityInfo,
	unknownArity, 
	arityInfo, setArityInfo, ppArityInfo, 

	-- ** Demand and strictness Info
 	strictnessInfo, setStrictnessInfo, 
  	demandInfo, setDemandInfo, pprStrictness,

	-- ** Unfolding Info
	unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,

	-- ** The InlinePragInfo type
	InlinePragInfo,
	inlinePragInfo, setInlinePragInfo,

	-- ** The OccInfo type
	OccInfo(..),
	isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,
	occInfo, setOccInfo,

	InsideLam, OneBranch,
	insideLam, notInsideLam, oneBranch, notOneBranch,

	-- ** The SpecInfo type
	SpecInfo(..),
	emptySpecInfo,
	isEmptySpecInfo, specInfoFreeVars,
	specInfoRules, seqSpecInfo, setSpecInfoHead,
        specInfo, setSpecInfo,

	-- ** The CAFInfo type
	CafInfo(..),
	ppCafInfo, mayHaveCafRefs,
	cafInfo, setCafInfo,

        -- ** Tick-box Info
        TickBoxOp(..), TickBoxId,
    ) where

import CoreSyn

import Class
import {-# SOURCE #-} PrimOp (PrimOp)
import Name
import VarSet
import BasicTypes
import DataCon
import TyCon
import ForeignCall
import Outputable	
import Module
import FastString
import Demand

-- infixl so you can say (id `set` a `set` b)
infixl 	1 `setSpecInfo`,
	  `setArityInfo`,
	  `setInlinePragInfo`,
	  `setUnfoldingInfo`,
	  `setOneShotInfo`,
	  `setOccInfo`,
	  `setCafInfo`,
	  `setStrictnessInfo`,
	  `setDemandInfo`

-- | The 'IdDetails' of an 'Id' give stable, and necessary, 
-- information about the Id. 
data IdDetails
  = VanillaId	

  -- | The 'Id' for a record selector
  | RecSelId                 
    { sel_tycon   :: TyCon	-- ^ For a data type family, this is the /instance/ 'TyCon'
				--   not the family 'TyCon'
    , sel_naughty :: Bool       -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:
                                --    data T = forall a. MkT { x :: a }
    }				-- See Note [Naughty record selectors] in TcTyClsDecls

  | DataConWorkId DataCon	-- ^ The 'Id' is for a data constructor /worker/
  | DataConWrapId DataCon	-- ^ The 'Id' is for a data constructor /wrapper/
				
				-- [the only reasons we need to know is so that
				--  a) to support isImplicitId
				--  b) when desugaring a RecordCon we can get 
				--     from the Id back to the data con]

  | ClassOpId Class 		-- ^ The 'Id' is a superclass selector or class operation of a class

  | PrimOpId PrimOp		-- ^ The 'Id' is for a primitive operator
  | FCallId ForeignCall		-- ^ The 'Id' is for a foreign call

  | TickBoxOpId TickBoxOp	-- ^ The 'Id' is for a HPC tick box (both traditional and binary)

  | DFunId Int Bool             -- ^ A dictionary function.
       -- Int = the number of "silent" arguments to the dfun
       --       e.g.  class D a => C a where ...
       --             instance C a => C [a]
       --       has is_silent = 1, because the dfun
       --       has type  dfun :: (D a, C a) => C [a]
       --       See Note [Silent superclass arguments] in TcInstDcls
       --
       -- Bool = True <=> the class has only one method, so may be
       --                  implemented with a newtype, so it might be bad
       --                  to be strict on this dictionary

coVarDetails :: IdDetails
coVarDetails = VanillaId

instance Outputable IdDetails where
    ppr = pprIdDetails

pprIdDetails :: IdDetails -> SDoc
pprIdDetails VanillaId = empty
pprIdDetails other     = brackets (pp other)
 where
   pp VanillaId         = panic "pprIdDetails"
   pp (DataConWorkId _) = ptext (sLit "DataCon")
   pp (DataConWrapId _) = ptext (sLit "DataConWrapper")
   pp (ClassOpId {})    = ptext (sLit "ClassOp")
   pp (PrimOpId _)      = ptext (sLit "PrimOp")
   pp (FCallId _)       = ptext (sLit "ForeignCall")
   pp (TickBoxOpId _)   = ptext (sLit "TickBoxOp")
   pp (DFunId ns nt)    = ptext (sLit "DFunId")
                             <> ppWhen (ns /= 0) (brackets (int ns))
                             <> ppWhen nt (ptext (sLit "(nt)"))
   pp (RecSelId { sel_naughty = is_naughty })
      			 = brackets $ ptext (sLit "RecSel") 
      			    <> ppWhen is_naughty (ptext (sLit "(naughty)"))

-- | An 'IdInfo' gives /optional/ information about an 'Id'.  If
-- present it never lies, but it may not be present, in which case there
-- is always a conservative assumption which can be made.
-- 
-- Two 'Id's may have different info even though they have the same
-- 'Unique' (and are hence the same 'Id'); for example, one might lack
-- the properties attached to the other.
-- 
-- The 'IdInfo' gives information about the value, or definition, of the
-- 'Id'.  It does not contain information about the 'Id''s usage,
-- except for 'demandInfo' and 'oneShotInfo'.
data IdInfo
  = IdInfo {
	arityInfo 	:: !ArityInfo,		-- ^ 'Id' arity
	specInfo 	:: SpecInfo,		-- ^ Specialisations of the 'Id's function which exist
			   			-- See Note [Specialisations and RULES in IdInfo]
	unfoldingInfo	:: Unfolding,		-- ^ The 'Id's unfolding
	cafInfo		:: CafInfo,		-- ^ 'Id' CAF info
        oneShotInfo	:: OneShotInfo,		-- ^ Info about a lambda-bound variable, if the 'Id' is one
	inlinePragInfo	:: InlinePragma,	-- ^ Any inline pragma atached to the 'Id'
	occInfo		:: OccInfo,		-- ^ How the 'Id' occurs in the program

        strictnessInfo  :: StrictSig,      --  ^ A strictness signature

        demandInfo      :: Demand        -- ^ ID demand information

    }

-- | Just evaluate the 'IdInfo' to WHNF
seqIdInfo :: IdInfo -> ()
seqIdInfo (IdInfo {}) = ()

-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the
-- compiler
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
  = seqSpecInfo (specInfo info)			`seq`

-- Omitting this improves runtimes a little, presumably because
-- some unfoldings are not calculated at all
--    seqUnfolding (unfoldingInfo info)		`seq`

    seqDemandInfo (demandInfo info)             `seq`
    seqStrictnessInfo (strictnessInfo info)     `seq`
    seqCaf (cafInfo info)			`seq`
    seqOneShot (oneShotInfo info)		`seq`
    seqOccInfo (occInfo info)

seqOneShot :: OneShotInfo -> ()
seqOneShot l = l `seq` ()

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

seqDemandInfo :: Demand -> ()
seqDemandInfo dmd = seqDemand dmd

setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
setSpecInfo 	  info sp = sp `seq` info { specInfo = sp }
setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo :: IdInfo -> OccInfo -> IdInfo
setOccInfo	  info oc = oc `seq` info { occInfo = oc }
	-- Try to avoid spack leaks by seq'ing

setUnfoldingInfoLazily :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfoLazily info uf 	-- Lazy variant to avoid looking at the
  =				-- unfolding of an imported Id unless necessary
    info { unfoldingInfo = uf }	-- (In this case the demand-zapping is redundant.)

setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo info uf 
  = -- We don't seq the unfolding, as we generate intermediate
    -- unfoldings which are just thrown away, so evaluating them is a
    -- waste of time.
    -- seqUnfolding uf `seq`
    info { unfoldingInfo = uf }

setArityInfo :: IdInfo -> ArityInfo -> IdInfo
setArityInfo	  info ar  = info { arityInfo = ar  }
setCafInfo :: IdInfo -> CafInfo -> IdInfo
setCafInfo        info caf = info { cafInfo = caf }

setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
setOneShotInfo      info lb = {-lb `seq`-} info { oneShotInfo = lb }

setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo info dd = dd `seq` info { demandInfo = dd }

setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo
setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }

-- | Basic 'IdInfo' that carries no useful information whatsoever
vanillaIdInfo :: IdInfo
vanillaIdInfo 
  = IdInfo {
	    cafInfo		= vanillaCafInfo,
	    arityInfo		= unknownArity,
	    specInfo		= emptySpecInfo,
	    unfoldingInfo	= noUnfolding,
	    oneShotInfo		= NoOneShotInfo,
	    inlinePragInfo 	= defaultInlinePragma,
	    occInfo		= NoOccInfo,
            demandInfo	        = topDmd,
	    strictnessInfo      = nopSig
	   }

-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references
noCafIdInfo :: IdInfo
noCafIdInfo  = vanillaIdInfo `setCafInfo`    NoCafRefs
	-- Used for built-in type Ids in MkId.

-- | An 'ArityInfo' of @n@ tells us that partial application of this 
-- 'Id' to up to @n-1@ value arguments does essentially no work.
--
-- That is not necessarily the same as saying that it has @n@ leading 
-- lambdas, because coerces may get in the way.
--
-- The arity might increase later in the compilation process, if
-- an extra lambda floats up to the binding site.
type ArityInfo = Arity

-- | It is always safe to assume that an 'Id' has an arity of 0
unknownArity :: Arity
unknownArity = 0 :: Arity

ppArityInfo :: Int -> SDoc
ppArityInfo 0 = empty
ppArityInfo n = hsep [ptext (sLit "Arity"), int n]

-- | Tells when the inlining is active.
-- When it is active the thing may be inlined, depending on how
-- big it is.
--
-- If there was an @INLINE@ pragma, then as a separate matter, the
-- RHS will have been made to look small with a Core inline 'Note'
--
-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves
-- entirely as a way to inhibit inlining until we want it
type InlinePragInfo = InlinePragma

pprStrictness :: StrictSig -> SDoc
pprStrictness sig = ppr sig

-- | Records the specializations of this 'Id' that we know about
-- in the form of rewrite 'CoreRule's that target them
data SpecInfo 
  = SpecInfo 
	[CoreRule] 
	VarSet		-- Locally-defined free vars of *both* LHS and RHS 
			-- of rules.  I don't think it needs to include the
			-- ru_fn though.
			-- Note [Rule dependency info] in OccurAnal

-- | Assume that no specilizations exist: always safe
emptySpecInfo :: SpecInfo
emptySpecInfo = SpecInfo [] emptyVarSet

isEmptySpecInfo :: SpecInfo -> Bool
isEmptySpecInfo (SpecInfo rs _) = null rs

-- | Retrieve the locally-defined free variables of both the left and
-- right hand sides of the specialization rules
specInfoFreeVars :: SpecInfo -> VarSet
specInfoFreeVars (SpecInfo _ fvs) = fvs

specInfoRules :: SpecInfo -> [CoreRule]
specInfoRules (SpecInfo rules _) = rules

-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's
setSpecInfoHead :: Name -> SpecInfo -> SpecInfo
setSpecInfoHead fn (SpecInfo rules fvs)
  = SpecInfo (map (setRuleIdName fn) rules) fvs

seqSpecInfo :: SpecInfo -> ()
seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs

-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs).

-- | Records whether an 'Id' makes Constant Applicative Form references
data CafInfo 
	= MayHaveCafRefs		-- ^ Indicates that the 'Id' is for either:
					--
					-- 1. A function or static constructor
					--    that refers to one or more CAFs, or
					--
					-- 2. A real live CAF

	| NoCafRefs			-- ^ A function or static constructor
				        -- that refers to no CAFs.
        deriving (Eq, Ord)

-- | Assumes that the 'Id' has CAF references: definitely safe
vanillaCafInfo :: CafInfo
vanillaCafInfo = MayHaveCafRefs

mayHaveCafRefs :: CafInfo -> Bool
mayHaveCafRefs  MayHaveCafRefs = True
mayHaveCafRefs _	       = False

seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()

instance Outputable CafInfo where
   ppr = ppCafInfo

ppCafInfo :: CafInfo -> SDoc
ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs")
ppCafInfo MayHaveCafRefs = empty

-- | This is used to remove information on lambda binders that we have
-- setup as part of a lambda group, assuming they will be applied all at once,
-- but turn out to be part of an unsaturated lambda as in e.g:
--
-- > (\x1. \x2. e) arg1
zapLamInfo :: IdInfo -> Maybe IdInfo
zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
  | is_safe_occ occ && is_safe_dmd demand
  = Nothing
  | otherwise
  = Just (info {occInfo = safe_occ, demandInfo = topDmd})
  where
	-- The "unsafe" occ info is the ones that say I'm not in a lambda
	-- because that might not be true for an unsaturated lambda
    is_safe_occ (OneOcc in_lam _ _) = in_lam
    is_safe_occ _other		    = True

    safe_occ = case occ of
		 OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt
		 _other	       	       -> occ

    is_safe_dmd dmd = not (isStrictDmd dmd)

-- | Remove demand info on the 'IdInfo' if it is present, otherwise return @Nothing@
zapDemandInfo :: IdInfo -> Maybe IdInfo
zapDemandInfo info = Just (info {demandInfo = topDmd})

zapFragileInfo :: IdInfo -> Maybe IdInfo
-- ^ Zap info that depends on free variables
zapFragileInfo info 
  = Just (info `setSpecInfo` emptySpecInfo
               `setUnfoldingInfo` noUnfolding
	       `setOccInfo` zapFragileOcc occ)
  where
    occ = occInfo info

type TickBoxId = Int

-- | Tick box for Hpc-style coverage
data TickBoxOp 
   = TickBox Module {-# UNPACK #-} !TickBoxId

instance Outputable TickBoxOp where
    ppr (TickBox mod n)         = ptext (sLit "tick") <+> ppr (mod,n)