{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-}

-- | Data types for representing different pointers and raw information
-- All pointers are stored in little-endian to make arithmetic easier.
--
-- We have to send and recieve the pointers in big endian though. This
-- conversion is dealt with in the Binary instance for ClosurePtr and
-- then the other pointers are derived from this instance using DerivingVia
module GHC.Debug.Types.Ptr( -- * InfoTables
                            InfoTablePtr(..)
                          , RawInfoTable(..)
                          -- UntaggedClosurePtr constructor not exported so
                          -- we can maintain the invariant that all
                          -- ClosurePtr are untagged
                          -- * Closures
                          , ClosurePtr(..,ClosurePtr)
                          , mkClosurePtr
                          , readClosurePtr
                          , RawClosure(..)
                          , rawClosureSize
                          , getInfoTblPtr
                          -- * Operations on 'ClosurePtr'
                          , applyBlockMask
                          , applyMBlockMask
                          , subtractBlockPtr
                          , heapAlloced

                          , getBlockOffset
                          -- * Blocks
                          , BlockPtr(..)
                          , RawBlock(..)
                          , isLargeBlock
                          , isPinnedBlock
                          , rawBlockAddr
                          , extractFromBlock
                          , blockMBlock
                          , rawBlockSize
                          -- * Stacks
                          , StackPtr(..)
                          , RawStack(..)

                          , subtractStackPtr
                          , calculateStackLen
                          , addStackPtr
                          , rawStackSize
                          , printStack
                          -- * Bitmaps
                          , PtrBitmap(..)
                          , traversePtrBitmap
                          -- * Constants
                          , blockMask
                          , mblockMask
                          , mblockMaxSize
                          , blockMaxSize
                          , profiling
                          , tablesNextToCode

                          -- * Other utility
                          , arrWordsBS
                          , prettyPrint
                          , printBS
                          )  where

import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString as BS
import Data.Hashable
import Data.Word

import GHC.Debug.Utils

import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import System.Endian

import Numeric (showHex, readHex)
import Data.Coerce
import Data.Bits
import GHC.Stack
import Control.Applicative
import qualified Data.Array.Unboxed as A
import Control.Monad
import qualified Data.Foldable as F

prettyPrint :: BS.ByteString -> String
prettyPrint :: ByteString -> String
prettyPrint = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Integral a, Show a) => a -> ShowS
showHex String
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

-- TODO: Fetch this from debuggee
tablesNextToCode :: Bool
tablesNextToCode :: Bool
tablesNextToCode = Bool
True

-- TODO: Fetch this from debuggee
profiling :: Bool
profiling :: Bool
profiling = Bool
False

newtype InfoTablePtr = InfoTablePtr Word64
                     deriving (InfoTablePtr -> InfoTablePtr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InfoTablePtr -> InfoTablePtr -> Bool
$c/= :: InfoTablePtr -> InfoTablePtr -> Bool
== :: InfoTablePtr -> InfoTablePtr -> Bool
$c== :: InfoTablePtr -> InfoTablePtr -> Bool
Eq, Eq InfoTablePtr
InfoTablePtr -> InfoTablePtr -> Bool
InfoTablePtr -> InfoTablePtr -> Ordering
InfoTablePtr -> InfoTablePtr -> InfoTablePtr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: InfoTablePtr -> InfoTablePtr -> InfoTablePtr
$cmin :: InfoTablePtr -> InfoTablePtr -> InfoTablePtr
max :: InfoTablePtr -> InfoTablePtr -> InfoTablePtr
$cmax :: InfoTablePtr -> InfoTablePtr -> InfoTablePtr
>= :: InfoTablePtr -> InfoTablePtr -> Bool
$c>= :: InfoTablePtr -> InfoTablePtr -> Bool
> :: InfoTablePtr -> InfoTablePtr -> Bool
$c> :: InfoTablePtr -> InfoTablePtr -> Bool
<= :: InfoTablePtr -> InfoTablePtr -> Bool
$c<= :: InfoTablePtr -> InfoTablePtr -> Bool
< :: InfoTablePtr -> InfoTablePtr -> Bool
$c< :: InfoTablePtr -> InfoTablePtr -> Bool
compare :: InfoTablePtr -> InfoTablePtr -> Ordering
$ccompare :: InfoTablePtr -> InfoTablePtr -> Ordering
Ord)
                     deriving newtype (Eq InfoTablePtr
Int -> InfoTablePtr -> Int
InfoTablePtr -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: InfoTablePtr -> Int
$chash :: InfoTablePtr -> Int
hashWithSalt :: Int -> InfoTablePtr -> Int
$chashWithSalt :: Int -> InfoTablePtr -> Int
Hashable)
                     deriving (Int -> InfoTablePtr -> ShowS
[InfoTablePtr] -> ShowS
InfoTablePtr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InfoTablePtr] -> ShowS
$cshowList :: [InfoTablePtr] -> ShowS
show :: InfoTablePtr -> String
$cshow :: InfoTablePtr -> String
showsPrec :: Int -> InfoTablePtr -> ShowS
$cshowsPrec :: Int -> InfoTablePtr -> ShowS
Show, Get InfoTablePtr
[InfoTablePtr] -> Put
InfoTablePtr -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [InfoTablePtr] -> Put
$cputList :: [InfoTablePtr] -> Put
get :: Get InfoTablePtr
$cget :: Get InfoTablePtr
put :: InfoTablePtr -> Put
$cput :: InfoTablePtr -> Put
Binary) via ClosurePtr

