diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghc.cabal.in | 2 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeLink.hs | 3 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeTypes.hs | 2 | ||||
| -rw-r--r-- | compiler/ghci/DebuggerUtils.hs | 132 | ||||
| -rw-r--r-- | compiler/ghci/RtClosureInspect.hs | 259 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 9 |
6 files changed, 103 insertions, 304 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index d2137f4c69..9b96fc5a83 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -64,6 +64,7 @@ Library transformers == 0.5.*, ghc-boot == @ProjectVersionMunged@, ghc-boot-th == @ProjectVersionMunged@, + ghc-heap == @ProjectVersionMunged@, ghci == @ProjectVersionMunged@ if os(windows) @@ -643,5 +644,4 @@ Library Debugger Linker RtClosureInspect - DebuggerUtils GHCi diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs index bea431185c..e7eb7108f9 100644 --- a/compiler/ghci/ByteCodeLink.hs +++ b/compiler/ghci/ByteCodeLink.hs @@ -23,7 +23,6 @@ import GhcPrelude import GHCi.RemoteTypes import GHCi.ResolvedBCO -import GHCi.InfoTable import GHCi.BreakArray import SizedSeq @@ -99,7 +98,7 @@ lookupStaticPtr hsc_env addr_of_label_string = do lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ()) lookupIE hsc_env ie con_nm = case lookupNameEnv ie con_nm of - Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a))) + Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info" m <- lookupSymbol hsc_env sym_to_find1 diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs index ecb9d2212f..628b576ca0 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -27,7 +27,6 @@ import SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes import GHCi.FFI -import GHCi.InfoTable import Control.DeepSeq import Foreign @@ -36,6 +35,7 @@ import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import GHC.Exts.Heap import GHC.Stack.CCS -- ----------------------------------------------------------------------------- diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs deleted file mode 100644 index 9af98c1bcf..0000000000 --- a/compiler/ghci/DebuggerUtils.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE CPP #-} - -module DebuggerUtils ( - dataConInfoPtrToName, - ) where - -import GhcPrelude - -import GHCi.InfoTable -import CmmInfo ( stdInfoTableSizeB ) -import DynFlags -import HscTypes -import FastString -import IfaceEnv -import Module -import OccName -import Name -import Outputable -import Util - -import Data.Char -import Foreign -import Data.List - -#include "HsVersions.h" - --- | Given a data constructor in the heap, find its Name. --- The info tables for data constructors have a field which records --- the source name of the constructor as a Ptr Word8 (UTF-8 encoded --- string). The format is: --- --- > Package:Module.Name --- --- We use this string to lookup the interpreter's internal representation of the name --- using the lookupOrig. --- -dataConInfoPtrToName :: HscEnv -> Ptr () -> IO Name -dataConInfoPtrToName hsc_env x = do - let dflags = hsc_dflags hsc_env - theString <- do - let ptr = castPtr x :: Ptr StgInfoTable - conDescAddress <- getConDescAddress dflags ptr - peekArray0 0 conDescAddress - let (pkg, mod, occ) = parse theString - pkgFS = mkFastStringByteList pkg - modFS = mkFastStringByteList mod - occFS = mkFastStringByteList occ - occName = mkOccNameFS OccName.dataName occFS - modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS) - lookupOrigIO hsc_env modName occName - - where - - {- To find the string in the constructor's info table we need to consider - the layout of info tables relative to the entry code for a closure. - - An info table can be next to the entry code for the closure, or it can - be separate. The former (faster) is used in registerised versions of ghc, - and the latter (portable) is for non-registerised versions. - - The diagrams below show where the string is to be found relative to - the normal info table of the closure. - - 1) Code next to table: - - -------------- - | | <- pointer to the start of the string - -------------- - | | <- the (start of the) info table structure - | | - | | - -------------- - | entry code | - | .... | - - In this case the pointer to the start of the string can be found in - the memory location _one word before_ the first entry in the normal info - table. - - 2) Code NOT next to table: - - -------------- - info table structure -> | *------------------> -------------- - | | | entry code | - | | | .... | - -------------- - ptr to start of str -> | | - -------------- - - In this case the pointer to the start of the string can be found - in the memory location: info_table_ptr + info_table_size - -} - - getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8) - getConDescAddress dflags ptr - | ghciTablesNextToCode = do - let ptr' = ptr `plusPtr` (- wORD_SIZE dflags) - -- NB. the offset must be read as an Int32 not a Word32, so - -- that the sign is preserved when converting to an Int. - offsetToString <- fromIntegral <$> (peek ptr' :: IO Int32) - return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString - | otherwise = - peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) - -- parsing names is a little bit fiddly because we have a string in the form: - -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). - -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. - -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas - -- this is not the conventional way of writing Haskell names. We stick with - -- convention, even though it makes the parsing code more troublesome. - -- Warning: this code assumes that the string is well formed. - parse :: [Word8] -> ([Word8], [Word8], [Word8]) - parse input - = ASSERT(all (`lengthExceeds` 0) ([pkg, mod, occ])) (pkg, mod, occ) - where - dot = fromIntegral (ord '.') - (pkg, rest1) = break (== fromIntegral (ord ':')) input - (mod, occ) - = (concat $ intersperse [dot] $ reverse modWords, occWord) - where - (modWords, occWord) = ASSERT(rest1 `lengthExceeds` 0) (parseModOcc [] (tail rest1)) - parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) - -- We only look for dots if str could start with a module name, - -- i.e. if it starts with an upper case character. - -- Otherwise we might think that "X.:->" is the module name in - -- "X.:->.+", whereas actually "X" is the module name and - -- ":->.+" is a constructor name. - parseModOcc acc str@(c : _) - | isUpper $ chr $ fromIntegral c - = case break (== dot) str of - (top, []) -> (acc, top) - (top, _ : bot) -> parseModOcc (top : acc) bot - parseModOcc acc str = (acc, str) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index d7e1267d97..025efe8cb2 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -21,17 +21,14 @@ module RtClosureInspect( -- unsafeDeepSeq, - Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection + constrClosToName, isConstr, isIndirection ) where #include "HsVersions.h" import GhcPrelude -import DebuggerUtils -import GHCi.RemoteTypes ( HValue ) -import qualified GHCi.InfoTable as InfoTable -import GHCi.InfoTable (StgInfoTable, peekItbl) +import GHCi.RemoteTypes import HscTypes import DataCon @@ -48,6 +45,9 @@ import TcEnv import TyCon import Name +import OccName +import Module +import IfaceEnv import Util import VarSet import BasicTypes ( Boxity(..) ) @@ -56,16 +56,14 @@ import PrelNames import TysWiredIn import DynFlags import Outputable as Ppr -import GHC.Arr ( Array(..) ) import GHC.Char import GHC.Exts +import GHC.Exts.Heap import GHC.IO ( IO(..) ) import SMRep ( roundUpTo ) import Control.Monad import Data.Maybe -import Data.Array.Base -import Data.Ix import Data.List import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..)) @@ -86,7 +84,7 @@ data Term = Term { ty :: RttiType , subTerms :: [Term] } | Prim { ty :: RttiType - , value :: [Word] } + , valRaw :: [Word] } | Suspension { ctype :: ClosureType , ty :: RttiType @@ -114,7 +112,13 @@ isPrim _ = False isNewtypeWrap NewtypeWrap{} = True isNewtypeWrap _ = False -isFun Suspension{ctype=Fun} = True +isFun Suspension{ctype=FUN} = True +isFun Suspension{ctype=FUN_1_0} = True +isFun Suspension{ctype=FUN_0_1} = True +isFun Suspension{ctype=FUN_2_0} = True +isFun Suspension{ctype=FUN_1_1} = True +isFun Suspension{ctype=FUN_0_2} = True +isFun Suspension{ctype=FUN_STATIC} = True isFun _ = False isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty @@ -134,101 +138,30 @@ instance Outputable (Term) where ppr t | Just doc <- cPprTerm cPprTermBase t = doc | otherwise = panic "Outputable Term instance" -------------------------------------------------------------------------- --- Runtime Closure Datatype and functions for retrieving closure related stuff -------------------------------------------------------------------------- -data ClosureType = Constr - | Fun - | Thunk Int - | ThunkSelector - | Blackhole - | AP - | PAP - | Indirection Int - | MutVar Int - | MVar Int - | Other Int - deriving (Show, Eq) - -data ClosureNonPtrs = ClosureNonPtrs ByteArray# - -data Closure = Closure { tipe :: ClosureType - , infoPtr :: Ptr () - , infoTable :: StgInfoTable - , ptrs :: Array Int HValue - , nonPtrs :: ClosureNonPtrs - } +---------------------------------------- +-- Runtime Closure information functions +---------------------------------------- -instance Outputable ClosureType where - ppr = text . show - -#include "../includes/rts/storage/ClosureTypes.h" - -aP_CODE, pAP_CODE :: Int -aP_CODE = AP -pAP_CODE = PAP -#undef AP -#undef PAP - -getClosureData :: DynFlags -> a -> IO Closure -getClosureData dflags a = - case unpackClosure# a of - (# iptr, ptrs, nptrs #) -> do - let iptr0 = Ptr iptr - let iptr1 - | ghciTablesNextToCode = iptr0 - | otherwise = - -- the info pointer we get back from unpackClosure# - -- is to the beginning of the standard info table, - -- but the Storable instance for info tables takes - -- into account the extra entry pointer when - -- !ghciTablesNextToCode, so we must adjust here: - iptr0 `plusPtr` negate (wORD_SIZE dflags) - itbl <- peekItbl iptr1 - let tipe = readCType (InfoTable.tipe itbl) - elems = fromIntegral (InfoTable.ptrs itbl) - ptrsList = Array 0 (elems - 1) elems ptrs - nptrs_data = ClosureNonPtrs nptrs - ASSERT(elems >= 0) return () - ptrsList `seq` - return (Closure tipe iptr0 itbl ptrsList nptrs_data) - -readCType :: Integral a => a -> ClosureType -readCType i - | i >= CONSTR && i <= CONSTR_NOCAF = Constr - | i >= FUN && i <= FUN_STATIC = Fun - | i >= THUNK && i < THUNK_SELECTOR = Thunk i' - | i == THUNK_SELECTOR = ThunkSelector - | i == BLACKHOLE = Blackhole - | i >= IND && i <= IND_STATIC = Indirection i' - | i' == aP_CODE = AP - | i == AP_STACK = AP - | i' == pAP_CODE = PAP - | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i' - | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i' - | otherwise = Other i' - where i' = fromIntegral i - -isConstr, isIndirection, isThunk :: ClosureType -> Bool -isConstr Constr = True +isConstr, isIndirection, isThunk :: GenClosure a -> Bool +isConstr ConstrClosure{} = True isConstr _ = False -isIndirection (Indirection _) = True +isIndirection IndClosure{} = True isIndirection _ = False -isThunk (Thunk _) = True -isThunk ThunkSelector = True -isThunk AP = True +isThunk ThunkClosure{} = True +isThunk APClosure{} = True +isThunk APStackClosure{} = True isThunk _ = False -isFullyEvaluated :: DynFlags -> a -> IO Bool -isFullyEvaluated dflags a = do - closure <- getClosureData dflags a - case tipe closure of - Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure) - return$ and are_subs_evaluated - _ -> return False - where amapM f = sequence . amap' f +isFullyEvaluated :: a -> IO Bool +isFullyEvaluated a = do + closure <- getClosureData a + if isConstr closure + then do are_subs_evaluated <- amapM isFullyEvaluated (ptrArgs closure) + return$ and are_subs_evaluated + else return False + where amapM f = sequence . map (\(Box x) -> f x) -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it {- @@ -243,6 +176,15 @@ unsafeDeepSeq = unsafeDeepSeq1 2 where tipe = unsafePerformIO (getClosureType a) -} +-- Lookup the name in a constructor closure +constrClosToName :: HscEnv -> Closure -> IO (Either String Name) +constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do + let occName = mkOccName OccName.dataName occ + modName = mkModule (stringToUnitId pkg) (mkModuleName mod) + Right `fmap` lookupOrigIO hsc_env modName occName +constrClosToName _hsc_env clos = + return (Left ("conClosToName: Expected ConstrClosure, got " ++ show clos)) + ----------------------------------- -- * Traversals for Terms ----------------------------------- @@ -374,7 +316,7 @@ ppr_termM _ _ t = ppr_termM1 t ppr_termM1 :: Monad m => Term -> m SDoc -ppr_termM1 Prim{value=words, ty=ty} = +ppr_termM1 Prim{valRaw=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = return (char '_' <+> whenPprDebug (text "::" <> ppr ty)) @@ -696,8 +638,6 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do text "Type obtained: " <> ppr (termType term)) return term where - dflags = hsc_dflags hsc_env - go :: Int -> Type -> Type -> HValue -> TcM Term -- I believe that my_ty should not have any enclosing -- foralls, nor any free RuntimeUnk skolems; @@ -708,27 +648,30 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do go 0 my_ty _old_ty a = do traceTR (text "Gave up reconstructing a term after" <> int max_depth <> text " steps") - clos <- trIO $ getClosureData dflags a - return (Suspension (tipe clos) my_ty a Nothing) + clos <- trIO $ getClosureData a + return (Suspension (tipe (info clos)) my_ty a Nothing) go !max_depth my_ty old_ty a = do let monomorphic = not(isTyVarTy my_ty) -- This ^^^ is a convention. The ancestor tests for -- monomorphism and passes a type instead of a tv - clos <- trIO $ getClosureData dflags a - case tipe clos of + clos <- trIO $ getClosureData a + case clos of -- Thunks we may want to force t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >> seq a (go (pred max_depth) my_ty old_ty a) -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up -- showing '_' which is what we want. - Blackhole -> do traceTR (text "Following a BLACKHOLE") - appArr (go max_depth my_ty old_ty) (ptrs clos) 0 + BlackholeClosure{indirectee=ind} -> do + traceTR (text "Following a BLACKHOLE") + (\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind -- We always follow indirections - Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) ) - go max_depth my_ty old_ty $! (ptrs clos ! 0) + IndClosure{indirectee=ind} -> do + traceTR (text "Following an indirection" ) + (\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind -- We also follow references - MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty + MutVarClosure{} + | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty -> do -- Deal with the MutVar# primitive -- It does not have a constructor at all, @@ -745,13 +688,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do return (RefWrap my_ty x) -- The interesting case - Constr -> do + ConstrClosure{ptrArgs=pArgs} -> do traceTR (text "entering a constructor " <> if monomorphic then parens (text "already monomorphic: " <> ppr my_ty) else Ppr.empty) - dcname <- liftIO $ dataConInfoPtrToName hsc_env (infoPtr clos) - (_,mb_dc) <- tryTc (tcLookupDataCon dcname) + Right dcname <- liftIO $ constrClosToName hsc_env clos + (_,mb_dc) <- tryTc (tcLookupDataCon dcname) case mb_dc of Nothing -> do -- This can happen for private constructors compiled -O0 -- where the .hi descriptor does not export them @@ -761,10 +704,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do traceTR (text "Not constructor" <+> ppr dcname) let dflags = hsc_dflags hsc_env tag = showPpr dflags dcname - vars <- replicateM (length$ elems$ ptrs clos) + vars <- replicateM (length pArgs) (newVar liftedTypeKind) - subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i - | (i, tv) <- zip [0..] vars] + subTerms <- sequence $ zipWith (\(Box x) tv -> + go (pred max_depth) tv tv (HValue x)) pArgs vars return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) Just dc -> do traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) @@ -773,9 +716,9 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do return (Term my_ty (Right dc) a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. - tipe_clos -> do - traceTR (text "Unknown closure:" <+> ppr tipe_clos) - return (Suspension tipe_clos my_ty a Nothing) + _ -> do + traceTR (text "Unknown closure:" <+> text (show clos)) + return (Suspension (tipe (info clos)) my_ty a Nothing) -- insert NewtypeWraps around newtypes expandNewtypes = foldTerm idTermFold { fTerm = worker } where @@ -798,7 +741,7 @@ extractSubTerms :: (Type -> HValue -> TcM Term) -> Closure -> [Type] -> TcM [Term] extractSubTerms recurse clos = liftM thdOf3 . go 0 0 where - !(ClosureNonPtrs array) = nonPtrs clos + array = dataArgs clos go ptr_i arr_i [] = return (ptr_i, arr_i, []) go ptr_i arr_i (ty:tys) @@ -829,7 +772,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 go_rep ptr_i arr_i ty rep | isGcPtrRep rep = do - t <- appArr (recurse ty) (ptrs clos) ptr_i + t <- (\(Box x) -> recurse ty (HValue x)) $ (ptrArgs clos)!!ptr_i return (ptr_i + 1, arr_i, t) | otherwise = do -- This is a bit involved since we allow packing multiple fields @@ -841,29 +784,34 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 -- Fields are always aligned. !aligned_idx = roundUpTo arr_i size_b !new_arr_i = aligned_idx + size_b - ws - | size_b < word_size = [index size_b array aligned_idx] - | otherwise = - let (q, r) = size_b `quotRem` word_size - in ASSERT( r == 0 ) - [ W# (indexWordArray# array i) - | o <- [0.. q - 1] - , let !(I# i) = (aligned_idx + o) `quot` word_size - ] + ws | size_b < word_size = + [index size_b array aligned_idx word_size] + | otherwise = + let (q, r) = size_b `quotRem` word_size + in ASSERT( r == 0 ) + [ array!!i + | o <- [0.. q - 1] + , let i = (aligned_idx `quot` word_size) + o + ] return (ptr_i, new_arr_i, Prim ty ws) unboxedTupleTerm ty terms = Term ty (Right (tupleDataCon Unboxed (length terms))) (error "unboxedTupleTerm: no HValue for unboxed tuple") terms - index item_size_b array (I# index_b) = - case item_size_b of - -- indexWord*Array# functions take offsets dependent not in bytes, - -- but in multiples of an element's size. - 1 -> W# (indexWord8Array# array index_b) - 2 -> W# (indexWord16Array# array (index_b `quotInt#` 2#)) - 4 -> W# (indexWord32Array# array (index_b `quotInt#` 4#)) - _ -> panic ("Weird byte-index: " ++ show (I# index_b)) + -- Extract a sub-word sized field from a word + index item_size_b array index_b word_size = + (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes + where + mask :: Word + mask = case item_size_b of + 1 -> 0xFF + 2 -> 0xFFFF + 4 -> 0xFFFFFFFF + _ -> panic ("Weird byte-index: " ++ show index_b) + (q,r) = index_b `quotRem` word_size + word = array!!q + moveBytes = r * 8 -- Fast, breadth-first Type reconstruction @@ -896,8 +844,6 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) return new_ty where - dflags = hsc_dflags hsc_env - -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> int max_depth <> text " steps") @@ -912,32 +858,31 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do go :: Type -> HValue -> TR [(Type, HValue)] go my_ty a = do traceTR (text "go" <+> ppr my_ty) - clos <- trIO $ getClosureData dflags a - case tipe clos of - Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO - Indirection _ -> go my_ty $! (ptrs clos ! 0) - MutVar _ -> do + clos <- trIO $ getClosureData a + case clos of + BlackholeClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind + IndClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind + MutVarClosure{} -> do contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w tv' <- newVar liftedTypeKind world <- newVar liftedTypeKind addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) return [(tv', contents)] - Constr -> do - dcname <- liftIO $ dataConInfoPtrToName hsc_env (infoPtr clos) + ConstrClosure{ptrArgs=pArgs} -> do + Right dcname <- liftIO $ constrClosToName hsc_env clos traceTR (text "Constr1" <+> ppr dcname) (_,mb_dc) <- tryTc (tcLookupDataCon dcname) case mb_dc of Nothing-> do - forM (elems $ ptrs clos) $ \a -> do + forM pArgs $ \(Box x) -> do tv <- newVar liftedTypeKind - return (tv, a) + return (tv, HValue x) Just dc -> do arg_tys <- getDataConArgTys dc my_ty (_, itys) <- findPtrTyss 0 arg_tys traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) - return $ [ appArr (\e-> (ty,e)) (ptrs clos) i - | (i,ty) <- itys] + return $ zipWith (\(_,ty) (Box x) -> (ty, HValue x)) itys pArgs _ -> return [] findPtrTys :: Int -- Current pointer index @@ -1303,15 +1248,3 @@ quantifyType ty = ( filter isTyVar $ , rho) where (_tvs, rho) = tcSplitForAllTys ty - --- Strict application of f at index i -appArr :: Ix i => (e -> a) -> Array i e -> Int -> a -appArr f a@(Array _ _ _ ptrs#) i@(I# i#) - = ASSERT2(i < length(elems a), ppr(length$ elems a, i)) - case indexArray# ptrs# i# of - (# e #) -> f e - -amap' :: (t -> b) -> Array Int t -> [b] -amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] - where g (I# i#) = case indexArray# arr# i# of - (# e #) -> f e diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 763a2ca37d..9165c6f4f9 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -3024,12 +3024,11 @@ primop NewBCOOp "newBCO#" GenPrimOp out_of_line = True primop UnpackClosureOp "unpackClosure#" GenPrimOp - a -> (# Addr#, Array# b, ByteArray# #) - { {\tt unpackClosure\# closure} copies non-pointers and pointers in the + a -> (# Addr#, ByteArray#, Array# b #) + { {\tt unpackClosure\# closure} copies the closure and pointers in the payload of the given closure into two new arrays, and returns a pointer to - the first word of the closure's info table, a pointer array for the - pointers in the payload, and a non-pointer array for the non-pointers in - the payload. } + the first word of the closure's info table, a non-pointer array for the raw + bytes of the closure, and a pointer array for the pointers in the payload. } with out_of_line = True |