-- (c) The University of Glasgow 2006
-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--
-- Storage manager representation of closures

{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module GHC.Runtime.Heap.Layout (
        -- * Words and bytes
        WordOff, ByteOff,
        wordsToBytes, bytesToWordsRoundUp,
        roundUpToWords, roundUpTo,

        StgWord, fromStgWord, toStgWord,
        StgHalfWord, fromStgHalfWord, toStgHalfWord,
        halfWordSize, halfWordSizeInBits,

        -- * Closure representation
        SMRep(..), -- CmmInfo sees the rep; no one else does
        IsStatic,
        ClosureTypeInfo(..), ArgDescr(..), Liveness,
        ConstrDescription,

        -- ** Construction
        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,
        smallArrPtrsRep, arrWordsRep,

        -- ** Predicates
        isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,
        isStackRep,

        -- ** Size-related things
        heapClosureSizeW,
        fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,
        arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW,
        smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW,
        fixedHdrSize,

        -- ** RTS closure types
        rtsClosureType, rET_SMALL, rET_BIG,
        aRG_GEN, aRG_GEN_BIG,

        -- ** Arrays
        card, cardRoundUp, cardTableSizeB, cardTableSizeW
    ) where

import GHC.Prelude

import GHC.Types.Basic( ConTagZ )
import GHC.Platform
import GHC.Platform.Profile

import GHC.Utils.Outputable
import GHC.Utils.Panic

import Data.Word
import Data.ByteString (ByteString)

{-
************************************************************************
*                                                                      *
                Words and bytes
*                                                                      *
************************************************************************
-}

-- | Byte offset, or byte count
type ByteOff = Int

-- | Word offset, or word count
type WordOff = Int

-- | Round up the given byte count to the next byte count that's a
-- multiple of the machine's word size.
roundUpToWords :: Platform -> ByteOff -> ByteOff
roundUpToWords platform n = roundUpTo n (platformWordSizeInBytes platform)

-- | Round up @base@ to a multiple of @size@.
roundUpTo :: ByteOff -> ByteOff -> ByteOff
roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1))

-- | Convert the given number of words to a number of bytes.
--
-- This function morally has type @WordOff -> ByteOff@, but uses @Num
-- a@ to allow for overloading.
wordsToBytes :: Num a => Platform -> a -> a
wordsToBytes platform n = fromIntegral (platformWordSizeInBytes platform) * n
{-# SPECIALIZE wordsToBytes :: Platform -> Int -> Int #-}
{-# SPECIALIZE wordsToBytes :: Platform -> Word -> Word #-}
{-# SPECIALIZE wordsToBytes :: Platform -> Integer -> Integer #-}

-- | First round the given byte count up to a multiple of the
-- machine's word size and then convert the result to words.
bytesToWordsRoundUp :: Platform -> ByteOff -> WordOff
bytesToWordsRoundUp platform n = (n + word_size - 1) `quot` word_size
 where word_size = platformWordSizeInBytes platform
-- StgWord is a type representing an StgWord on the target platform.
-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform
newtype StgWord = StgWord Word64
    deriving (Eq, Bits)

fromStgWord :: StgWord -> Integer
fromStgWord (StgWord i) = toInteger i

toStgWord :: Platform -> Integer -> StgWord
toStgWord platform i
    = case platformWordSize platform of
      -- These conversions mean that things like toStgWord (-1)
      -- do the right thing
      PW4 -> StgWord (fromIntegral (fromInteger i :: Word32))
      PW8 -> StgWord (fromInteger i)

instance Outputable StgWord where
    ppr (StgWord i) = integer (toInteger i)

--

-- A Word32 is large enough to hold half a Word for either a 32bit or
-- 64bit platform
newtype StgHalfWord = StgHalfWord Word32
    deriving Eq

fromStgHalfWord :: StgHalfWord -> Integer
fromStgHalfWord (StgHalfWord w) = toInteger w

toStgHalfWord :: Platform -> Integer -> StgHalfWord
toStgHalfWord platform i
    = case platformWordSize platform of
      -- These conversions mean that things like toStgHalfWord (-1)
      -- do the right thing
      PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))
      PW8 -> StgHalfWord (fromInteger i :: Word32)

instance Outputable StgHalfWord where
    ppr (StgHalfWord w) = integer (toInteger w)

-- | Half word size in bytes
halfWordSize :: Platform -> ByteOff
halfWordSize platform = platformWordSizeInBytes platform `div` 2

halfWordSizeInBits :: Platform -> Int
halfWordSizeInBits platform = platformWordSizeInBits platform `div` 2

{-
************************************************************************
*                                                                      *
\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}
*                                                                      *
************************************************************************
-}