-- Invariant, ClosurePtrs are *always* untagged, we take some care to
-- untag them when making a ClosurePtr so we don't have to do it on every
-- call to decodeClosure
newtype ClosurePtr = UntaggedClosurePtr Word64
                   deriving (ClosurePtr -> ClosurePtr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClosurePtr -> ClosurePtr -> Bool
$c/= :: ClosurePtr -> ClosurePtr -> Bool
== :: ClosurePtr -> ClosurePtr -> Bool
$c== :: ClosurePtr -> ClosurePtr -> Bool
Eq)
                   deriving newtype (Eq ClosurePtr
Int -> ClosurePtr -> Int
ClosurePtr -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: ClosurePtr -> Int
$chash :: ClosurePtr -> Int
hashWithSalt :: Int -> ClosurePtr -> Int
$chashWithSalt :: Int -> ClosurePtr -> Int
Hashable)

pattern ClosurePtr :: Word64 -> ClosurePtr
pattern $mClosurePtr :: forall {r}. ClosurePtr -> (Word64 -> r) -> ((# #) -> r) -> r
ClosurePtr p <- UntaggedClosurePtr p

{-# COMPLETE ClosurePtr #-}

mkClosurePtr :: Word64 -> ClosurePtr
mkClosurePtr :: Word64 -> ClosurePtr
mkClosurePtr = ClosurePtr -> ClosurePtr
untagClosurePtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ClosurePtr
UntaggedClosurePtr

readClosurePtr :: String -> Maybe ClosurePtr
readClosurePtr :: String -> Maybe ClosurePtr
readClosurePtr (Char
'0':Char
'x':String
s) = case forall a. (Eq a, Num a) => ReadS a
readHex String
s of
                               [(Word64
res, String
"")] -> forall a. a -> Maybe a
Just (Word64 -> ClosurePtr
mkClosurePtr Word64
res)
                               [(Word64, String)]
_ -> forall a. Maybe a
Nothing
readClosurePtr String
_ = forall a. Maybe a
Nothing

instance Binary ClosurePtr where
  put :: ClosurePtr -> Put
put (ClosurePtr Word64
p) = Word64 -> Put
putWord64be (Word64 -> Word64
toBE64 Word64
p)
  get :: Get ClosurePtr
get = Word64 -> ClosurePtr
mkClosurePtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word64
fromBE64 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64be

instance Ord ClosurePtr where
  (ClosurePtr Word64
x) compare :: ClosurePtr -> ClosurePtr -> Ordering
`compare` (ClosurePtr Word64
y) = Word64
x forall a. Ord a => a -> a -> Ordering
`compare` Word64
y

instance Show ClosurePtr where
  show :: ClosurePtr -> String
show (ClosurePtr Word64
0) = String
"null"
  show (ClosurePtr Word64
p) =  String
"0x" forall a. [a] -> [a] -> [a]
++ forall a. (Integral a, Show a) => a -> ShowS
showHex Word64
p String
""


newtype StackPtr = StackPtr Word64
                   deriving (StackPtr -> StackPtr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StackPtr -> StackPtr -> Bool
$c/= :: StackPtr -> StackPtr -> Bool
== :: StackPtr -> StackPtr -> Bool
$c== :: StackPtr -> StackPtr -> Bool
Eq, Eq StackPtr
StackPtr -> StackPtr -> Bool
StackPtr -> StackPtr -> Ordering
StackPtr -> StackPtr -> StackPtr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StackPtr -> StackPtr -> StackPtr
$cmin :: StackPtr -> StackPtr -> StackPtr
max :: StackPtr -> StackPtr -> StackPtr
$cmax :: StackPtr -> StackPtr -> StackPtr
>= :: StackPtr -> StackPtr -> Bool
$c>= :: StackPtr -> StackPtr -> Bool
> :: StackPtr -> StackPtr -> Bool
$c> :: StackPtr -> StackPtr -> Bool
<= :: StackPtr -> StackPtr -> Bool
$c<= :: StackPtr -> StackPtr -> Bool
< :: StackPtr -> StackPtr -> Bool
$c< :: StackPtr -> StackPtr -> Bool
compare :: StackPtr -> StackPtr -> Ordering
$ccompare :: StackPtr -> StackPtr -> Ordering
Ord)
                   deriving newtype (Eq StackPtr
Int -> StackPtr -> Int
StackPtr -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: StackPtr -> Int
$chash :: StackPtr -> Int
hashWithSalt :: Int -> StackPtr -> Int
$chashWithSalt :: Int -> StackPtr -> Int
Hashable)
                   deriving (Int -> StackPtr -> ShowS
[StackPtr] -> ShowS
StackPtr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StackPtr] -> ShowS
$cshowList :: [StackPtr] -> ShowS
show :: StackPtr -> String
$cshow :: StackPtr -> String
showsPrec :: Int -> StackPtr -> ShowS
$cshowsPrec :: Int -> StackPtr -> ShowS
Show, Get StackPtr
[StackPtr] -> Put
StackPtr -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [StackPtr] -> Put
$cputList :: [StackPtr] -> Put
get :: Get StackPtr
$cget :: Get StackPtr
put :: StackPtr -> Put
$cput :: StackPtr -> Put
Binary) via ClosurePtr

newtype StringPtr = StringPtr Word64
  deriving Int -> StringPtr -> ShowS
[StringPtr] -> ShowS
StringPtr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StringPtr] -> ShowS
$cshowList :: [StringPtr] -> ShowS
show :: StringPtr -> String
$cshow :: StringPtr -> String
showsPrec :: Int -> StringPtr -> ShowS
$cshowsPrec :: Int -> StringPtr -> ShowS
Show via StackPtr


subtractBlockPtr :: ClosurePtr -> BlockPtr -> Word64
subtractBlockPtr :: ClosurePtr -> BlockPtr -> Word64
subtractBlockPtr ClosurePtr
cp BlockPtr
bp = StackPtr -> ClosurePtr -> Word64
subtractStackPtr (coerce :: forall a b. Coercible a b => a -> b
coerce ClosurePtr
cp) (coerce :: forall a b. Coercible a b => a -> b
coerce BlockPtr
bp)

subtractStackPtr :: StackPtr -> ClosurePtr -> Word64
subtractStackPtr :: StackPtr -> ClosurePtr -> Word64
subtractStackPtr (StackPtr Word64
c) (ClosurePtr Word64
c2) =
  Word64
c forall a. Num a => a -> a -> a
- Word64
c2

addStackPtr :: StackPtr -> Word64 -> StackPtr
addStackPtr :: StackPtr -> Word64 -> StackPtr
addStackPtr (StackPtr Word64
c) Word64
o = Word64 -> StackPtr
StackPtr (Word64
c forall a. Num a => a -> a -> a
+ Word64
o)

rawClosureSize :: RawClosure -> Int
rawClosureSize :: RawClosure -> Int
rawClosureSize (RawClosure ByteString
s) = ByteString -> Int
BS.length ByteString
s

calculateStackLen :: Word32 -> Word64 -> ClosurePtr -> StackPtr -> Word64
calculateStackLen :: Word32 -> Word64 -> ClosurePtr -> StackPtr -> Word64
calculateStackLen Word32
siz Word64
offset (ClosurePtr Word64
p) (StackPtr Word64
sp) =
  (Word64
p  -- Pointer to start of StgStack closure
    forall a. Num a => a -> a -> a
+ Word64
offset       -- Offset to end of closure
    forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
siz forall a. Num a => a -> a -> a
* Word64
8) -- Stack_Size (in words)
    )
    forall a. Num a => a -> a -> a
