[Git][ghc/ghc][wip/decode_cloned_stack] 14 commits: Formatting: Move foreign imports to top
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Jan 21 20:09:25 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
53f8eb5c by Sven Tennie at 2023-01-21T14:39:12+00:00
Formatting: Move foreign imports to top
- - - - -
67c63ad1 by Sven Tennie at 2023-01-21T15:04:27+00:00
Reduce duplication
- - - - -
04aa3d49 by Sven Tennie at 2023-01-21T15:07:39+00:00
Rename
- - - - -
019f0eac by Sven Tennie at 2023-01-21T15:40:55+00:00
Delete unused registers
- - - - -
1c9b803c by Sven Tennie at 2023-01-21T15:43:06+00:00
Cleanup
- - - - -
642c244a by Sven Tennie at 2023-01-21T15:53:48+00:00
Reformat
- - - - -
f7136b27 by Sven Tennie at 2023-01-21T17:59:28+00:00
Make distinction between bate and word offsets
- - - - -
0f7d2ad1 by Sven Tennie at 2023-01-21T18:04:38+00:00
Formatting: Order functions
- - - - -
e58ef246 by Sven Tennie at 2023-01-21T18:06:07+00:00
Delete unused type
- - - - -
bdb71a27 by Sven Tennie at 2023-01-21T18:33:04+00:00
Use more meaningful offset
- - - - -
4b896513 by Sven Tennie at 2023-01-21T18:54:17+00:00
Use constants
- - - - -
e377c9f2 by Sven Tennie at 2023-01-21T19:22:24+00:00
Replace prim with getWord call
- - - - -
2199f7ec by Sven Tennie at 2023-01-21T19:28:53+00:00
getWord: WordOffsets
- - - - -
2fc29feb by Sven Tennie at 2023-01-21T20:07:55+00:00
Remove duplication: Small and large bitmap decoding
- - - - -
4 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/StackConstants.hsc
- libraries/ghc-heap/cbits/Stack.c
- libraries/ghc-heap/cbits/Stack.cmm
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -13,6 +13,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
-- TODO: Find better place than top level. Re-export from top-level?
module GHC.Exts.DecodeStack (
@@ -34,33 +35,44 @@ import GHC.Exts.Heap.Closures as CL
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.DecodeHeap
-type StackFrameIter# = (#
- -- | StgStack
- StackSnapshot#,
- -- | offset in machine words
- Word#
- #)
+foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word# -> Word#
-data StackFrameIter = StackFrameIter StackFrameIter#
+derefStackWord :: StackFrameIter -> Word
+derefStackWord (StackFrameIter {..}) = W# (derefStackWord# stackSnapshot# (wordOffsetToWord# index))
--- TODO: Remove this instance (debug only)
-instance Show StackFrameIter where
- show (StackFrameIter (# _, i# #)) = "StackFrameIter " ++ "(StackSnapshot _" ++ " " ++ show (W# i#)
+foreign import prim "getUpdateFrameTypezh" getUpdateFrameType# :: StackSnapshot# -> Word# -> Word#
--- | Get an interator starting with the top-most stack frame
-stackHead :: StackSnapshot -> StackFrameIter
-stackHead (StackSnapshot s) = StackFrameIter (# s , 0## #) -- GHC stacks are never empty
+getUpdateFrameType :: StackFrameIter -> UpdateFrameType
+getUpdateFrameType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) (W# (getUpdateFrameType# stackSnapshot# (wordOffsetToWord# index)))
-foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
+-- TODO: This can be simplified if the offset is always full words
+foreign import prim "unpackClosureReferencedByFramezh" unpackClosureReferencedByFrame# :: Word# -> StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# b #)
--- | Advance iterator to the next stack frame (if any)
-advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
-advanceStackFrameIter (StackFrameIter (# s, i #)) = let !(# s', i', hasNext #) = advanceStackFrameIter# s i in
- if (I# hasNext) > 0 then Just $ StackFrameIter (# s', i' #)
- else Nothing
+unpackClosureReferencedByFrame :: WordOffset -> StackSnapshot# -> WordOffset -> (# Addr#, ByteArray#, Array# b #)
+unpackClosureReferencedByFrame wo1 ss# wo2 = unpackClosureReferencedByFrame# (wordOffsetToWord# wo1) ss# (wordOffsetToWord# wo2)
+
+foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> StackSnapshot#
+
+getUnderflowFrameNextChunk :: StackFrameIter -> StackSnapshot
+getUnderflowFrameNextChunk (StackFrameIter {..}) = StackSnapshot s#
+ where
+ s# = getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index)
+
+foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> Word#
+
+getWord :: StackFrameIter -> WordOffset -> Word
+getWord (StackFrameIter {..}) relativeOffset = W# (getWord# stackSnapshot# (wordOffsetToWord# index) (wordOffsetToWord# relativeOffset))
+
+foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
+
+getRetFunType :: StackFrameIter -> RetFunType
+getRetFunType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) (W# (getRetFunType# stackSnapshot# (wordOffsetToWord# index)))
foreign import prim "getInfoTableTypezh" getInfoTableType# :: StackSnapshot# -> Word# -> Word#
+getInfoTableType :: StackFrameIter -> ClosureType
+getInfoTableType (StackFrameIter {..}) = (toEnum . fromIntegral) (W# (getInfoTableType# stackSnapshot# (wordOffsetToWord# index)))
+
foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
@@ -71,8 +83,36 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word
foreign import prim "getRetSmallSpecialTypezh" getRetSmallSpecialType# :: StackSnapshot# -> Word# -> Word#
+getRetSmallSpecialType :: StackFrameIter -> SpecialRetSmall
+getRetSmallSpecialType (StackFrameIter {..}) = let special# = getRetSmallSpecialType# stackSnapshot# (wordOffsetToWord# index)
+ in
+ (toEnum . fromInteger . toInteger) (W# special#)
+
foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word# #)
+foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
+
+data StackFrameIter = StackFrameIter {
+ stackSnapshot# :: StackSnapshot#,
+ index :: WordOffset
+ }
+-- TODO: Remove this instance (debug only)
+instance Show StackFrameIter where
+ show (StackFrameIter { .. }) = "StackFrameIter " ++ "(StackSnapshot _" ++ " " ++ show index
+
+-- | Get an interator starting with the top-most stack frame
+stackHead :: StackSnapshot -> StackFrameIter
+stackHead (StackSnapshot s) = StackFrameIter s 0 -- GHC stacks are never empty
+
+-- | Advance iterator to the next stack frame (if any)
+advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
+advanceStackFrameIter (StackFrameIter {..}) = let !(# s', i', hasNext #) = advanceStackFrameIter# stackSnapshot# (wordOffsetToWord# index) in
+ if (I# hasNext) > 0 then Just $ StackFrameIter s' (primWordToWordOffset i')
+ else Nothing
+
+primWordToWordOffset :: Word# -> WordOffset
+primWordToWordOffset w# = fromIntegral (W# w#)
+
data BitmapEntry = BitmapEntry {
closureFrame :: StackFrameIter,
isPrimitive :: Bool
@@ -88,8 +128,8 @@ wordsToBitmapEntries sfi (b:bs) bitmapSize =
mbLastFrame = fmap closureFrame mbLastEntry
in
case mbLastFrame of
- Just (StackFrameIter (# s'#, i'# #)) ->
- entries ++ wordsToBitmapEntries (StackFrameIter (# s'#, plusWord# i'# 1## #)) bs (subtractDecodedBitmapWord bitmapSize)
+ Just (StackFrameIter {..} ) ->
+ entries ++ wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + 1)) bs (subtractDecodedBitmapWord bitmapSize)
Nothing -> error "This should never happen! Recursion ended not in base case."
where
subtractDecodedBitmapWord :: Word -> Word
@@ -97,25 +137,21 @@ wordsToBitmapEntries sfi (b:bs) bitmapSize =
toBitmapEntries :: StackFrameIter -> Word -> Word -> [BitmapEntry]
toBitmapEntries _ _ 0 = []
-toBitmapEntries sfi@(StackFrameIter(# s, i #)) bitmapWord bSize = BitmapEntry {
+toBitmapEntries sfi@(StackFrameIter {..}) bitmapWord bSize = BitmapEntry {
closureFrame = sfi,
isPrimitive = (bitmapWord .&. 1) /= 0
- } : toBitmapEntries (StackFrameIter (# s , plusWord# i 1## #)) (bitmapWord `shiftR` 1) (bSize - 1)
+ } : toBitmapEntries (StackFrameIter stackSnapshot# (index + 1)) (bitmapWord `shiftR` 1) (bSize - 1)
toBitmapPayload :: BitmapEntry -> IO Box
-toBitmapPayload e | isPrimitive e = pure $ DecodedClosureBox. CL.UnknownTypeWordSizedPrimitive . toWord . closureFrame $ e
- where
- toWord (StackFrameIter (# s#, i# #)) = W# (derefStackWord# s# i#)
-toBitmapPayload e = toClosure unpackClosureFromStackFrame# (closureFrame e)
-
--- TODO: Offset should be in Words. That's the smallest reasonable unit.
--- TODO: Negative offsets won't work! Consider using Word
-getClosure :: StackFrameIter -> Int -> IO Box
-getClosure sfi relativeOffset = toClosure (unpackClosureReferencedByFrame# (intToWord# relativeOffset)) sfi
-
-toClosure :: (StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# Any #)) -> StackFrameIter -> IO Box
-toClosure f# (StackFrameIter (# s#, i# #)) =
- case f# s# i# of
+toBitmapPayload e | isPrimitive e = pure $ DecodedClosureBox. CL.UnknownTypeWordSizedPrimitive . derefStackWord . closureFrame $ e
+toBitmapPayload e = toClosure (unpackClosureReferencedByFrame 0) (closureFrame e)
+
+getClosure :: StackFrameIter -> WordOffset-> IO Box
+getClosure sfi relativeOffset = toClosure (unpackClosureReferencedByFrame relativeOffset) sfi
+
+toClosure :: (StackSnapshot# -> WordOffset -> (# Addr#, ByteArray#, Array# Any #)) -> StackFrameIter -> IO Box
+toClosure f# (StackFrameIter {..}) =
+ case f# stackSnapshot# index of
(# infoTableAddr, heapRep, pointersArray #) ->
let infoTablePtr = Ptr infoTableAddr
ptrList = [case indexArray# pointersArray i of
@@ -125,68 +161,79 @@ toClosure f# (StackFrameIter (# s#, i# #)) =
in
DecodedClosureBox <$> (getClosureDataFromHeapRep heapRep infoTablePtr ptrList)
--- TODO: Make function more readable: No IO in let bindings
-decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> Word# -> IO [Box]
-decodeLargeBitmap getterFun# (StackFrameIter (# stackFrame#, closureOffset# #)) relativePayloadOffset# =
- let !(# bitmapArray#, size# #) = getterFun# stackFrame# closureOffset#
- bitmapWords :: [Word] = foldrByteArray (\w acc -> W# w : acc) [] bitmapArray#
- bes = wordsToBitmapEntries (StackFrameIter (# stackFrame#, plusWord# closureOffset# relativePayloadOffset# #)) bitmapWords (W# size#)
- payloads = mapM toBitmapPayload bes
+decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
+decodeLargeBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset =
+ let !(# bitmapArray#, size# #) = getterFun# stackSnapshot# (wordOffsetToWord# index)
+ bitmapWords :: [Word] = byteArrayToList bitmapArray#
in
- payloads
-
--- TODO: Make function more readable: No IO in let bindings
-decodeSmallBitmap :: (StackSnapshot# -> Word# -> (# Word#, Word# #)) -> StackFrameIter -> Word# -> IO [Box]
-decodeSmallBitmap getterFun# (StackFrameIter (# stackFrame#, closureOffset# #)) relativePayloadOffset# =
- let !(# bitmap#, size# #) = getterFun# stackFrame# closureOffset#
- bes = toBitmapEntries (StackFrameIter (# stackFrame#, plusWord# closureOffset# relativePayloadOffset# #))(W# bitmap#) (W# size#)
- payloads = mapM toBitmapPayload bes
+ decodeBitmaps sfi relativePayloadOffset bitmapWords (W# size#)
+
+decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> IO [Box]
+decodeBitmaps (StackFrameIter {..}) relativePayloadOffset bitmapWords size =
+ let
+ bes = wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + relativePayloadOffset)) bitmapWords size
in
- payloads
+ mapM toBitmapPayload bes
--- TODO: Negative offsets won't work! Consider using Word
-getWord :: StackFrameIter -> Int -> Word
-getWord (StackFrameIter (# s#, i# #)) relativeOffset = W# (getWord# s# i# (intToWord# relativeOffset))
+decodeSmallBitmap :: (StackSnapshot# -> Word# -> (# Word#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
+decodeSmallBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset =
+ let !(# bitmap#, size# #) = getterFun# stackSnapshot# (wordOffsetToWord# index)
+ size = W# size#
+ bitmapWords = if size > 0 then [(W# bitmap#)] else []
+ in
+ decodeBitmaps sfi relativePayloadOffset bitmapWords size
+
+byteArrayToList :: ByteArray# -> [Word]
+byteArrayToList bArray = go 0
+ where
+ go i
+ | i < maxIndex = (W# (indexWordArray# bArray (toInt# i))) : (go (i + 1))
+ | otherwise = []
+ maxIndex = sizeofByteArray bArray `quot` sizeOf (undefined :: Word)
+
+byteOffsetToWord# :: ByteOffset -> Word#
+byteOffsetToWord# bo = intToWord# (fromIntegral bo)
+
+wordOffsetToWord# :: WordOffset -> Word#
+wordOffsetToWord# wo = intToWord# (fromIntegral wo)
unpackStackFrameIter :: StackFrameIter -> IO CL.Closure
-unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) = trace ("decoding ... " ++ show @ClosureType ((toEnum . fromIntegral) (W# (getInfoTableType# s# i#))) ++ "\n") $
- case (toEnum . fromIntegral) (W# (getInfoTableType# s# i#)) of
+unpackStackFrameIter sfi =
+ case getInfoTableType sfi of
RET_BCO -> do
bco' <- getClosure sfi offsetStgClosurePayload
- args' <- decodeLargeBitmap getBCOLargeBitmap# sfi 2##
+ -- The arguments begin directly after the payload's one element
+ args' <- decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
pure $ CL.RetBCO bco' args'
RET_SMALL -> do
- payloads <- decodeSmallBitmap getSmallBitmap# sfi 1##
- let special# = getRetSmallSpecialType# s# i#
- special = (toEnum . fromInteger . toInteger) (W# special#)
+ payloads <- decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
+ let special = getRetSmallSpecialType sfi
pure $ CL.RetSmall special payloads
- RET_BIG -> CL.RetBig <$> decodeLargeBitmap getLargeBitmap# sfi 1##
+ RET_BIG -> CL.RetBig <$> decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
RET_FUN -> do
- let t = (toEnum . fromInteger . toInteger) (W# (getRetFunType# s# i#))
+ let t = getRetFunType sfi
size' = getWord sfi offsetStgRetFunFrameSize
fun' <- getClosure sfi offsetStgRetFunFrameFun
payload' <-
if t == CL.ARG_GEN_BIG then
- decodeLargeBitmap getRetFunLargeBitmap# sfi 3##
+ decodeLargeBitmap getRetFunLargeBitmap# sfi offsetStgRetFunFramePayload
else
- -- TODO: The offsets should be based on DerivedConstants.h
- decodeSmallBitmap getRetFunSmallBitmap# sfi 3##
+ decodeSmallBitmap getRetFunSmallBitmap# sfi offsetStgRetFunFramePayload
pure $ CL.RetFun t size' fun' payload'
-- TODO: Decode update frame type
UPDATE_FRAME -> let
- !t = (toEnum . fromInteger . toInteger) (W# (getUpdateFrameType# s# i#))
+ !t = getUpdateFrameType sfi
c = getClosure sfi offsetStgUpdateFrameUpdatee
in
(CL.UpdateFrame t ) <$> c
CATCH_FRAME -> do
- -- TODO: Replace with getWord# expression
- let exceptionsBlocked = W# (getCatchFrameExceptionsBlocked# s# i#)
+ let exceptionsBlocked = getWord sfi offsetStgCatchFrameExceptionsBlocked
c <- getClosure sfi offsetStgCatchFrameHandler
pure $ CL.CatchFrame exceptionsBlocked c
UNDERFLOW_FRAME -> let
- nextChunk# = getUnderflowFrameNextChunk# s# i#
+ nextChunk = getUnderflowFrameNextChunk sfi
in
- pure $ CL.UnderflowFrame (StackSnapshot nextChunk#)
+ pure $ CL.UnderflowFrame nextChunk
STOP_FRAME -> pure CL.StopFrame
ATOMICALLY_FRAME -> CL.AtomicallyFrame
<$> getClosure sfi offsetStgAtomicallyFrameCode
@@ -201,17 +248,6 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) = trace ("decoding ... "
<*> getClosure sfi offsetStgCatchSTMFrameHandler
x -> error $ "Unexpected closure type on stack: " ++ show x
--- | Right-fold over the elements of a 'ByteArray'.
--- Copied from `primitive`
-foldrByteArray :: forall b. (Word# -> b -> b) -> b -> ByteArray# -> b
-{-# INLINE foldrByteArray #-}
-foldrByteArray f z arr = go 0
- where
- go i
- | i < maxI = f (indexWordArray# arr (toInt# i)) (go (i + 1))
- | otherwise = z
- maxI = sizeofByteArray arr `quot` sizeOf (undefined :: Word)
-
-- | Size of the byte array in bytes.
-- Copied from `primitive`
sizeofByteArray :: ByteArray# -> Int
@@ -225,22 +261,6 @@ toInt# (I# i) = i
intToWord# :: Int -> Word#
intToWord# i = int2Word# (toInt# i)
-foreign import prim "unpackClosureFromStackFramezh" unpackClosureFromStackFrame# :: StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# b #)
-
-foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word# -> Word#
-
-foreign import prim "getUpdateFrameTypezh" getUpdateFrameType# :: StackSnapshot# -> Word# -> Word#
-
-foreign import prim "unpackClosureReferencedByFramezh" unpackClosureReferencedByFrame# :: Word# -> StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# b #)
-
-foreign import prim "getCatchFrameExceptionsBlockedzh" getCatchFrameExceptionsBlocked# :: StackSnapshot# -> Word# -> Word#
-
-foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> StackSnapshot#
-
-foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> Word#
-
-foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
-
decodeStack :: StackSnapshot -> IO CL.Closure
decodeStack s = do
stack <- decodeStack' s
=====================================
libraries/ghc-heap/GHC/Exts/StackConstants.hsc
=====================================
@@ -1,4 +1,6 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Exts.StackConstants where
-- TODO: Better expression to allow is only for the latest (this branch) GHC?
@@ -12,62 +14,76 @@ import Prelude
#undef BLOCKS_PER_MBLOCK
#include "DerivedConstants.h"
-offsetStgCatchFrameHandler :: Int
-offsetStgCatchFrameHandler = (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
+newtype ByteOffset = ByteOffset { offsetInBytes :: Int }
+ deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
-offsetStgCatchSTMFrameCode :: Int
-offsetStgCatchSTMFrameCode = (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
+newtype WordOffset = WordOffset { offsetInWords :: Int }
+ deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
-offsetStgCatchSTMFrameHandler :: Int
-offsetStgCatchSTMFrameHandler = (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
+offsetStgCatchFrameHandler :: WordOffset
+offsetStgCatchFrameHandler = byteOffsetToWordOffset $ (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
-offsetStgUpdateFrameUpdatee :: Int
-offsetStgUpdateFrameUpdatee = (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
+offsetStgCatchFrameExceptionsBlocked :: WordOffset
+offsetStgCatchFrameExceptionsBlocked = byteOffsetToWordOffset $ (#const OFFSET_StgCatchFrame_exceptions_blocked) + (#size StgHeader)
-offsetStgAtomicallyFrameCode :: Int
-offsetStgAtomicallyFrameCode = (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
+offsetStgCatchSTMFrameCode :: WordOffset
+offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
-offsetStgAtomicallyFrameResult :: Int
-offsetStgAtomicallyFrameResult = (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
+offsetStgCatchSTMFrameHandler :: WordOffset
+offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $ (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
-offsetStgCatchRetryFrameRunningAltCode :: Int
-offsetStgCatchRetryFrameRunningAltCode = (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
+offsetStgUpdateFrameUpdatee :: WordOffset
+offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $ (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
-offsetStgCatchRetryFrameRunningFirstCode :: Int
-offsetStgCatchRetryFrameRunningFirstCode = (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
+offsetStgAtomicallyFrameCode :: WordOffset
+offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $ (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
-offsetStgCatchRetryFrameAltCode :: Int
-offsetStgCatchRetryFrameAltCode = (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
+offsetStgAtomicallyFrameResult :: WordOffset
+offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $ (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
-offsetStgRetFunFrameSize :: Int
+offsetStgCatchRetryFrameRunningAltCode :: WordOffset
+offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningFirstCode :: WordOffset
+offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameAltCode :: WordOffset
+offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
+
+offsetStgRetFunFrameSize :: WordOffset
-- StgRetFun has no header, but only a pointer to the info table at the beginning.
-offsetStgRetFunFrameSize = (#const OFFSET_StgRetFun_size)
+offsetStgRetFunFrameSize = byteOffsetToWordOffset $ (#const OFFSET_StgRetFun_size)
-offsetStgRetFunFrameFun :: Int
-offsetStgRetFunFrameFun = (#const OFFSET_StgRetFun_fun)
+offsetStgRetFunFrameFun :: WordOffset
+offsetStgRetFunFrameFun = byteOffsetToWordOffset $ (#const OFFSET_StgRetFun_fun)
-offsetStgRetFunFramePayload :: Int
-offsetStgRetFunFramePayload = (#const OFFSET_StgRetFun_payload)
+offsetStgRetFunFramePayload :: WordOffset
+offsetStgRetFunFramePayload = byteOffsetToWordOffset $ (#const OFFSET_StgRetFun_payload)
-offsetStgBCOFrameInstrs :: Int
+offsetStgBCOFrameInstrs :: ByteOffset
offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
-offsetStgBCOFrameLiterals :: Int
+offsetStgBCOFrameLiterals :: ByteOffset
offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader)
-offsetStgBCOFramePtrs :: Int
+offsetStgBCOFramePtrs :: ByteOffset
offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader)
-offsetStgBCOFrameArity :: Int
+offsetStgBCOFrameArity :: ByteOffset
offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader)
-offsetStgBCOFrameSize :: Int
+offsetStgBCOFrameSize :: ByteOffset
offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader)
-offsetStgClosurePayload :: Int
-offsetStgClosurePayload = (#const OFFSET_StgClosure_payload) + (#size StgHeader)
+offsetStgClosurePayload :: WordOffset
+offsetStgClosurePayload = byteOffsetToWordOffset $ (#const OFFSET_StgClosure_payload) + (#size StgHeader)
+
+byteOffsetToWordOffset :: ByteOffset -> WordOffset
+byteOffsetToWordOffset bo = if bo `mod` bytesInWord == 0 then
+ fromIntegral $ bo `div` bytesInWord
+ else
+ error "Unexpected struct alignment!"
+ where
+ bytesInWord = (#const SIZEOF_VOID_P)
--- TODO: Should be SIZEOF_VOID_P
-bytesInWord :: Int
-bytesInWord = (#const SIZEOF_UNSIGNED_LONG)
#endif
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -124,9 +124,7 @@ StgWord getBitmapWord(StgClosure *c) {
const StgInfoTable *info = get_itbl(c);
StgWord bitmap = info->layout.bitmap;
- // debugBelch("getBitmapWord - bitmap : %lu \n", bitmap);
StgWord bitmapWord = BITMAP_BITS(bitmap);
- // debugBelch("getBitmapWord - bitmapWord : %lu \n", bitmapWord);
return bitmapWord;
}
@@ -185,11 +183,7 @@ StgWord getBCOLargeBitmapSize(StgClosure *c) {
#define SIZEOF_W SIZEOF_VOID_P
#define WDS(n) ((n)*SIZEOF_W)
-StgArrBytes *getLargeBitmaps(Capability *cap, StgClosure *c) {
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
-
- const StgInfoTable *info = get_itbl(c);
- StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+static StgArrBytes *largeBitmapToStgArrBytes(Capability *cap, StgLargeBitmap *bitmap) {
StgWord neededWords = ROUNDUP_BITS_TO_WDS(bitmap->size);
StgArrBytes *array =
(StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + neededWords);
@@ -203,42 +197,31 @@ StgArrBytes *getLargeBitmaps(Capability *cap, StgClosure *c) {
return array;
}
-StgArrBytes *getRetFunLargeBitmaps(Capability *cap, StgRetFun *ret_fun) {
+StgArrBytes *getLargeBitmap(Capability *cap, StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ const StgInfoTable *info = get_itbl(c);
+ StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+
+ return largeBitmapToStgArrBytes(cap, bitmap);
+}
+
+StgArrBytes *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);
- StgWord neededWords = ROUNDUP_BITS_TO_WDS(bitmap->size);
- StgArrBytes *array =
- (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + neededWords);
- SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM);
- array->bytes = WDS(ROUNDUP_BITS_TO_WDS(bitmap->size));
- for (int i = 0; i < neededWords; i++) {
- array->payload[i] = bitmap->bitmap[i];
- }
-
- return array;
+ return largeBitmapToStgArrBytes(cap, bitmap);
}
-// TODO: Much duplication between: getBCOLargeBitmaps, getRetFunLargeBitmaps,
-// getLargeBitmaps
-StgArrBytes *getBCOLargeBitmaps(Capability *cap, StgClosure *c) {
+StgArrBytes *getBCOLargeBitmap(Capability *cap, StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
StgBCO *bco = (StgBCO *)*c->payload;
StgLargeBitmap *bitmap = BCO_BITMAP(bco);
- StgWord neededWords = ROUNDUP_BITS_TO_WDS(bitmap->size);
- StgArrBytes *array =
- (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + neededWords);
- SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM);
- array->bytes = WDS(ROUNDUP_BITS_TO_WDS(bitmap->size));
- for (int i = 0; i < neededWords; i++) {
- array->payload[i] = bitmap->bitmap[i];
- }
-
- return array;
+ return largeBitmapToStgArrBytes(cap, bitmap);
}
#if defined(DEBUG)
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -1,8 +1,7 @@
-#include "Cmm.h"
-
-// TODO: comment out
// Uncomment to enable assertions during development
-#define DEBUG 1
+// #define DEBUG 1
+
+#include "Cmm.h"
advanceStackFrameIterzh (P_ stack, W_ offsetWords) {
W_ frameSize;
@@ -40,15 +39,6 @@ advanceStackFrameIterzh (P_ stack, W_ offsetWords) {
}
}
- // TODO: Execute this block only in -DDEBUG
-#if DEBUG
- if(hasNext > 0) {
- P_ nextClosure;
- nextClosure = StgStack_sp(stack) + WDS(offsetWords);
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(nextClosure));
- }
-#endif
-
return (newStack, newOffsetWords, hasNext);
}
@@ -75,7 +65,7 @@ getSmallBitmapzh(P_ stack, W_ offsetWords) {
c = StgStack_sp(stack) + WDS(offsetWords);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- W_ bitmap, size, specialType;
+ W_ bitmap, size;
(bitmap) = ccall getBitmapWord(c);
(size) = ccall getBitmapSize(c);
@@ -111,7 +101,7 @@ getLargeBitmapzh(P_ stack, W_ offsetWords){
c = StgStack_sp(stack) + WDS(offsetWords);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- (stgArrBytes) = ccall getLargeBitmaps(MyCapability(), c);
+ (stgArrBytes) = ccall getLargeBitmap(MyCapability(), c);
(size) = ccall getLargeBitmapSize(c);
return (stgArrBytes, size);
@@ -123,7 +113,7 @@ getBCOLargeBitmapzh(P_ stack, W_ offsetWords){
c = StgStack_sp(stack) + WDS(offsetWords);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- (stgArrBytes) = ccall getBCOLargeBitmaps(MyCapability(), c);
+ (stgArrBytes) = ccall getBCOLargeBitmap(MyCapability(), c);
(size) = ccall getBCOLargeBitmapSize(c);
return (stgArrBytes, size);
@@ -135,19 +125,15 @@ getRetFunLargeBitmapzh(P_ stack, W_ offsetWords){
c = StgStack_sp(stack) + WDS(offsetWords);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- (stgArrBytes) = ccall getRetFunLargeBitmaps(MyCapability(), c);
+ (stgArrBytes) = ccall getRetFunLargeBitmap(MyCapability(), c);
(size) = ccall getRetFunSize(c);
return (stgArrBytes, size);
}
-unpackClosureFromStackFramezh(P_ stack, W_ offsetWords){
- jump unpackClosureReferencedByFramezh(0, stack, offsetWords);
-}
-
-unpackClosureReferencedByFramezh(W_ offsetBytes, P_ stack, W_ offsetWords){
+unpackClosureReferencedByFramezh(W_ offsetWordsInFrame, P_ stack, W_ offsetWordsBase){
P_ closurePtrAddr, closurePtr;
- closurePtrAddr = (StgStack_sp(stack) + WDS(offsetWords) + offsetBytes);
+ closurePtrAddr = (StgStack_sp(stack) + WDS(offsetWordsBase) + WDS(offsetWordsInFrame));
closurePtr = P_[closurePtrAddr];
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));
jump stg_unpackClosurezh(closurePtr);
@@ -163,24 +149,14 @@ getUpdateFrameTypezh(P_ stack, W_ offsetWords){
return (type);
}
-getCatchFrameExceptionsBlockedzh(P_ stack, W_ offsetWords){
- P_ closurePtr;
- closurePtr = (StgStack_sp(stack) + WDS(offsetWords));
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));
-
- W_ exceptions_blocked;
- exceptions_blocked = StgCatchFrame_exceptions_blocked(closurePtr);
- return (exceptions_blocked);
-}
-
getWordzh(P_ stack, W_ offsetWords, W_ offsetBytes){
P_ wordAddr;
- wordAddr = (StgStack_sp(stack) + WDS(offsetWords) + offsetBytes);
+ wordAddr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(offsetBytes));
return (W_[wordAddr]);
}
getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords){
- P_ closurePtr, closurePtrPrime, updateePtr;
+ P_ closurePtr;
closurePtr = (StgStack_sp(stack) + WDS(offsetWords));
ASSERT(LOOKS_LIKE_CLOURE_PTR(closurePtr));
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc141e9b3e8bbfebc745d0b7d2c69dc34473df9f...2fc29feb84e6a1b5e2dfaa7a2bedaaf9eb41afea
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc141e9b3e8bbfebc745d0b7d2c69dc34473df9f...2fc29feb84e6a1b5e2dfaa7a2bedaaf9eb41afea
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230121/c328d277/attachment-0001.html>
More information about the ghc-commits
mailing list