-- | A description of the layout of a closure.  Corresponds directly
-- to the closure types in includes\/rts\/storage\/ClosureTypes.h.
data SMRep
  = HeapRep              -- GC routines consult sizes in info tbl
        IsStatic
        !WordOff         --  # ptr words
        !WordOff         --  # non-ptr words INCLUDING SLOP (see mkHeapRep below)
        ClosureTypeInfo  -- type-specific info

  | ArrayPtrsRep
        !WordOff        -- # ptr words
        !WordOff        -- # card table words

  | SmallArrayPtrsRep
        !WordOff        -- # ptr words

  | ArrayWordsRep
        !WordOff        -- # bytes expressed in words, rounded up

  | StackRep            -- Stack frame (RET_SMALL or RET_BIG)
        Liveness

  | RTSRep              -- The RTS needs to declare info tables with specific
        Int             -- type tags, so this form lets us override the default
        SMRep           -- tag for an SMRep.
  deriving (Eq, Ord)

-- | True \<=> This is a static closure.  Affects how we garbage-collect it.
-- Static closure have an extra static link field at the end.
-- Constructors do not have a static variant; see Note [static constructors]
type IsStatic = Bool

-- From an SMRep you can get to the closure type defined in
-- rts/include/rts/storage/ClosureTypes.h. Described by the function
-- rtsClosureType below.

data ClosureTypeInfo
  = Constr        ConTagZ ConstrDescription
  | Fun           FunArity ArgDescr
  | Thunk
  | ThunkSelector SelectorOffset
  | BlackHole
  | IndStatic
  deriving (Eq, Ord)

type ConstrDescription = ByteString -- result of dataConIdentity
type FunArity          = Int
type SelectorOffset    = Int

-- | We represent liveness bitmaps as a Bitmap (whose internal representation
-- really is a bitmap).  These are pinned onto case return vectors to indicate
-- the state of the stack for the garbage collector.
--
-- In the compiled program, liveness bitmaps that fit inside a single word
-- (StgWord) are stored as a single word, while larger bitmaps are stored as a
-- pointer to an array of words.

type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
                         --                    False <=> ptr

--------------------------------------------------------------------------------
-- | An ArgDescr describes the argument pattern of a function

data ArgDescr
  = ArgSpec             -- Fits one of the standard patterns
        !Int            -- RTS type identifier ARG_P, ARG_N, ...

  | ArgGen              -- General case
        Liveness        -- Details about the arguments

  | ArgUnknown          -- For imported binds.
                        -- Invariant: Never Unknown for binds of the module
                        -- we are compiling.
  deriving (Eq, Ord)

instance Outputable ArgDescr where
  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
  ppr ArgUnknown = text "ArgUnknown"

-----------------------------------------------------------------------------
-- Construction

mkHeapRep :: Profile -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo
          -> SMRep
mkHeapRep profile is_static ptr_wds nonptr_wds cl_type_info
  = HeapRep is_static
            ptr_wds
            (nonptr_wds + slop_wds)
            cl_type_info
  where
     slop_wds
      | is_static = 0
      | otherwise = max 0 (minClosureSize profile - (hdr_size + payload_size))

     hdr_size     = closureTypeHdrSize profile cl_type_info
     payload_size = ptr_wds + nonptr_wds

mkRTSRep :: Int -> SMRep -> SMRep
mkRTSRep = RTSRep

mkStackRep :: [Bool] -> SMRep
mkStackRep liveness = StackRep liveness

blackHoleRep :: SMRep
blackHoleRep = HeapRep False 0 0 BlackHole

indStaticRep :: SMRep
indStaticRep = HeapRep True 1 0 IndStatic

arrPtrsRep :: Platform -> WordOff -> SMRep
arrPtrsRep platform elems = ArrayPtrsRep elems (cardTableSizeW platform elems)