- Word64
sp -- Minus current Sp

printBS :: HasCallStack => BS.ByteString -> String
-- Not technically all ClosurePtr but good for the show instance
printBS :: HasCallStack => ByteString -> String
printBS ByteString
bs = forall a. Show a => a -> String
show (forall a. HasCallStack => Get a -> ByteString -> a
runGet_ (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall t. Binary t => Get t
get @ClosurePtr)) (ByteString -> ByteString
BSL.fromStrict ByteString
bs))

printStack :: RawStack -> String
printStack :: RawStack -> String
printStack (RawStack ByteString
s) = HasCallStack => ByteString -> String
printBS ByteString
s

arrWordsBS :: [Word] -> BSL.ByteString
arrWordsBS :: [Word] -> ByteString
arrWordsBS = Put -> ByteString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word -> Put
putWordhost

-- | Check if the ClosurePtr is block allocated or not
-- TODO: MP: These numbers are hard-coded from what
-- mblock_address_space.begin and mblock_address_space.end were when
-- I inspected them in gdb. I don't know if they are always the same of
-- should be queried from the debuggee
heapAlloced :: ClosurePtr -> Bool
heapAlloced :: ClosurePtr -> Bool
heapAlloced (ClosurePtr Word64
w) = (Word64
w forall a. Ord a => a -> a -> Bool
>= Word64
0x4200000000 Bool -> Bool -> Bool
&& Word64
w forall a. Ord a => a -> a -> Bool
<= Word64
0x14200000000)

