[Git][ghc/ghc][wip/decode_cloned_stack] 3 commits: Fix C warnings
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Jan 21 13:08:01 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
720f52ac by Sven Tennie at 2023-01-21T11:47:43+00:00
Fix C warnings
- - - - -
6b505389 by Sven Tennie at 2023-01-21T11:48:17+00:00
Delete obsolete test
- - - - -
97d24436 by Sven Tennie at 2023-01-21T13:07:35+00:00
Cleanup: validate flavour
- - - - -
9 changed files:
- libraries/base/GHC/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/tests/all.T
- − libraries/ghc-heap/tests/decode_cloned_stack.hs
- libraries/ghc-heap/tests/stack_lib.c
- libraries/ghci/GHCi/Run.hs
Changes:
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -30,7 +30,6 @@ import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofA
import GHC.IO (IO (..))
import GHC.InfoProv (InfoProv (..), InfoProvEnt, ipLoc, ipeProv, peekInfoProv)
import GHC.Stable
-import qualified GHC.Generics
-- | A frozen snapshot of the state of an execution stack.
--
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -97,10 +97,10 @@ wordsToBitmapEntries sfi (b:bs) bitmapSize =
toBitmapEntries :: StackFrameIter -> Word -> Word -> [BitmapEntry]
toBitmapEntries _ _ 0 = []
-toBitmapEntries sfi@(StackFrameIter(# s, i #)) bitmap bSize = BitmapEntry {
+toBitmapEntries sfi@(StackFrameIter(# s, i #)) bitmapWord bSize = BitmapEntry {
closureFrame = sfi,
- isPrimitive = (bitmap .&. 1) /= 0
- } : toBitmapEntries (StackFrameIter (# s , plusWord# i 1## #)) (bitmap `shiftR` 1) (bSize - 1)
+ isPrimitive = (bitmapWord .&. 1) /= 0
+ } : toBitmapEntries (StackFrameIter (# s , plusWord# i 1## #)) (bitmapWord `shiftR` 1) (bSize - 1)
toBitmapPayload :: BitmapEntry -> IO Box
toBitmapPayload e | isPrimitive e = pure $ DecodedClosureBox. CL.UnknownTypeWordSizedPrimitive . toWord . closureFrame $ e
@@ -144,17 +144,10 @@ decodeSmallBitmap getterFun# (StackFrameIter (# stackFrame#, closureOffset# #))
in
payloads
--- TODO: Negative offsets won't work! Consider using Word
-getHalfWord :: StackFrameIter -> Int -> Word
-getHalfWord (StackFrameIter (# s#, i# #)) relativeOffset = W# (getHalfWord# s# i# (intToWord# relativeOffset))
-
-- TODO: Negative offsets won't work! Consider using Word
getWord :: StackFrameIter -> Int -> Word
getWord (StackFrameIter (# s#, i# #)) relativeOffset = W# (getWord# s# i# (intToWord# relativeOffset))
-bytesToWords :: Int -> Int
-bytesToWords b = b `div` bytesInWord
-
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
@@ -246,8 +239,6 @@ foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :
foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> Word#
-foreign import prim "getHalfWordzh" getHalfWord# :: StackSnapshot# -> Word# -> Word# -> Word#
-
foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
#if defined(DEBUG)
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -97,7 +97,7 @@ areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
_ -> pure True
#if MIN_VERSION_base(4,17,0)
-- TODO: Implement
-areBoxesEqual (DecodedClosureBox a) (DecodedClosureBox b) = error "Not implemented, yet!"
+areBoxesEqual (DecodedClosureBox _) (DecodedClosureBox _) = error "Not implemented, yet!"
areBoxesEqual _ _ = pure $ False
#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where
@@ -14,7 +15,6 @@ import GHC.Exts
import GHC.Exts.Heap.ProfInfo.PeekProfInfo
import GHC.Exts.Heap.ProfInfo.Types
import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
-import Debug.Trace
import Numeric
data TSOFields = TSOFields {
@@ -117,8 +117,7 @@ peekStackFields ptr = do
marking' <- (#peek struct StgStack_, marking) ptr
#endif
Ptr sp' <- (#peek struct StgStack_, sp) ptr
- let Ptr stack' = (#ptr struct StgStack_, stack) ptr
- traceM $ "stack' " ++ showAddr## stack'
+ let !(Ptr stack') = (#ptr struct StgStack_, stack) ptr
return StackFields {
stack_size = stack_size',
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -202,15 +202,6 @@ getWordzh(P_ stack, W_ index, W_ offset){
return (W_[wordAddr]);
}
-// TODO: Rename: index -> wordOffset, offset -> byteOffset
-getHalfWordzh(P_ stack, W_ index, W_ offset){
- P_ wordAddr;
- wordAddr = (StgStack_sp(stack) + WDS(index) + offset);
- bits32 result;
- result = bits32[wordAddr];
- return (result);
-}
-
getUnderflowFrameNextChunkzh(P_ stack, W_ index){
P_ closurePtr, closurePtrPrime, updateePtr;
closurePtr = (StgStack_sp(stack) + WDS(index));
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -57,11 +57,6 @@ test('T21622',
only_ways(['normal']),
compile_and_run, [''])
-# TODO: Are debug flags needed here?
-test('decode_cloned_stack',
- [only_ways(['normal'])],
- compile_and_run, ['-debug -optc-g -g'])
-
# TODO: Remove debug flags
test('stack_big_ret',
[
=====================================
libraries/ghc-heap/tests/decode_cloned_stack.hs deleted
=====================================
@@ -1,13 +0,0 @@
-module Main where
-
-import GHC.Stack.CloneStack
-import GHC.Exts.DecodeStack
-import GHC.Float (minExpt)
-import System.IO (hPutStrLn, stderr)
-
-main :: IO ()
-main = do
- stack <- cloneMyStack
- res <- decodeStack stack
- hPutStrLn stderr $ "result: " ++ show res
- return ()
=====================================
libraries/ghc-heap/tests/stack_lib.c
=====================================
@@ -65,7 +65,7 @@ ClosureTypeList *foldSmallBitmapToList(StgPtr spBottom, StgPtr payload,
if ((bitmap & 1) == 0) {
const StgClosure *c = (StgClosure *)payload[i];
c = UNTAG_CONST_CLOSURE(c);
- StgInfoTable *info = get_itbl(c);
+ const StgInfoTable *info = get_itbl(c);
list = add(list, info->type);
}
// TODO: Primitives are ignored here.
@@ -87,7 +87,7 @@ ClosureTypeList *foldLargeBitmapToList(StgPtr spBottom, StgPtr payload,
j = 0;
for (; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1) {
if ((bitmap & 1) == 0) {
- StgClosure *c = (StgClosure *)payload[i];
+ const StgClosure *c = (StgClosure *)payload[i];
c = UNTAG_CONST_CLOSURE(c);
list = add(list, get_itbl(c)->type);
}
@@ -221,7 +221,7 @@ StgArrBytes *createArrayClosure(ClosureTypeList *list) {
StgWord neededWords = listSize(list);
StgArrBytes *array =
(StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + neededWords);
- SET_HDR(array, &stg_ARR_WORDS_info, CCCS);
+ SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM);
array->bytes = WDS(listSize(list));
for (int i = 0; list != NULL; i++) {
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
- UnboxedTuples #-}
+ UnboxedTuples, LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- |
@@ -94,7 +94,11 @@ run m = case m of
StartTH -> startTH
GetClosure ref -> do
clos <- Heap.getClosureData =<< localRef ref
- mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos
+ mapM (\case
+ Heap.Box x -> mkRemoteRef (HValue x)
+ -- TODO: Is this unsafeCoerce really necessary?
+ Heap.DecodedClosureBox d -> mkRemoteRef (HValue (unsafeCoerce d))
+ ) clos
Seq ref -> doSeq ref
ResumeSeq ref -> resumeSeq ref
_other -> error "GHCi.Run.run"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c836005ef313c1d7fe6d6e9216944533c6b9ba7e...97d24436e041791748bc07ca6b7f66180454e95c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c836005ef313c1d7fe6d6e9216944533c6b9ba7e...97d24436e041791748bc07ca6b7f66180454e95c
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/4eb8fd55/attachment-0001.html>
More information about the ghc-commits
mailing list