smallArrPtrsRep :: WordOff -> SMRep
smallArrPtrsRep elems = SmallArrayPtrsRep elems

arrWordsRep :: Platform -> ByteOff -> SMRep
arrWordsRep platform bytes = ArrayWordsRep (bytesToWordsRoundUp platform bytes)

-----------------------------------------------------------------------------
-- Predicates

isStaticRep :: SMRep -> IsStatic
isStaticRep (HeapRep is_static _ _ _) = is_static
isStaticRep (RTSRep _ rep)            = isStaticRep rep
isStaticRep _                         = False

isStackRep :: SMRep -> Bool
isStackRep StackRep{}     = True
isStackRep (RTSRep _ rep) = isStackRep rep
isStackRep _              = False

isConRep :: SMRep -> Bool
isConRep (HeapRep _ _ _ Constr{}) = True
isConRep _                        = False

isThunkRep :: SMRep -> Bool
isThunkRep (HeapRep _ _ _ Thunk)           = True
isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True
isThunkRep (HeapRep _ _ _ BlackHole)       = True
isThunkRep (HeapRep _ _ _ IndStatic)       = True
isThunkRep _                               = False

isFunRep :: SMRep -> Bool
isFunRep (HeapRep _ _ _ Fun{}) = True
isFunRep _                     = False

isStaticNoCafCon :: SMRep -> Bool
-- This should line up exactly with CONSTR_NOCAF below
-- See Note [Static NoCaf constructors]
isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True
isStaticNoCafCon _                        = False


-----------------------------------------------------------------------------
-- Size-related things

fixedHdrSize :: Profile -> ByteOff
fixedHdrSize profile = wordsToBytes (profilePlatform profile) (fixedHdrSizeW profile)

-- | Size of a closure header (StgHeader in includes\/rts\/storage\/Closures.h)
fixedHdrSizeW :: Profile -> WordOff
fixedHdrSizeW profile = pc_STD_HDR_SIZE (profileConstants profile) + profHdrSize profile

-- | Size of the profiling part of a closure header
-- (StgProfHeader in includes\/rts\/storage\/Closures.h)
profHdrSize :: Profile -> WordOff
profHdrSize profile =
   if profileIsProfiling profile
      then pc_PROF_HDR_SIZE (profileConstants profile)
      else 0

-- | The garbage collector requires that every closure is at least as
--   big as this.
minClosureSize :: Profile -> WordOff
minClosureSize profile
 = fixedHdrSizeW profile
   + pc_MIN_PAYLOAD_SIZE (profileConstants profile)

arrWordsHdrSize :: Profile -> ByteOff
arrWordsHdrSize profile
 = fixedHdrSize profile
   + pc_SIZEOF_StgArrBytes_NoHdr (profileConstants profile)

arrWordsHdrSizeW :: Profile -> WordOff
arrWordsHdrSizeW profile
 = fixedHdrSizeW profile
   + (pc_SIZEOF_StgArrBytes_NoHdr (profileConstants profile) `quot`
      platformWordSizeInBytes (profilePlatform profile))

arrPtrsHdrSize :: Profile -> ByteOff
arrPtrsHdrSize profile
 = fixedHdrSize profile
   + pc_SIZEOF_StgMutArrPtrs_NoHdr (profileConstants profile)

arrPtrsHdrSizeW :: Profile -> WordOff
arrPtrsHdrSizeW profile
 = fixedHdrSizeW profile
   + (pc_SIZEOF_StgMutArrPtrs_NoHdr (profileConstants profile) `quot`
      platformWordSizeInBytes (profilePlatform profile))

smallArrPtrsHdrSize :: Profile -> ByteOff
smallArrPtrsHdrSize profile
 = fixedHdrSize profile
   + pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (profileConstants profile)

smallArrPtrsHdrSizeW :: Profile -> WordOff
smallArrPtrsHdrSizeW profile
 = fixedHdrSizeW profile
   + (pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (profileConstants profile) `quot`
      platformWordSizeInBytes (profilePlatform profile))

-- Thunks have an extra header word on SMP, so the update doesn't
-- splat the payload.
thunkHdrSize :: Profile -> WordOff
thunkHdrSize profile = fixedHdrSizeW profile + smp_hdr
        where
         platform = profilePlatform profile
         smp_hdr  = pc_SIZEOF_StgSMPThunkHeader (platformConstants platform) `quot`
                         platformWordSizeInBytes platform