newtype RawInfoTable = RawInfoTable BS.ByteString
                     deriving (RawInfoTable -> RawInfoTable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawInfoTable -> RawInfoTable -> Bool
$c/= :: RawInfoTable -> RawInfoTable -> Bool
== :: RawInfoTable -> RawInfoTable -> Bool
$c== :: RawInfoTable -> RawInfoTable -> Bool
Eq, Eq RawInfoTable
RawInfoTable -> RawInfoTable -> Bool
RawInfoTable -> RawInfoTable -> Ordering
RawInfoTable -> RawInfoTable -> RawInfoTable
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawInfoTable -> RawInfoTable -> RawInfoTable
$cmin :: RawInfoTable -> RawInfoTable -> RawInfoTable
max :: RawInfoTable -> RawInfoTable -> RawInfoTable
$cmax :: RawInfoTable -> RawInfoTable -> RawInfoTable
>= :: RawInfoTable -> RawInfoTable -> Bool
$c>= :: RawInfoTable -> RawInfoTable -> Bool
> :: RawInfoTable -> RawInfoTable -> Bool
$c> :: RawInfoTable -> RawInfoTable -> Bool
<= :: RawInfoTable -> RawInfoTable -> Bool
$c<= :: RawInfoTable -> RawInfoTable -> Bool
< :: RawInfoTable -> RawInfoTable -> Bool
$c< :: RawInfoTable -> RawInfoTable -> Bool
compare :: RawInfoTable -> RawInfoTable -> Ordering
$ccompare :: RawInfoTable -> RawInfoTable -> Ordering
Ord, Int -> RawInfoTable -> ShowS
[RawInfoTable] -> ShowS
RawInfoTable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawInfoTable] -> ShowS
$cshowList :: [RawInfoTable] -> ShowS
show :: RawInfoTable -> String
$cshow :: RawInfoTable -> String
showsPrec :: Int -> RawInfoTable -> ShowS
$cshowsPrec :: Int -> RawInfoTable -> ShowS
Show)
                     deriving newtype (Get RawInfoTable
[RawInfoTable] -> Put
RawInfoTable -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [RawInfoTable] -> Put
$cputList :: [RawInfoTable] -> Put
get :: Get RawInfoTable
$cget :: Get RawInfoTable
put :: RawInfoTable -> Put
$cput :: RawInfoTable -> Put
Binary)

