[Git][ghc/ghc][wip/fix-hadrian-ticky] 9 commits: rts/linker: Fix relocation overflow in PE linker
Ben Gamari
gitlab at gitlab.haskell.org
Wed Nov 11 21:43:42 UTC 2020
Ben Gamari pushed to branch wip/fix-hadrian-ticky at Glasgow Haskell Compiler / GHC
Commits:
d445cf05 by Ben Gamari at 2020-11-10T10:26:20-05:00
rts/linker: Fix relocation overflow in PE linker
Previously the overflow check for the IMAGE_REL_AMD64_ADDR32NB
relocation failed to account for the signed nature of the value.
Specifically, the overflow check was:
uint64_t v;
v = S + A;
if (v >> 32) { ... }
However, `v` ultimately needs to fit into 32-bits as a signed value.
Consequently, values `v > 2^31` in fact overflow yet this is not caught
by the existing overflow check.
Here we rewrite the overflow check to rather ensure that
`INT32_MIN <= v <= INT32_MAX`. There is now quite a bit of repetition
between the `IMAGE_REL_AMD64_REL32` and `IMAGE_REL_AMD64_ADDR32` cases
but I am leaving fixing this for future work.
This bug was first noticed by @awson.
Fixes #15808.
- - - - -
4c407f6e by Sylvain Henry at 2020-11-10T10:27:00-05:00
Export SPEC from GHC.Exts (#13681)
- - - - -
7814cd5b by David Eichmann at 2020-11-10T10:27:35-05:00
ghc-heap: expose decoding from heap representation
Co-authored-by: Sven Tennie <sven.tennie at gmail.com>
Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com>
Co-authored-by: Ben Gamari <bgamari.foss at gmail.com>
- - - - -
fa344d33 by Richard Eisenberg at 2020-11-10T10:28:10-05:00
Add test case for #17186.
This got fixed sometime recently; not worth it trying to
figure out which commit.
- - - - -
2e63a0fb by David Eichmann at 2020-11-10T10:28:46-05:00
Add code comments for StgInfoTable and StgStack structs
- - - - -
31fe9a73 by Ben Gamari at 2020-11-11T16:43:04-05:00
hadrian: Dump STG when ticky is enabled
This changes the "ticky" modifier to enable dumping of final STG as this
is generally needed to make sense of the ticky profiles.
- - - - -
c34f9e5a by Ben Gamari at 2020-11-11T16:43:04-05:00
hadrian: Introduce notion of flavour transformers
This extends Hadrian's notion of "flavour", as described in #18942.
- - - - -
20af5712 by Ben Gamari at 2020-11-11T16:43:35-05:00
hadrian: Add a viaLlvmBackend modifier
Note that this also slightly changes the semantics of these flavours as
we only use LLVM for >= stage1 builds.
- - - - -
759fb39e by Ben Gamari at 2020-11-11T16:43:35-05:00
hadrian: Add profiled_ghc and no_dynamic_ghc modifiers
- - - - -
12 changed files:
- hadrian/src/Flavour.hs
- hadrian/src/Settings.hs
- hadrian/src/Settings/Flavours/Llvm.hs
- includes/rts/storage/Closures.h
- includes/rts/storage/Heap.h
- includes/rts/storage/TSO.h
- libraries/base/GHC/Exts.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- rts/Heap.c
- rts/linker/PEi386.c
- + testsuite/tests/typecheck/should_compile/T17186.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -1,17 +1,28 @@
module Flavour
( Flavour (..), werror
, DocTargets, DocTarget(..)
+ , parseFlavour
-- * Flavour transformers
+ , flavourTransformers
, addArgs
, splitSections, splitSectionsIf
, enableThreadSanitizer
, enableDebugInfo, enableTickyGhc
+ , viaLlvmBackend
+ , enableProfiledGhc
+ , disableDynamicGhcPrograms
) where
import Expression
import Data.Set (Set)
+import Data.Map (Map)
+import qualified Data.Map as M
import Packages
+import Text.Parsec.Prim as P
+import Text.Parsec.Combinator as P
+import Text.Parsec.Char as P
+
-- Please update doc/{flavours.md, user-settings.md} when changing this file.
-- | 'Flavour' is a collection of build settings that fully define a GHC build.
-- Note the following type semantics:
@@ -69,6 +80,49 @@ type DocTargets = Set DocTarget
data DocTarget = Haddocks | SphinxHTML | SphinxPDFs | SphinxMan | SphinxInfo
deriving (Eq, Ord, Show, Bounded, Enum)
+flavourTransformers :: Map String (Flavour -> Flavour)
+flavourTransformers = M.fromList
+ [ "werror" =: werror
+ , "debug_info" =: enableDebugInfo
+ , "ticky_ghc" =: enableTickyGhc
+ , "split_sections" =: splitSections
+ , "thread_sanitizer" =: enableThreadSanitizer
+ , "llvm" =: viaLlvmBackend
+ , "profiled_ghc" =: enableProfiledGhc
+ , "no_dynamic_ghc" =: disableDynamicGhcPrograms
+ ]
+ where (=:) = (,)
+
+type Parser = Parsec String ()
+
+parseFlavour :: [Flavour] -- ^ base flavours
+ -> Map String (Flavour -> Flavour) -- ^ modifiers
+ -> String
+ -> Either String Flavour
+parseFlavour baseFlavours transformers str =
+ case P.runParser parser () "" str of
+ Left perr -> Left $ "error parsing flavour specifier: " ++ show perr
+ Right f -> Right f
+ where
+ parser :: Parser Flavour
+ parser = do
+ base <- baseFlavour
+ transs <- P.many flavourTrans
+ return $ foldr ($) base transs
+
+ baseFlavour :: Parser Flavour
+ baseFlavour =
+ P.choice [ f <$ P.string (name f)
+ | f <- baseFlavours
+ ]
+
+ flavourTrans :: Parser (Flavour -> Flavour)
+ flavourTrans = do
+ void $ P.char '+'
+ P.choice [ trans <$ P.string nm
+ | (nm, trans) <- M.toList transformers
+ ]
+
-- | Add arguments to the 'args' of a 'Flavour'.
addArgs :: Args -> Flavour -> Flavour
addArgs args' fl = fl { args = args fl <> args' }
@@ -94,7 +148,13 @@ enableTickyGhc =
[ builder (Ghc CompileHs) ? ticky
, builder (Ghc LinkHs) ? ticky
]
- ticky = arg "-ticky" <> arg "-ticky-allocd"
+ ticky = mconcat
+ [ arg "-ticky"
+ , arg "-ticky-allocd"
+ -- You generally need STG dumps to interpret ticky profiles
+ , arg "-ddump-to-file"
+ , arg "-ddump-stg-final"
+ ]
-- | Transform the input 'Flavour' so as to build with
-- @-split-sections@ whenever appropriate. You can
@@ -126,3 +186,17 @@ enableThreadSanitizer = addArgs $ mconcat
, builder (Cabal Flags) ? arg "thread-sanitizer"
, builder RunTest ? arg "--config=have_thread_sanitizer=True"
]
+
+-- | Use the LLVM backend in stages 1 and later.
+viaLlvmBackend :: Flavour -> Flavour
+viaLlvmBackend = addArgs $ notStage0 ? builder Ghc ? arg "-fllvm"
+
+-- | Build the GHC executable with profiling enabled. It is also recommended
+-- that you use this with @'dynamicGhcPrograms' = False@ since GHC does not
+-- support loading of profiled libraries with the dynamically-linker.
+enableProfiledGhc :: Flavour -> Flavour
+enableProfiledGhc flavour = flavour { ghcProfiled = True }
+
+-- | Disable 'dynamicGhcPrograms'.
+disableDynamicGhcPrograms :: Flavour -> Flavour
+disableDynamicGhcPrograms flavour = flavour { dynamicGhcPrograms = pure False }
=====================================
hadrian/src/Settings.hs
=====================================
@@ -75,11 +75,9 @@ flavour = do
let flavours = hadrianFlavours ++ userFlavours
(_settingErrs, tweak) = applySettings kvs
- return $
- case filter (\fl -> name fl == flavourName) flavours of
- [] -> error $ "Unknown build flavour: " ++ flavourName
- [f] -> tweak f
- _ -> error $ "Multiple build flavours named " ++ flavourName
+ case parseFlavour flavours flavourTransformers flavourName of
+ Left err -> fail err
+ Right f -> return $ tweak f
-- TODO: switch to Set Package as the order of packages should not matter?
-- Otherwise we have to keep remembering to sort packages from time to time.
=====================================
hadrian/src/Settings/Flavours/Llvm.hs
=====================================
@@ -5,7 +5,6 @@ module Settings.Flavours.Llvm (
quickLlvmFlavour,
) where
-import Expression
import Flavour
import Settings.Flavours.Benchmark
@@ -22,8 +21,5 @@ quickLlvmFlavour = mkLlvmFlavour quickFlavour
-- | Turn a flavour into an LLVM flavour
mkLlvmFlavour :: Flavour -> Flavour
-mkLlvmFlavour flav = flav
- { name = name flav ++ "-llvm"
- , args = mconcat [ args flav
- , builder Ghc ? arg "-fllvm" ]
- }
+mkLlvmFlavour flav = viaLlvmBackend $ flav
+ { name = name flav ++ "-llvm" }
=====================================
includes/rts/storage/Closures.h
=====================================
@@ -63,6 +63,11 @@ typedef struct {
-------------------------------------------------------------------------- */
typedef struct {
+ // If TABLES_NEXT_TO_CODE is defined, then `info` is offset by
+ // `sizeof(StgInfoTable)` and so points to the `code` field of the
+ // StgInfoTable! You may want to use `get_itbl` to get the pointer to the
+ // start of the info table. See
+ // https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/storage/heap-objects#tables_next_to_code.
const StgInfoTable* info;
#if defined(PROFILING)
StgProfHeader prof;
=====================================
includes/rts/storage/Heap.h
=====================================
@@ -16,3 +16,12 @@ void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
, StgClosure *fun, StgClosure **payload, StgWord size);
StgWord heap_view_closureSize(StgClosure *closure);
+
+/*
+ * Collect the pointers of a closure into the given array. `size` should be
+ * large enough to hold all collected pointers e.g.
+ * `heap_view_closureSize(closure)`. Returns the number of pointers collected.
+ * The caller must ensure that `closure` is not modified (or moved by the GC)
+ * for the duration of the call to `collect_pointers`.
+ */
+StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *ptrs[]);
=====================================
includes/rts/storage/TSO.h
=====================================
@@ -242,10 +242,22 @@ typedef struct StgTSO_ {
typedef struct StgStack_ {
StgHeader header;
- StgWord32 stack_size; // stack size in *words*
+
+ /* Size of the `stack` field in *words*. This is not affected by how much of
+ * the stack space is used, nor if more stack space is linked to by an
+ * UNDERFLOW_FRAME.
+ */
+ StgWord32 stack_size;
+
StgWord8 dirty; // non-zero => dirty
StgWord8 marking; // non-zero => someone is currently marking the stack
- StgPtr sp; // current stack pointer
+
+ /* Pointer to the "top" of the stack i.e. the most recently written address.
+ * The stack is filled downwards, so the "top" of the stack starts with `sp
+ * = stack + stack_size` and is decremented as the stack fills with data.
+ * See comment on "Invariants" below.
+ */
+ StgPtr sp;
StgWord stack[];
} StgStack;
=====================================
libraries/base/GHC/Exts.hs
=====================================
@@ -72,7 +72,7 @@ module GHC.Exts
breakpoint, breakpointCond,
-- * Ids with special behaviour
- inline, noinline, lazy, oneShot,
+ inline, noinline, lazy, oneShot, SPEC (..),
-- * Running 'RealWorld' state thread
runRW#,
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -7,6 +7,9 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnliftedFFITypes #-}
{-|
Module : GHC.Exts.Heap
@@ -25,6 +28,7 @@ module GHC.Exts.Heap (
, ClosureType(..)
, PrimType(..)
, HasHeapRep(getClosureData)
+ , getClosureDataFromHeapRep
-- * Info Table types
, StgInfoTable(..)
@@ -58,7 +62,7 @@ import GHC.Exts.Heap.Utils
import Control.Monad
import Data.Bits
-import GHC.Arr
+import Foreign
import GHC.Exts
import GHC.Int
import GHC.Word
@@ -66,13 +70,19 @@ import GHC.Word
#include "ghcconfig.h"
class HasHeapRep (a :: TYPE rep) where
- getClosureData :: a -> IO Closure
+
+ -- | Decode a closure to it's heap representation ('GenClosure').
+ getClosureData
+ :: a
+ -- ^ Closure to decode.
+ -> IO Closure
+ -- ^ Heap representation of the closure.
instance HasHeapRep (a :: TYPE 'LiftedRep) where
- getClosureData = getClosure
+ getClosureData = getClosureDataFromHeapObject
instance HasHeapRep (a :: TYPE 'UnliftedRep) where
- getClosureData x = getClosure (unsafeCoerce# x)
+ getClosureData x = getClosureDataFromHeapObject (unsafeCoerce# x)
instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
getClosureData x = return $
@@ -102,49 +112,84 @@ instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
getClosureData x = return $
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
--- | This returns the raw representation of the given argument. The second
--- component of the triple is the raw words of the closure on the heap, and the
--- third component is those words that are actually pointers. Once back in the
--- Haskell world, the raw words that hold pointers may be outdated after a
--- garbage collector run, but the corresponding values in 'Box's will still
--- point to the correct value.
-getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
-getClosureRaw x = do
+-- | Get the heap representation of a closure _at this moment_, even if it is
+-- unevaluated or an indirection or other exotic stuff. Beware when passing
+-- something to this function, the same caveats as for
+-- 'GHC.Exts.Heap.Closures.asBox' apply.
+--
+-- For most use cases 'getClosureData' is an easier to use alternative.
+--
+-- Currently TSO and STACK objects will return `UnsupportedClosure`. This is
+-- because it is not memory safe to extract TSO and STACK objects (done via
+-- `unpackClosure#`). Other threads may be mutating those objects and interleave
+-- with reads in `unpackClosure#`. This is particularly problematic with STACKs
+-- where pointer values may be overwritten by non-pointer values as the
+-- corresponding haskell thread runs.
+getClosureDataFromHeapObject
+ :: a
+ -- ^ Heap object to decode.
+ -> IO Closure
+ -- ^ Heap representation of the closure.
+getClosureDataFromHeapObject x = do
case unpackClosure# x of
--- This is a hack to cover the bootstrap compiler using the old version of
--- 'unpackClosure'. The new 'unpackClosure' return values are not merely
--- a reordering, so using the old version would not work.
- (# iptr, dat, pointers #) -> do
- let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
- end = fromIntegral nelems - 1
- rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
- pelems = I# (sizeofArray# pointers)
- ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers
- pure (Ptr iptr, rawWds, ptrList)
-
--- From GHC.Runtime.Heap.Inspect
-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
-
--- | This function returns a parsed heap representation of the argument _at
--- this moment_, even if it is unevaluated or an indirection or other exotic
--- stuff. Beware when passing something to this function, the same caveats as
--- for 'asBox' apply.
-getClosure :: a -> IO Closure
-getClosure x = do
- (iptr, wds, pts) <- getClosureRaw x
- itbl <- peekItbl iptr
- -- The remaining words after the header
- let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
- -- For data args in a pointers then non-pointers closure
- -- This is incorrect in non pointers-first setups
- -- not sure if that happens
- npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds
+#if MIN_VERSION_ghc_prim(0,5,3)
+ (# infoTableAddr, heapRep, pointersArray #) -> do
+#else
+ -- This is a hack to cover the bootstrap compiler using the old version
+ -- of 'unpackClosure'. The new 'unpackClosure' return values are not
+ -- merely a reordering, so using the old version would not work.
+ (# infoTableAddr, pointersArray, heapRep #) -> do
+#endif
+ let infoTablePtr = Ptr infoTableAddr
+ ptrList = [case indexArray# pointersArray i of
+ (# ptr #) -> Box ptr
+ | I# i <- [0..(I# (sizeofArray# pointersArray)) - 1]
+ ]
+
+ infoTable <- peekItbl infoTablePtr
+ case tipe infoTable of
+ TSO -> pure $ UnsupportedClosure infoTable
+ STACK -> pure $ UnsupportedClosure infoTable
+ _ -> getClosureDataFromHeapRep heapRep infoTablePtr ptrList
+
+-- | Convert an unpacked heap object, to a `GenClosure b`. The inputs to this
+-- function can be generated from a heap object using `unpackClosure#`.
+getClosureDataFromHeapRep
+ :: ByteArray#
+ -- ^ Heap representation of the closure as returned by `unpackClosure#`.
+ -- This includes all of the object including the header, info table
+ -- pointer, pointer data, and non-pointer data. The ByteArray# may be
+ -- pinned or unpinned.
+ -> Ptr StgInfoTable
+ -- ^ Pointer to the `StgInfoTable` of the closure, extracted from the heap
+ -- representation. The info table must not be movable by GC i.e. must be in
+ -- pinned or off-heap memory.
+ -> [b]
+ -- ^ Pointers in the payload of the closure, extracted from the heap
+ -- representation as returned by `collect_pointers()` in `Heap.c`. The type
+ -- `b` is some representation of a pointer e.g. `Any` or `Ptr Any`.
+ -> IO (GenClosure b)
+ -- ^ Heap representation of the closure.
+getClosureDataFromHeapRep heapRep infoTablePtr pts = do
+ itbl <- peekItbl infoTablePtr
+ let -- heapRep as a list of words.
+ rawHeapWords :: [Word]
+ rawHeapWords = [W# (indexWordArray# heapRep i) | I# i <- [0.. end] ]
+ where
+ nelems = (I# (sizeofByteArray# heapRep)) `div` wORD_SIZE
+ end = fromIntegral nelems - 1
+
+ -- Just the payload of rawHeapWords (no header).
+ payloadWords :: [Word]
+ payloadWords = drop (closureTypeHeaderSize (tipe itbl)) rawHeapWords
+
+ -- The non-pointer words in the payload. Only valid for closures with a
+ -- "pointers first" layout. Not valid for bit field layout.
+ npts :: [Word]
+ npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) rawHeapWords
case tipe itbl of
t | t >= CONSTR && t <= CONSTR_NOCAF -> do
- (p, m, n) <- dataConNames iptr
+ (p, m, n) <- dataConNames infoTablePtr
if m == "GHC.ByteCode.Instr" && n == "BreakInfo"
then pure $ UnsupportedClosure itbl
else pure $ ConstrClosure itbl pts npts p m n
@@ -164,9 +209,9 @@ getClosure x = do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to AP"
-- We expect at least the arity, n_args, and fun fields
- unless (length rawWds >= 2) $
+ unless (length payloadWords >= 2) $
fail $ "Expected at least 2 raw words to AP"
- let splitWord = rawWds !! 0
+ let splitWord = payloadWords !! 0
pure $ APClosure itbl
#if defined(WORDS_BIGENDIAN)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
@@ -181,9 +226,9 @@ getClosure x = do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to PAP"
-- We expect at least the arity, n_args, and fun fields
- unless (length rawWds >= 2) $
+ unless (length payloadWords >= 2) $
fail "Expected at least 2 raw words to PAP"
- let splitWord = rawWds !! 0
+ let splitWord = payloadWords !! 0
pure $ PAPClosure itbl
#if defined(WORDS_BIGENDIAN)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
@@ -218,10 +263,10 @@ getClosure x = do
unless (length pts >= 3) $
fail $ "Expected at least 3 ptr argument to BCO, found "
++ show (length pts)
- unless (length rawWds >= 4) $
+ unless (length payloadWords >= 4) $
fail $ "Expected at least 4 words to BCO, found "
- ++ show (length rawWds)
- let splitWord = rawWds !! 3
+ ++ show (length payloadWords)
+ let splitWord = payloadWords !! 3
pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
#if defined(WORDS_BIGENDIAN)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
@@ -230,27 +275,30 @@ getClosure x = do
(fromIntegral splitWord)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
- (drop 4 rawWds)
+ (drop 4 payloadWords)
ARR_WORDS -> do
- unless (length rawWds >= 1) $
+ unless (length payloadWords >= 1) $
fail $ "Expected at least 1 words to ARR_WORDS, found "
- ++ show (length rawWds)
- pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds)
+ ++ show (length payloadWords)
+ pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords)
t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
- unless (length rawWds >= 2) $
+ unless (length payloadWords >= 2) $
fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
- ++ "found " ++ show (length rawWds)
- pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts
+ ++ "found " ++ show (length payloadWords)
+ pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts
t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
- unless (length rawWds >= 1) $
+ unless (length payloadWords >= 1) $
fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
- ++ "found " ++ show (length rawWds)
- pure $ SmallMutArrClosure itbl (rawWds !! 0) pts
+ ++ "found " ++ show (length payloadWords)
+ pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts
- t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
+ t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
+ unless (length pts >= 1) $
+ fail $ "Expected at least 1 words to MUT_VAR, found "
+ ++ show (length pts)
pure $ MutVarClosure itbl (head pts)
t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
@@ -260,13 +308,12 @@ getClosure x = do
pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
BLOCKING_QUEUE ->
- pure $ OtherClosure itbl pts wds
+ pure $ OtherClosure itbl pts rawHeapWords
-- pure $ BlockingQueueClosure itbl
-- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)
- -- pure $ OtherClosure itbl pts wds
+ -- pure $ OtherClosure itbl pts rawHeapWords
--
-
WEAK ->
pure $ WeakClosure
{ info = itbl
=====================================
rts/Heap.c
=====================================
@@ -76,23 +76,12 @@ void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
}
}
-StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
-
- StgWord size = heap_view_closureSize(closure);
- StgWord nptrs = 0;
- StgWord i;
-
- // First collect all pointers here, with the comfortable memory bound
- // of the whole closure. Afterwards we know how many pointers are in
- // the closure and then we can allocate space on the heap and copy them
- // there
- StgClosure *ptrs[size];
-
+// See Heap.h
+StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *ptrs[size]) {
StgClosure **end;
- StgClosure **ptr;
-
const StgInfoTable *info = get_itbl(closure);
+ StgWord nptrs = 0;
+ StgWord i;
switch (info->type) {
case INVALID_OBJECT:
@@ -101,6 +90,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
// No pointers
case ARR_WORDS:
+ case STACK:
break;
// Default layout
@@ -123,7 +113,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
case FUN_0_2:
case FUN_STATIC:
end = closure->payload + info->layout.payload.ptrs;
- for (ptr = closure->payload; ptr < end; ptr++) {
+ for (StgClosure **ptr = closure->payload; ptr < end; ptr++) {
ptrs[nptrs++] = *ptr;
}
break;
@@ -136,7 +126,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
case THUNK_0_2:
case THUNK_STATIC:
end = ((StgThunk *)closure)->payload + info->layout.payload.ptrs;
- for (ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) {
+ for (StgClosure **ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) {
ptrs[nptrs++] = *ptr;
}
break;
@@ -228,6 +218,21 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
break;
}
+ return nptrs;
+}
+
+StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+
+ StgWord size = heap_view_closureSize(closure);
+
+ // First collect all pointers here, with the comfortable memory bound
+ // of the whole closure. Afterwards we know how many pointers are in
+ // the closure and then we can allocate space on the heap and copy them
+ // there
+ StgClosure *ptrs[size];
+ StgWord nptrs = collect_pointers(closure, size, ptrs);
+
size = nptrs + mutArrPtrsCardTableSize(nptrs);
StgMutArrPtrs *arr =
(StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
@@ -236,7 +241,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
arr->ptrs = nptrs;
arr->size = size;
- for (i = 0; i<nptrs; i++) {
+ for (StgWord i = 0; i<nptrs; i++) {
arr->payload[i] = ptrs[i];
}
=====================================
rts/linker/PEi386.c
=====================================
@@ -1952,13 +1952,15 @@ ocResolve_PEi386 ( ObjectCode* oc )
{
uint64_t v;
v = S + A;
- if (v >> 32) {
+ // N.B. in the case of the sign-extended relocations we must ensure that v
+ // fits in a signed 32-bit value. See #15808.
+ if (((int64_t) v > (int64_t) INT32_MAX) || ((int64_t) v < (int64_t) INT32_MIN)) {
copyName (getSymShortName (info, sym), oc,
symbol, sizeof(symbol)-1);
S = makeSymbolExtra_PEi386(oc, symIndex, S, (char *)symbol);
/* And retry */
v = S + A;
- if (v >> 32) {
+ if (((int64_t) v > (int64_t) INT32_MAX) || ((int64_t) v < (int64_t) INT32_MIN)) {
barf("IMAGE_REL_AMD64_ADDR32[NB]: High bits are set in %zx for %s",
v, (char *)symbol);
}
@@ -1970,14 +1972,14 @@ ocResolve_PEi386 ( ObjectCode* oc )
{
intptr_t v;
v = S + (int32_t)A - ((intptr_t)pP) - 4;
- if ((v > (intptr_t) INT32_MAX) || (v < (intptr_t) INT32_MIN)) {
+ if ((v > (int64_t) INT32_MAX) || (v < (int64_t) INT32_MIN)) {
/* Make the trampoline then */
copyName (getSymShortName (info, sym),
oc, symbol, sizeof(symbol)-1);
S = makeSymbolExtra_PEi386(oc, symIndex, S, (char *)symbol);
/* And retry */
v = S + (int32_t)A - ((intptr_t)pP) - 4;
- if ((v > (intptr_t) INT32_MAX) || (v < (intptr_t) INT32_MIN)) {
+ if ((v > (int64_t) INT32_MAX) || (v < (int64_t) INT32_MIN)) {
barf("IMAGE_REL_AMD64_REL32: High bits are set in %zx for %s",
v, (char *)symbol);
}
=====================================
testsuite/tests/typecheck/should_compile/T17186.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeOperators, AllowAmbiguousTypes #-}
+
+module T17186 where
+
+-- This test is significantly abbreviated from what was posted; see
+-- #16512 for more context.
+
+type family Dim v
+
+type family v `OfDim` (n :: Dim v) = r | r -> n
+
+(!*^) :: Dim m `OfDim` j -> Dim m `OfDim` i
+(!*^) = undefined
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -728,4 +728,4 @@ test('T18831', normal, compile, [''])
test('T18920', normal, compile, [''])
test('T15942', normal, compile, [''])
test('ClassDefaultInHsBoot', [extra_files(['ClassDefaultInHsBootA1.hs','ClassDefaultInHsBootA2.hs','ClassDefaultInHsBootA2.hs-boot','ClassDefaultInHsBootA3.hs'])], multimod_compile, ['ClassDefaultInHsBoot', '-v0'])
-
+test('T17186', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea6693a58c02f6d9c3aab795c100bb154c251681...759fb39e012e38903817f8bb860ef3f5ab623b66
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea6693a58c02f6d9c3aab795c100bb154c251681...759fb39e012e38903817f8bb860ef3f5ab623b66
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/20201111/53e2ccdb/attachment-0001.html>
More information about the ghc-commits
mailing list