hdrSize :: Profile -> SMRep -> ByteOff
hdrSize profile rep = wordsToBytes (profilePlatform profile) (hdrSizeW profile rep)

hdrSizeW :: Profile -> SMRep -> WordOff
hdrSizeW profile (HeapRep _ _ _ ty)    = closureTypeHdrSize profile ty
hdrSizeW profile (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW profile
hdrSizeW profile (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW profile
hdrSizeW profile (ArrayWordsRep _)     = arrWordsHdrSizeW profile
hdrSizeW _ _                           = panic "GHC.Runtime.Heap.Layout.hdrSizeW"

nonHdrSize :: Platform -> SMRep -> ByteOff
nonHdrSize platform rep = wordsToBytes platform (nonHdrSizeW rep)

nonHdrSizeW :: SMRep -> WordOff
nonHdrSizeW (HeapRep _ p np _) = p + np
nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct
nonHdrSizeW (SmallArrayPtrsRep elems) = elems
nonHdrSizeW (ArrayWordsRep words) = words
nonHdrSizeW (StackRep bs)      = length bs
nonHdrSizeW (RTSRep _ rep)     = nonHdrSizeW rep

-- | The total size of the closure, in words.
heapClosureSizeW :: Profile -> SMRep -> WordOff
heapClosureSizeW profile rep = case rep of
   HeapRep _ p np ty       -> closureTypeHdrSize profile ty + p + np
   ArrayPtrsRep elems ct   -> arrPtrsHdrSizeW profile + elems + ct
   SmallArrayPtrsRep elems -> smallArrPtrsHdrSizeW profile + elems
   ArrayWordsRep words     -> arrWordsHdrSizeW profile + words
   _                       -> panic "GHC.Runtime.Heap.Layout.heapClosureSize"

closureTypeHdrSize :: Profile -> ClosureTypeInfo -> WordOff
closureTypeHdrSize profile ty = case ty of
                  Thunk           -> thunkHdrSize profile
                  ThunkSelector{} -> thunkHdrSize profile
                  BlackHole       -> thunkHdrSize profile
                  IndStatic       -> thunkHdrSize profile
                  _               -> fixedHdrSizeW profile
        -- All thunks use thunkHdrSize, even if they are non-updatable.
        -- this is because we don't have separate closure types for
        -- updatable vs. non-updatable thunks, so the GC can't tell the
        -- difference.  If we ever have significant numbers of non-
        -- updatable thunks, it might be worth fixing this.

-- ---------------------------------------------------------------------------
-- Arrays

-- | The byte offset into the card table of the card for a given element
card :: Platform -> Int -> Int
card platform i = i `shiftR` pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)

-- | Convert a number of elements to a number of cards, rounding up
cardRoundUp :: Platform -> Int -> Int
cardRoundUp platform i =
  card platform (i + ((1 `shiftL` pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)) - 1))

-- | The size of a card table, in bytes
cardTableSizeB :: Platform -> Int -> ByteOff
cardTableSizeB platform elems = cardRoundUp platform elems

-- | The size of a card table, in words
cardTableSizeW :: Platform -> Int -> WordOff
cardTableSizeW platform elems =
  bytesToWordsRoundUp platform (cardTableSizeB platform elems)

-----------------------------------------------------------------------------
-- deriving the RTS closure type from an SMRep

#include "ClosureTypes.h"
#include "FunTypes.h"
-- Defines CONSTR, CONSTR_1_0 etc