newtype RawClosure = RawClosure BS.ByteString
                   deriving (RawClosure -> RawClosure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawClosure -> RawClosure -> Bool
$c/= :: RawClosure -> RawClosure -> Bool
== :: RawClosure -> RawClosure -> Bool
$c== :: RawClosure -> RawClosure -> Bool
Eq, Eq RawClosure
RawClosure -> RawClosure -> Bool
RawClosure -> RawClosure -> Ordering
RawClosure -> RawClosure -> RawClosure
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawClosure -> RawClosure -> RawClosure
$cmin :: RawClosure -> RawClosure -> RawClosure
max :: RawClosure -> RawClosure -> RawClosure
$cmax :: RawClosure -> RawClosure -> RawClosure
>= :: RawClosure -> RawClosure -> Bool
$c>= :: RawClosure -> RawClosure -> Bool
> :: RawClosure -> RawClosure -> Bool
$c> :: RawClosure -> RawClosure -> Bool
<= :: RawClosure -> RawClosure -> Bool
$c<= :: RawClosure -> RawClosure -> Bool
< :: RawClosure -> RawClosure -> Bool
$c< :: RawClosure -> RawClosure -> Bool
compare :: RawClosure -> RawClosure -> Ordering
$ccompare :: RawClosure -> RawClosure -> Ordering
Ord, Int -> RawClosure -> ShowS
[RawClosure] -> ShowS
RawClosure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawClosure] -> ShowS
$cshowList :: [RawClosure] -> ShowS
show :: RawClosure -> String
$cshow :: RawClosure -> String
showsPrec :: Int -> RawClosure -> ShowS
$cshowsPrec :: Int -> RawClosure -> ShowS
Show)

getRawClosure :: Get RawClosure
getRawClosure :: Get RawClosure
getRawClosure = do
  Word32
len <- Get Word32
getWord32be
  ByteString -> RawClosure
RawClosure forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len)

putRawClosure :: RawClosure -> Put
putRawClosure :: RawClosure -> Put
putRawClosure (RawClosure ByteString
rc) = do
  let n :: Int
n = ByteString -> Int
BS.length ByteString
rc
  Word32 -> Put
putWord32be (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  ByteString -> Put
putByteString ByteString
rc

instance Binary RawClosure where
  get :: Get RawClosure
get = Get RawClosure
getRawClosure
  put :: RawClosure -> Put
put = RawClosure -> Put
putRawClosure

newtype RawStack = RawStack BS.ByteString
                   deriving (RawStack -> RawStack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawStack -> RawStack -> Bool
$c/= :: RawStack -> RawStack -> Bool
== :: RawStack -> RawStack -> Bool
$c== :: RawStack -> RawStack -> Bool
Eq, Eq RawStack
RawStack -> RawStack -> Bool
RawStack -> RawStack -> Ordering
RawStack -> RawStack -> RawStack
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawStack -> RawStack -> RawStack
$cmin :: RawStack -> RawStack -> RawStack
max :: RawStack -> RawStack -> RawStack
$cmax :: RawStack -> RawStack -> RawStack
>= :: RawStack -> RawStack -> Bool
$c>= :: RawStack -> RawStack -> Bool
> :: RawStack -> RawStack -> Bool
$c> :: RawStack -> RawStack -> Bool
<= :: RawStack -> RawStack -> Bool
$c<= :: RawStack -> RawStack -> Bool
< :: RawStack -> RawStack -> Bool
$c< :: RawStack -> RawStack -> Bool
compare :: RawStack -> RawStack -> Ordering
$ccompare :: RawStack -> RawStack -> Ordering
Ord, Int -> RawStack -> ShowS
[RawStack] -> ShowS
RawStack -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawStack] -> ShowS
$cshowList :: [RawStack] -> ShowS
show :: RawStack -> String
$cshow :: RawStack -> String
showsPrec :: Int -> RawStack -> ShowS
$cshowsPrec :: Int -> RawStack -> ShowS
Show)

