From ecdc15ea7813c43a4d84b7c6554a13c06f210a7e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 19 May 2007 22:05:26 +0000 Subject: [PATCH] Rewrite the unsafe code dealing with unboxed primitives in RtClosureInspect Closure uses now a list of Words instead of a ByteArray# to store the non ptrs. Term.Prim follows this and keeps the [Word] value instead of storing the Show representation, which wasn't the best idea anyway. This fixes test print022 --- compiler/ghci/RtClosureInspect.hs | 106 ++++++++++++++++++------------------- compiler/types/TyCon.lhs | 13 +++++ 2 files changed, 64 insertions(+), 55 deletions(-) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index f289b14..0bcc7b2 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -53,7 +53,7 @@ import TysPrim import PrelNames import TysWiredIn -import Constants ( wORD_SIZE ) +import Constants import Outputable import Maybes import Panic @@ -61,17 +61,13 @@ import FiniteMap import GHC.Arr ( Array(..) ) import GHC.Ptr ( Ptr(..), castPtr ) -import GHC.Exts -import GHC.Int ( Int32(..), Int64(..) ) -import GHC.Word ( Word32(..), Word64(..) ) +import GHC.Exts import Control.Monad import Data.Maybe import Data.Array.Base import Data.List ( partition, nub ) -import Foreign.Storable - -import IO +import Foreign --------------------------------------------- -- * A representation of semi evaluated Terms @@ -94,7 +90,7 @@ data Term = Term { ty :: Type , subTerms :: [Term] } | Prim { ty :: Type - , value :: String } + , value :: [Word] } | Suspension { ctype :: ClosureType , mb_ty :: Maybe Type @@ -138,7 +134,7 @@ data Closure = Closure { tipe :: ClosureType , infoPtr :: Ptr () , infoTable :: StgInfoTable , ptrs :: Array Int HValue - , nonPtrs :: ByteArray# + , nonPtrs :: [Word] } instance Outputable ClosureType where @@ -159,7 +155,9 @@ getClosureData a = let tipe = readCType (BCI.tipe itbl) elems = BCI.ptrs itbl ptrsList = Array 0 (fromIntegral$ elems) ptrs - ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs) + nptrs_data = [W# (indexWordArray# nptrs i) + | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ] + ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data) readCType :: Integral a => a -> ClosureType readCType i @@ -216,55 +214,25 @@ isPointed :: Type -> Bool isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t) isPointed _ = True -#define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#)) - -extractUnboxed :: [Type] -> ByteArray# -> [String] -extractUnboxed tt ba = helper tt (byteArrayContents# ba) - where helper :: [Type] -> Addr# -> [String] - helper (t:tt) addr - | Just ( tycon,_) <- splitTyConApp_maybe t - = let (offset, txt) = decode tycon addr - (I# word_offset) = offset*wORD_SIZE - in txt : helper tt (plusAddr# addr word_offset) - | otherwise - = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)] - panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t) - helper [] addr = [] - decode :: TyCon -> Addr# -> (Int, String) - decode t addr - | t == charPrimTyCon = MKDECODER(1,C#,indexCharOffAddr#) - | t == intPrimTyCon = MKDECODER(1,I#,indexIntOffAddr#) - | t == wordPrimTyCon = MKDECODER(1,W#,indexWordOffAddr#) - | t == floatPrimTyCon = MKDECODER(1,F#,indexFloatOffAddr#) - | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#) - | t == int32PrimTyCon = MKDECODER(1,I32#,indexInt32OffAddr#) - | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#) - | t == int64PrimTyCon = MKDECODER(2,I64#,indexInt64OffAddr#) - | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#) - | t == addrPrimTyCon = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off))) --OPT Improve the presentation of addresses - | t == stablePtrPrimTyCon = (1, "") - | t == stableNamePrimTyCon = (1, "") - | t == statePrimTyCon = (1, "") - | t == realWorldTyCon = (1, "") - | t == threadIdPrimTyCon = (1, "") - | t == weakPrimTyCon = (1, "") - | t == arrayPrimTyCon = (1,"") - | t == byteArrayPrimTyCon = (1,"") - | t == mutableArrayPrimTyCon = (1, "") - | t == mutableByteArrayPrimTyCon = (1, "") - | t == mutVarPrimTyCon= (1, "") - | t == mVarPrimTyCon = (1, "") - | t == tVarPrimTyCon = (1, "") - | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>')) - -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess! - -- TODO: Improve the offset handling in decode (make it machine dependant) +extractUnboxed :: [Type] -> Closure -> [[Word]] +extractUnboxed tt clos = go tt (nonPtrs clos) + where sizeofType t + | Just (tycon,_) <- splitTyConApp_maybe t + = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon + | otherwise = pprPanic "Expected a TcTyCon" (ppr t) + go [] _ = [] + go (t:tt) xx + | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx + = x : go tt rest + +sizeofTyCon = sizeofPrimRep . tyConPrimRep ----------------------------------- -- * Traversals for Terms ----------------------------------- data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a - , fPrim :: Type -> String -> a + , fPrim :: Type -> [Word] -> a , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a } @@ -319,7 +287,7 @@ pprTerm p Term{dc=dc, subTerms=tt} pprTerm _ t = pprTerm1 t -pprTerm1 Prim{value=value} = text value +pprTerm1 Prim{value=words, ty=ty} = text$ repPrim (tyConAppTyCon ty) words pprTerm1 t@Term{} = pprTerm 0 t pprTerm1 Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_' pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n} @@ -379,6 +347,34 @@ cPprTermBase pprP = getListTerms t@Suspension{} = [t] getListTerms t = pprPanic "getListTerms" (ppr t) +repPrim :: TyCon -> [Word] -> String +repPrim t = rep where + rep x + | t == charPrimTyCon = show (build x :: Char) + | t == intPrimTyCon = show (build x :: Int) + | t == wordPrimTyCon = show (build x :: Word) + | t == floatPrimTyCon = show (build x :: Float) + | t == doublePrimTyCon = show (build x :: Double) + | t == int32PrimTyCon = show (build x :: Int32) + | t == word32PrimTyCon = show (build x :: Word32) + | t == int64PrimTyCon = show (build x :: Int64) + | t == word64PrimTyCon = show (build x :: Word64) + | t == addrPrimTyCon = show (nullPtr `plusPtr` build x) + | t == stablePtrPrimTyCon = "" + | t == stableNamePrimTyCon = "" + | t == statePrimTyCon = "" + | t == realWorldTyCon = "" + | t == threadIdPrimTyCon = "" + | t == weakPrimTyCon = "" + | t == arrayPrimTyCon = "" + | t == byteArrayPrimTyCon = "" + | t == mutableArrayPrimTyCon = "" + | t == mutableByteArrayPrimTyCon = "" + | t == mutVarPrimTyCon= "" + | t == mVarPrimTyCon = "" + | t == tVarPrimTyCon = "" + | otherwise = showSDoc (char '<' <> ppr t <> char '>') + where build ww = unsafePerformIO $ withArray ww (peek . castPtr) ----------------------------------- -- Type Reconstruction ----------------------------------- @@ -530,7 +526,7 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed [ appArr (go tv t) (ptrs clos) i | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP] - let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos) + let unboxeds = extractUnboxed subTtypesNP clos subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds) subTerms = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes) return (Term tv dc a subTerms) diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 85881b6..85cbf22 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -11,6 +11,7 @@ module TyCon( PrimRep(..), tyConPrimRep, + sizeofPrimRep, AlgTyConRhs(..), visibleDataCons, TyConParent(..), @@ -76,6 +77,7 @@ import PrelNames import Maybes import Outputable import FastString +import Constants \end{code} %************************************************************************ @@ -454,6 +456,17 @@ data PrimRep | AddrRep -- a pointer, but not to a Haskell value | FloatRep | DoubleRep + +-- Size of a PrimRep, in bytes +sizeofPrimRep :: PrimRep -> Int +sizeofPrimRep IntRep = wORD_SIZE +sizeofPrimRep WordRep = wORD_SIZE +sizeofPrimRep Int64Rep = wORD64_SIZE +sizeofPrimRep Word64Rep= wORD64_SIZE +sizeofPrimRep FloatRep = 4 +sizeofPrimRep DoubleRep= 8 +sizeofPrimRep AddrRep = wORD_SIZE +sizeofPrimRep PtrRep = wORD_SIZE \end{code} %************************************************************************ -- 1.7.10.4