-- | Derives the RTS closure type from an 'SMRep'
rtsClosureType :: SMRep -> Int
rtsClosureType rep
    = case rep of
      RTSRep ty _ -> ty

      -- See Note [static constructors]
      HeapRep _     1 0 Constr{} -> CONSTR_1_0
      HeapRep _     0 1 Constr{} -> CONSTR_0_1
      HeapRep _     2 0 Constr{} -> CONSTR_2_0
      HeapRep _     1 1 Constr{} -> CONSTR_1_1
      HeapRep _     0 2 Constr{} -> CONSTR_0_2
      HeapRep _     0 _ Constr{} -> CONSTR_NOCAF
           -- See Note [Static NoCaf constructors]
      HeapRep _     _ _ Constr{} -> CONSTR

      HeapRep False 1 0 Fun{} -> FUN_1_0
      HeapRep False 0 1 Fun{} -> FUN_0_1
      HeapRep False 2 0 Fun{} -> FUN_2_0
      HeapRep False 1 1 Fun{} -> FUN_1_1
      HeapRep False 0 2 Fun{} -> FUN_0_2
      HeapRep False _ _ Fun{} -> FUN

      HeapRep False 1 0 Thunk -> THUNK_1_0
      HeapRep False 0 1 Thunk -> THUNK_0_1
      HeapRep False 2 0 Thunk -> THUNK_2_0
      HeapRep False 1 1 Thunk -> THUNK_1_1
      HeapRep False 0 2 Thunk -> THUNK_0_2
      HeapRep False _ _ Thunk -> THUNK

      HeapRep False _ _ ThunkSelector{} ->  THUNK_SELECTOR

      HeapRep True _ _ Fun{}      -> FUN_STATIC
      HeapRep True _ _ Thunk      -> THUNK_STATIC
      HeapRep False _ _ BlackHole -> BLACKHOLE
      HeapRep False _ _ IndStatic -> IND_STATIC

      StackRep _ -> STACK

      _ -> panic "rtsClosureType"

-- We export these ones
rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int
rET_SMALL   = RET_SMALL
rET_BIG     = RET_BIG
aRG_GEN     = ARG_GEN
aRG_GEN_BIG = ARG_GEN_BIG

{-
Note [static constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~

We used to have a CONSTR_STATIC closure type, and each constructor had
two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with
CONSTR_STATIC.

This distinction was removed, because when copying a data structure
into a compact region, we must copy static constructors into the
compact region too.  If we didn't do this, we would need to track the
references from the compact region out to the static constructors,
because they might (indirectly) refer to CAFs.

Since static constructors will be copied to the heap, if we wanted to
use different info tables for static and dynamic constructors, we
would have to switch the info pointer when copying the constructor
into the compact region, which means we would need an extra field of
the static info table to point to the dynamic one.

However, since the distinction between static and dynamic closure
types is never actually needed (other than for assertions), we can
just drop the distinction and use the same info table for both.

The GC *does* need to distinguish between static and dynamic closures,
but it does this using the HEAP_ALLOCED() macro which checks whether
the address of the closure resides within the dynamic heap.
HEAP_ALLOCED() doesn't read the closure's info table.

Note [Static NoCaf constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we know that a top-level binding 'x' is not Caffy (ie no CAFs are
reachable from 'x'), then a statically allocated constructor (Just x)
is also not Caffy, and the garbage collector need not follow its
argument fields.  Exploiting this would require two static info tables
for Just, for the two cases where the argument was Caffy or non-Caffy.

Currently we don't do this; instead we treat nullary constructors
as non-Caffy, and the others as potentially Caffy.


************************************************************************
*                                                                      *
             Pretty printing of SMRep and friends
*                                                                      *
************************************************************************
-}

instance Outputable ClosureTypeInfo where
   ppr = pprTypeInfo

instance Outputable SMRep where
   ppr (HeapRep static ps nps tyinfo)
     = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace)
     where
       header = text "HeapRep"
                <+> if static then text "static" else empty
                <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps
       pp_n :: String -> Int -> SDoc
       pp_n _ 0 = empty
       pp_n s n = int n <+> text s

   ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size

   ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size

   ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words

   ppr (StackRep bs) = text "StackRep" <+> ppr bs

   ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep

pprTypeInfo :: ClosureTypeInfo -> SDoc
pprTypeInfo (Constr tag descr)
  = text "Con" <+>
    braces (sep [ text "tag:" <+> ppr tag
                , text "descr:" <> text (show descr) ])

pprTypeInfo (Fun arity args)
  = text "Fun" <+>
    braces (sep [ text "arity:"    <+> ppr arity
                , text "fun_type:" <+> ppr args ])

pprTypeInfo (ThunkSelector offset)
  = text "ThunkSel" <+> ppr offset

pprTypeInfo Thunk     = text "Thunk"
pprTypeInfo BlackHole = text "BlackHole"
pprTypeInfo IndStatic = text "IndStatic"