newtype RawPayload = RawPayload BS.ByteString
                   deriving (RawPayload -> RawPayload -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawPayload -> RawPayload -> Bool
$c/= :: RawPayload -> RawPayload -> Bool
== :: RawPayload -> RawPayload -> Bool
$c== :: RawPayload -> RawPayload -> Bool
Eq, Eq RawPayload
RawPayload -> RawPayload -> Bool
RawPayload -> RawPayload -> Ordering
RawPayload -> RawPayload -> RawPayload
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawPayload -> RawPayload -> RawPayload
$cmin :: RawPayload -> RawPayload -> RawPayload
max :: RawPayload -> RawPayload -> RawPayload
$cmax :: RawPayload -> RawPayload -> RawPayload
>= :: RawPayload -> RawPayload -> Bool
$c>= :: RawPayload -> RawPayload -> Bool
> :: RawPayload -> RawPayload -> Bool
$c> :: RawPayload -> RawPayload -> Bool
<= :: RawPayload -> RawPayload -> Bool
$c<= :: RawPayload -> RawPayload -> Bool
< :: RawPayload -> RawPayload -> Bool
$c< :: RawPayload -> RawPayload -> Bool
compare :: RawPayload -> RawPayload -> Ordering
$ccompare :: RawPayload -> RawPayload -> Ordering
Ord, Int -> RawPayload -> ShowS
[RawPayload] -> ShowS
RawPayload -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawPayload] -> ShowS
$cshowList :: [RawPayload] -> ShowS
show :: RawPayload -> String
$cshow :: RawPayload -> String
showsPrec :: Int -> RawPayload -> ShowS
$cshowsPrec :: Int -> RawPayload -> ShowS
Show)

rawStackSize :: RawStack -> Int
rawStackSize :: RawStack -> Int
rawStackSize (RawStack ByteString
bs) = ByteString -> Int
BS.length ByteString
bs


newtype BlockPtr = BlockPtr Word64
                   deriving (BlockPtr -> BlockPtr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockPtr -> BlockPtr -> Bool
$c/= :: BlockPtr -> BlockPtr -> Bool
== :: BlockPtr -> BlockPtr -> Bool
$c== :: BlockPtr -> BlockPtr -> Bool
Eq, Eq BlockPtr
BlockPtr -> BlockPtr -> Bool
BlockPtr -> BlockPtr -> Ordering
BlockPtr -> BlockPtr -> BlockPtr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockPtr -> BlockPtr -> BlockPtr
$cmin :: BlockPtr -> BlockPtr -> BlockPtr
max :: BlockPtr -> BlockPtr -> BlockPtr
$cmax :: BlockPtr -> BlockPtr -> BlockPtr
>= :: BlockPtr -> BlockPtr -> Bool
$c>= :: BlockPtr -> BlockPtr -> Bool
> :: BlockPtr -> BlockPtr -> Bool
$c> :: BlockPtr -> BlockPtr -> Bool
<= :: BlockPtr -> BlockPtr -> Bool
$c<= :: BlockPtr -> BlockPtr -> Bool
< :: BlockPtr -> BlockPtr -> Bool
$c< :: BlockPtr -> BlockPtr -> Bool
compare :: BlockPtr -> BlockPtr -> Ordering
$ccompare :: BlockPtr -> BlockPtr -> Ordering
Ord)
                   deriving newtype (Eq BlockPtr
Int -> BlockPtr -> Int
BlockPtr -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: BlockPtr -> Int
$chash :: BlockPtr -> Int
hashWithSalt :: Int -> BlockPtr -> Int
$chashWithSalt :: Int -> BlockPtr -> Int
Hashable)
                   deriving (Get BlockPtr
[BlockPtr] -> Put
BlockPtr -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [BlockPtr] -> Put
$cputList :: [BlockPtr] -> Put
get :: Get BlockPtr
$cget :: Get BlockPtr
put :: BlockPtr -> Put
$cput :: BlockPtr -> Put
Binary, Int -> BlockPtr -> ShowS
[BlockPtr] -> ShowS
BlockPtr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockPtr] -> ShowS
$cshowList :: [BlockPtr] -> ShowS
show :: BlockPtr -> String
$cshow :: BlockPtr -> String
showsPrec :: Int -> BlockPtr -> ShowS
$cshowsPrec :: Int -> BlockPtr -> ShowS
Show) via StackPtr

blockMBlock :: BlockPtr -> Word64
blockMBlock :: BlockPtr -> Word64
blockMBlock (BlockPtr Word64
p) = Word64
p forall a. Bits a => a -> a -> a
.&. (forall a. Bits a => a -> a
complement Word64
mblockMask)

