From c67b7aa4a0441e65746b4ed7fc97c32a16bff6ea Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Tue, 13 Mar 2012 08:33:09 +0000 Subject: [PATCH] Make package -Wall safe --- ghc-heap-view.cabal | 1 + src/GHC/HeapView.hs | 76 ++++++++++++++++++--------------------------- 2 files changed, 32 insertions(+), 45 deletions(-) diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal index de05a64..1bce7b7 100644 --- a/ghc-heap-view.cabal +++ b/ghc-heap-view.cabal @@ -32,6 +32,7 @@ Library ghc-prim C-Sources: cbits/HeapView.c cbits/HeapViewPrim.cmm Hs-source-dirs: src/ + Ghc-options: -Wall if flag(prim-supports-any) cpp-options: -DPRIM_SUPPORTS_ANY diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs index f788ef6..a60899d 100644 --- a/src/GHC/HeapView.hs +++ b/src/GHC/HeapView.hs @@ -27,26 +27,14 @@ module GHC.HeapView ( ) where -import System.IO.Unsafe import GHC.Exts -import GHC.Prim -import System.Environment -import GHC.Arr ((!), Array(..), elems) +import GHC.Arr (Array(..)) import GHC.Constants ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS ) -import System.Mem -import System.Mem.StableName import Foreign -import Foreign.C -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Array import Numeric ( showHex ) -import Data.Word -import Data.Bits import Data.Char -import Control.Monad -- | An arbitrarily Haskell value in a safe Box. The point is that even -- unevaluated thunks can safely be moved around inside the Box, and when @@ -58,11 +46,11 @@ type HalfWord = Word32 instance Show Box where -- From libraries/base/GHC/Ptr.lhs - showsPrec _ (Box any) rs = - -- unsafePerformIO (print "↓" >> pClosure any) `seq` + showsPrec _ (Box a) rs = + -- unsafePerformIO (print "↓" >> pClosure a) `seq` pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs where - ptr = W# (aToWord# any) + ptr = W# (aToWord# a) tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) addr = ptr - tag -- want 0s prefixed to pad it out to a fixed length. @@ -116,7 +104,7 @@ instance Storable StgInfoTable where alignment _ = wORD_SIZE - poke a0 itbl + poke _a0 _itbl = error "Storable StgInfoTable is read-only" peek a0 @@ -152,10 +140,6 @@ sizeOfPointee :: (Storable a) => Ptr a -> Int sizeOfPointee addr = sizeOf (typeHack addr) where typeHack = undefined :: Ptr a -> a -store :: Storable a => a -> PtrIO () -store x = do addr <- advance - lift (poke addr x) - {- Embedded StateT, also from ByteCodeItbls -} @@ -167,6 +151,7 @@ instance Monad m => Monad (State s m) where State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s') fail str = State (\_ -> fail str) +lift :: Monad m => m a -> State s m a lift m = State (\s -> m >>= \a -> return (s, a)) runState :: (Monad m) => s -> State s m a -> m a @@ -295,7 +280,7 @@ data Closure = ArrWordsClosure { info :: StgInfoTable , bytes :: Word - , words :: [Word] + , arrWords :: [Word] } | MutArrClosure { info :: StgInfoTable @@ -319,7 +304,7 @@ data Closure = OtherClosure { info :: StgInfoTable , hvalues :: [Box] - , words :: [Word] + , rawWords :: [Word] } deriving (Show) @@ -335,6 +320,7 @@ allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs] allPtrs (ArrWordsClosure {..}) = [] allPtrs (MutArrClosure {..}) = mccPayload allPtrs (FunClosure {..}) = ptrArgs +allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue] allPtrs (OtherClosure {..}) = hvalues @@ -373,10 +359,10 @@ getClosureRaw x = case slurpClosure# (unsafeCoerce# x) of (# iptr, dat, ptrs #) -> do let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE - words = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ] + rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ] pelems = I# (sizeofArray# ptrs) ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs - ptrList `seq` words `seq` return (Ptr iptr, words, ptrList) + ptrList `seq` rawWords `seq` return (Ptr iptr, rawWords, ptrList) -- From compiler/ghci/RtClosureInspect.hs amap' :: (t -> b) -> Array Int t -> [b] @@ -393,10 +379,10 @@ dataConInfoPtrToNames ptr = do return $ fmap (chr . fromIntegral) wl where getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) - getConDescAddress ptr + getConDescAddress ptr' | True = do - offsetToString <- peek (ptr `plusPtr` (negate wORD_SIZE)) - return $ (ptr `plusPtr` stdInfoTableSizeB) + offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE)) + return $ (ptr' `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: Word)) -- This is code for !ghciTablesNextToCode: {- @@ -430,29 +416,29 @@ dataConInfoPtrToNames ptr = do -- 'asBox' apply. getClosureData :: a -> IO Closure getClosureData x = do - (iptr, words, ptrs) <- getClosureRaw x + (iptr, wds, ptrs) <- getClosureRaw x itbl <- peek iptr case tipe itbl of t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do name <- dataConInfoPtrToNames iptr - return $ ConsClosure itbl ptrs (drop (length ptrs + 1) words) name + return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) name t | t >= THUNK && t <= THUNK_STATIC -> do - return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) words) + return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds) t | t >= FUN && t <= FUN_STATIC -> do - return $ FunClosure itbl ptrs (drop (length ptrs + 1) words) + return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds) AP -> return $ APClosure itbl - (fromIntegral $ words !! 2) - (fromIntegral $ shiftR (words !! 2) (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral $ wds !! 2) + (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2)) (head ptrs) (tail ptrs) PAP -> return $ PAPClosure itbl - (fromIntegral $ words !! 2) - (fromIntegral $ shiftR (words !! 2) (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral $ wds !! 2) + (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2)) (head ptrs) (tail ptrs) THUNK_SELECTOR -> @@ -467,24 +453,24 @@ getClosureData x = do BCO -> return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) - (fromIntegral $ words !! 4) - (fromIntegral $ shiftR (words !! 4) (wORD_SIZE_IN_BITS `div` 2)) - (words !! 5) + (fromIntegral $ wds !! 4) + (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2)) + (wds !! 5) ARR_WORDS -> - return $ ArrWordsClosure itbl (words !! 1) (drop 2 words) + return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds) MUT_ARR_PTRS_FROZEN -> - return $ MutArrClosure itbl (words !! 2) (words !! 3) ptrs + return $ MutArrClosure itbl (wds !! 2) (wds !! 3) ptrs BLOCKING_QUEUE -> - return $ OtherClosure itbl ptrs words + return $ OtherClosure itbl ptrs wds -- return $ BlockingQueueClosure itbl -- (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3) - -- return $ OtherClosure itbl ptrs words - x -> error $ "getClosureData: Cannot handle closure type " ++ show x + -- return $ OtherClosure itbl ptrs wds + closure -> error $ "getClosureData: Cannot handle closure type " ++ show closure -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with. getBoxedClosureData :: Box -> IO Closure -getBoxedClosureData b@(Box a) = getClosureData a +getBoxedClosureData (Box a) = getClosureData a -- 2.20.1