[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: compiler: Fingerprint more code generation flags
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Jul 11 18:12:31 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
d1c92bf3 by Ben Gamari at 2023-07-11T08:07:02-04:00
compiler: Fingerprint more code generation flags
Previously our recompilation check was quite inconsistent in its
coverage of non-optimisation code generation flags. Specifically, we
failed to account for most flags that would affect the behavior of
generated code in ways that might affect the result of a program's
execution (e.g. `-feager-blackholing`, `-fstrict-dicts`)
Closes #23369.
- - - - -
eb623149 by Ben Gamari at 2023-07-11T08:07:02-04:00
compiler: Record original thunk info tables on stack
Here we introduce a new code generation option, `-forig-thunk-info`,
which ensures that an `stg_orig_thunk_info` frame is pushed before every
update frame. This can be invaluable when debugging thunk cycles and
similar.
See Note [Original thunk info table frames] for details.
Closes #23255.
- - - - -
4731f44e by Jaro Reinders at 2023-07-11T08:07:40-04:00
Fix wrong MIN_VERSION_GLASGOW_HASKELL macros
I forgot to change these after rebasing.
- - - - -
c3f23d76 by Matthew Pickering at 2023-07-11T14:12:11-04:00
Remove references to make build system in mk/build.mk
Fixes #23636
- - - - -
056f909e by sheaf at 2023-07-11T14:12:18-04:00
Valid hole fits: don't panic on a Given
The function GHC.Tc.Errors.validHoleFits would end up panicking when
encountering a Given constraint. To fix this, it suffices to filter out
the Givens before continuing.
Fixes #22684
- - - - -
23 changed files:
- .gitlab/ci.sh
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Driver/Config/StgToCmm.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Config.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/cbits/genSym.c
- docs/users_guide/debugging.rst
- rts/RtsSymbols.c
- rts/StgMiscClosures.cmm
- rts/include/rts/storage/Closures.h
- rts/include/stg/MiscClosures.h
- + testsuite/tests/codeGen/should_run/OrigThunkInfo.hs
- + testsuite/tests/codeGen/should_run/OrigThunkInfo.stdout
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/typecheck/should_fail/T22684.hs
- + testsuite/tests/typecheck/should_fail/T22684.stderr
- testsuite/tests/typecheck/should_fail/all.T
- utils/deriveConstants/Main.hs
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -75,16 +75,6 @@ Environment variables affecting both build systems:
(either "x86-64-darwin" or "aarch-darwin")
NO_BOOT Whether to run ./boot or not, used when testing the source dist
-Environment variables determining build configuration of Make system:
-
- BUILD_FLAVOUR Which flavour to build.
- BUILD_SPHINX_HTML Whether to build Sphinx HTML documentation.
- BUILD_SPHINX_PDF Whether to build Sphinx PDF documentation.
- INTEGER_LIBRARY Which integer library to use (integer-simple or integer-gmp).
- HADDOCK_HYPERLINKED_SOURCES
- Whether to build hyperlinked Haddock sources.
- TEST_TYPE Which test rule to run.
-
Environment variables determining build configuration of Hadrian system:
BUILD_FLAVOUR Which flavour to build.
@@ -390,26 +380,6 @@ function cleanup_submodules() {
end_section "clean submodules"
}
-function prepare_build_mk() {
- if [[ -z "$BUILD_FLAVOUR" ]]; then fail "BUILD_FLAVOUR is not set"; fi
- if [[ -z ${BUILD_SPHINX_HTML:-} ]]; then BUILD_SPHINX_HTML=YES; fi
- if [[ -z ${BUILD_SPHINX_PDF:-} ]]; then BUILD_SPHINX_PDF=YES; fi
-
- cat > mk/build.mk <<EOF
-BIGNUM_BACKEND=${BIGNUM_BACKEND}
-include mk/flavours/${BUILD_FLAVOUR}.mk
-GhcLibHcOpts+=-haddock
-EOF
-
- if [ -n "${HADDOCK_HYPERLINKED_SOURCES:-}" ]; then
- echo "EXTRA_HADDOCK_OPTS += --hyperlinked-source --quickjump" >> mk/build.mk
- fi
-
-
- info "build.mk is:"
- cat mk/build.mk
-}
-
function configure() {
case "${CONFIGURE_WRAPPER:-}" in
emconfigure) source "$EMSDK/emsdk_env.sh" ;;
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -53,6 +53,7 @@ module GHC.Cmm.CLabel (
mkDirty_MUT_VAR_Label,
mkMUT_VAR_CLEAN_infoLabel,
mkNonmovingWriteBarrierEnabledLabel,
+ mkOrigThunkInfoLabel,
mkUpdInfoLabel,
mkBHUpdInfoLabel,
mkIndStaticInfoLabel,
@@ -641,7 +642,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
-- Constructing Cmm Labels
mkDirty_MUT_VAR_Label,
mkNonmovingWriteBarrierEnabledLabel,
- mkUpdInfoLabel,
+ mkOrigThunkInfoLabel, mkUpdInfoLabel,
mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
mkMAP_DIRTY_infoLabel,
@@ -655,6 +656,7 @@ mkDirty_MUT_VAR_Label,
mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
mkNonmovingWriteBarrierEnabledLabel
= CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
+mkOrigThunkInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo
mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo
mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo
mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo
=====================================
compiler/GHC/Driver/Config/StgToCmm.hs
=====================================
@@ -41,6 +41,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
, stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags
, stgToCmmSCCProfiling = sccProfilingEnabled dflags
, stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags
+ , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo dflags
, stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags
, stgToCmmOmitYields = gopt Opt_OmitYields dflags
, stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -5,6 +5,7 @@ module GHC.Driver.Flags
, GeneralFlag(..)
, Language(..)
, optimisationFlags
+ , codeGenFlags
-- * Warnings
, WarningGroup(..)
@@ -337,6 +338,7 @@ data GeneralFlag
| Opt_IgnoreHpcChanges
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
+ | Opt_OrigThunkInfo
| Opt_NoHsMain
| Opt_SplitSections
| Opt_StgStats
@@ -484,15 +486,11 @@ data GeneralFlag
| Opt_G_NoOptCoercion
deriving (Eq, Show, Enum)
--- Check whether a flag should be considered an "optimisation flag"
--- for purposes of recompilation avoidance (see
--- Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags). Being listed here is
--- not a guarantee that the flag has no other effect. We could, and
--- perhaps should, separate out the flags that have some minor impact on
--- program semantics and/or error behavior (e.g., assertions), but
--- then we'd need to go to extra trouble (and an additional flag)
--- to allow users to ignore the optimisation level even though that
--- means ignoring some change.
+-- | The set of flags which affect optimisation for the purposes of
+-- recompilation avoidance. Specifically, these include flags which
+-- affect code generation but not the semantics of the program.
+--
+-- See Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags)
optimisationFlags :: EnumSet GeneralFlag
optimisationFlags = EnumSet.fromList
[ Opt_CallArity
@@ -524,16 +522,12 @@ optimisationFlags = EnumSet.fromList
, Opt_EnableRewriteRules
, Opt_RegsGraph
, Opt_RegsIterative
- , Opt_PedanticBottoms
, Opt_LlvmTBAA
- , Opt_LlvmFillUndefWithGarbage
, Opt_IrrefutableTuples
, Opt_CmmSink
, Opt_CmmElimCommonBlocks
, Opt_AsmShortcutting
- , Opt_OmitYields
, Opt_FunToThunk
- , Opt_DictsStrict
, Opt_DmdTxDictSel
, Opt_Loopification
, Opt_CfgBlocklayout
@@ -542,8 +536,48 @@ optimisationFlags = EnumSet.fromList
, Opt_WorkerWrapper
, Opt_WorkerWrapperUnlift
, Opt_SolveConstantDicts
+ ]
+
+-- | The set of flags which affect code generation and can change a program's
+-- runtime behavior (other than performance). These include flags which affect:
+--
+-- * user visible debugging information (e.g. info table provenance)
+-- * the ability to catch runtime errors (e.g. -fignore-asserts)
+-- * the runtime result of the program (e.g. -fomit-yields)
+-- * which code or interface file declarations are emitted
+--
+-- We also considered placing flags which affect asympototic space behavior
+-- (e.g. -ffull-laziness) however this would mean that changing optimisation
+-- levels would trigger recompilation even with -fignore-optim-changes,
+-- regressing #13604.
+--
+-- Also, arguably Opt_IgnoreAsserts should be here as well; however, we place
+-- it instead in 'optimisationFlags' since it is implied by @-O[12]@ and
+-- therefore would also break #13604.
+--
+-- See #23369.
+codeGenFlags :: EnumSet GeneralFlag
+codeGenFlags = EnumSet.fromList
+ [ -- Flags that affect runtime result
+ Opt_EagerBlackHoling
+ , Opt_ExcessPrecision
+ , Opt_DictsStrict
+ , Opt_PedanticBottoms
+ , Opt_OmitYields
+
+ -- Flags that affect generated code
+ , Opt_ExposeAllUnfoldings
+ , Opt_NoTypeableBinds
+
+ -- Flags that affect catching of runtime errors
, Opt_CatchNonexhaustiveCases
- , Opt_IgnoreAsserts
+ , Opt_LlvmFillUndefWithGarbage
+ , Opt_DoTagInferenceChecks
+
+ -- Flags that affect debugging information
+ , Opt_DistinctConstructorTables
+ , Opt_InfoTableMap
+ , Opt_OrigThunkInfo
]
data WarningFlag =
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -66,6 +66,7 @@ module GHC.Driver.Session (
makeDynFlagsConsistent,
positionIndependent,
optimisationFlags,
+ codeGenFlags,
setFlagsFromEnvFile,
pprDynFlagsDiff,
flagSpecOf,
@@ -2346,6 +2347,7 @@ fFlagsDeps = [
flagSpec "do-eta-reduction" Opt_DoEtaReduction,
flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion,
flagSpec "eager-blackholing" Opt_EagerBlackHoling,
+ flagSpec "orig-thunk-info" Opt_OrigThunkInfo,
flagSpec "embed-manifest" Opt_EmbedManifest,
flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules,
flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings,
=====================================
compiler/GHC/Iface/Recomp/Flags.hs
=====================================
@@ -67,7 +67,10 @@ fingerprintDynFlags hsc_env this_mod nameio =
ticky =
map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]
- flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters))
+ -- Other flags which affect code generation
+ codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags)
+
+ flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters))
in -- pprTrace "flags" (ppr flags) $
computeFingerprint nameio flags
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -730,7 +730,8 @@ setupUpdate closure_info node body
lbl | bh = mkBHUpdInfoLabel
| otherwise = mkUpdInfoLabel
- pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
+ pushOrigThunkInfoFrame closure_info
+ $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
| otherwise -- A static closure
= do { tickyUpdateBhCaf closure_info
@@ -738,7 +739,8 @@ setupUpdate closure_info node body
; if closureUpdReqd closure_info
then do -- Blackhole the (updatable) CAF:
{ upd_closure <- link_caf node
- ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
+ ; pushOrigThunkInfoFrame closure_info
+ $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
else do {tickyUpdateFrameOmitted; body}
}
@@ -754,8 +756,7 @@ pushUpdateFrame lbl updatee body
= do
updfr <- getUpdFrameOff
profile <- getProfile
- let
- hdr = fixedHdrSize profile
+ let hdr = fixedHdrSize profile
frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile)
--
emitUpdateFrame (CmmStackSlot Old frame) lbl updatee
@@ -773,6 +774,47 @@ emitUpdateFrame frame lbl updatee = do
emitStore (cmmOffset platform frame off_updatee) updatee
initUpdFrameProf frame
+-----------------------------------------------------------------------------
+-- Original thunk info table frames
+--
+-- Note [Original thunk info table frames]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very
+-- useful to know which thunks the program is in the process of evaluating.
+-- However, in the case of updateable thunks this can be very difficult
+-- to determine since the process of blackholing overwrites the thunk's
+-- info table pointer.
+--
+-- To help in such situations we provide the -forig-thunk-info flag. This enables
+-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to
+-- accompany each update frame. As the name suggests, this frame captures the
+-- the original info table of the thunk being updated. The entry code for these
+-- frames has no operational effects; the frames merely exist as breadcrumbs
+-- for debugging.
+
+pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode ()
+pushOrigThunkInfoFrame closure_info body = do
+ cfg <- getStgToCmmConfig
+ if stgToCmmOrigThunkInfo cfg
+ then do_it
+ else body
+ where
+ orig_itbl = mkLblExpr (closureInfoLabel closure_info)
+ do_it = do
+ updfr <- getUpdFrameOff
+ profile <- getProfile
+ let platform = profilePlatform profile
+ hdr = fixedHdrSize profile
+ orig_info_frame_sz =
+ hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile)
+ off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (profileConstants profile)
+ frame_off = updfr + orig_info_frame_sz
+ frame = CmmStackSlot Old frame_off
+ --
+ emitStore frame (mkLblExpr mkOrigThunkInfoLabel)
+ emitStore (cmmOffset platform frame off_orig_info) orig_itbl
+ withUpdFrameOff frame_off body
+
-----------------------------------------------------------------------------
-- Entering a CAF
--
=====================================
compiler/GHC/StgToCmm/Config.hs
=====================================
@@ -50,6 +50,7 @@ data StgToCmmConfig = StgToCmmConfig
, stgToCmmFastPAPCalls :: !Bool -- ^
, stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled
, stgToCmmEagerBlackHole :: !Bool -- ^
+ , stgToCmmOrigThunkInfo :: !Bool -- ^ Push @stg_orig_thunk_info@ frames during thunk update.
, stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See note [Mapping
-- Info Tables to Source Positions]
, stgToCmmOmitYields :: !Bool -- ^ true means omit heap checks when no allocation is performed
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -1563,16 +1563,19 @@ validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the
-- the valid hole fits.
validHoleFits ctxt@(CEC { cec_encl = implics
, cec_tidy = lcl_env}) simps hole
- = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole
+ = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (mapMaybe mk_wanted simps) hole
; return (ctxt {cec_tidy = tidy_env}, fits) }
where
- mk_wanted :: ErrorItem -> CtEvidence
- mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })
- = CtWanted { ctev_pred = pred
- , ctev_dest = dest
- , ctev_loc = loc
- , ctev_rewriters = emptyRewriterSet }
- mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item)
+ mk_wanted :: ErrorItem -> Maybe CtEvidence
+ mk_wanted (EI { ei_pred = pred, ei_evdest = m_dest, ei_loc = loc })
+ | Just dest <- m_dest
+ = Just (CtWanted { ctev_pred = pred
+ , ctev_dest = dest
+ , ctev_loc = loc
+ , ctev_rewriters = emptyRewriterSet })
+ | otherwise
+ = Nothing -- The ErrorItem was a Given
+
-- See Note [Constraints include ...]
givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)]
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -4867,7 +4867,9 @@ data ErrorItem
= EI { ei_pred :: PredType -- report about this
-- The ei_pred field will never be an unboxed equality with
-- a (casted) tyvar on the right; this is guaranteed by the solver
- , ei_evdest :: Maybe TcEvDest -- for Wanteds, where to put evidence
+ , ei_evdest :: Maybe TcEvDest
+ -- ^ for Wanteds, where to put the evidence
+ -- for Givens, Nothing
, ei_flavour :: CtFlavour
, ei_loc :: CtLoc
, ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a
=====================================
compiler/cbits/genSym.c
=====================================
@@ -9,7 +9,7 @@
//
// The CPP is thus about the RTS version GHC is linked against, and not the
// version of the GHC being built.
-#if !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0)
+#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
HsWord64 ghc_unique_counter64 = 0;
#endif
#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
@@ -18,7 +18,7 @@ HsInt ghc_unique_inc = 1;
// This function has been added to the RTS. Here we pessimistically assume
// that a threaded RTS is used. This function is only used for bootstrapping.
-#if !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0)
+#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
EXTERN_INLINE StgWord64
atomic_inc64(StgWord64 volatile* p, StgWord64 incr)
{
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -1115,6 +1115,18 @@ Checking for consistency
cases. This is helpful when debugging demand analysis or type checker bugs
which can sometimes manifest as segmentation faults.
+.. ghc-flag:: -forig-thunk-info
+ :shortdesc: Generate ``stg_orig_thunk_info`` stack frames on thunk entry
+ :type: dynamic
+
+ When debugging cyclic thunks it can be helpful to know the original
+ info table of a thunk being evaluated. This flag enables code generation logic
+ to facilitate this, producing a ``stg_orig_thunk_info`` stack frame alongside
+ the usual update frame; such ``orig_thunk`` frames have no operational
+ effect but capture the original info table of the updated thunk for inspection
+ by debugging tools. See ``Note [Original thunk info table frames]`` in
+ ``GHC.StgToCmm.Bind`` for details.
+
.. ghc-flag:: -fcheck-prim-bounds
:shortdesc: Instrument array primops with bounds checks.
:type: dynamic
=====================================
rts/RtsSymbols.c
=====================================
@@ -870,7 +870,8 @@ extern char **environ;
SymI_HasDataProto(stg_unpack_cstring_utf8_info) \
SymI_HasDataProto(stg_upd_frame_info) \
SymI_HasDataProto(stg_bh_upd_frame_info) \
- SymI_HasProto(suspendThread) \
+ SymI_HasDataProto(stg_orig_thunk_info_frame_info) \
+ SymI_HasProto(suspendThread) \
SymI_HasDataProto(stg_takeMVarzh) \
SymI_HasDataProto(stg_readMVarzh) \
SymI_HasDataProto(stg_threadStatuszh) \
@@ -878,7 +879,7 @@ extern char **environ;
SymI_HasDataProto(stg_tryTakeMVarzh) \
SymI_HasDataProto(stg_tryReadMVarzh) \
SymI_HasDataProto(stg_unmaskAsyncExceptionszh) \
- SymI_HasProto(unloadObj) \
+ SymI_HasProto(unloadObj) \
SymI_HasDataProto(stg_unsafeThawArrayzh) \
SymI_HasDataProto(stg_waitReadzh) \
SymI_HasDataProto(stg_waitWritezh) \
@@ -892,7 +893,7 @@ extern char **environ;
SymI_NeedsProto(stg_interp_constr5_entry) \
SymI_NeedsProto(stg_interp_constr6_entry) \
SymI_NeedsProto(stg_interp_constr7_entry) \
- SymI_HasDataProto(stg_arg_bitmaps) \
+ SymI_HasDataProto(stg_arg_bitmaps) \
SymI_HasProto(large_alloc_lim) \
SymI_HasProto(g0) \
SymI_HasProto(allocate) \
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -45,6 +45,17 @@ import CLOSURE stg_ret_t_info;
import CLOSURE stg_ret_v_info;
#endif
+/* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */
+INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL,
+ W_ info_ptr,
+ W_ thunk_info_ptr)
+ /* no args => explicit stack */
+{
+ unwind Sp = W_[Sp + WDS(2)];
+ Sp_adj(2);
+ jump %ENTRY_CODE(Sp(0)) [*]; // NB. all registers live!
+}
+
/* ----------------------------------------------------------------------------
Stack underflow
------------------------------------------------------------------------- */
=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -261,6 +261,13 @@ typedef struct _StgUpdateFrame {
StgClosure *updatee;
} StgUpdateFrame;
+// Thunk update frame
+//
+// Closure types: RET_SMALL
+typedef struct _StgOrigThunkInfoFrame {
+ StgHeader header;
+ StgInfoTable *info_ptr;
+} StgOrigThunkInfoFrame;
// Closure types: RET_SMALL
typedef struct {
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -52,6 +52,7 @@ RTS_RET(stg_upd_frame);
RTS_RET(stg_bh_upd_frame);
RTS_RET(stg_marked_upd_frame);
RTS_RET(stg_noupd_frame);
+RTS_RET(stg_orig_thunk_info_frame);
RTS_RET(stg_catch_frame);
RTS_RET(stg_catch_retry_frame);
RTS_RET(stg_atomically_frame);
=====================================
testsuite/tests/codeGen/should_run/OrigThunkInfo.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+xs = iterate (+1) 0
+ten = xs !! 10
+main = print ten
=====================================
testsuite/tests/codeGen/should_run/OrigThunkInfo.stdout
=====================================
@@ -0,0 +1,2 @@
+10
+
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -225,3 +225,4 @@ test('T22296',[only_ways(llvm_ways)
,unless(arch('x86_64'), skip)],compile_and_run,[''])
test('T22798', normal, compile_and_run, ['-fregs-graph'])
test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds'])
+test('OrigThunkInfo', normal, compile_and_run, ['-forig-thunk-info'])
=====================================
testsuite/tests/typecheck/should_fail/T22684.hs
=====================================
@@ -0,0 +1,19 @@
+module T22684 where
+
+-- Example 1 from #22684
+p :: (Int ~ Bool => r) -> r
+p _ = undefined
+
+q :: r
+q = p _
+
+-- Example 3 from #22684
+class Category k where
+ (.) :: k b c -> k a b -> k a c
+
+data Free p a b where
+ Prod :: Free p a (b, c)
+ Sum :: Free p (Either a b) c
+
+instance Category (Free p) where
+ Sum . Prod = _
=====================================
testsuite/tests/typecheck/should_fail/T22684.stderr
=====================================
@@ -0,0 +1,35 @@
+
+T22684.hs:8:7: error: [GHC-88464]
+ • Found hole: _ :: r
+ Where: ‘r’ is a rigid type variable bound by
+ the type signature for:
+ q :: forall r. r
+ at T22684.hs:7:1-6
+ • In the first argument of ‘p’, namely ‘_’
+ In the expression: p _
+ In an equation for ‘q’: q = p _
+ • Relevant bindings include q :: r (bound at T22684.hs:8:1)
+ Constraints include Int ~ Bool (from T22684.hs:8:7)
+ Valid hole fits include q :: r (bound at T22684.hs:8:1)
+
+T22684.hs:19:16: error: [GHC-88464]
+ • Found hole: _ :: Free p a c
+ Where: ‘k’, ‘p’ are rigid type variables bound by
+ the instance declaration
+ at T22684.hs:18:10-26
+ ‘a’, ‘c’ are rigid type variables bound by
+ the type signature for:
+ (T22684..) :: forall b c a. Free p b c -> Free p a b -> Free p a c
+ at T22684.hs:19:7
+ • In an equation for ‘T22684..’: Sum T22684.. Prod = _
+ In the instance declaration for ‘Category (Free p)’
+ • Relevant bindings include
+ (.) :: Free p b c -> Free p a b -> Free p a c
+ (bound at T22684.hs:19:7)
+ Constraints include
+ b ~ (b2, c1) (from T22684.hs:19:9-12)
+ b ~ Either a1 b1 (from T22684.hs:19:3-5)
+ Valid hole fits include
+ q :: forall r. r
+ with q @(Free p a c)
+ (bound at T22684.hs:8:1)
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -696,4 +696,5 @@ test('VisFlag2', normal, compile_fail, [''])
test('VisFlag3', normal, compile_fail, [''])
test('VisFlag4', normal, compile_fail, [''])
test('VisFlag5', normal, compile_fail, [''])
+test('T22684', normal, compile_fail, [''])
test('T23514a', normal, compile_fail, [''])
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -437,6 +437,7 @@ wanteds os = concat
,structField Both "StgEntCounter" "entry_count"
,closureSize Both "StgUpdateFrame"
+ ,closureSize Both "StgOrigThunkInfoFrame"
,closureSize C "StgCatchFrame"
,closureSize C "StgStopFrame"
,closureSize C "StgDeadThreadFrame"
@@ -479,6 +480,7 @@ wanteds os = concat
,structSize C "StgTSOProfInfo"
,closureField Both "StgUpdateFrame" "updatee"
+ ,closureField Both "StgOrigThunkInfoFrame" "info_ptr"
,closureField C "StgCatchFrame" "handler"
,closureField C "StgCatchFrame" "exceptions_blocked"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e96c949e48b373a2f235b33955884e64e9825a18...056f909e96ff169efaf251a13144f0edea6893d0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e96c949e48b373a2f235b33955884e64e9825a18...056f909e96ff169efaf251a13144f0edea6893d0
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/20230711/e85118b3/attachment-0001.html>
More information about the ghc-commits
mailing list