applyMBlockMask :: ClosurePtr -> BlockPtr
applyMBlockMask :: ClosurePtr -> BlockPtr
applyMBlockMask (ClosurePtr Word64
p) = Word64 -> BlockPtr
BlockPtr (Word64
p forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement Word64
mblockMask)

applyBlockMask :: ClosurePtr -> BlockPtr
applyBlockMask :: ClosurePtr -> BlockPtr
applyBlockMask (ClosurePtr Word64
p) = Word64 -> BlockPtr
BlockPtr (Word64
p forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement Word64
blockMask)

getBlockOffset :: ClosurePtr -> Word64
getBlockOffset :: ClosurePtr -> Word64
getBlockOffset (ClosurePtr Word64
p) = Word64
p forall a. Bits a => a -> a -> a
.&. Word64
blockMask

mblockMaxSize, blockMaxSize :: Word64
mblockMaxSize :: Word64
mblockMaxSize = Word64
mblockMask forall a. Num a => a -> a -> a
+ Word64
1
blockMaxSize :: Word64
blockMaxSize = Word64
blockMask forall a. Num a => a -> a -> a
+ Word64
1

mblockMask :: Word64
mblockMask :: Word64
mblockMask = Word64
0b11111111111111111111 -- 20 bits

blockMask :: Word64
blockMask :: Word64
blockMask = Word64
0b111111111111 -- 12 bits

isPinnedBlock :: RawBlock -> Bool
isPinnedBlock :: RawBlock -> Bool
isPinnedBlock (RawBlock BlockPtr
_ Word16
flags ByteString
_) = (Word16
flags forall a. Bits a => a -> a -> a
.&. Word16
0b100) forall a. Eq a => a -> a -> Bool
/= Word16
0

isLargeBlock :: RawBlock -> Bool
isLargeBlock :: RawBlock -> Bool
isLargeBlock (RawBlock BlockPtr
_ Word16
flags ByteString
_) = (Word16
flags forall a. Bits a => a -> a -> a
.&. Word16
0b10) forall a. Eq a => a -> a -> Bool
/= Word16
0

data RawBlock = RawBlock BlockPtr Word16 BS.ByteString
                    deriving (Int -> RawBlock -> ShowS
[RawBlock] -> ShowS
RawBlock -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawBlock] -> ShowS
$cshowList :: [RawBlock] -> ShowS
show :: RawBlock -> String
$cshow :: RawBlock -> String
showsPrec :: Int -> RawBlock -> ShowS
$cshowsPrec :: Int -> RawBlock -> ShowS
Show)

-- flags, Ptr, size then raw block
getBlock :: Get RawBlock
getBlock :: Get RawBlock
getBlock = do
  Word16
bflags <- Get Word16
getWord16le
  BlockPtr
bptr <- forall t. Binary t => Get t
get
  Int32
len <- Get Int32
getInt32be
  ByteString
rb <- Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
  return (BlockPtr -> Word16 -> ByteString -> RawBlock
RawBlock BlockPtr
bptr Word16
bflags ByteString
rb)

putBlock :: RawBlock -> Put
putBlock :: RawBlock -> Put
putBlock (RawBlock BlockPtr
bptr Word16
bflags ByteString
rb) = do
  Word16 -> Put
putWord16le Word16
bflags
  forall t. Binary t => t -> Put
put BlockPtr
bptr
  Int32 -> Put
putInt32be (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
rb)
  ByteString -> Put
putByteString ByteString
rb

instance Binary RawBlock where
  get :: Get RawBlock
get = Get RawBlock
getBlock
  put :: RawBlock -> Put
put = RawBlock -> Put
putBlock

rawBlockSize :: RawBlock -> Int
rawBlockSize :: RawBlock -> Int
rawBlockSize (RawBlock BlockPtr
_ Word16
_ ByteString
bs) = ByteString -> Int
BS.length ByteString
bs

rawBlockAddr :: RawBlock -> BlockPtr
rawBlockAddr :: RawBlock -> BlockPtr
rawBlockAddr (RawBlock BlockPtr
addr Word16
_ ByteString
_) = BlockPtr
addr

-- | Invariant: ClosurePtr is within the range of the block
-- The 'RawClosure' this returns is actually the tail of the whole block,
-- this is fine because the memory for each block is only allocated once
-- due to how BS.drop is implemented via pointer arithmetic.
extractFromBlock :: ClosurePtr
                -> RawBlock
                -> RawClosure
extractFromBlock :: ClosurePtr -> RawBlock -> RawClosure
extractFromBlock ClosurePtr
cp (RawBlock BlockPtr
bp Word16
_ ByteString
b) =
--  Calling closureSize doesn't work as the info table addresses are bogus
--  clos_size_w <- withForeignPtr fp' (\p -> return $ closureSize (ptrToBox p))
--  let clos_size = clos_size_w * 8
    --traceShow (fp, offset, cp, bp,o, l)
    --traceShow ("FP", fp `plusForeignPtr` offset)
    ByteString -> RawClosure
RawClosure (Int -> ByteString -> ByteString
BS.drop Int
offset ByteString
b)
    where
      offset :: Int
offset = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ClosurePtr -> BlockPtr -> Word64
subtractBlockPtr ClosurePtr
cp BlockPtr
bp)

tAG_MASK :: Word64
tAG_MASK :: Word64
tAG_MASK = Word64
0b111

untagClosurePtr :: ClosurePtr -> ClosurePtr
untagClosurePtr :: ClosurePtr -> ClosurePtr
untagClosurePtr (ClosurePtr Word64
w) = Word64 -> ClosurePtr
UntaggedClosurePtr (Word64
w forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement Word64
tAG_MASK)

getInfoTblPtr :: HasCallStack => RawClosure -> InfoTablePtr
getInfoTblPtr :: HasCallStack => RawClosure -> InfoTablePtr
getInfoTblPtr (RawClosure ByteString
bs) = forall a. HasCallStack => Get a -> ByteString -> a
runGet_ (forall a. Int -> Get a -> Get a
isolate Int
8 forall t. Binary t => Get t
get) (ByteString -> ByteString
BSL.fromStrict ByteString
bs)

-- | A bitmap that records whether each field of a stack frame is a pointer.
newtype PtrBitmap = PtrBitmap (A.Array Int Bool) deriving (Int -> PtrBitmap -> ShowS
[PtrBitmap] -> ShowS
PtrBitmap -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PtrBitmap] -> ShowS
$cshowList :: [PtrBitmap] -> ShowS
show :: PtrBitmap -> String
$cshow :: PtrBitmap -> String
showsPrec :: Int -> PtrBitmap -> ShowS
$cshowsPrec :: Int -> PtrBitmap -> ShowS
Show)

traversePtrBitmap :: Monad m => (Bool -> m a) -> PtrBitmap -> m [a]
traversePtrBitmap :: forall (m :: * -> *) a.
Monad m =>
(Bool -> m a) -> PtrBitmap -> m [a]
traversePtrBitmap Bool -> m a
f (PtrBitmap Array Int Bool
arr) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Bool -> m a
f (forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
A.elems Array Int Bool
arr)

getPtrBitmap :: Get PtrBitmap
getPtrBitmap :: Get PtrBitmap
getPtrBitmap = do
  Word32
len <- Get Word32
getWord32be
  [Word8]
bits <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len) Get Word8
getWord8
  let arr :: Array Int Bool
arr = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
A.listArray (Int
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
lenforall a. Num a => a -> a -> a
-Int
1) (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Eq a => a -> a -> Bool
==Word8
1) [Word8]
bits)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Array Int Bool -> PtrBitmap
PtrBitmap Array Int Bool
arr

putPtrBitmap :: PtrBitmap -> Put
putPtrBitmap :: PtrBitmap -> Put
putPtrBitmap (PtrBitmap Array Int Bool
pbm) = do
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Array Int Bool
pbm
  Word32 -> Put
putWord32be (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
F.traverse_ (\Bool
b -> if Bool
b then Word8 -> Put
putWord8 Word8
1 else Word8 -> Put
putWord8 Word8
0) Array Int Bool
pbm

instance Binary PtrBitmap where
  get :: Get PtrBitmap
get = Get PtrBitmap
getPtrBitmap
  put :: PtrBitmap -> Put
put = PtrBitmap -> Put
putPtrBitmap