27 Mar '26
Simon Jakobi pushed new branch wip/sjakobi/elem-tests at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/elem-tests
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: Fix assert in Interpreter.c
by Marge Bot (＠marge-bot) 27 Mar '26
by Marge Bot (＠marge-bot) 27 Mar '26
27 Mar '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
404b71c1 by Luite Stegeman at 2026-03-27T04:40:49-04:00
Fix assert in Interpreter.c
If we skip exactly the number of words on the stack we end up on
the first word in the next chunk.
- - - - -
a85bd503 by Luite Stegeman at 2026-03-27T04:40:49-04:00
Support arbitrary size unboxed tuples in bytecode
This stores the size (number of words on the stack) of the next
expected tuple in the TSO, ctoi_spill_size field, eliminating
the need of stg_ctoi_tN frames for each size.
Note: On 32 bit platform there is still a bytecode tuple size
limit of 255 words on the stack.
Fixes #26946
- - - - -
e2209031 by Luite Stegeman at 2026-03-27T04:40:49-04:00
Add specialized frames for small tuples
Small tuples are now returned more efficiently to the interpreter.
They use one less word of stack space and don't need manipulation
of the TSO anymore.
- - - - -
b26bb2ea by VeryMilkyJoe at 2026-03-27T04:41:38-04:00
Remove backwards compatibility pattern synonym `ModLocation`
Fixes #24932
- - - - -
66e5e324 by Vladislav Zavialov at 2026-03-27T04:42:25-04:00
Extend HsExpr with the StarIsType syntax (#26587, #26967)
This patch allows kinds of the form `k -> *` and `* -> k` to occur in
expression syntax, i.e. to be used as required type arguments.
For example:
{-# LANGUAGE RequiredTypeArguments, StarIsType #-}
x1 = f (* -> * -> *)
x2 = f (forall k. k -> *)
x3 = f ((* -> *) -> Constraint)
Summary of the changes:
* Introduce the HsStar constructor of HsExpr and its extension field XStar.
It is analogous to HsStarTy in HsType.
* Refactor HsStarTy to store the unicode flag as TokStar, defined as
type TokStar = EpUniToken "*" "★" -- similar to TokForall, TokRArrow, etc.
The token is stored in the extension field and replaces the Bool field.
* Extend the `infixexp2` nonterminal to parse `*` as a direct argument of `->`.
This is more limited than the full StarIsType syntax, but has the nice
property of not conflicting with the multiplication operator `a * b`.
Test case: T26967 T26967_tyop
- - - - -
f8de456f by Sylvain Henry at 2026-03-27T04:43:22-04:00
STM: don't create a transaction in the rhs of catchRetry# (#26028)
We don't need to create a transaction for the rhs of (catchRetry#)
because contrary to the lhs we don't need to abort it on retry. Moreover
it is particularly harmful if we have code such as (#26028):
let cN = readTVar vN >> retry
tree = c1 `orElse` (c2 `orElse` (c3 `orElse` ...))
atomically tree
Because it will stack transactions for the rhss and the read-sets of all
the transactions will be iteratively merged in O(n^2) after the
execution of the most nested retry.
This is the second attempt at implementing this. The first attempt
triggered segfaults (#26291) and has been reverted.
Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com>
- - - - -
fcf092dd by Luite Stegeman at 2026-03-27T04:44:17-04:00
Windows: remove StgAsyncIOResult and fix crash/leaks
In stg_block_async{_void}, a stack slot was reserved for
an StgAsyncIOResult. This slot would be filled by the IO
manager upon completion of the async call.
However, if the blocked thread was interrupted by an async
exception, we would end up in an invalid state:
- If the blocked computation was never re-entered, the
StgAsyncIOResult would never be freed.
- If the blocked computation was re-entered, the thread would
find an unitialized stack slot for the StgAsyncIOResult,
leading to a crash reading its fields, or freeing the pointer.
We fix this by removing the StgAsyncIOResult altogether and writing
the result directly to the stack.
Fixes #26341
- - - - -
05094993 by Luite Stegeman at 2026-03-27T04:45:12-04:00
Don't refine DEFAULT alt for unary typeclasses
A non-DEFAULT data alt for a unary typeclass dictionary would
interfere with Unary Class Magic, leading to segfaults.
fixes #27071
- - - - -
4ee260cf by sheaf at 2026-03-27T04:46:06-04:00
Fix several oversights in hsExprType
This commit fixes several oversights in GHC.Hs.Syn.Type.hsExprType:
- The 'RecordCon' case was returning the type of the constructor,
instead of the constructor application. This is fixed by using
'splitFunTys'.
- The 'ExplicitTuple' case failed to take into account tuple sections,
and was also incorrectly handling 1-tuples (e.g. 'Solo') which can
be constructed using Template Haskell.
- The 'NegApp' case was returning the type of the negation operator,
again failing to apply it to the argument. Fixed by using
'funResultTy'.
- The 'HsProc' case was computing the result type of the arrow proc
block, without taking into account the argument type. Fix that by
adding a new field to 'CmdTopTc' that stores the arrow type, so that
we can construct the correct result type `arr a b` for
`proc (pat :: a) -> (cmd :: b)`.
- The 'ArithSeq' and 'NegApp' cases were failing to take into account
the result 'HsWrapper', which could e.g. silently drop casts.
This is fixed by introducing 'syntaxExpr_wrappedFunResTy' which, on
top of taking the result type, applies the result 'HsWrapper'.
These fixes are validated by the new GHC API test T26910.
Fixes #26910
- - - - -
e97232ce by Hai at 2026-03-27T04:47:04-04:00
Parser.y: avoid looking at token with QualifiedDo
This changes the behavior of 'hintQualifiedDo' so that the supplied
token is not inspected when the QualifiedDo language extension bit is
set.
- - - - -
97665855 by Vladislav Zavialov at 2026-03-27T05:20:22-04:00
Infix holes in types (#11107)
This patch introduces several improvements that follow naturally from
refactoring HsOpTy to represent the operator as an HsType, aligning it
with the approach taken by OpApp and HsExpr.
User-facing changes:
1. Infix holes (t1 `_` t2) are now permitted in types, following the
precedent set by term-level expressions.
Test case: T11107
2. Error messages for illegal promotion ticks are now reported at more
precise source locations.
Test case: T17865
Internal changes:
* The definition of HsOpTy now mirrors that of OpApp:
| HsOpTy (XOpTy p) (LHsType p) (LHsType p) (LHsType p)
| OpApp (XOpApp p) (LHsExpr p) (LHsExpr p) (LHsExpr p)
This moves us one step closer to unifying HsType and HsExpr.
* Ignoring locations,
the old pattern match (HsOpTy x prom lhs op rhs)
is now written as (HsOpTy x lhs (HsTyVar x' prom op) rhs)
but we also handle (HsOpTy x lhs (HsWildCardTy x') rhs)
Constructors other than HsTyVar and HsWildCardTy never appear
in the operator position.
* The various definitions across the compiler have been updated to work
with the new representation, drawing inspiration from the term-level
pipeline where appropriate. For example,
ppr_infix_ty <=> ppr_infix_expr
get_tyop <=> get_op
lookupTypeFixityRn <=> lookupExprFixityRn
(the latter is factored out from rnExpr)
Test cases: T11107 T17865
- - - - -
ec38e053 by mangoiv at 2026-03-27T05:20:23-04:00
ci: build i386 non-validate for deb12
This is a small fix that will unlock ghcup metadata to run, i386 debian
12 was missing as a job.
- - - - -
118 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC.hs
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/AddImplicitBinds.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Fixity.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Type.hs
- docs/users_guide/exts/required_type_arguments.rst
- rts/Apply.cmm
- rts/Continuation.c
- rts/ContinuationOps.cmm
- rts/HeapStackCheck.cmm
- rts/IOManager.c
- rts/Interpreter.c
- rts/PrimOps.cmm
- rts/Printer.c
- rts/RaiseAsync.c
- rts/RtsSymbols.c
- rts/STM.c
- rts/STM.h
- rts/Schedule.c
- rts/StgMiscClosures.cmm
- rts/Threads.c
- rts/Threads.h
- rts/include/rts/Bytecodes.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- rts/win32/AsyncMIO.c
- rts/win32/AsyncMIO.h
- + testsuite/tests/bytecode/tuplestress/ByteCode.hs
- + testsuite/tests/bytecode/tuplestress/Common.hs-incl
- + testsuite/tests/bytecode/tuplestress/Obj.hs
- + testsuite/tests/bytecode/tuplestress/TupleStress.hs
- + testsuite/tests/bytecode/tuplestress/TupleStress.stdout
- + testsuite/tests/bytecode/tuplestress/all.T
- + testsuite/tests/concurrent/should_run/T26341.hs
- + testsuite/tests/concurrent/should_run/T26341.stdout
- + testsuite/tests/concurrent/should_run/T26341a.hs
- + testsuite/tests/concurrent/should_run/T26341a.stdout
- + testsuite/tests/concurrent/should_run/T26341b.hs
- + testsuite/tests/concurrent/should_run/T26341b.stdout
- testsuite/tests/concurrent/should_run/all.T
- + testsuite/tests/ghc-api/T26910.hs
- + testsuite/tests/ghc-api/T26910.stdout
- + testsuite/tests/ghc-api/T26910_Input.hs
- testsuite/tests/ghc-api/all.T
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
- + testsuite/tests/lib/stm/T26028.hs
- + testsuite/tests/lib/stm/T26028.stdout
- + testsuite/tests/lib/stm/T26291a.hs
- + testsuite/tests/lib/stm/T26291a.stdout
- + testsuite/tests/lib/stm/T26291b.hs
- + testsuite/tests/lib/stm/T26291b.stdout
- + testsuite/tests/lib/stm/all.T
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_fail/T17865.stderr
- + testsuite/tests/partial-sigs/should_compile/T11107.hs
- + testsuite/tests/partial-sigs/should_compile/T11107.stderr
- testsuite/tests/partial-sigs/should_compile/all.T
- + testsuite/tests/simplCore/should_run/T27071.hs
- + testsuite/tests/simplCore/should_run/T27071.stdout
- testsuite/tests/simplCore/should_run/all.T
- + testsuite/tests/vdq-rta/should_compile/T26967.hs
- + testsuite/tests/vdq-rta/should_compile/T26967.stderr
- + testsuite/tests/vdq-rta/should_compile/T26967_tyop.hs
- + testsuite/tests/vdq-rta/should_compile/T26967_tyop.stderr
- testsuite/tests/vdq-rta/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/deriveConstants/Main.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/137afcefcd5830d7c545a296ef0f37…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/137afcefcd5830d7c545a296ef0f37…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Parser.y: avoid looking at token with QualifiedDo
by Marge Bot (＠marge-bot) 27 Mar '26
by Marge Bot (＠marge-bot) 27 Mar '26
27 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e97232ce by Hai at 2026-03-27T04:47:04-04:00
Parser.y: avoid looking at token with QualifiedDo
This changes the behavior of 'hintQualifiedDo' so that the supplied
token is not inspected when the QualifiedDo language extension bit is
set.
- - - - -
1 changed file:
- compiler/GHC/Parser.y
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4512,12 +4512,14 @@ hintExplicitForall tok = do
-- Hint about qualified-do
hintQualifiedDo :: Located Token -> P ()
hintQualifiedDo tok = do
- qualifiedDo <- getBit QualifiedDoBit
- case maybeQDoDoc of
- Just qdoDoc | not qualifiedDo ->
- addError $ mkPlainErrorMsgEnvelope (getLoc tok) $
- (PsErrIllegalQualifiedDo qdoDoc)
- _ -> return ()
+ qualifiedDo <- getBit QualifiedDoBit
+ unless qualifiedDo $
+ maybe
+ (return ())
+ (\qdoDoc ->
+ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $
+ (PsErrIllegalQualifiedDo qdoDoc))
+ maybeQDoDoc
where
maybeQDoDoc = case unLoc tok of
ITdo (Just m) -> Just $ ftext m <> text ".do"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e97232ce6d5b530a873291b4b8d99a7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e97232ce6d5b530a873291b4b8d99a7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
27 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
4ee260cf by sheaf at 2026-03-27T04:46:06-04:00
Fix several oversights in hsExprType
This commit fixes several oversights in GHC.Hs.Syn.Type.hsExprType:
- The 'RecordCon' case was returning the type of the constructor,
instead of the constructor application. This is fixed by using
'splitFunTys'.
- The 'ExplicitTuple' case failed to take into account tuple sections,
and was also incorrectly handling 1-tuples (e.g. 'Solo') which can
be constructed using Template Haskell.
- The 'NegApp' case was returning the type of the negation operator,
again failing to apply it to the argument. Fixed by using
'funResultTy'.
- The 'HsProc' case was computing the result type of the arrow proc
block, without taking into account the argument type. Fix that by
adding a new field to 'CmdTopTc' that stores the arrow type, so that
we can construct the correct result type `arr a b` for
`proc (pat :: a) -> (cmd :: b)`.
- The 'ArithSeq' and 'NegApp' cases were failing to take into account
the result 'HsWrapper', which could e.g. silently drop casts.
This is fixed by introducing 'syntaxExpr_wrappedFunResTy' which, on
top of taking the result type, applies the result 'HsWrapper'.
These fixes are validated by the new GHC API test T26910.
Fixes #26910
- - - - -
9 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Zonk/Type.hs
- + testsuite/tests/ghc-api/T26910.hs
- + testsuite/tests/ghc-api/T26910.stdout
- + testsuite/tests/ghc-api/T26910_Input.hs
- testsuite/tests/ghc-api/all.T
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1608,9 +1608,16 @@ is Less Cool because
-}
data CmdTopTc
- = CmdTopTc Type -- Nested tuple of inputs on the command's stack
- Type -- return type of the command
- (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
+ = CmdTopTc
+ -- | Nested tuple of inputs on the command's stack
+ { ctt_stack :: Type
+ -- | Arrow type
+ , ctt_arr_ty :: Type
+ -- | Return type of the command
+ , ctt_res_ty :: Type
+ -- | Command syntax table; see Note [CmdSyntaxTable]
+ , ctt_table :: CmdSyntaxTable GhcTc
+ }
type instance XCmdTop GhcPs = NoExtField
type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -25,6 +25,7 @@ import GHC.Tc.Types.Evidence
import GHC.Types.Id
import GHC.Types.Var( VarBndr(..) )
import GHC.Types.SrcLoc
+import GHC.Utils.Misc ( HasDebugCallStack )
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -114,11 +115,16 @@ hsExprType (HsLam _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_gr
hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f
hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x
hsExprType (OpApp v _ _ _) = dataConCantHappen v
-hsExprType (NegApp _ _ se) = syntaxExprType se
+hsExprType (NegApp _ _ se) = syntaxExpr_wrappedFunResTy se
hsExprType (HsPar _ e) = lhsExprType e
hsExprType (SectionL v _ _) = dataConCantHappen v
hsExprType (SectionR v _ _) = dataConCantHappen v
-hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args
+hsExprType (ExplicitTuple _ args box) =
+ -- Deal with tuple sections: one function arrow per missing argument
+ mkScaledFunTys [s | Missing s <- args] $
+ -- Use 'mkTupleTy1' to avoid flattening 1-tuples, as per
+ -- Note [Don't flatten tuples from HsSyn] in GHC.Core.Make.
+ mkTupleTy1 box (map hsTupArgType args)
hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys
hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group
hsExprType (HsIf _ _ t _) = lhsExprType t
@@ -126,25 +132,29 @@ hsExprType (HsMultiIf ty _) = ty
hsExprType (HsLet _ _ body) = lhsExprType body
hsExprType (HsDo ty _ _) = ty
hsExprType (ExplicitList ty _) = mkListTy ty
-hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
+hsExprType (RecordCon con_expr _ _) = snd (splitFunTys (hsExprType con_expr))
hsExprType (RecordUpd v _ _) = dataConCantHappen v
hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v
hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v
hsExprType (ExprWithTySig _ e _) = lhsExprType e
-hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
- Just op -> piResultTy (syntaxExprType op) asi_ty
- Nothing -> asi_ty
- where
- asi_ty = arithSeqInfoType asi
+hsExprType (ArithSeq _ mb_overloaded_op asi) =
+ case mb_overloaded_op of
+ Just se -> syntaxExpr_wrappedFunResTy se
+ Nothing -> arithSeqInfoType asi
hsExprType (HsTypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty
hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty
-hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice"
- (ppr e)
- -- Typed splices should have been eliminated during zonking, but we
- -- can't use `dataConCantHappen` since they are still present before
- -- than in the typechecked AST.
+hsExprType e@(HsTypedSplice{}) =
+ -- Typed splices should have been eliminated during zonking, but we
+ -- can't use `dataConCantHappen` since they are still present before
+ -- then in the typechecked AST.
+ pprPanic "hsExprType: Unexpected HsTypedSplice"
+ (ppr e)
hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext
-hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
+hsExprType (HsProc _ pat (L _ (HsCmdTop cmd_top_tc _))) =
+ let CmdTopTc { ctt_arr_ty = arr_ty, ctt_res_ty = res_ty } = cmd_top_tc
+ in
+ -- (proc (pat :: a) -> (cmd :: b)) :: arr a b
+ mkAppTys arr_ty [hsLPatType pat, res_ty]
hsExprType (HsStatic (ty,_) _s) = ty
hsExprType (HsPragE _ _ e) = lhsExprType e
hsExprType (HsEmbTy x _) = dataConCantHappen x
@@ -178,6 +188,13 @@ hsTupArgType :: HsTupArg GhcTc -> Type
hsTupArgType (Present _ e) = lhsExprType e
hsTupArgType (Missing (Scaled _ ty)) = ty
+-- | The result type of a @SyntaxExpr GhcTc@ for a unary function,
+-- including the result 'HsWrapper'.
+syntaxExpr_wrappedFunResTy :: HasDebugCallStack => SyntaxExpr GhcTc -> Type
+syntaxExpr_wrappedFunResTy (SyntaxExprTc { syn_expr = e, syn_res_wrap = wrap }) =
+ hsWrapperType wrap (funResultTy (hsExprType e))
+syntaxExpr_wrappedFunResTy NoSyntaxExprTc =
+ panic "syntaxExpr_wrappedFunResTy: unexpected NoSyntaxExprTc"
-- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))
type PRType = (Type, [Type])
@@ -191,7 +208,7 @@ liftPRType :: (Type -> Type) -> PRType -> PRType
liftPRType f pty = (f (prTypeType pty), [])
hsWrapperType :: HsWrapper -> Type -> Type
--- Return the type of (WrapExpr wrap e), given that e :: ty
+-- ^ Return the type of @WrapExpr wrap e@, given that @e :: ty@
hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
where
go WpHole = id
@@ -209,12 +226,5 @@ hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas)
go (WpLet _) = id
-lhsCmdTopType :: LHsCmdTop GhcTc -> Type
-lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty
-
matchGroupTcType :: MatchGroupTc -> Type
matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res
-
-syntaxExprType :: SyntaxExpr GhcTc -> Type
-syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
-syntaxExprType NoSyntaxExprTc = panic "syntaxExprType: Unexpected NoSyntaxExprTc"
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -284,7 +284,7 @@ dsProcExpr
:: LPat GhcTc
-> LHsCmdTop GhcTc
-> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc { ctt_res_ty = cmd_ty, ctt_table = ids }) cmd)) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders CollWithDictBinders pat)
(core_cmd, _free_vars, env_ids)
@@ -656,8 +656,15 @@ dsTrimCmdArg
-> DsM (CoreExpr, -- desugared expression
DIdSet) -- subset of local vars that occur free
dsTrimCmdArg local_vars env_ids
- (L _ (HsCmdTop
- (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
+ (L _
+ (HsCmdTop
+ (CmdTopTc
+ { ctt_stack = stack_ty
+ , ctt_res_ty = cmd_ty
+ , ctt_table = ids
+ })
+ cmd)
+ ) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids')
<- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -136,7 +136,11 @@ tcCmdTop :: CmdEnv
tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)
= setSrcSpanA loc $
do { cmd' <- tcCmd env cmd cmd_ty
- ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }
+ ; let cmd_top = CmdTopTc { ctt_stack = cmd_stk
+ , ctt_arr_ty = cmd_arr env
+ , ctt_res_ty = res_ty
+ , ctt_table = names }
+ ; return (L loc $ HsCmdTop cmd_top cmd') }
----------------------------------------
tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1211,10 +1211,14 @@ zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc)
zonkCmdTop cmd = wrapLocZonkMA (zonk_cmd_top) cmd
zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc)
-zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
+zonk_cmd_top (HsCmdTop (CmdTopTc { ctt_stack = stack_tys
+ , ctt_arr_ty = arr_ty
+ , ctt_res_ty = res_ty
+ , ctt_table = ids }) cmd)
= do new_cmd <- zonkLCmd cmd
new_stack_tys <- zonkTcTypeToTypeX stack_tys
- new_ty <- zonkTcTypeToTypeX ty
+ new_arr_ty <- zonkTcTypeToTypeX arr_ty
+ new_res_ty <- zonkTcTypeToTypeX res_ty
new_ids <- mapSndM zonkExpr ids
massert (definitelyLiftedType new_stack_tys)
@@ -1222,7 +1226,13 @@ zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
-- but indeed it should always be lifted due to the typing
-- rules for arrows
- return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
+ let new_cmd_top =
+ CmdTopTc { ctt_stack = new_stack_tys
+ , ctt_arr_ty = new_arr_ty
+ , ctt_res_ty = new_res_ty
+ , ctt_table = new_ids }
+
+ return (HsCmdTop new_cmd_top new_cmd)
-------------------------------------------------------------------------
zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper
=====================================
testsuite/tests/ghc-api/T26910.hs
=====================================
@@ -0,0 +1,113 @@
+module Main where
+
+-- base
+import Control.Applicative
+import Control.Monad.IO.Class
+ ( liftIO )
+import Data.List.NonEmpty
+ ( NonEmpty (..) )
+import System.Environment
+ ( getArgs )
+
+-- directory
+import System.Directory
+ ( removeFile )
+
+-- ghc
+import GHC
+import GHC.Data.Bag
+ ( bagToList )
+import GHC.Driver.Ppr
+ ( showSDoc )
+import GHC.Driver.Session
+import GHC.Hs
+import GHC.Hs.Syn.Type
+ ( hsExprType )
+import GHC.Types.Name
+ ( nameOccName, occNameString )
+import GHC.Types.Var
+ ( varName )
+import GHC.Unit.Types
+ ( GenUnit (..), Definite (..) )
+import GHC.Utils.Outputable
+ ( ppr )
+
+--------------------------------------------------------------------------------
+
+findBindBody :: String -> LHsBinds GhcTc -> Maybe (HsExpr GhcTc)
+findBindBody name = asum . map go
+ where
+ go (L _ FunBind { fun_id = L _ fid
+ , fun_matches = MG { mg_alts = L _ (m:_) } })
+ | occNameString (nameOccName (varName fid)) == name
+ = case m_grhss (unLoc m) of
+ GRHSs { grhssGRHSs = L _ (GRHS _ _ bodyL) :| _ } -> Just (unLoc bodyL)
+ go (L _ (XHsBindsLR AbsBinds { abs_binds })) = findBindBody name abs_binds
+ go _ = Nothing
+
+checkBinding :: DynFlags -> String -> LHsBinds GhcTc -> IO ()
+checkBinding dflags name tcSrc =
+ case findBindBody name tcSrc of
+ Nothing ->
+ putStrLn $ name ++ " NOT FOUND"
+ Just body ->
+ putStrLn $
+ "(<body of " ++ name ++ ">) :: " ++ showSDoc dflags (ppr (hsExprType body))
+
+main :: IO ()
+main = do
+ [libdir] <- getArgs
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ logger <- getLogger
+
+ -- Add 'template-haskell' dependency
+ (dflags, _, _) <- parseDynamicFlags logger dflags [noLoc "-package template-haskell"]
+ setSessionDynFlags dflags
+
+ let modName = mkModuleName "T26910_Input"
+ m = mkModule (RealUnit (Definite (homeUnitId_ dflags))) modName
+ addTarget Target
+ { targetId = TargetModule modName
+ , targetAllowObjCode = True
+ , targetUnitId = homeUnitId_ dflags
+ , targetContents = Nothing
+ }
+ _ <- load LoadAllTargets
+ modSum <- getModSummary m
+ parsed <- parseModule modSum
+ tc <- typecheckModule parsed
+
+ let tcSrc = tm_typechecked_source tc
+ check name = liftIO $ checkBinding dflags name tcSrc
+
+ check "e_reccon" -- RecordCon
+ check "e_negapp" -- NegApp
+ check "e_proc" -- HsProc
+ check "e_arith_ol" -- ArithSeq
+
+ check "e_var" -- ConLikeTc
+ check "e_lit" -- HsLit
+ check "e_overlit" -- HsOverLit
+ check "e_lam" -- HsLam
+ check "e_app" -- HsApp
+ check "e_apptype" -- HsAppType
+ check "e_par" -- HsPar
+ check "e_tuple1" -- ExplicitTuple
+ check "e_tuple2" -- ExplicitTuple + TupleSections
+ check "e_tuple3" -- ExplicitTuple 1-tuple (with Template Haskell)
+ check "e_utuple1" -- ExplicitTuple (unboxed)
+ check "e_utuple2" -- ExplicitTuple + TupleSections (unboxed)
+ check "e_usum" -- Unboxed sums
+ check "e_case" -- HsCase
+ check "e_if" -- HsIf
+ check "e_multiif" -- HsMultiIf
+ check "e_let" -- HsLet
+ check "e_list" -- ExplicitList + OverloadedLists
+ check "e_arith" -- ArithSeq
+ check "e_tysig" -- ExprWithTySig
+ check "e_listcomp" -- HsDo (ListComp)
+ check "e_recsel" -- HsRecSelTc
+ check "e_ubracket" -- HsUntypedBracket
+ check "e_tbracket" -- HsTypedBracket
+ check "e_static" -- HsStatic
=====================================
testsuite/tests/ghc-api/T26910.stdout
=====================================
@@ -0,0 +1,29 @@
+(<body of e_reccon>) :: MyRec
+(<body of e_negapp>) :: T Word
+(<body of e_proc>) :: Int -> Int
+(<body of e_arith_ol>) :: MyList Int
+(<body of e_var>) :: Either Int Bool
+(<body of e_lit>) :: Char
+(<body of e_overlit>) :: T Word
+(<body of e_lam>) :: Bool -> Bool
+(<body of e_app>) :: Bool
+(<body of e_apptype>) :: Bool -> Bool
+(<body of e_par>) :: Bool
+(<body of e_tuple1>) :: (Int, Bool)
+(<body of e_tuple2>) :: Int -> (Int, Bool)
+(<body of e_tuple3>) :: Solo Char
+(<body of e_utuple1>) :: (# Int, Int# #)
+(<body of e_utuple2>) :: Int -> Int# -> (# Int, Int# #)
+(<body of e_usum>) :: (# Int# | Word# #)
+(<body of e_case>) :: Bool
+(<body of e_if>) :: Char
+(<body of e_multiif>) :: Int
+(<body of e_let>) :: Int
+(<body of e_list>) :: [Int]
+(<body of e_arith>) :: MyList Int
+(<body of e_tysig>) :: Bool
+(<body of e_listcomp>) :: [Int]
+(<body of e_recsel>) :: MyRec -> Int
+(<body of e_ubracket>) :: Q Exp
+(<body of e_tbracket>) :: Code Q Char
+(<body of e_static>) :: StaticPtr Bool
=====================================
testsuite/tests/ghc-api/T26910_Input.hs
=====================================
@@ -0,0 +1,187 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE StaticPointers #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module T26910_Input where
+
+-- base
+import Prelude
+ hiding ( negate, fromInteger )
+import qualified Prelude
+import Control.Arrow
+ ( (>>>), arr, first, returnA )
+import Data.Kind
+ ( Type )
+import Data.Tuple
+ ( Solo(..) )
+import GHC.Exts
+ ( TYPE, RuntimeRep(..), LiftedRep
+ , IsList (..)
+ , Int#, Word#
+ )
+import GHC.StaticPtr
+ ( StaticPtr )
+
+-- template-haskell
+import qualified Language.Haskell.TH as TH
+
+--------------------------------------------------------------------------------
+
+ifThenElse :: Bool -> a -> a -> a
+ifThenElse c t f =
+ case c of
+ True -> t
+ False -> f
+
+data MyRec = MyRec { recInt :: Int, recBool :: Bool }
+
+-- Used to test ArithSeq with overloaded fromList (OverloadedLists)
+newtype MyList a = MyList [a]
+instance IsList (MyList a) where
+ type Item (MyList a) = a
+ fromList = MyList
+ toList (MyList xs) = xs
+
+-- RecordCon
+e_reccon :: MyRec
+e_reccon = MyRec { recInt = 1, recBool = True }
+
+-- NegApp
+e_negapp :: T Word
+e_negapp = -(1 :: Int)
+
+type R :: Type -> RuntimeRep
+type family R a where
+ R Word = LiftedRep
+
+type T :: forall (a :: Type) -> TYPE (R a)
+type family T a where
+ T Word = Int
+
+-- Weird RebindableSyntax negation that involves casts
+negate :: T Word -> T Word
+negate = Prelude.negate
+
+-- HsProc
+e_proc :: Int -> Int
+e_proc = proc x -> returnA -< x
+
+-- ArithSeq (with OverloadedLists)
+e_arith_ol :: MyList Int
+e_arith_ol = [1..10 :: Int]
+
+-- XExpr (ConLikeTc)
+e_var :: Either Int Bool
+e_var = Left 3
+
+-- HsLit
+e_lit :: Char
+e_lit = 'x'
+
+-- HsOverLit
+e_overlit :: T Word
+e_overlit = 42
+
+fromInteger :: Integer -> T Word
+fromInteger = Prelude.fromInteger
+
+-- HsLam
+e_lam :: Bool -> Bool
+e_lam = \ x -> not x
+
+-- HsApp
+e_app :: Bool
+e_app = not True
+
+-- HsAppType
+e_apptype :: Bool -> Bool
+e_apptype = id @Bool
+
+-- HsPar
+e_par :: Bool
+e_par = (True)
+
+-- ExplicitTuple
+e_tuple1 :: (Int, Bool)
+e_tuple1 = (1 :: Int, True)
+
+-- ExplicitTuple + TupleSections
+e_tuple2 :: Int -> (Int, Bool)
+e_tuple2 = (, True)
+
+-- ExplicitTuple one-tuple
+e_tuple3 :: Solo Char
+e_tuple3 =
+ $( return $ TH.TupE [ Just $ TH.LitE ( TH.CharL 'x' ) ] )
+
+-- Unboxed tuple
+e_utuple1 :: () -> (# Int, Int# #)
+e_utuple1 _ = (# 1, 1# #)
+
+-- Unboxed tuple + TupleSections
+e_utuple2 :: Int -> Int# -> (# Int, Int# #)
+e_utuple2 = (# , #)
+
+-- Unboxed sums
+e_usum :: () -> (# Int# | Word# #)
+e_usum _ = (# 1# | #)
+
+-- HsCase
+e_case :: Bool
+e_case = case id True of { True -> False; False -> True }
+
+-- HsIf
+e_if :: Char
+e_if = if id True then 'x' else 'y'
+
+-- HsMultiIf
+e_multiif :: Int
+e_multiif = if | id True -> (1 :: Int)
+ | otherwise -> (2 :: Int)
+
+-- HsLet
+e_let :: Int
+e_let = let x = 1 :: Int in x
+
+-- ExplicitList
+e_list :: [Int]
+e_list = [1 :: Int, 2, 3]
+
+-- ArithSeq with overloaded fromList
+e_arith :: MyList Int
+e_arith = [1 :: Int ..]
+
+-- ExprWithTySig
+e_tysig :: Bool
+e_tysig = (True :: Bool)
+
+-- HsDo ListComp
+e_listcomp :: [Int]
+e_listcomp = [x | x <- [1 :: Int, 2, 3]]
+
+-- HsRecSelTc
+e_recsel :: MyRec -> Int
+e_recsel = recInt
+
+-- HsUntypedBracket
+e_ubracket :: TH.Q TH.Exp
+e_ubracket = [| 'y' |]
+
+-- HsTypedBracket
+e_tbracket :: TH.Code TH.Q Char
+e_tbracket = [|| 'z' ||]
+
+-- HsStatic
+e_static :: StaticPtr Bool
+e_static = static True
=====================================
testsuite/tests/ghc-api/all.T
=====================================
@@ -74,4 +74,8 @@ test('T25577', [ extra_run_opts(f'"{config.libdir}"')
test('T26120', [], compile_and_run, ['-package ghc'])
test('T26264', normal, compile_and_run, ['-package ghc'])
+test('T26910', [ extra_run_opts(f'"{config.libdir}"')
+ # doesn't work in wasm/js due to lack of pipe(2) support
+ , when(arch('wasm32') or arch('javascript'), skip)
+ ], compile_and_run, ['-package ghc -package template-haskell'])
test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ee260cfaebd3fb6c2ceb757a0a0267…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ee260cfaebd3fb6c2ceb757a0a0267…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Don't refine DEFAULT alt for unary typeclasses
by Marge Bot (＠marge-bot) 27 Mar '26
by Marge Bot (＠marge-bot) 27 Mar '26
27 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
05094993 by Luite Stegeman at 2026-03-27T04:45:12-04:00
Don't refine DEFAULT alt for unary typeclasses
A non-DEFAULT data alt for a unary typeclass dictionary would
interfere with Unary Class Magic, leading to segfaults.
fixes #27071
- - - - -
7 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Utils.hs
- + testsuite/tests/simplCore/should_run/T27071.hs
- + testsuite/tests/simplCore/should_run/T27071.stdout
- testsuite/tests/simplCore/should_run/all.T
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -286,7 +286,9 @@ data Alt b
-- See Note [GHC Formalism] in GHC.Core.Lint
data AltCon
= DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
- -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
+ -- Invariant: the 'DataCon' is always from a @data@ type,
+ -- and never from a @newtype@ or a unary class.
+ -- See Note [DataAlt restrictions]
| LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@
-- Invariant: always an *unlifted* literal
@@ -330,6 +332,63 @@ mkBinds Recursive binds = [Rec binds]
mkBinds NonRecursive binds = map (uncurry NonRec) binds
{-
+Note [DataAlt restrictions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The DataCon in a DataAlt is subject to three restrictions:
+
+(DALT1) It is never from a newtype.
+
+ Newtypes are always represented via coercions, never by pattern matching
+ on their data constructor. We can still have a case expression over a
+ newtype scrutinee if we are just doing an eval:
+
+ case x of { DEFAULT -> e }
+
+ but we must not match on the newtype constructor.
+
+(DALT2) It is never from a `type data` declaration.
+
+ The constructors of a `type data` declaration (see
+ Note [Type data declarations] in GHC.Rename.Module) exist only at the
+ type level and have no value-level representation. Nevertheless, it is
+ possible to strictly evaluate a value whose type is a `type data`
+ declaration. For example (from test type-data/should_compile/T2294b.hs):
+
+ type data T a where
+ A :: T Int
+
+ f :: T a -> ()
+ f !x = ()
+
+ We want to generate the following Core for f:
+
+ f = \(@a) (x :: T a) ->
+ case x of { __DEFAULT -> () }
+
+ Namely we do _not_ want to match on `A`, as it doesn't exist at the value
+ level! See wrinkle (W2b) in Note [Type data declarations] in
+ GHC.Rename.Module.
+
+(DALT3) It is never from a unary class (#27071).
+
+ Unary class constructors are erased at runtime: the dictionary IS the
+ single method (or superclass), with no wrapper. Matching on the dictionary
+ constructor is therefore illegal in Core; case expressions over unary
+ class dictionaries must use DEFAULT. For example, given
+
+ class C a where { op :: a -> a }
+
+ a case on a C dictionary looks like:
+
+ case d of bndr { DEFAULT -> ...bndr... }
+ not:
+ case d of { C:C op -> ...op... } -- WRONG
+
+ See (UCM13) in Note [Unary class magic] in GHC.Core.TyCon.
+
+All three restrictions are checked by Core Lint, and they each give rise
+to a special case in `GHC.Core.Utils.refineDefaultAlt`.
+
Note [Literal alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Literal alternatives (LitAlt lit) are always for *un-lifted* literals.
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -1720,11 +1720,13 @@ lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs)
lit_ty = literalType lit
lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs)
- | isNewTyCon (dataConTyCon con)
+ | isNewTyCon (dataConTyCon con) -- (DALT1) in Note [DataAlt restrictions] in GHC.Core
= zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt)
+ | isUnaryClassTyCon (dataConTyCon con) -- (DALT3) in Note [DataAlt restrictions] in GHC.Core
+ = zeroUE <$ addErrL (mkUnaryClassDataConAltMsg scrut_ty alt)
| Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
= addLoc (CaseAlt alt) $ do
- { checkTypeDataConOcc "pattern" con
+ { checkTypeDataConOcc "pattern" con -- (DALT2) in Note [DataAlt restrictions] in GHC.Core
; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
-- Instantiate the universally quantified
@@ -3806,6 +3808,11 @@ mkNewTyDataConAltMsg scrut_ty alt
text "Scrutinee type:" <+> ppr scrut_ty,
text "Alternative:" <+> pprCoreAlt alt ]
+mkUnaryClassDataConAltMsg :: Type -> CoreAlt -> SDoc
+mkUnaryClassDataConAltMsg scrut_ty alt
+ = vcat [ text "Data alternative for unary class datacon"
+ , text "Scrutinee type:" <+> ppr scrut_ty
+ , text "Alternative:" <+> pprCoreAlt alt ]
------------------------------------------------------
-- Other error messages
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -1584,6 +1584,20 @@ There are a number of wrinkles
a black hole when rehydrating interface the interface file. Easiest just to
store the bit! See `ifUnary` in GHC.Iface.Synatax.IfaceClassBody.
+(UCM13) In Core, a case expression must never pattern-match on a unary class
+ data constructor (#27071). Since the constructor is erased at runtime, the
+ only valid form is:
+
+ case d of bndr { DEFAULT -> ...bndr... }
+
+ See (DALT3) Note [DataAlt restrictions] in GHC.Core.
+
+ Generally, class dictionaries are only taken apart by the method
+ selectors, which are never inlined; see Note [ClassOp/DFun selection]
+ in GHC.Tc.TyCl.Instance. However the demand analyser can add `seq` forcing
+ on strict arguments (see Note [Which Ids should be strictified] in
+ GHC.Core.Utils), so we must be careful not to "fill in" the DEFAULT to mention
+ the data constructor; see GHC.Core.Utils.refineDefaultAlt.
Note [Representing unary classes with newtypes: bad, bad, bad]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -858,8 +858,9 @@ refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders
refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts
| Alt DEFAULT _ rhs : rest_alts <- all_alts
, isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples.
- , not (isNewTyCon tycon) -- Exception 1 in Note [Refine DEFAULT case alternatives]
- , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives]
+ , not (isNewTyCon tycon) -- (DALT1) in Note [DataAlt restrictions] in GHC.Core
+ , not (isTypeDataTyCon tycon) -- (DALT2) in Note [DataAlt restrictions] in GHC.Core
+ , not (isUnaryClassTyCon tycon) -- (DALT3) in Note [DataAlt restrictions] in GHC.Core
, Just all_cons <- tyConDataCons_maybe tycon
, let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons]
-- We now know it's a data type, so we can use
@@ -1200,38 +1201,9 @@ with a specific constructor is desirable.
`imposs_deflt_cons` argument is populated with constructors which
are matched elsewhere.
-There are two exceptions where we avoid refining a DEFAULT case:
-
-* Exception 1: Newtypes
-
- We can have a newtype, if we are just doing an eval:
-
- case x of { DEFAULT -> e }
-
- And we don't want to fill in a default for them!
-
-* Exception 2: `type data` declarations
-
- The data constructors for a `type data` declaration (see
- Note [Type data declarations] in GHC.Rename.Module) do not exist at the
- value level. Nevertheless, it is possible to strictly evaluate a value
- whose type is a `type data` declaration. Test case
- type-data/should_compile/T2294b.hs contains an example:
-
- type data T a where
- A :: T Int
-
- f :: T a -> ()
- f !x = ()
-
- We want to generate the following Core for f:
-
- f = \(@a) (x :: T a) ->
- case x of
- __DEFAULT -> ()
-
- Namely, we do _not_ want to match on `A`, as it doesn't exist at the value
- level! See wrinkle (W2b) in Note [Type data declarations] in GHC.Rename.Module
+We must not refine the DEFAULT into a DataAlt for newtypes, `type data`
+declarations, or unary classes, since none of these have a data constructor
+that can appear in a DataAlt. See Note [DataAlt restrictions] in GHC.Core.
Note [Combine identical alternatives]
=====================================
testsuite/tests/simplCore/should_run/T27071.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -O -fworker-wrapper-cbv #-}
+module Main where
+
+class MyClass a where
+ myVal :: Int
+
+instance MyClass Bool where
+ myVal = 0
+
+showMyVal :: forall a. MyClass a => String
+showMyVal = show (myVal @a)
+{-# NOINLINE showMyVal #-}
+
+main :: IO ()
+main = putStrLn (showMyVal @Bool)
=====================================
testsuite/tests/simplCore/should_run/T27071.stdout
=====================================
@@ -0,0 +1 @@
+0
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -121,3 +121,4 @@ test('T25096', normal, compile_and_run, ['-O -dcore-lint'])
test('AppIsHNF', normal, compile_and_run, ['-O'])
test('T24359b', normal, compile_and_run, ['-O'])
test('T23429', normal, compile_and_run, ['-O'])
+test('T27071', normal, compile_and_run, ['-O -fworker-wrapper-cbv'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05094993774191ede5c96770d8c91e8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05094993774191ede5c96770d8c91e8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Windows: remove StgAsyncIOResult and fix crash/leaks
by Marge Bot (＠marge-bot) 27 Mar '26
by Marge Bot (＠marge-bot) 27 Mar '26
27 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
fcf092dd by Luite Stegeman at 2026-03-27T04:44:17-04:00
Windows: remove StgAsyncIOResult and fix crash/leaks
In stg_block_async{_void}, a stack slot was reserved for
an StgAsyncIOResult. This slot would be filled by the IO
manager upon completion of the async call.
However, if the blocked thread was interrupted by an async
exception, we would end up in an invalid state:
- If the blocked computation was never re-entered, the
StgAsyncIOResult would never be freed.
- If the blocked computation was re-entered, the thread would
find an unitialized stack slot for the StgAsyncIOResult,
leading to a crash reading its fields, or freeing the pointer.
We fix this by removing the StgAsyncIOResult altogether and writing
the result directly to the stack.
Fixes #26341
- - - - -
17 changed files:
- rts/HeapStackCheck.cmm
- rts/IOManager.c
- rts/PrimOps.cmm
- rts/RtsSymbols.c
- rts/Threads.c
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- rts/win32/AsyncMIO.c
- rts/win32/AsyncMIO.h
- + testsuite/tests/concurrent/should_run/T26341.hs
- + testsuite/tests/concurrent/should_run/T26341.stdout
- + testsuite/tests/concurrent/should_run/T26341a.hs
- + testsuite/tests/concurrent/should_run/T26341a.stdout
- + testsuite/tests/concurrent/should_run/T26341b.hs
- + testsuite/tests/concurrent/should_run/T26341b.stdout
- testsuite/tests/concurrent/should_run/all.T
- utils/deriveConstants/Main.hs
Changes:
=====================================
rts/HeapStackCheck.cmm
=====================================
@@ -703,38 +703,24 @@ stg_block_throwto (P_ tso, P_ exception)
}
#if defined(mingw32_HOST_OS)
-INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ ares )
+INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ len, W_ errCode )
return ()
{
- W_ len, errC;
-
- len = TO_W_(StgAsyncIOResult_len(ares));
- errC = TO_W_(StgAsyncIOResult_errCode(ares));
- ccall free(ares "ptr");
- return (len, errC);
+ return (len, errCode);
}
stg_block_async
{
- Sp_adj(-2);
- Sp(0) = stg_block_async_info;
- BLOCK_GENERIC;
-}
+ W_ eintr;
+ (eintr) = ccall rts_EINTR();
-/* Used by threadDelay implementation; it would be desirable to get rid of
- * this free()'ing void return continuation.
- */
-INFO_TABLE_RET ( stg_block_async_void, RET_SMALL, W_ info_ptr, W_ ares )
- return ()
-{
- ccall free(ares "ptr");
- return ();
-}
-
-stg_block_async_void
-{
- Sp_adj(-2);
- Sp(0) = stg_block_async_void_info;
+ // Fill the stack frame with values that indicate that the operation
+ // has been interrupted. The IO manager will overwrite these with the
+ // actual results if the async operation completes.
+ Sp_adj(-3);
+ Sp(0) = stg_block_async_info;
+ Sp(1) = -1; // len: -1 indicates error
+ Sp(2) = eintr; // errCode: interrupted
BLOCK_GENERIC;
}
=====================================
rts/IOManager.c
=====================================
@@ -633,10 +633,8 @@ void scavengeTSOIOManager(StgTSO *tso)
#endif
/* case IO_MANAGER_WIN32_LEGACY:
- * BlockedOn{Read,Write,DoProc} uses block_info.async_result
- * The StgAsyncIOResult async_result is allocated on the C heap.
- * It'd probably be better if it used the GC heap. If it did we'd
- * scavenge it here.
+ * BlockedOn{Read,Write,DoProc} uses block_info.async_reqID
+ * which is a plain integer, so nothing to scavenge.
*/
default:
@@ -846,7 +844,7 @@ void syncIOCancel(Capability *cap, StgTSO *tso)
case IO_MANAGER_WIN32_LEGACY:
removeThreadFromDeQueue(cap, &cap->iomgr->blocked_queue_hd,
&cap->iomgr->blocked_queue_tl, tso);
- abandonWorkRequest(tso->block_info.async_result->reqID);
+ abandonWorkRequest(tso->block_info.async_reqID);
break;
#endif
default:
@@ -885,12 +883,7 @@ bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay)
* would make the primops more consistent.
*/
{
- StgAsyncIOResult *ares = stgMallocBytes(sizeof(StgAsyncIOResult),
- "syncDelay");
- ares->reqID = addDelayRequest(us_delay);
- ares->len = 0;
- ares->errCode = 0;
- tso->block_info.async_result = ares;
+ tso->block_info.async_reqID = addDelayRequest(us_delay);
/* Having all async-blocked threads reside on the blocked_queue
* simplifies matters, so set the status to OnDoProc and put the
=====================================
rts/PrimOps.cmm
=====================================
@@ -2255,18 +2255,7 @@ stg_delayzh ( W_ us_delay )
(ok) = ccall syncDelay(MyCapability() "ptr", CurrentTSO "ptr", us_delay);
if (ok != 0::CBool) (likely: True) {
- /* Annoyingly, we cannot be consistent with how we wait and resume the
- * blocked thread. The reason is that the win32 legacy I/O manager
- * allocates a StgAsyncIOResult struct on the C heap which has to be
- * freed when the thread resumes. It's a bit awkward to arrange to
- * allocate it on the GC heap instead, so that's how it is for now.
- * Sigh.
- */
-#if defined(mingw32_HOST_OS)
- jump stg_block_async_void();
-#else
jump stg_block_noregs();
-#endif
} else {
jump stg_raisezh(HsIface_heapOverflow_closure(W_[ghc_hs_iface]));
}
@@ -2276,21 +2265,14 @@ stg_delayzh ( W_ us_delay )
#if defined(mingw32_HOST_OS)
stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf )
{
- W_ ares;
CInt reqID;
#if defined(THREADED_RTS)
ccall sbarf("asyncRead# on threaded RTS") never returns;
#else
- /* could probably allocate this on the heap instead */
- ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
- "stg_asyncReadzh");
(reqID) = ccall addIORequest(fd, 0/*FALSE*/,is_sock,len,buf "ptr");
- StgAsyncIOResult_reqID(ares) = reqID;
- StgAsyncIOResult_len(ares) = 0;
- StgAsyncIOResult_errCode(ares) = 0;
- StgTSO_block_info(CurrentTSO) = ares;
+ StgTSO_block_info(CurrentTSO) = reqID;
ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32);
%release StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I32;
@@ -2302,21 +2284,14 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf )
stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf )
{
- W_ ares;
CInt reqID;
#if defined(THREADED_RTS)
ccall sbarf("asyncWrite# on threaded RTS") never returns;
#else
- ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
- "stg_asyncWritezh");
(reqID) = ccall addIORequest(fd, 1/*TRUE*/,is_sock,len,buf "ptr");
-
- StgAsyncIOResult_reqID(ares) = reqID;
- StgAsyncIOResult_len(ares) = 0;
- StgAsyncIOResult_errCode(ares) = 0;
- StgTSO_block_info(CurrentTSO) = ares;
+ StgTSO_block_info(CurrentTSO) = reqID;
ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32);
%release StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I32;
@@ -2328,21 +2303,14 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf )
stg_asyncDoProczh ( W_ proc, W_ param )
{
- W_ ares;
CInt reqID;
#if defined(THREADED_RTS)
ccall sbarf("asyncDoProc# on threaded RTS") never returns;
#else
- /* could probably allocate this on the heap instead */
- ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
- "stg_asyncDoProczh");
(reqID) = ccall addDoProcRequest(proc "ptr",param "ptr");
- StgAsyncIOResult_reqID(ares) = reqID;
- StgAsyncIOResult_len(ares) = 0;
- StgAsyncIOResult_errCode(ares) = 0;
- StgTSO_block_info(CurrentTSO) = ares;
+ StgTSO_block_info(CurrentTSO) = reqID;
ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32);
%release StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I32;
=====================================
rts/RtsSymbols.c
=====================================
@@ -30,6 +30,7 @@
#include <shfolder.h> /* SHGetFolderPathW */
#include "IOManager.h"
#include "win32/AsyncWinIO.h"
+#include "win32/AsyncMIO.h"
#endif
#if defined(openbsd_HOST_OS)
@@ -168,6 +169,7 @@ extern char **environ;
SymI_HasProto(__stdio_common_vswprintf_s) \
SymI_HasProto(__stdio_common_vswprintf) \
SymI_HasProto(_errno) \
+ SymI_HasProto(rts_EINTR) \
/* see Note [Symbols for MinGW's printf] */ \
SymI_HasProto(_lock_file) \
SymI_HasProto(_unlock_file) \
=====================================
rts/Threads.c
=====================================
@@ -926,7 +926,7 @@ printThreadBlockage(StgTSO *tso)
switch (ACQUIRE_LOAD(&tso->why_blocked)) {
#if defined(mingw32_HOST_OS)
case BlockedOnDoProc:
- debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
+ debugBelch("is blocked on proc (request: %" FMT_Word ")", tso->block_info.async_reqID);
break;
#endif
#if !defined(THREADED_RTS)
=====================================
rts/include/rts/storage/TSO.h
=====================================
@@ -37,15 +37,6 @@ typedef StgWord64 StgThreadID;
*/
typedef unsigned int StgThreadReturnCode;
-#if defined(mingw32_HOST_OS)
-/* results from an async I/O request + its request ID. */
-typedef struct {
- unsigned int reqID;
- int len;
- int errCode;
-} StgAsyncIOResult;
-#endif
-
/* Reason for thread being blocked. See comment above struct StgTso_. */
typedef union {
StgClosure *closure;
@@ -57,7 +48,7 @@ typedef union {
StgAsyncIOOp *aiop;
StgTimeoutQueue *timeout;
#if defined(mingw32_HOST_OS)
- StgAsyncIOResult *async_result;
+ StgWord async_reqID;
#endif
#if !defined(THREADED_RTS)
StgWord target;
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -379,8 +379,6 @@ RTS_RET(stg_block_putmvar);
#if defined(mingw32_HOST_OS)
RTS_FUN_DECL(stg_block_async);
RTS_RET(stg_block_async);
-RTS_FUN_DECL(stg_block_async_void);
-RTS_RET(stg_block_async_void);
#endif
RTS_FUN_DECL(stg_block_stmwait);
RTS_FUN_DECL(stg_block_throwto);
=====================================
rts/win32/AsyncMIO.c
=====================================
@@ -8,16 +8,19 @@
* For the WINIO manager see base in the GHC.Event modules.
*/
-#if !defined(THREADED_RTS)
#include "Rts.h"
+#include <errno.h>
+#include "win32/AsyncMIO.h"
+
+#if !defined(THREADED_RTS)
+
#include "RtsUtils.h"
#include <windows.h>
#include <stdio.h>
#include "Schedule.h"
#include "Capability.h"
#include "IOManagerInternals.h"
-#include "win32/AsyncMIO.h"
#include "win32/MIOManager.h"
/*
@@ -299,14 +302,9 @@ start:
case BlockedOnRead:
case BlockedOnWrite:
case BlockedOnDoProc:
- if (tso->block_info.async_result->reqID == rID) {
- // Found the thread blocked waiting on request;
- // stodgily fill
- // in its result block.
- tso->block_info.async_result->len =
- completedTable[i].len;
- tso->block_info.async_result->errCode =
- completedTable[i].errCode;
+ if (tso->block_info.async_reqID == rID) {
+ HsInt len = completedTable[i].len;
+ HsInt errCode = completedTable[i].errCode;
// Drop the matched TSO from blocked_queue
if (prev) {
@@ -322,11 +320,14 @@ start:
// Terminates the run queue + this inner for-loop.
tso->_link = END_TSO_QUEUE;
tso->why_blocked = NotBlocked;
- // save the StgAsyncIOResult in the
- // stg_block_async_info stack frame, because
- // the block_info field will be overwritten by
- // pushOnRunQueue().
- tso->stackobj->sp[1] = (W_)tso->block_info.async_result;
+ // For stg_block_async frames (read/write/doProc),
+ // write len and errCode directly to the stack.
+ // For stg_block_noregs frames (delay), nothing
+ // to write.
+ if (tso->stackobj->sp[0] == (W_)&stg_block_async_info) {
+ tso->stackobj->sp[1] = (W_)len;
+ tso->stackobj->sp[2] = (W_)errCode;
+ }
pushOnRunQueue(&MainCapability, tso);
break;
}
@@ -389,3 +390,8 @@ resetAbandonRequestWait( void )
}
#endif /* !defined(THREADED_RTS) */
+
+HsInt rts_EINTR(void)
+{
+ return EINTR;
+}
=====================================
rts/win32/AsyncMIO.h
=====================================
@@ -27,3 +27,4 @@ extern int awaitRequests(bool wait);
extern void abandonRequestWait(void);
extern void resetAbandonRequestWait(void);
+extern HsInt rts_EINTR(void);
=====================================
testsuite/tests/concurrent/should_run/T26341.hs
=====================================
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -O -fno-full-laziness #-}
+
+import Control.Concurrent (threadDelay, myThreadId, forkIO, killThread)
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Exception
+import GHC.Exts
+
+compute :: Int
+compute = noinline unsafePerformIO $ do
+ mainThreadID <- myThreadId
+ _ <- forkIO $ do
+ threadDelay 500000
+ killThread mainThreadID
+ threadDelay 1000000
+ return 0
+
+main = do
+ catch (print compute) (\(e :: AsyncException) -> print $ "1:" ++ show e)
+ catch (print compute) (\(e :: AsyncException) -> print $ "2:" ++ show e)
+ print "done"
=====================================
testsuite/tests/concurrent/should_run/T26341.stdout
=====================================
@@ -0,0 +1,3 @@
+"1:thread killed"
+0
+"done"
=====================================
testsuite/tests/concurrent/should_run/T26341a.hs
=====================================
@@ -0,0 +1,75 @@
+-- Test that re-evaluating an AP_STACK from an interrupted async I/O call
+-- does not crash. On Windows non-threaded RTS, re-entry returns EINTR
+-- which readRawBufferPtr converts to IOException Interrupted. On the
+-- threaded RTS (any platform), the blocking read is re-attempted and
+-- succeeds because we write a byte to the pipe between evaluations.
+--
+-- Before the fix for #26341, re-evaluation on Windows would crash or read
+-- uninitialized memory from a freed StgAsyncIOResult.
+{-# OPTIONS_GHC -O -fno-full-laziness #-}
+
+import Control.Concurrent (threadDelay, myThreadId, forkIO, killThread, rtsSupportsBoundThreads)
+import Control.Exception
+import Data.IORef
+import Foreign
+import Foreign.C
+import GHC.Exts
+import GHC.IO.Exception (IOErrorType(..), IOException(..))
+import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)
+import System.Info (os)
+import System.IO.Unsafe (unsafePerformIO)
+import System.Process (createPipeFd)
+
+-- Store the write fd so main can feed data into the pipe between
+-- evaluations. On Unix this unblocks the re-entered read; on Windows
+-- stg_block_async returns EINTR regardless.
+{-# NOINLINE writeFdRef #-}
+writeFdRef :: IORef CInt
+writeFdRef = unsafePerformIO $ newIORef (-1)
+
+-- | A thunk whose unsafePerformIO blocks on a pipe read. A forked
+-- thread kills the main thread after 200ms, which creates an AP_STACK.
+{-# NOINLINE blockedRead #-}
+blockedRead :: ()
+blockedRead = noinline unsafePerformIO $ do
+ (readFd, writeFd) <- createPipeFd
+ writeIORef writeFdRef writeFd
+ buf <- mallocBytes 1
+ mainTid <- myThreadId
+ _ <- forkIO $ do
+ threadDelay 200000 -- 200ms
+ killThread mainTid
+ -- readRawBufferPtr dispatches to asyncReadRawBufferPtr on Windows
+ -- non-threaded RTS; on Unix it uses threadWaitRead + read().
+ _ <- readRawBufferPtr "blockedRead" (FD readFd 0) buf 0 1
+ return ()
+
+main :: IO ()
+main = do
+ -- First evaluation: the thunk blocks on the pipe read, gets killed.
+ catch (evaluate blockedRead)
+ (\(e :: AsyncException) -> putStrLn $ "caught: " ++ show e)
+
+ -- Write a byte so the re-entered read can complete on Unix.
+ wfd <- readIORef writeFdRef
+ buf <- mallocBytes 1
+ poke buf 0
+ _ <- writeRawBufferPtr "unblock" (FD wfd 0) buf 0 1
+
+ -- Second evaluation: AP_STACK re-enters.
+ -- Non-threaded Windows: asyncRead returns (-1, EINTR) → IOException
+ -- Threaded / Unix: read succeeds → returns normally
+ let expectEINTR = os == "mingw32" && not rtsSupportsBoundThreads
+ result <- try (evaluate blockedRead)
+ case result of
+ Left e
+ | Just ioe <- fromException e
+ , ioe_type (ioe :: IOException) == Interrupted
+ -> putStrLn "re-evaluated ok"
+ | otherwise
+ -> putStrLn $ "unexpected: " ++ show e
+ Right ()
+ | expectEINTR -> putStrLn "unexpected: expected EINTR"
+ | otherwise -> putStrLn "re-evaluated ok"
+
+ putStrLn "done"
=====================================
testsuite/tests/concurrent/should_run/T26341a.stdout
=====================================
@@ -0,0 +1,3 @@
+caught: thread killed
+re-evaluated ok
+done
=====================================
testsuite/tests/concurrent/should_run/T26341b.hs
=====================================
@@ -0,0 +1,101 @@
+-- Stress test for #26341: repeatedly interrupt async-blocked threads and
+-- re-enter their AP_STACKs. Before the fix, re-entering a thunk whose
+-- unsafePerformIO was blocked on an async I/O call (Windows non-threaded
+-- RTS) would read uninitialized memory or free a dangling pointer,
+-- because stg_block_async reserved a stack slot for a heap-allocated
+-- StgAsyncIOResult that became invalid after an async exception.
+--
+-- This test spawns many concurrent workers, each of which:
+-- 1. Creates a pipe.
+-- 2. Builds a thunk that blocks on a pipe read via unsafePerformIO.
+-- 3. Evaluates the thunk and kills it with an async exception.
+-- 4. Re-evaluates the thunk (AP_STACK re-entry).
+-- 5. Repeats many times.
+--
+-- On threaded RTS / Unix the re-entered read succeeds (we write a byte
+-- first). On Windows non-threaded RTS the re-entered async call returns
+-- EINTR. Both paths exercise the fixed stack-frame layout.
+{-# OPTIONS_GHC -O -fno-full-laziness #-}
+
+import Control.Concurrent
+import Control.Exception
+import Foreign
+import Foreign.C
+import GHC.Exts
+import GHC.IO.Exception (IOErrorType(..), IOException(..))
+import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)
+import System.IO (hFlush, stdout)
+import System.IO.Unsafe (unsafePerformIO)
+import System.Posix.Internals (c_close)
+import System.Process (createPipeFd)
+
+iterations :: Int
+iterations = 200
+
+workers :: Int
+workers = 4
+
+-- Each worker independently performs `iterations` rounds of:
+-- block on pipe read → interrupt → re-evaluate the AP_STACK.
+worker :: Int -> MVar () -> IO ()
+worker wid done = do
+ buf <- mallocBytes 1
+ let go 0 = return ()
+ go n = do
+ (readFd, writeFd) <- createPipeFd
+
+ -- Build a fresh thunk each iteration so we get a new AP_STACK.
+ let {-# NOINLINE blockedThunk #-}
+ blockedThunk :: ()
+ blockedThunk = noinline unsafePerformIO $ do
+ tid <- myThreadId
+ _ <- forkIO $ do
+ threadDelay 1000 -- 1ms: tight window
+ killThread tid
+ _ <- readRawBufferPtr "stress" (FD readFd 0) buf 0 1
+ return ()
+
+ -- First evaluation: block and get killed.
+ catch (evaluate blockedThunk)
+ (\(_ :: SomeException) -> return ())
+
+ -- Write a byte so the re-entered read can complete on
+ -- threaded RTS / Unix.
+ poke buf 0
+ _ <- writeRawBufferPtr "unblock" (FD writeFd 0) buf 0 1
+
+ -- Second evaluation: AP_STACK re-entry.
+ result <- try (evaluate blockedThunk)
+ case result of
+ Left e
+ | Just ioe <- fromException e
+ , ioe_type (ioe :: IOException) == Interrupted
+ -> return () -- expected on Windows non-threaded
+ | otherwise
+ -> throwIO (userError $
+ "worker " ++ show wid ++ " iteration " ++ show n ++
+ ": unexpected exception: " ++ show e)
+ Right () -> return () -- expected on threaded / Unix
+
+ -- Close the pipe fds.
+ _ <- c_close readFd
+ _ <- c_close writeFd
+
+ go (n - 1)
+
+ go iterations
+ putMVar done ()
+
+main :: IO ()
+main = do
+ dones <- mapM (\wid -> do
+ done <- newEmptyMVar
+ _ <- forkIO (worker wid done)
+ return done
+ ) [1..workers]
+
+ -- Wait for all workers to finish.
+ mapM_ takeMVar dones
+
+ putStrLn "stress test passed"
+ hFlush stdout
=====================================
testsuite/tests/concurrent/should_run/T26341b.stdout
=====================================
@@ -0,0 +1 @@
+stress test passed
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -309,3 +309,19 @@ test('hs_try_putmvar003',
# Check forkIO exception determinism under optimization
test('T13330', normal, compile_and_run, ['-O'])
+
+test('T26341', normal, compile_and_run, [''])
+
+# Test EINTR for async I/O interrupted by an exception (#26341)
+test('T26341a'
+ # test uses pipe operations which are not supported by the JS/wasm backends
+ , when(arch('wasm32') or arch('javascript'), skip)
+ , compile_and_run, ['-package process'])
+
+# Stress test: many threads repeatedly interrupt and re-enter async-blocked
+# thunks (#26341). Before the fix, this would crash due to dangling
+# StgAsyncIOResult pointers on the stack.
+test('T26341b'
+ # test uses pipe operations which are not supported by the JS/wasm backends
+ , when(arch('wasm32') or arch('javascript'), skip)
+ , compile_and_run, ['-package process'])
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -627,12 +627,7 @@ wanteds os = concat
-- Note that this conditional part only affects the C headers.
-- That's important, as it means we get the same PlatformConstants
-- type on all platforms.
- ,if os == Just Windows
- then concat [structSize C "StgAsyncIOResult"
- ,structField C "StgAsyncIOResult" "reqID"
- ,structField C "StgAsyncIOResult" "len"
- ,structField C "StgAsyncIOResult" "errCode"]
- else []
+ ,[]
-- struct HsIface
,structField C "HsIface" "Z0T_closure"
@@ -759,9 +754,6 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
"",
"#define PROFILING",
"#define THREADED_RTS",
- -- We need to define this if we want StgAsyncIOResult
- -- struct to be present after CPP
- --
-- FIXME: rts/PosixSource.h should include ghcplatform.h
-- which should set this. There is a mismatch host/target
-- again...
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcf092dda534cc38637d1f7920aa0da…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcf092dda534cc38637d1f7920aa0da…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] STM: don't create a transaction in the rhs of catchRetry# (#26028)
by Marge Bot (＠marge-bot) 27 Mar '26
by Marge Bot (＠marge-bot) 27 Mar '26
27 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
f8de456f by Sylvain Henry at 2026-03-27T04:43:22-04:00
STM: don't create a transaction in the rhs of catchRetry# (#26028)
We don't need to create a transaction for the rhs of (catchRetry#)
because contrary to the lhs we don't need to abort it on retry. Moreover
it is particularly harmful if we have code such as (#26028):
let cN = readTVar vN >> retry
tree = c1 `orElse` (c2 `orElse` (c3 `orElse` ...))
atomically tree
Because it will stack transactions for the rhss and the read-sets of all
the transactions will be iteratively merged in O(n^2) after the
execution of the most nested retry.
This is the second attempt at implementing this. The first attempt
triggered segfaults (#26291) and has been reverted.
Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com>
- - - - -
12 changed files:
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/STM.c
- rts/STM.h
- rts/Schedule.c
- + testsuite/tests/lib/stm/T26028.hs
- + testsuite/tests/lib/stm/T26028.stdout
- + testsuite/tests/lib/stm/T26291a.hs
- + testsuite/tests/lib/stm/T26291a.stdout
- + testsuite/tests/lib/stm/T26291b.hs
- + testsuite/tests/lib/stm/T26291b.stdout
- + testsuite/tests/lib/stm/all.T
Changes:
=====================================
rts/PrimOps.cmm
=====================================
@@ -1229,16 +1229,27 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
gcptr trec, outer, arg;
trec = StgTSO_trec(CurrentTSO);
- outer = StgTRecHeader_enclosing_trec(trec);
- (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
- if (r != 0) {
- // Succeeded (either first branch or second branch)
- StgTSO_trec(CurrentTSO) = outer;
- return (ret);
- } else {
- // Did not commit: abort and restart.
- StgTSO_trec(CurrentTSO) = outer;
- jump stg_abort();
+ if (running_alt_code != 1) {
+ // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup
+ // the nested transaction.
+ // See Note [catchRetry# implementation]
+ outer = StgTRecHeader_enclosing_trec(trec);
+ (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
+ if (r != 0) {
+ // Succeeded in first branch
+ StgTSO_trec(CurrentTSO) = outer;
+ return (ret);
+ } else {
+ // Did not commit: abort and restart.
+ StgTSO_trec(CurrentTSO) = outer;
+ jump stg_abort();
+ }
+ }
+ else {
+ // nothing to do in the rhs code of catchRetry# lhs rhs, it's already
+ // using the parent transaction (not a nested one).
+ // See Note [catchRetry# implementation]
+ return (ret);
}
}
@@ -1471,21 +1482,26 @@ retry_pop_stack:
outer = StgTRecHeader_enclosing_trec(trec);
if (frame_type == CATCH_RETRY_FRAME) {
- // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
- ASSERT(outer != NO_TREC);
- // Abort the transaction attempting the current branch
- ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
- ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
+ // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME
+
if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
- // Retry in the first branch: try the alternative
- ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
- StgTSO_trec(CurrentTSO) = trec;
+ // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested
+ // transaction. See Note [catchRetry# implementation]
+
+ // check that we have a parent transaction
+ ASSERT(outer != NO_TREC);
+
+ // Abort the nested transaction
+ ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+ ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
+
+ // As we are retrying in the lhs code, we must now try the rhs code
+ StgTSO_trec(CurrentTSO) = outer;
StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
R1 = StgCatchRetryFrame_alt_code(frame);
jump stg_ap_v_fast [R1];
} else {
- // Retry in the alternative code: propagate the retry
- StgTSO_trec(CurrentTSO) = outer;
+ // Retry in the rhs code: propagate the retry
Sp = Sp + SIZEOF_StgCatchRetryFrame;
goto retry_pop_stack;
}
=====================================
rts/RaiseAsync.c
=====================================
@@ -1043,8 +1043,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
}
case CATCH_STM_FRAME:
- case CATCH_RETRY_FRAME:
- // CATCH frames within an atomically block: abort the
+ // CATCH_STM frame within an atomically block: abort the
// inner transaction and continue. Eventually we will
// hit the outer transaction that will get frozen (see
// above).
@@ -1056,14 +1055,30 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
{
StgTRecHeader *trec = tso -> trec;
StgTRecHeader *outer = trec -> enclosing_trec;
- debugTraceCap(DEBUG_stm, cap,
- "found atomically block delivering async exception");
+ debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");
stmAbortTransaction(cap, trec);
stmFreeAbortedTRec(cap, trec);
tso -> trec = outer;
break;
};
+ case CATCH_RETRY_FRAME:
+ // CATCH_RETRY frame within an atomically block: if we're executing
+ // the lhs code, abort the inner transaction and continue; if we're
+ // executing the rhs, continue (no nested transaction to abort. See
+ // Note [catchRetry# implementation]). Eventually we will hit the
+ // outer transaction that will get frozen (see above).
+ //
+ // As for the CATCH_STM_FRAME case above, we do not care
+ // whether the transaction is valid or not because its
+ // possible validity cannot have caused the exception
+ // and will not be visible after the abort.
+ {
+ debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame");
+ stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)frame);
+ break;
+ };
+
default:
// see Note [Update async masking state on unwind] in Schedule.c
if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {
=====================================
rts/STM.c
=====================================
@@ -961,6 +961,46 @@ void stmFreeAbortedTRec(Capability *cap,
TRACE("%p : stmFreeAbortedTRec done", trec);
}
+/*
+Note [catchRetry# implementation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+catchRetry# creates a nested transaction for its lhs:
+- if the lhs transaction succeeds:
+ - the lhs transaction is committed
+ - its read-variables are merged with those of the parent transaction
+ - the rhs code is ignored
+- if the lhs transaction retries:
+ - the lhs transaction is aborted
+ - its read-variables are merged with those of the parent transaction
+ - the rhs code is executed directly in the parent transaction (see #26028).
+
+So note that:
+- lhs code uses a nested transaction
+- rhs code doesn't use a nested transaction
+
+We have to take which case we're in into account (using the running_alt_code
+field of the catchRetry frame) in catchRetry's entry code, in retry#
+implementation, and also when an async exception is received (to cleanup the
+right number of transactions).
+*/
+
+/* Called when unwinding past a CATCH_RETRY_FRAME.
+ * Only aborts the transaction if we're executing the lhs (running_alt_code=0),
+ * because rhs code uses the parent transaction directly with no nested trec.
+ * See Note [catchRetry# implementation].
+ */
+void stmAbortNestedCatchRetryTransaction(Capability *cap,
+ StgTSO *tso,
+ StgCatchRetryFrame *frame) {
+ if (!frame->running_alt_code) {
+ StgTRecHeader *trec = tso->trec;
+ StgTRecHeader *outer = trec->enclosing_trec;
+ stmAbortTransaction(cap, trec);
+ stmFreeAbortedTRec(cap, trec);
+ tso->trec = outer;
+ }
+}
+
/*......................................................................*/
void stmCondemnTransaction(Capability *cap,
=====================================
rts/STM.h
=====================================
@@ -67,6 +67,9 @@ StgTRecHeader *stmStartNestedTransaction(Capability *cap, StgTRecHeader *outer
void stmAbortTransaction(Capability *cap, StgTRecHeader *trec);
void stmFreeAbortedTRec(Capability *cap, StgTRecHeader *trec);
+void stmAbortNestedCatchRetryTransaction(Capability *cap,
+ StgTSO *tso,
+ StgCatchRetryFrame *frame);
/*
* Ensure that a subsequent commit / validation will fail. We use this
=====================================
rts/Schedule.c
=====================================
@@ -3088,14 +3088,9 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
return STOP_FRAME;
case CATCH_RETRY_FRAME: {
- StgTRecHeader *trec = tso -> trec;
- StgTRecHeader *outer = trec -> enclosing_trec;
debugTrace(DEBUG_stm,
"found CATCH_RETRY_FRAME at %p during raise", p);
- debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer);
- stmAbortTransaction(cap, trec);
- stmFreeAbortedTRec(cap, trec);
- tso -> trec = outer;
+ stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)p);
p = next;
continue;
}
@@ -3248,14 +3243,9 @@ findAtomicallyFrameHelper (Capability *cap, StgTSO *tso)
return ATOMICALLY_FRAME;
case CATCH_RETRY_FRAME: {
- StgTRecHeader *trec = tso -> trec;
- StgTRecHeader *outer = trec -> enclosing_trec;
debugTrace(DEBUG_stm,
"found CATCH_RETRY_FRAME at %p while aborting after orElse", p);
- debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer);
- stmAbortTransaction(cap, trec);
- stmFreeAbortedTRec(cap, trec);
- tso -> trec = outer;
+ stmAbortNestedCatchRetryTransaction(cap, tso, (StgCatchRetryFrame *)p);
p = next;
continue;
}
=====================================
testsuite/tests/lib/stm/T26028.hs
=====================================
@@ -0,0 +1,23 @@
+module Main where
+
+import GHC.Conc
+
+forever :: IO String
+forever = delay 10 >> forever
+
+terminates :: IO String
+terminates = delay 1 >> pure "terminates"
+
+delay s = threadDelay (1000000 * s)
+
+async :: IO a -> IO (STM a)
+async a = do
+ var <- atomically (newTVar Nothing)
+ forkIO (a >>= atomically . writeTVar var . Just)
+ pure (readTVar var >>= maybe retry pure)
+
+main :: IO ()
+main = do
+ x <- mapM async $ terminates : replicate 50000 forever
+ r <- atomically (foldr1 orElse x)
+ print r
=====================================
testsuite/tests/lib/stm/T26028.stdout
=====================================
@@ -0,0 +1 @@
+"terminates"
=====================================
testsuite/tests/lib/stm/T26291a.hs
=====================================
@@ -0,0 +1,15 @@
+module Main where
+
+import Control.Concurrent.STM
+import Control.Exception
+
+main :: IO ()
+main = do
+ result <- try @SomeException $ atomically $
+ -- LHS retries → CATCH_RETRY_FRAME gets running_alt_code=1, RHS executes.
+ -- RHS throws → raiseExceptionHelper walks the stack, finds the
+ -- CATCH_RETRY_FRAME (running_alt_code=1), and must NOT abort tso->trec.
+ orElse retry (throwSTM (ErrorCall "test"))
+ case result of
+ Left _ -> putStrLn "OK"
+ Right _ -> putStrLn "impossible"
=====================================
testsuite/tests/lib/stm/T26291a.stdout
=====================================
@@ -0,0 +1 @@
+OK
=====================================
testsuite/tests/lib/stm/T26291b.hs
=====================================
@@ -0,0 +1,42 @@
+-- Test for the findAtomicallyFrameHelper crash when running_alt_code=1.
+--
+-- findAtomicallyFrameHelper is called by stg_abort, which fires when a nested
+-- transaction's stmCommitNestedTransaction fails (due to a concurrent TVar
+-- write conflicting with the nested trec's read set). If the walk encounters
+-- a CATCH_RETRY_FRAME with running_alt_code=1, the old code unconditionally
+-- called stmAbortTransaction on tso->trec, which is the *parent* transaction
+-- (no nested trec exists for the RHS). That freed the parent trec, leaving
+-- tso->trec as garbage; stg_abort then dereferenced it and crashed.
+--
+-- The structure that exercises this:
+-- outer orElse: LHS retries → RHS runs (outer CATCH_RETRY_FRAME has running_alt_code=1)
+-- inner orElse: LHS reads a TVar in a nested trec and tries to commit
+-- → if a concurrent writer invalidates the read, stmCommitNestedTransaction fails
+-- → stg_abort → findAtomicallyFrameHelper encounters the outer CATCH_RETRY_FRAME
+-- (running_alt_code=1) → crash without the fix.
+module Main where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+
+main :: IO ()
+main = do
+ tv <- newTVarIO (0 :: Int)
+
+ -- Continuously modify tv to provoke nested-commit failures.
+ _ <- forkIO $ let loop = atomically (modifyTVar' tv (+1)) >> loop in loop
+
+ -- Run the critical orElse pattern many times. Each iteration the inner LHS
+ -- reads tv (nested trec) and tries to commit; concurrent writes will
+ -- occasionally cause the commit to fail and trigger stg_abort.
+ let loop 0 = return ()
+ loop n = do
+ _ <- atomically $
+ orElse
+ retry -- outer LHS: always retries
+ (orElse (readTVar tv) (return 0)) -- outer RHS (running_alt_code=1):
+ -- inner LHS reads tv (nested trec)
+ loop (n - 1)
+ loop (100000 :: Int)
+
+ putStrLn "OK"
=====================================
testsuite/tests/lib/stm/T26291b.stdout
=====================================
@@ -0,0 +1 @@
+OK
=====================================
testsuite/tests/lib/stm/all.T
=====================================
@@ -0,0 +1,3 @@
+test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2'])
+test('T26291a', normal, compile_and_run, ['-O2'])
+test('T26291b', only_ways(['threaded1']), compile_and_run, ['-O2'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8de456fb914adfe7994af80f769b28…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8de456fb914adfe7994af80f769b28…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Extend HsExpr with the StarIsType syntax (#26587, #26967)
by Marge Bot (＠marge-bot) 27 Mar '26
by Marge Bot (＠marge-bot) 27 Mar '26
27 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
66e5e324 by Vladislav Zavialov at 2026-03-27T04:42:25-04:00
Extend HsExpr with the StarIsType syntax (#26587, #26967)
This patch allows kinds of the form `k -> *` and `* -> k` to occur in
expression syntax, i.e. to be used as required type arguments.
For example:
{-# LANGUAGE RequiredTypeArguments, StarIsType #-}
x1 = f (* -> * -> *)
x2 = f (forall k. k -> *)
x3 = f ((* -> *) -> Constraint)
Summary of the changes:
* Introduce the HsStar constructor of HsExpr and its extension field XStar.
It is analogous to HsStarTy in HsType.
* Refactor HsStarTy to store the unicode flag as TokStar, defined as
type TokStar = EpUniToken "*" "★" -- similar to TokForall, TokRArrow, etc.
The token is stored in the extension field and replaces the Bool field.
* Extend the `infixexp2` nonterminal to parse `*` as a direct argument of `->`.
This is more limited than the full StarIsType syntax, but has the nice
property of not conflicting with the multiplication operator `a * b`.
Test case: T26967 T26967_tyop
- - - - -
37 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Type.hs
- docs/users_guide/exts/required_type_arguments.rst
- + testsuite/tests/vdq-rta/should_compile/T26967.hs
- + testsuite/tests/vdq-rta/should_compile/T26967.stderr
- + testsuite/tests/vdq-rta/should_compile/T26967_tyop.hs
- + testsuite/tests/vdq-rta/should_compile/T26967_tyop.stderr
- testsuite/tests/vdq-rta/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66e5e3245a26bdaadfaab5358df04f9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66e5e3245a26bdaadfaab5358df04f9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Remove backwards compatibility pattern synonym `ModLocation`
by Marge Bot (＠marge-bot) 27 Mar '26
by Marge Bot (＠marge-bot) 27 Mar '26
27 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b26bb2ea by VeryMilkyJoe at 2026-03-27T04:41:38-04:00
Remove backwards compatibility pattern synonym `ModLocation`
Fixes #24932
- - - - -
5 changed files:
- compiler/GHC.hs
- compiler/GHC/CoreToStg/AddImplicitBinds.hs
- compiler/GHC/Unit/Module/Location.hs
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -79,7 +79,13 @@ module GHC (
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
- pattern ModLocation,
+ ml_hs_file,
+ ml_hi_file,
+ ml_dyn_hi_file,
+ ml_obj_file,
+ ml_dyn_obj_file,
+ ml_hie_file,
+ ml_bytecode_file,
getModSummary,
getModuleGraph,
isLoaded,
@@ -1575,7 +1581,7 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
-- a module by using 'getModSummary'
--
-- XXX: Explain pre-conditions
-getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)
+getModuleSourceAndFlags :: ModSummary -> IO (FilePath, StringBuffer, DynFlags)
getModuleSourceAndFlags m = do
case ml_hs_file $ ms_location m of
Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))
=====================================
compiler/GHC/CoreToStg/AddImplicitBinds.hs
=====================================
@@ -10,7 +10,7 @@ import GHC.Prelude
import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) )
-import GHC.Unit( ModLocation(..) )
+import GHC.Unit( ModLocation(..), ml_hs_file )
import GHC.Core
import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId )
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -2,22 +2,19 @@
{-# LANGUAGE ViewPatterns #-}
-- | Module location
module GHC.Unit.Module.Location
- ( ModLocation
- ( ..
- , ml_hs_file
- , ml_hi_file
- , ml_dyn_hi_file
- , ml_obj_file
- , ml_dyn_obj_file
- , ml_hie_file
- , ml_bytecode_file
- )
- , pattern ModLocation
+ ( ModLocation(..)
, addBootSuffix
, addBootSuffixLocn
, addBootSuffixLocnOut
, removeBootSuffix
, mkFileSrcSpan
+ , ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ , ml_bytecode_file
)
where
@@ -128,33 +125,30 @@ mkFileSrcSpan mod_loc
-- Helpers for backwards compatibility
-- ----------------------------------------------------------------------------
-{-# COMPLETE ModLocation #-}
-
-pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation
-pattern ModLocation
- { ml_hs_file
- , ml_hi_file
- , ml_dyn_hi_file
- , ml_obj_file
- , ml_dyn_obj_file
- , ml_hie_file
- , ml_bytecode_file
- } <- OsPathModLocation
- { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file)
- , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file)
- , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file)
- , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file)
- , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file)
- , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file)
- , ml_bytecode_file_ospath = (unsafeDecodeUtf -> ml_bytecode_file)
- } where
- ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file ml_bytecode_file
- = OsPathModLocation
- { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file
- , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file
- , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file
- , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file
- , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file
- , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file
- , ml_bytecode_file_ospath = unsafeEncodeUtf ml_bytecode_file
- }
+ml_hs_file :: ModLocation -> Maybe FilePath
+{-# INLINE ml_hs_file #-}
+ml_hs_file = fmap unsafeDecodeUtf . ml_hs_file_ospath
+
+ml_hi_file :: ModLocation -> FilePath
+{-# INLINE ml_hi_file #-}
+ml_hi_file = unsafeDecodeUtf . ml_hi_file_ospath
+
+ml_dyn_hi_file :: ModLocation -> FilePath
+{-# INLINE ml_dyn_hi_file #-}
+ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_ospath
+
+ml_obj_file :: ModLocation -> FilePath
+{-# INLINE ml_obj_file #-}
+ml_obj_file = unsafeDecodeUtf . ml_obj_file_ospath
+
+ml_dyn_obj_file :: ModLocation -> FilePath
+{-# INLINE ml_dyn_obj_file #-}
+ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_ospath
+
+ml_hie_file :: ModLocation -> FilePath
+{-# INLINE ml_hie_file #-}
+ml_hie_file = unsafeDecodeUtf . ml_hie_file_ospath
+
+ml_bytecode_file :: ModLocation -> FilePath
+{-# INLINE ml_bytecode_file #-}
+ml_bytecode_file = unsafeDecodeUtf . ml_bytecode_file_ospath
=====================================
testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
=====================================
@@ -31,7 +31,7 @@ convertToFixed (ModuleNodeCompile ms) =
-- with the module summary information
let modName = ms_mod_name ms
modLoc = ms_location ms
- in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing}
+ in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing }
-- | Load a module graph and report the result
=====================================
testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
=====================================
@@ -29,7 +29,7 @@ convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo
convertToFixed (ModuleNodeCompile ms) =
let modName = ms_mod_name ms
modLoc = ms_location ms
- in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing}
+ in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing }
-- | Test a module graph and report if it matches expected invariant violations
testModuleGraph :: String -> ModuleGraph -> [ModuleGraphInvariantError] -> Ghc ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b26bb2ea9516782465a1978d0feeadc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b26bb2ea9516782465a1978d0feeadc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
27 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
404b71c1 by Luite Stegeman at 2026-03-27T04:40:49-04:00
Fix assert in Interpreter.c
If we skip exactly the number of words on the stack we end up on
the first word in the next chunk.
- - - - -
a85bd503 by Luite Stegeman at 2026-03-27T04:40:49-04:00
Support arbitrary size unboxed tuples in bytecode
This stores the size (number of words on the stack) of the next
expected tuple in the TSO, ctoi_spill_size field, eliminating
the need of stg_ctoi_tN frames for each size.
Note: On 32 bit platform there is still a bytecode tuple size
limit of 255 words on the stack.
Fixes #26946
- - - - -
e2209031 by Luite Stegeman at 2026-03-27T04:40:49-04:00
Add specialized frames for small tuples
Small tuples are now returned more efficiently to the interpreter.
They use one less word of stack space and don't need manipulation
of the TSO anymore.
- - - - -
25 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/StgToByteCode.hs
- rts/Apply.cmm
- rts/Continuation.c
- rts/ContinuationOps.cmm
- rts/Interpreter.c
- rts/Printer.c
- rts/RaiseAsync.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/StgMiscClosures.cmm
- rts/Threads.c
- rts/Threads.h
- rts/include/rts/Bytecodes.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- + testsuite/tests/bytecode/tuplestress/ByteCode.hs
- + testsuite/tests/bytecode/tuplestress/Common.hs-incl
- + testsuite/tests/bytecode/tuplestress/Obj.hs
- + testsuite/tests/bytecode/tuplestress/TupleStress.hs
- + testsuite/tests/bytecode/tuplestress/TupleStress.stdout
- + testsuite/tests/bytecode/tuplestress/all.T
- utils/deriveConstants/Main.hs
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -973,13 +973,16 @@ return_non_tuple V32 = error "return_non_tuple: vector"
return_non_tuple V64 = error "return_non_tuple: vector"
{-
- we can only handle up to a fixed number of words on the stack,
- because we need a stg_ctoi_tN stack frame for each size N. See
- Note [unboxed tuple bytecodes and tuple_BCO].
+ The maximum number of words that can be spilled on the stack for
+ a tuple return. This is limited by the encoding of the stack
+ spill size in the call_info word (used by stg_ret_t):
- If needed, you can support larger tuples by adding more in
- Jumps.cmm, StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and
- raising this limit.
+ - On 32-bit platforms: 8-bit (bits 24-31), max 255
+ - On 64-bit platforms: 40-bit (bits 24-63)
+
+ The stg_ctoi_t frame itself has no size limit since it reads the
+ spill count from the TSO's ctoi_tuple_spill_words field. See
+ Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm.
Note that the limit is the number of words passed on the stack.
If the calling convention passes part of the tuple in registers, the
@@ -987,8 +990,10 @@ return_non_tuple V64 = error "return_non_tuple: vector"
take multiple words on the stack (for example Double# on a 32 bit
platform).
-}
-maxTupleReturnNativeStackSize :: WordOff
-maxTupleReturnNativeStackSize = 62
+maxTupleReturnNativeStackSize :: Platform -> WordOff
+maxTupleReturnNativeStackSize platform = case platformWordSize platform of
+ PW4 -> 255
+ PW8 -> 1099511627775
{-
Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall
@@ -997,9 +1002,10 @@ maxTupleReturnNativeStackSize = 62
See Note [GHCi and native call registers] for more information.
-}
-mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32
+mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word64
mkNativeCallInfoSig platform NativeCallInfo{..}
- | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize
+ | nativeCallType == NativeTupleReturn
+ && nativeCallStackSpillSize > maxTupleReturnNativeStackSize platform
= pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler"
(ppr nativeCallStackSpillSize <+> text "stack words." <+>
text "Use -fobject-code to get around this limit"
@@ -1008,8 +1014,9 @@ mkNativeCallInfoSig platform NativeCallInfo{..}
= -- 24 bits for register bitmap
assertPpr (length argRegs <= 24) (text "too many registers for bitmap:" <+> ppr (length argRegs))
- -- 8 bits for continuation offset (only for NativeTupleReturn)
- assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset)
+ -- continuation offset must fit in available bits above the bitmap
+ assertPpr (cont_offset <= fromIntegral (maxTupleReturnNativeStackSize platform))
+ (text "continuation offset too large:" <+> ppr cont_offset)
-- all regs accounted for
assertPpr (all (`elem` (map fst argRegs)) (regSetToList nativeCallRegs))
@@ -1023,12 +1030,12 @@ mkNativeCallInfoSig platform NativeCallInfo{..}
foldl' reg_bit 0 argRegs .|. (cont_offset `shiftL` 24)
where
- cont_offset :: Word32
+ cont_offset :: Word64
cont_offset
| nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize
| otherwise = 0 -- there is no continuation for primcalls
- reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
+ reg_bit :: Word64 -> (GlobalReg, Int) -> Word64
reg_bit x (r, n)
| r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n
| otherwise = x
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -488,11 +488,12 @@ bciStackUse PUSH_BCO{} = 1
bciStackUse (PUSH_ALTS bco _) = 2 {- profiling only, restore CCCS -} +
3 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_TUPLE bco info _) =
- -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t)
- -- tuple
- -- (call_info, tuple_bco, stg_ret_t)
+ -- ctoi frame: small (4 words) or generic (5 words, with old_spill)
+ -- + tuple data + ret_t frame (3 words)
1 {- profiling only -} +
- 7 + fromIntegral (nativeCallSize info) + protoBCOStackUse bco
+ ctoi_frame + 3 + fromIntegral (nativeCallSize info) + protoBCOStackUse bco
+ where ctoi_frame | nativeCallStackSpillSize info <= mAX_SMALL_TUPLE_CTOI = 4
+ | otherwise = 5
bciStackUse (PUSH_PAD8) = 1 -- overapproximation
bciStackUse (PUSH_PAD16) = 1 -- overapproximation
bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -6,6 +6,8 @@
-- (c) The University of Glasgow 2002-2006
--
+#include "Bytecodes.h"
+
-- | Bytecode assembler types
module GHC.ByteCode.Types
( CompiledByteCode(..), seqCompiledByteCode
@@ -13,6 +15,7 @@ module GHC.ByteCode.Types
, FFIInfo(..)
, RegBitmap(..)
, NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo
+ , mAX_SMALL_TUPLE_CTOI
, ByteOff(..), WordOff(..), HalfWord(..)
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
@@ -160,6 +163,12 @@ voidTupleReturnInfo = NativeCallInfo NativeTupleReturn 0 emptyRegSet 0
voidPrimCallInfo :: NativeCallInfo
voidPrimCallInfo = NativeCallInfo NativePrimCall 0 emptyRegSet 0
+-- | Maximum nativeCallStackSpillSize for which we use a small
+-- stg_ctoi_tN frame (no old_spill slot, no TSO access) instead of
+-- the generic stg_ctoi_t frame.
+mAX_SMALL_TUPLE_CTOI :: WordOff
+mAX_SMALL_TUPLE_CTOI = MAX_SMALL_TUPLE_CTOI
+
type ItblEnv = NameEnv (Name, ItblPtr)
type AddrEnv = NameEnv (Name, AddrPtr)
-- We need the Name in the range so we know which
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -1128,7 +1128,7 @@ doCase d s p scrut bndr alts
-- 'Simple' tuples with at most one non-void component,
-- like (# Word# #) or (# Int#, State# RealWorld #) do not have a
-- tuple return frame. This is because (# foo #) and (# foo, Void# #)
- -- have the same runtime rep. We have more efficient specialized
+ -- have the same runtime rep. We have more efficient small
-- return frames for the situations with one non-void element.
non_void_arg_reps = typeArgReps platform bndr_ty
@@ -1146,10 +1146,19 @@ doCase d s p scrut bndr alts
-- When an alt is entered, it assumes the returned value is
-- on top of the itbl; see Note [Return convention for non-tuple values]
-- for details.
+ -- Whether this tuple return uses a small stg_ctoi_tN frame
+ -- (no old_spill slot, no TSO access) instead of the generic
+ -- stg_ctoi_t frame.
+ small_tuple_frame :: Bool
+ small_tuple_frame =
+ ubx_tuple_frame && nativeCallStackSpillSize call_info <= mAX_SMALL_TUPLE_CTOI
+
ctoi_frame_header_w :: WordOff
ctoi_frame_header_w
- | ubx_tuple_frame =
+ | small_tuple_frame =
if profiling then 5 else 4
+ | ubx_tuple_frame =
+ if profiling then 6 else 5
| otherwise = 2
-- The size of the ret_*_info frame header, whose frame returns the
@@ -1293,10 +1302,16 @@ doCase d s p scrut bndr alts
-- case-of-case expressions, which is the only time we can be compiling a
-- case expression with s /= 0.
- -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
+ -- unboxed tuples get extra words in the ctoi frame after the
+ -- info pointer and cont_BCO:
+ -- call_info, tuple_BCO, [old_spill], [CCCS]
+ -- tuple_BCO at position 1 is a pointer.
+ -- Small frames (stg_ctoi_tN) omit the old_spill slot.
(extra_pointers, extra_slots)
- | ubx_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS
- | ubx_tuple_frame = ([1], 2) -- call_info, tuple_BCO
+ | small_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS
+ | small_tuple_frame = ([1], 2) -- call_info, tuple_BCO
+ | ubx_tuple_frame && profiling = ([1], 4) -- call_info, tuple_BCO, old_spill, CCCS
+ | ubx_tuple_frame = ([1], 3) -- call_info, tuple_BCO, old_spill
| otherwise = ([], 0)
bitmap_size :: WordOff
@@ -1535,14 +1550,12 @@ for the call and and a stack offset. The layout is as follows:
list is active. Bit 1 for the
second register in the list and so on.
- - bit 24-31: Unsigned byte indicating the stack offset
+ - bit 24+: Unsigned value indicating the stack offset
of the continuation in words. For tuple returns
this is the number of words returned on the
stack. For primcalls this field is unused, since
we don't jump to a continuation.
-The upper 32 bits on 64 bit platforms are currently unused.
-
If a register is smaller than a word on the stack (for example a
single precision float on a 64 bit system), then the stack slot
is padded to a whole word.
@@ -1551,8 +1564,8 @@ is padded to a whole word.
If a tuple is returned in three registers and an additional two
words on the stack, then three bits in the register bitmap
- (bits 0-23) would be set. And bit 24-31 would be
- 00000010 (two in binary).
+ (bits 0-23) would be set. And the stack offset (bits 24+) would
+ encode the value two.
The values on the stack before a call to POP_ARG_REGS would
be as follows:
@@ -1580,7 +1593,7 @@ is padded to a whole word.
At this point all the arguments are in place and we are ready
to jump to the continuation, the location (offset from Sp) of
- which is found by inspecting the value of bits 24-31. In this
+ which is found by inspecting the value of bits 24+. In this
case the offset is two words.
On x86_64, the double precision (Dn) and single precision
@@ -1734,9 +1747,11 @@ Note [unboxed tuple bytecodes and tuple_BCO]
* tuple_BCO: see below
The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE
- instruction is executed, followed by stg_ctoi_tN_info, with N depending
- on the number of stack words used by the tuple in the GHC native calling
- convention. N is derived from call_info.
+ instruction is executed, followed by stg_ctoi_t_info. It also saves
+ the old ctoi_tuple_spill_words value from the TSO in the frame and sets
+ the TSO field to the number of stack words used by the tuple in the
+ GHC native calling convention. This spill count is derived from
+ call_info.
For example if we expect a tuple with three words on the stack, the stack
looks as follows after PUSH_ALTS_TUPLE:
@@ -1747,12 +1762,13 @@ Note [unboxed tuple bytecodes and tuple_BCO]
cont_free_var_2
...
cont_free_var_n
+ old_spill
call_info
tuple_BCO
cont_BCO
- stg_ctoi_t3_info <- Sp
+ stg_ctoi_t_info <- Sp
- If the tuple is returned by object code, stg_ctoi_t3 will deal with
+ If the tuple is returned by object code, stg_ctoi_t will deal with
adjusting the stack pointer and converting the tuple to the bytecode
calling convention. See Note [GHCi unboxed tuples stack spills] for more
details.
=====================================
rts/Apply.cmm
=====================================
@@ -719,6 +719,8 @@ for:
goto for;
}
+ ccall restoreStackInvariants(CurrentTSO "ptr", Sp "ptr", Words);
+
// Off we go!
TICK_ENT_VIA_NODE();
@@ -776,6 +778,8 @@ for:
goto for;
}
+ ccall restoreStackInvariants(CurrentTSO "ptr", Sp "ptr", Words);
+
// Off we go!
TICK_ENT_VIA_NODE();
=====================================
rts/Continuation.c
=====================================
@@ -457,6 +457,11 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT
}
}
+ // see Note [GHCi unboxed tuples stack spills]
+ if (info_ptr == &stg_ctoi_t_info) {
+ tso->ctoi_tuple_spill_words = frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET];
+ }
+
// Advance to the next frame.
frame += stack_frame_sizeW((StgClosure *)frame);
}
=====================================
rts/ContinuationOps.cmm
=====================================
@@ -200,6 +200,8 @@ stg_CONTINUATION_apply // explicit stack
Sp_adj(-new_stack_words);
prim %memcpy(Sp, p, WDS(new_stack_words), SIZEOF_W);
+ ccall restoreStackInvariants(CurrentTSO "ptr", Sp "ptr", new_stack_words);
+
TICK_UNKNOWN_CALL();
TICK_SLOW_CALL_fast_v();
=====================================
rts/Interpreter.c
=====================================
@@ -572,72 +572,6 @@ void interp_shutdown( void ){
#endif
-const StgPtr ctoi_tuple_infos[] = {
- (StgPtr) &stg_ctoi_t0_info,
- (StgPtr) &stg_ctoi_t1_info,
- (StgPtr) &stg_ctoi_t2_info,
- (StgPtr) &stg_ctoi_t3_info,
- (StgPtr) &stg_ctoi_t4_info,
- (StgPtr) &stg_ctoi_t5_info,
- (StgPtr) &stg_ctoi_t6_info,
- (StgPtr) &stg_ctoi_t7_info,
- (StgPtr) &stg_ctoi_t8_info,
- (StgPtr) &stg_ctoi_t9_info,
- (StgPtr) &stg_ctoi_t10_info,
- (StgPtr) &stg_ctoi_t11_info,
- (StgPtr) &stg_ctoi_t12_info,
- (StgPtr) &stg_ctoi_t13_info,
- (StgPtr) &stg_ctoi_t14_info,
- (StgPtr) &stg_ctoi_t15_info,
- (StgPtr) &stg_ctoi_t16_info,
- (StgPtr) &stg_ctoi_t17_info,
- (StgPtr) &stg_ctoi_t18_info,
- (StgPtr) &stg_ctoi_t19_info,
- (StgPtr) &stg_ctoi_t20_info,
- (StgPtr) &stg_ctoi_t21_info,
- (StgPtr) &stg_ctoi_t22_info,
- (StgPtr) &stg_ctoi_t23_info,
- (StgPtr) &stg_ctoi_t24_info,
- (StgPtr) &stg_ctoi_t25_info,
- (StgPtr) &stg_ctoi_t26_info,
- (StgPtr) &stg_ctoi_t27_info,
- (StgPtr) &stg_ctoi_t28_info,
- (StgPtr) &stg_ctoi_t29_info,
- (StgPtr) &stg_ctoi_t30_info,
- (StgPtr) &stg_ctoi_t31_info,
- (StgPtr) &stg_ctoi_t32_info,
- (StgPtr) &stg_ctoi_t33_info,
- (StgPtr) &stg_ctoi_t34_info,
- (StgPtr) &stg_ctoi_t35_info,
- (StgPtr) &stg_ctoi_t36_info,
- (StgPtr) &stg_ctoi_t37_info,
- (StgPtr) &stg_ctoi_t38_info,
- (StgPtr) &stg_ctoi_t39_info,
- (StgPtr) &stg_ctoi_t40_info,
- (StgPtr) &stg_ctoi_t41_info,
- (StgPtr) &stg_ctoi_t42_info,
- (StgPtr) &stg_ctoi_t43_info,
- (StgPtr) &stg_ctoi_t44_info,
- (StgPtr) &stg_ctoi_t45_info,
- (StgPtr) &stg_ctoi_t46_info,
- (StgPtr) &stg_ctoi_t47_info,
- (StgPtr) &stg_ctoi_t48_info,
- (StgPtr) &stg_ctoi_t49_info,
- (StgPtr) &stg_ctoi_t50_info,
- (StgPtr) &stg_ctoi_t51_info,
- (StgPtr) &stg_ctoi_t52_info,
- (StgPtr) &stg_ctoi_t53_info,
- (StgPtr) &stg_ctoi_t54_info,
- (StgPtr) &stg_ctoi_t55_info,
- (StgPtr) &stg_ctoi_t56_info,
- (StgPtr) &stg_ctoi_t57_info,
- (StgPtr) &stg_ctoi_t58_info,
- (StgPtr) &stg_ctoi_t59_info,
- (StgPtr) &stg_ctoi_t60_info,
- (StgPtr) &stg_ctoi_t61_info,
- (StgPtr) &stg_ctoi_t62_info,
-};
-
#if defined(PROFILING)
//
@@ -710,7 +644,7 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
// How many words were on the stack
stackWords = (StgWord *)frame - (StgWord *) Sp;
- ASSERT(offset_words > stackWords);
+ ASSERT(offset_words >= stackWords);
// Recursive, in the very unlikely case we have to traverse two
// stack chunks.
@@ -1317,10 +1251,12 @@ do_return_nonpointer:
things on the stack. Therefore we store the CCCS inside the
stg_ctoi_t frame.
- If we have a tuple being returned, the stack looks like this:
+ If we have a tuple being returned, the stack looks like this
+ for the generic stg_ctoi_t frame:
...
- <CCCS> <- to restore, Sp offset <next frame + 4 words>
+ <CCCS> <- to restore, Sp offset <next frame + 5 words>
+ old_spill
tuple_BCO
tuple_info
cont_BCO
@@ -1331,13 +1267,31 @@ do_return_nonpointer:
tuple_info
tuple_BCO
stg_ret_t <- Sp
+
+ Small frames (stg_ctoi_tN) omit the old_spill slot,
+ so CCCS is at offset <next frame + 4 words>.
*/
if(SpW(0) == (W_)&stg_ret_t_info) {
- cap->r.rCCCS = (CostCentreStack*)ReadSpW(offset + 4);
+ StgWord cccs_offset =
+ (ReadSpW(offset) == (W_)&stg_ctoi_t_info) ? 5 : 4;
+ cap->r.rCCCS = (CostCentreStack*)ReadSpW(offset + cccs_offset);
}
#endif
+ /* When returning a tuple to a generic stg_ctoi_t frame
+ (as opposed to a small stg_ctoi_tN frame), restore
+ tso->ctoi_tuple_spill_words from the frame's old_spill
+ slot.
+
+ See Note [GHCi unboxed tuples stack spills] in
+ StgMiscClosures.cmm. */
+ if(SpW(0) == (W_)&stg_ret_t_info
+ && ReadSpW(offset) == (W_)&stg_ctoi_t_info) {
+ cap->r.rCurrentTSO->ctoi_tuple_spill_words =
+ ReadSpW(offset + CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET);
+ }
+
/* Keep the ret frame and the ctoi frame for run_BCO.
* See Note [Stack layout when entering run_BCO] */
goto run_BCO;
@@ -2332,22 +2286,47 @@ run_BCO:
W_ o_bco = BCO_GET_LARGE_ARG;
W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
W_ o_tuple_bco = BCO_GET_LARGE_ARG;
+ int tuple_stack_words = tuple_info >> 24;
#if defined(PROFILING)
SpW(-1) = (W_)cap->r.rCCCS;
Sp_subW(1);
#endif
- SpW(-1) = BCO_PTR(o_tuple_bco);
- SpW(-2) = tuple_info;
- SpW(-3) = BCO_PTR(o_bco);
- int tuple_stack_words = (tuple_info >> 24) & 0xff;
- if (tuple_stack_words > 62) {
- barf("unsupported tuple size %d", tuple_stack_words);
+ /* See Note [GHCi unboxed tuples stack spills] in
+ StgMiscClosures.cmm */
+ if (tuple_stack_words <= MAX_SMALL_TUPLE_CTOI) {
+ /* Use a small info table that encodes the spill
+ count statically, avoiding access to
+ TSO->ctoi_tuple_spill_words entirely.
+ The frame is one word smaller than stg_ctoi_t
+ (no old_spill slot). */
+ static const StgInfoTable *const ctoi_t_small[] = {
+ &stg_ctoi_t0_info, &stg_ctoi_t1_info,
+ &stg_ctoi_t2_info, &stg_ctoi_t3_info,
+ &stg_ctoi_t4_info, &stg_ctoi_t5_info,
+ &stg_ctoi_t6_info, &stg_ctoi_t7_info,
+ &stg_ctoi_t8_info
+ };
+ _Static_assert(sizeof(ctoi_t_small) / sizeof(ctoi_t_small[0])
+ == MAX_SMALL_TUPLE_CTOI + 1,
+ "ctoi_t_small must have MAX_SMALL_TUPLE_CTOI + 1 entries");
+ SpW(-1) = BCO_PTR(o_tuple_bco);
+ SpW(-2) = tuple_info;
+ SpW(-3) = BCO_PTR(o_bco);
+ SpW(-4) = (W_)ctoi_t_small[tuple_stack_words];
+ Sp_subW(4);
+ } else {
+ /* Generic path: save/restore ctoi_tuple_spill_words
+ via the TSO */
+ SpW(-1) = cap->r.rCurrentTSO->ctoi_tuple_spill_words;
+ SpW(-2) = BCO_PTR(o_tuple_bco);
+ SpW(-3) = tuple_info;
+ SpW(-4) = BCO_PTR(o_bco);
+ SpW(-5) = (W_)&stg_ctoi_t_info;
+ Sp_subW(5);
+ cap->r.rCurrentTSO->ctoi_tuple_spill_words = tuple_stack_words;
}
- W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
- SpW(-4) = ctoi_t_offset;
- Sp_subW(4);
NEXT_INSTRUCTION;
}
=====================================
rts/Printer.c
=====================================
@@ -705,6 +705,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
debugBelch("stg_apply_interp_info" );
} else if (c == (StgWord)&stg_ret_t_info) {
debugBelch("stg_ret_t_info" );
+ } else if (c == (StgWord)&stg_ctoi_t_info) {
+ debugBelch("stg_ctoi_t_info" );
} else if (c == (StgWord)&stg_ctoi_t0_info) {
debugBelch("stg_ctoi_t0_info" );
} else if (c == (StgWord)&stg_ctoi_t1_info) {
@@ -723,8 +725,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
debugBelch("stg_ctoi_t7_info" );
} else if (c == (StgWord)&stg_ctoi_t8_info) {
debugBelch("stg_ctoi_t8_info" );
- /* there are more stg_ctoi_tN_info frames,
- but we don't print them all */
} else {
debugBelch("RET_BCO");
}
=====================================
rts/RaiseAsync.c
=====================================
@@ -1074,6 +1074,11 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
tso->flags |= TSO_BLOCKEX;
tso->flags &= ~TSO_INTERRUPTIBLE;
}
+ // see Note [GHCi unboxed tuples stack spills] in
+ // StgMiscClosures.cmm
+ if (*frame == (W_)&stg_ctoi_t_info) {
+ tso->ctoi_tuple_spill_words = frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET];
+ }
break;
}
=====================================
rts/RtsSymbols.c
=====================================
@@ -473,7 +473,16 @@ extern char **environ;
SymI_HasDataProto(stg_ret_d_info) \
SymI_HasDataProto(stg_ret_l_info) \
SymI_HasDataProto(stg_ret_t_info) \
- SymI_HasDataProto(stg_ctoi_t) \
+ SymI_HasDataProto(stg_ctoi_t_info) \
+ SymI_HasDataProto(stg_ctoi_t0_info) \
+ SymI_HasDataProto(stg_ctoi_t1_info) \
+ SymI_HasDataProto(stg_ctoi_t2_info) \
+ SymI_HasDataProto(stg_ctoi_t3_info) \
+ SymI_HasDataProto(stg_ctoi_t4_info) \
+ SymI_HasDataProto(stg_ctoi_t5_info) \
+ SymI_HasDataProto(stg_ctoi_t6_info) \
+ SymI_HasDataProto(stg_ctoi_t7_info) \
+ SymI_HasDataProto(stg_ctoi_t8_info) \
SymI_HasDataProto(stg_primcall_info) \
SymI_HasDataProto(stg_gc_prim_p) \
SymI_HasDataProto(stg_gc_prim_pp) \
=====================================
rts/Schedule.c
=====================================
@@ -3110,6 +3110,11 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
tso->flags |= TSO_BLOCKEX;
tso->flags &= ~TSO_INTERRUPTIBLE;
}
+ // see Note [GHCi unboxed tuples stack spills] in
+ // StgMiscClosures.cmm
+ if (*p == (StgWord)&stg_ctoi_t_info) {
+ tso->ctoi_tuple_spill_words = p[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]; // restore old_spill
+ }
p = next;
continue;
}
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -230,25 +230,22 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
spilled_2
spilled_3 <- Sp
- This makes it difficult to write a procedure that can handle tuples of
- any size.
+ stg_ctoi_t reads the number of spilled words from the
+ ctoi_tuple_spill_words field in the TSO to skip over the spilled data
+ on the stack. This field is set by the interpreter when pushing
+ the stg_ctoi_t frame (bci_PUSH_ALTS_T instruction). The old
+ value of the TSO field is saved in the frame itself, to handle
+ nested tuple returns correctly.
- To get around this, we use a Cmm procedure that adjusts the stack pointer
- to skip over the tuple:
-
- ...
- stg_ctoi_t3 (advances Sp by 3 words, then calls stg_ctoi_t)
- spilled_1
- spilled_2
- spilled_3 <- Sp
-
- When stg_ctoi_t is called, the stack looks like:
+ When stg_ctoi_t has adjusted Sp and read the frame, the stack
+ looks like:
...
+ old_spill
tuple_BCO
tuple_info
cont_BCO (continuation in bytecode)
- stg_ctoi_t3 <- Sp
+ stg_ctoi_t <- Sp
spilled_1
spilled_2
spilled_3
@@ -258,10 +255,11 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
stack looks as follows:
...
+ old_spill
tuple_BCO
tuple_info
cont_BCO
- stg_ctoi_t3
+ stg_ctoi_t
spilled_1
spilled_2
spilled_3
@@ -279,108 +277,52 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
At this point we can safely jump to the interpreter.
- */
+ We maintain the following invariants around the spill info:
-#define MK_STG_CTOI_T(N) INFO_TABLE_RET( \
- stg_ctoi_t ## N, RET_BCO ) \
- { Sp_adj(N); jump stg_ctoi_t SCALAR_ARG_REGS; }
-
-MK_STG_CTOI_T(0)
-MK_STG_CTOI_T(1)
-MK_STG_CTOI_T(2)
-MK_STG_CTOI_T(3)
-MK_STG_CTOI_T(4)
-MK_STG_CTOI_T(5)
-MK_STG_CTOI_T(6)
-MK_STG_CTOI_T(7)
-MK_STG_CTOI_T(8)
-MK_STG_CTOI_T(9)
-
-MK_STG_CTOI_T(10)
-MK_STG_CTOI_T(11)
-MK_STG_CTOI_T(12)
-MK_STG_CTOI_T(13)
-MK_STG_CTOI_T(14)
-MK_STG_CTOI_T(15)
-MK_STG_CTOI_T(16)
-MK_STG_CTOI_T(17)
-MK_STG_CTOI_T(18)
-MK_STG_CTOI_T(19)
-
-MK_STG_CTOI_T(20)
-MK_STG_CTOI_T(21)
-MK_STG_CTOI_T(22)
-MK_STG_CTOI_T(23)
-MK_STG_CTOI_T(24)
-MK_STG_CTOI_T(25)
-MK_STG_CTOI_T(26)
-MK_STG_CTOI_T(27)
-MK_STG_CTOI_T(28)
-MK_STG_CTOI_T(29)
-
-MK_STG_CTOI_T(30)
-MK_STG_CTOI_T(31)
-MK_STG_CTOI_T(32)
-MK_STG_CTOI_T(33)
-MK_STG_CTOI_T(34)
-MK_STG_CTOI_T(35)
-MK_STG_CTOI_T(36)
-MK_STG_CTOI_T(37)
-MK_STG_CTOI_T(38)
-MK_STG_CTOI_T(39)
-
-MK_STG_CTOI_T(40)
-MK_STG_CTOI_T(41)
-MK_STG_CTOI_T(42)
-MK_STG_CTOI_T(43)
-MK_STG_CTOI_T(44)
-MK_STG_CTOI_T(45)
-MK_STG_CTOI_T(46)
-MK_STG_CTOI_T(47)
-MK_STG_CTOI_T(48)
-MK_STG_CTOI_T(49)
-
-MK_STG_CTOI_T(50)
-MK_STG_CTOI_T(51)
-MK_STG_CTOI_T(52)
-MK_STG_CTOI_T(53)
-MK_STG_CTOI_T(54)
-MK_STG_CTOI_T(55)
-MK_STG_CTOI_T(56)
-MK_STG_CTOI_T(57)
-MK_STG_CTOI_T(58)
-MK_STG_CTOI_T(59)
-
-MK_STG_CTOI_T(60)
-MK_STG_CTOI_T(61)
-MK_STG_CTOI_T(62)
+ - tso->ctoi_tuple_spill_words == (frame[CTOI_TUPLE_INFO_OFFSET] >> 24)
+ where frame is the topmost stg_ctoi_t frame on the tso's stack.
+ - for each stg_ctoi_t frame, ctoi_t_frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET]
+ is equal to previous_ctoi_t_frame[CTOI_TUPLE_INFO_OFFSET] >> 24
+
+ This affects unwinding/capturing/restoring the stack for exceptions
+ and continuations.
+ */
/*
Convert a tuple return value to be used in bytecode.
See Note [GHCi and native call registers] for information on how
values are moved between the stack and registers.
+
+ See Note [GHCi unboxed tuples stack spills] for the stack layout.
*/
-stg_ctoi_t
- /* explicit stack */
+INFO_TABLE_RET( stg_ctoi_t, RET_BCO )
{
-
- W_ tuple_info, tuple_stack;
+ W_ tuple_spill, tuple_info;
P_ tuple_BCO;
+ W_ old_spill;
+
+ /* read number of spilled stack words from the TSO */
+ tuple_spill = StgTSO_ctoi_tuple_spill_words(CurrentTSO);
+
+ /* skip over tuple data on the stack */
+ Sp = Sp + WDS(tuple_spill);
tuple_info = Sp(2); /* tuple information word */
tuple_BCO = Sp(3); /* bytecode object that returns the tuple in
the interpreter */
+ old_spill = Sp(4); /* saved ctoi_tuple_spill_words from TSO */
#if defined(PROFILING)
- CCCS = Sp(4);
+ CCCS = Sp(5);
#endif
- /* number of words spilled on stack */
- tuple_stack = (tuple_info >> 24) & 0xff;
+ /* restore old spill count in the TSO */
+ StgTSO_ctoi_tuple_spill_words(CurrentTSO) = old_spill;
- Sp = Sp - WDS(tuple_stack);
+ /* move Sp back down to include spilled data */
+ Sp = Sp - WDS(tuple_spill);
PUSH_SCALAR_ARG_REGS(tuple_info);
@@ -393,6 +335,59 @@ stg_ctoi_t
jump stg_yield_to_interpreter [];
}
+/*
+ Small versions of stg_ctoi_t for small spill counts (0..MAX_SMALL_TUPLE_CTOI
+ words).
+
+ These avoid accessing TSO->ctoi_tuple_spill_words entirely, since the
+ spill count is known statically from the info table.
+
+ The frame layout is one word smaller than stg_ctoi_t, omitting
+ the old_spill slot:
+
+ CCCS (profiling only)
+ tuple_BCO
+ tuple_info
+ cont_BCO
+ stg_ctoi_tN_info (N = spill count, words)
+
+ Exception unwinding code and restoreStackInvariants only match
+ stg_ctoi_t_info, so these frames are correctly skipped.
+
+ See Note [GHCi unboxed tuples stack spills] for the general design.
+ */
+
+#if defined(PROFILING)
+#define CTOI_TN_RESTORE_CCS CCCS = Sp(4);
+#else
+#define CTOI_TN_RESTORE_CCS
+#endif
+
+#define STG_CTOI_TN_BODY(n) \
+ W_ tuple_info; \
+ P_ tuple_BCO; \
+ Sp = Sp + WDS(n); \
+ tuple_info = Sp(2); \
+ tuple_BCO = Sp(3); \
+ CTOI_TN_RESTORE_CCS \
+ Sp = Sp - WDS(n); \
+ PUSH_SCALAR_ARG_REGS(tuple_info); \
+ Sp_adj(-3); \
+ Sp(2) = tuple_info; \
+ Sp(1) = tuple_BCO; \
+ Sp(0) = stg_ret_t_info; \
+ jump stg_yield_to_interpreter [];
+
+INFO_TABLE_RET( stg_ctoi_t0, RET_BCO ) { STG_CTOI_TN_BODY(0) }
+INFO_TABLE_RET( stg_ctoi_t1, RET_BCO ) { STG_CTOI_TN_BODY(1) }
+INFO_TABLE_RET( stg_ctoi_t2, RET_BCO ) { STG_CTOI_TN_BODY(2) }
+INFO_TABLE_RET( stg_ctoi_t3, RET_BCO ) { STG_CTOI_TN_BODY(3) }
+INFO_TABLE_RET( stg_ctoi_t4, RET_BCO ) { STG_CTOI_TN_BODY(4) }
+INFO_TABLE_RET( stg_ctoi_t5, RET_BCO ) { STG_CTOI_TN_BODY(5) }
+INFO_TABLE_RET( stg_ctoi_t6, RET_BCO ) { STG_CTOI_TN_BODY(6) }
+INFO_TABLE_RET( stg_ctoi_t7, RET_BCO ) { STG_CTOI_TN_BODY(7) }
+INFO_TABLE_RET( stg_ctoi_t8, RET_BCO ) { STG_CTOI_TN_BODY(8) }
+
INFO_TABLE_RET( stg_ret_t, RET_BCO )
{
W_ tuple_info, tuple_stack;
@@ -401,7 +396,7 @@ INFO_TABLE_RET( stg_ret_t, RET_BCO )
Sp_adj(3);
/* number of words spilled on stack */
- tuple_stack = (tuple_info >> 24) & 0xff;
+ tuple_stack = tuple_info >> 24;
POP_SCALAR_ARG_REGS(tuple_info);
=====================================
rts/Threads.c
=====================================
@@ -114,6 +114,8 @@ createThread(Capability *cap, W_ size)
ASSIGN_Int64((W_*)&(tso->alloc_limit), 0);
+ tso->ctoi_tuple_spill_words = 0;
+
tso->trec = NO_TREC;
tso->label = NULL;
@@ -1053,3 +1055,38 @@ printThreadQueue(StgTSO *t)
}
#endif /* DEBUG */
+
+/*
+ * restoreStackInvariants: restore stack invariants
+ *
+ * This should be called after restoring a captured stack from
+ * sp .. sp + words
+ */
+void
+restoreStackInvariants(StgTSO *tso, StgPtr sp, StgWord words)
+{
+ StgPtr end = sp + words;
+ StgPtr frame = sp;
+
+ /*
+ Restore ctoi_tuple_spill_words invariants after adding stack:
+
+ - set the saved value in the last stg_ctoi_t frame to the current
+ tso->ctoi_tuple_spill_words
+ - set tso->ctoi_tuple_spill_words to the value in the first stg_ctoi_t frame
+
+ See Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm.
+ */
+ StgPtr first_ctoi_frame = NULL, last_ctoi_frame = NULL;
+ while (frame < end) {
+ if (*(StgWord*)frame == (StgWord)&stg_ctoi_t_info) {
+ if(first_ctoi_frame == NULL) first_ctoi_frame = frame;
+ last_ctoi_frame = frame;
+ }
+ frame += stack_frame_sizeW((StgClosure *)frame);
+ }
+ if(last_ctoi_frame != NULL) {
+ last_ctoi_frame[CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET] = tso->ctoi_tuple_spill_words;
+ tso->ctoi_tuple_spill_words = first_ctoi_frame[CTOI_TUPLE_INFO_OFFSET] >> 24;
+ }
+}
=====================================
rts/Threads.h
=====================================
@@ -40,6 +40,10 @@ StgBool isThreadBound (StgTSO* tso);
void threadStackOverflow (Capability *cap, StgTSO *tso);
W_ threadStackUnderflow (Capability *cap, StgTSO *tso);
+#define CTOI_OLD_TUPLE_SPILL_WORDS_OFFSET 4
+#define CTOI_TUPLE_INFO_OFFSET 2
+void restoreStackInvariants(StgTSO *tso, StgPtr sp, StgWord words);
+
#if defined(DEBUG)
void printThreadBlockage (StgTSO *tso);
void printThreadStatus (StgTSO *t);
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -232,4 +232,10 @@
cases. */
#define INTERP_STACK_CHECK_THRESH 50
+/* Maximum nativeCallStackSpillSize for which we use a small stg_ctoi_tN
+ frame (no old_spill slot, no TSO access) instead of the generic
+ stg_ctoi_t frame. Must match the stg_ctoi_tN definitions in
+ StgMiscClosures.cmm. */
+#define MAX_SMALL_TUPLE_CTOI 8
+
/*-------------------------------------------------------------------------*/
=====================================
rts/include/rts/storage/TSO.h
=====================================
@@ -186,6 +186,15 @@ typedef struct StgTSO_ {
*/
StgWord32 tot_stack_size;
+ /*
+ * The number of stack words spilled by the current stg_ctoi_t
+ * frame. This is used by stg_ctoi_t to handle tuple returns from compiled
+ * to interpreted code.
+ *
+ * See Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm
+ */
+ StgWord ctoi_tuple_spill_words;
+
#if defined(TICKY_TICKY)
/* TICKY-specific stuff would go here. */
#endif
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -96,7 +96,7 @@ RTS_RET(stg_ctoi_D1);
RTS_RET(stg_ctoi_L1);
RTS_RET(stg_ctoi_V);
-RTS_FUN_DECL(stg_ctoi_t);
+RTS_RET(stg_ctoi_t);
RTS_RET(stg_ctoi_t0);
RTS_RET(stg_ctoi_t1);
RTS_RET(stg_ctoi_t2);
@@ -106,66 +106,6 @@ RTS_RET(stg_ctoi_t5);
RTS_RET(stg_ctoi_t6);
RTS_RET(stg_ctoi_t7);
RTS_RET(stg_ctoi_t8);
-RTS_RET(stg_ctoi_t9);
-
-RTS_RET(stg_ctoi_t10);
-RTS_RET(stg_ctoi_t11);
-RTS_RET(stg_ctoi_t12);
-RTS_RET(stg_ctoi_t13);
-RTS_RET(stg_ctoi_t14);
-RTS_RET(stg_ctoi_t15);
-RTS_RET(stg_ctoi_t16);
-RTS_RET(stg_ctoi_t17);
-RTS_RET(stg_ctoi_t18);
-RTS_RET(stg_ctoi_t19);
-
-RTS_RET(stg_ctoi_t20);
-RTS_RET(stg_ctoi_t21);
-RTS_RET(stg_ctoi_t22);
-RTS_RET(stg_ctoi_t23);
-RTS_RET(stg_ctoi_t24);
-RTS_RET(stg_ctoi_t25);
-RTS_RET(stg_ctoi_t26);
-RTS_RET(stg_ctoi_t27);
-RTS_RET(stg_ctoi_t28);
-RTS_RET(stg_ctoi_t29);
-
-RTS_RET(stg_ctoi_t30);
-RTS_RET(stg_ctoi_t31);
-RTS_RET(stg_ctoi_t32);
-RTS_RET(stg_ctoi_t33);
-RTS_RET(stg_ctoi_t34);
-RTS_RET(stg_ctoi_t35);
-RTS_RET(stg_ctoi_t36);
-RTS_RET(stg_ctoi_t37);
-RTS_RET(stg_ctoi_t38);
-RTS_RET(stg_ctoi_t39);
-
-RTS_RET(stg_ctoi_t40);
-RTS_RET(stg_ctoi_t41);
-RTS_RET(stg_ctoi_t42);
-RTS_RET(stg_ctoi_t43);
-RTS_RET(stg_ctoi_t44);
-RTS_RET(stg_ctoi_t45);
-RTS_RET(stg_ctoi_t46);
-RTS_RET(stg_ctoi_t47);
-RTS_RET(stg_ctoi_t48);
-RTS_RET(stg_ctoi_t49);
-
-RTS_RET(stg_ctoi_t50);
-RTS_RET(stg_ctoi_t51);
-RTS_RET(stg_ctoi_t52);
-RTS_RET(stg_ctoi_t53);
-RTS_RET(stg_ctoi_t54);
-RTS_RET(stg_ctoi_t55);
-RTS_RET(stg_ctoi_t56);
-RTS_RET(stg_ctoi_t57);
-RTS_RET(stg_ctoi_t58);
-RTS_RET(stg_ctoi_t59);
-
-RTS_RET(stg_ctoi_t60);
-RTS_RET(stg_ctoi_t61);
-RTS_RET(stg_ctoi_t62);
RTS_RET(stg_primcall);
RTS_RET(stg_apply_interp);
=====================================
testsuite/tests/bytecode/tuplestress/ByteCode.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fbyte-code #-}
+
+module ByteCode where
+
+import GHC.Exts
+import GHC.Word
+
+#include "Common.hs-incl"
=====================================
testsuite/tests/bytecode/tuplestress/Common.hs-incl
=====================================
@@ -0,0 +1,492 @@
+-- Stress test definitions for unboxed tuples in the bytecode interpreter.
+--
+-- See Note [Unboxed tuple stress test] for an overview.
+
+-- Note [Unboxed tuple stress test]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- This test exercises the marshalling of unboxed tuples between
+-- native code and the bytecode interpreter. It systematically tests
+-- various tuple sizes around key boundaries (register capacity,
+-- small frame limit), different element types (pointers, Int#,
+-- Double#, Float#, Word64#, sub-word types), mixed type combinations,
+-- and void components.
+--
+-- For each tuple type, a NOINLINE producer and consumer are defined.
+-- The main test calls each through all four combinations of
+-- bytecode/native producer x bytecode/native consumer.
+--
+-- Key boundaries on x86_64:
+-- - 6 vanilla registers for pointers and non-pointer words
+-- - 6 float/double registers
+-- - small_tuple_frame: nativeCallStackSpillSize <= mAX_SMALL_TUPLE_CTOI
+-- - generic stg_ctoi_t frame for larger spills
+
+-- ============================================================
+-- Pure pointer tuples
+-- ============================================================
+
+{-# NOINLINE p2 #-}
+p2 :: a -> a -> (# a, a #)
+p2 x1 x2 = (# x1, x2 #)
+
+{-# NOINLINE p2_a #-}
+p2_a :: (a -> a -> (# a, a #)) -> a -> a -> (a, a)
+p2_a f x1 x2 = case f x1 x2 of (# y1, y2 #) -> (y1, y2)
+
+{-# NOINLINE p7 #-}
+p7 :: a -> a -> a -> a -> a -> a -> a
+ -> (# a, a, a, a, a, a, a #)
+p7 x1 x2 x3 x4 x5 x6 x7 =
+ (# x1, x2, x3, x4, x5, x6, x7 #)
+
+{-# NOINLINE p7_a #-}
+p7_a :: (a -> a -> a -> a -> a -> a -> a
+ -> (# a, a, a, a, a, a, a #))
+ -> a -> a -> a -> a -> a -> a -> a
+ -> (a, a, a, a, a, a, a)
+p7_a f x1 x2 x3 x4 x5 x6 x7 =
+ case f x1 x2 x3 x4 x5 x6 x7 of
+ (# y1, y2, y3, y4, y5, y6, y7 #) ->
+ (y1, y2, y3, y4, y5, y6, y7)
+
+-- ============================================================
+-- Pure Int# tuples
+-- ============================================================
+
+{-# NOINLINE n2 #-}
+n2 :: Int -> Int -> (# Int#, Int# #)
+n2 (I# x1) (I# x2) = (# x1, x2 #)
+
+{-# NOINLINE n2_a #-}
+n2_a :: (Int -> Int -> (# Int#, Int# #)) -> Int -> Int -> (Int, Int)
+n2_a f x1 x2 = case f x1 x2 of (# y1, y2 #) -> (I# y1, I# y2)
+
+{-# NOINLINE n7 #-}
+n7 :: Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int# #)
+n7 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) (I# x6) (I# x7) =
+ (# x1, x2, x3, x4, x5, x6, x7 #)
+
+{-# NOINLINE n7_a #-}
+n7_a :: (Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int# #))
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> (Int, Int, Int, Int, Int, Int, Int)
+n7_a f x1 x2 x3 x4 x5 x6 x7 =
+ case f x1 x2 x3 x4 x5 x6 x7 of
+ (# y1, y2, y3, y4, y5, y6, y7 #) ->
+ (I# y1, I# y2, I# y3, I# y4, I# y5, I# y6, I# y7)
+
+type TN15 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#
+ , Int#, Int#, Int#, Int#, Int#, Int#, Int# #)
+
+{-# NOINLINE n15 #-}
+n15 :: TN15
+n15 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) (I# x6) (I# x7) (I# x8)
+ (I# x9) (I# x10) (I# x11) (I# x12) (I# x13) (I# x14) (I# x15) =
+ (# x1, x2, x3, x4, x5, x6, x7, x8
+ , x9, x10, x11, x12, x13, x14, x15 #)
+
+{-# NOINLINE n15_a #-}
+n15_a :: TN15
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> ((Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int))
+n15_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 =
+ case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 of
+ (# y1, y2, y3, y4, y5, y6, y7, y8
+ , y9, y10, y11, y12, y13, y14, y15 #) ->
+ ( (I# y1, I# y2, I# y3, I# y4, I# y5)
+ , (I# y6, I# y7, I# y8, I# y9, I# y10)
+ , (I# y11, I# y12, I# y13, I# y14, I# y15) )
+
+-- ============================================================
+-- Pure Double# tuples
+-- ============================================================
+
+{-# NOINLINE d7 #-}
+d7 :: Double -> Double -> Double -> Double
+ -> Double -> Double -> Double
+ -> (# Double#, Double#, Double#, Double#
+ , Double#, Double#, Double# #)
+d7 (D# x1) (D# x2) (D# x3) (D# x4) (D# x5) (D# x6) (D# x7) =
+ (# x1, x2, x3, x4, x5, x6, x7 #)
+
+{-# NOINLINE d7_a #-}
+d7_a :: (Double -> Double -> Double -> Double
+ -> Double -> Double -> Double
+ -> (# Double#, Double#, Double#, Double#
+ , Double#, Double#, Double# #))
+ -> Double -> Double -> Double -> Double
+ -> Double -> Double -> Double
+ -> (Double, Double, Double, Double, Double, Double, Double)
+d7_a f x1 x2 x3 x4 x5 x6 x7 =
+ case f x1 x2 x3 x4 x5 x6 x7 of
+ (# y1, y2, y3, y4, y5, y6, y7 #) ->
+ (D# y1, D# y2, D# y3, D# y4, D# y5, D# y6, D# y7)
+
+-- ============================================================
+-- Pure Float# tuples
+-- ============================================================
+
+{-# NOINLINE fl7 #-}
+fl7 :: Float -> Float -> Float -> Float
+ -> Float -> Float -> Float
+ -> (# Float#, Float#, Float#, Float#
+ , Float#, Float#, Float# #)
+fl7 (F# x1) (F# x2) (F# x3) (F# x4) (F# x5) (F# x6) (F# x7) =
+ (# x1, x2, x3, x4, x5, x6, x7 #)
+
+{-# NOINLINE fl7_a #-}
+fl7_a :: (Float -> Float -> Float -> Float
+ -> Float -> Float -> Float
+ -> (# Float#, Float#, Float#, Float#
+ , Float#, Float#, Float# #))
+ -> Float -> Float -> Float -> Float
+ -> Float -> Float -> Float
+ -> (Float, Float, Float, Float, Float, Float, Float)
+fl7_a f x1 x2 x3 x4 x5 x6 x7 =
+ case f x1 x2 x3 x4 x5 x6 x7 of
+ (# y1, y2, y3, y4, y5, y6, y7 #) ->
+ (F# y1, F# y2, F# y3, F# y4, F# y5, F# y6, F# y7)
+
+-- ============================================================
+-- Pure Word64# tuples
+-- ============================================================
+
+{-# NOINLINE w7 #-}
+w7 :: Word64 -> Word64 -> Word64 -> Word64
+ -> Word64 -> Word64 -> Word64
+ -> (# Word64#, Word64#, Word64#, Word64#
+ , Word64#, Word64#, Word64# #)
+w7 (W64# x1) (W64# x2) (W64# x3) (W64# x4)
+ (W64# x5) (W64# x6) (W64# x7) =
+ (# x1, x2, x3, x4, x5, x6, x7 #)
+
+{-# NOINLINE w7_a #-}
+w7_a :: (Word64 -> Word64 -> Word64 -> Word64
+ -> Word64 -> Word64 -> Word64
+ -> (# Word64#, Word64#, Word64#, Word64#
+ , Word64#, Word64#, Word64# #))
+ -> Word64 -> Word64 -> Word64 -> Word64
+ -> Word64 -> Word64 -> Word64
+ -> (Word64, Word64, Word64, Word64, Word64, Word64, Word64)
+w7_a f x1 x2 x3 x4 x5 x6 x7 =
+ case f x1 x2 x3 x4 x5 x6 x7 of
+ (# y1, y2, y3, y4, y5, y6, y7 #) ->
+ (W64# y1, W64# y2, W64# y3, W64# y4,
+ W64# y5, W64# y6, W64# y7)
+
+-- ============================================================
+-- Mixed pointer + Int# tuples (interleaved)
+-- ============================================================
+
+-- 6 elements: 3 pointers + 3 Int#
+{-# NOINLINE mpi6 #-}
+mpi6 :: Int -> Int -> Int -> Int -> Int -> Int
+ -> (# Int, Int#, Int, Int#, Int, Int# #)
+mpi6 x1 (I# x2) x3 (I# x4) x5 (I# x6) =
+ (# x1, x2, x3, x4, x5, x6 #)
+
+{-# NOINLINE mpi6_a #-}
+mpi6_a :: (Int -> Int -> Int -> Int -> Int -> Int
+ -> (# Int, Int#, Int, Int#, Int, Int# #))
+ -> Int -> Int -> Int -> Int -> Int -> Int
+ -> (Int, Int, Int, Int, Int, Int)
+mpi6_a f x1 x2 x3 x4 x5 x6 =
+ case f x1 x2 x3 x4 x5 x6 of
+ (# y1, y2, y3, y4, y5, y6 #) ->
+ (y1, I# y2, y3, I# y4, y5, I# y6)
+
+-- ============================================================
+-- Mixed pointer + Double# tuples (interleaved)
+-- ============================================================
+
+-- 6 elements: 3 pointers + 3 Double#
+{-# NOINLINE mpd6 #-}
+mpd6 :: Int -> Double -> Int -> Double -> Int -> Double
+ -> (# Int, Double#, Int, Double#, Int, Double# #)
+mpd6 x1 (D# x2) x3 (D# x4) x5 (D# x6) =
+ (# x1, x2, x3, x4, x5, x6 #)
+
+{-# NOINLINE mpd6_a #-}
+mpd6_a :: (Int -> Double -> Int -> Double -> Int -> Double
+ -> (# Int, Double#, Int, Double#, Int, Double# #))
+ -> Int -> Double -> Int -> Double -> Int -> Double
+ -> (Int, Double, Int, Double, Int, Double)
+mpd6_a f x1 x2 x3 x4 x5 x6 =
+ case f x1 x2 x3 x4 x5 x6 of
+ (# y1, y2, y3, y4, y5, y6 #) ->
+ (y1, D# y2, y3, D# y4, y5, D# y6)
+
+-- ============================================================
+-- Mixed all types: pointer + Int# + Double# + Float#
+-- ============================================================
+
+-- 8 elements: 2 of each type, interleaved
+{-# NOINLINE mall8 #-}
+mall8 :: Int -> Int -> Double -> Float -> Int -> Int -> Double -> Float
+ -> (# Int, Int#, Double#, Float#, Int, Int#, Double#, Float# #)
+mall8 x1 (I# x2) (D# x3) (F# x4) x5 (I# x6) (D# x7) (F# x8) =
+ (# x1, x2, x3, x4, x5, x6, x7, x8 #)
+
+{-# NOINLINE mall8_a #-}
+mall8_a :: (Int -> Int -> Double -> Float -> Int -> Int -> Double -> Float
+ -> (# Int, Int#, Double#, Float#, Int, Int#, Double#, Float# #))
+ -> Int -> Int -> Double -> Float -> Int -> Int -> Double -> Float
+ -> (Int, Int, Double, Float, Int, Int, Double, Float)
+mall8_a f x1 x2 x3 x4 x5 x6 x7 x8 =
+ case f x1 x2 x3 x4 x5 x6 x7 x8 of
+ (# y1, y2, y3, y4, y5, y6, y7, y8 #) ->
+ (y1, I# y2, D# y3, F# y4, y5, I# y6, D# y7, F# y8)
+
+-- ============================================================
+-- Sub-word types: Word8#, Word16#, Word32#
+-- ============================================================
+
+{-# NOINLINE sub5 #-}
+sub5 :: Word8 -> Word16 -> Word32 -> Int -> Int
+ -> (# Word8#, Word16#, Word32#, Int#, Int #)
+sub5 (W8# x1) (W16# x2) (W32# x3) (I# x4) x5 =
+ (# x1, x2, x3, x4, x5 #)
+
+{-# NOINLINE sub5_a #-}
+sub5_a :: (Word8 -> Word16 -> Word32 -> Int -> Int
+ -> (# Word8#, Word16#, Word32#, Int#, Int #))
+ -> Word8 -> Word16 -> Word32 -> Int -> Int
+ -> (Word8, Word16, Word32, Int, Int)
+sub5_a f x1 x2 x3 x4 x5 =
+ case f x1 x2 x3 x4 x5 of
+ (# y1, y2, y3, y4, y5 #) ->
+ (W8# y1, W16# y2, W32# y3, I# y4, y5)
+
+-- ============================================================
+-- Void components: (# #) interleaved with real values
+-- ============================================================
+
+{-# NOINLINE vd6 #-}
+vd6 :: Int -> Int -> Int
+ -> (# Int, (# #), Int, (# #), Int#, (# #) #)
+vd6 x1 x2 (I# x3) = (# x1, (# #), x2, (# #), x3, (# #) #)
+
+{-# NOINLINE vd6_a #-}
+vd6_a :: (Int -> Int -> Int
+ -> (# Int, (# #), Int, (# #), Int#, (# #) #))
+ -> Int -> Int -> Int
+ -> (Int, Int, Int)
+vd6_a f x1 x2 x3 =
+ case f x1 x2 x3 of
+ (# y1, _, y3, _, y5, _ #) -> (y1, y3, I# y5)
+
+-- ============================================================
+-- Recursive step functions
+-- ============================================================
+
+-- 4-element mixed step: each element incremented by a different amount
+-- ptr: +1, Int#: +2, Double#: +0.5, Double#: +1.5
+{-# NOINLINE rec_step4 #-}
+rec_step4 :: Int -> Int -> Double -> Double
+ -> (# Int, Int#, Double#, Double# #)
+rec_step4 x1 (I# x2) (D# x3) (D# x4) =
+ (# x1 + 1, x2 +# 2#, x3 +## 0.5##, x4 +## 1.5## #)
+
+{-# NOINLINE rec_step4_a #-}
+rec_step4_a :: (Int -> Int -> Double -> Double
+ -> (# Int, Int#, Double#, Double# #))
+ -> Int -> Int -> Double -> Double
+ -> (Int, Int, Double, Double)
+rec_step4_a f x1 x2 x3 x4 =
+ case f x1 x2 x3 x4 of
+ (# y1, y2, y3, y4 #) -> (y1, I# y2, D# y3, D# y4)
+
+-- ============================================================
+-- Large tuples: boundary and stress sizes
+-- ============================================================
+
+-- 14 Int#: exactly stg_ctoi_t8 (last small frame, spill = 8 words on x86_64)
+type TN14 = Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int#
+ , Int#, Int#, Int#, Int#, Int#, Int#, Int# #)
+
+{-# NOINLINE n14 #-}
+n14 :: TN14
+n14 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) (I# x6) (I# x7)
+ (I# x8) (I# x9) (I# x10) (I# x11) (I# x12) (I# x13) (I# x14) =
+ (# x1, x2, x3, x4, x5, x6, x7
+ , x8, x9, x10, x11, x12, x13, x14 #)
+
+{-# NOINLINE n14_a #-}
+n14_a :: TN14
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> ((Int,Int,Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int,Int,Int))
+n14_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 =
+ case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 of
+ (# y1, y2, y3, y4, y5, y6, y7
+ , y8, y9, y10, y11, y12, y13, y14 #) ->
+ ( (I# y1, I# y2, I# y3, I# y4, I# y5, I# y6, I# y7)
+ , (I# y8, I# y9, I# y10, I# y11, I# y12, I# y13, I# y14) )
+
+-- 20 Int#: generic frame, large spill, all non-pointer
+type TN20 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#
+ , Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #)
+
+{-# NOINLINE n20 #-}
+n20 :: TN20
+n20 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5)
+ (I# x6) (I# x7) (I# x8) (I# x9) (I# x10)
+ (I# x11) (I# x12) (I# x13) (I# x14) (I# x15)
+ (I# x16) (I# x17) (I# x18) (I# x19) (I# x20) =
+ (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10
+ , x11, x12, x13, x14, x15, x16, x17, x18, x19, x20 #)
+
+{-# NOINLINE n20_a #-}
+n20_a :: TN20
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> ((Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int)
+ ,(Int,Int,Int,Int,Int),(Int,Int,Int,Int,Int))
+n20_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
+ x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 =
+ case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
+ x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 of
+ (# y1, y2, y3, y4, y5, y6, y7, y8, y9, y10
+ , y11, y12, y13, y14, y15, y16, y17, y18, y19, y20 #) ->
+ ( (I# y1, I# y2, I# y3, I# y4, I# y5)
+ , (I# y6, I# y7, I# y8, I# y9, I# y10)
+ , (I# y11, I# y12, I# y13, I# y14, I# y15)
+ , (I# y16, I# y17, I# y18, I# y19, I# y20) )
+
+-- 32 Int#: very large generic frame, spill = 26 words
+type TN32 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> (# Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#
+ , Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#
+ , Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int#
+ , Int#, Int#, Int#, Int#, Int#, Int#, Int#, Int# #)
+
+{-# NOINLINE n32 #-}
+n32 :: TN32
+n32 (I# x1) (I# x2) (I# x3) (I# x4) (I# x5) (I# x6) (I# x7) (I# x8)
+ (I# x9) (I# x10) (I# x11) (I# x12) (I# x13) (I# x14) (I# x15) (I# x16)
+ (I# x17) (I# x18) (I# x19) (I# x20) (I# x21) (I# x22) (I# x23) (I# x24)
+ (I# x25) (I# x26) (I# x27) (I# x28) (I# x29) (I# x30) (I# x31) (I# x32) =
+ (# x1, x2, x3, x4, x5, x6, x7, x8
+ , x9, x10, x11, x12, x13, x14, x15, x16
+ , x17, x18, x19, x20, x21, x22, x23, x24
+ , x25, x26, x27, x28, x29, x30, x31, x32 #)
+
+{-# NOINLINE n32_a #-}
+n32_a :: TN32
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> ((Int,Int,Int,Int,Int,Int,Int,Int)
+ ,(Int,Int,Int,Int,Int,Int,Int,Int)
+ ,(Int,Int,Int,Int,Int,Int,Int,Int)
+ ,(Int,Int,Int,Int,Int,Int,Int,Int))
+n32_a f x1 x2 x3 x4 x5 x6 x7 x8
+ x9 x10 x11 x12 x13 x14 x15 x16
+ x17 x18 x19 x20 x21 x22 x23 x24
+ x25 x26 x27 x28 x29 x30 x31 x32 =
+ case f x1 x2 x3 x4 x5 x6 x7 x8
+ x9 x10 x11 x12 x13 x14 x15 x16
+ x17 x18 x19 x20 x21 x22 x23 x24
+ x25 x26 x27 x28 x29 x30 x31 x32 of
+ (# y1, y2, y3, y4, y5, y6, y7, y8
+ , y9, y10, y11, y12, y13, y14, y15, y16
+ , y17, y18, y19, y20, y21, y22, y23, y24
+ , y25, y26, y27, y28, y29, y30, y31, y32 #) ->
+ ( (I# y1, I# y2, I# y3, I# y4, I# y5, I# y6, I# y7, I# y8)
+ , (I# y9, I# y10, I# y11, I# y12, I# y13, I# y14, I# y15, I# y16)
+ , (I# y17, I# y18, I# y19, I# y20, I# y21, I# y22, I# y23, I# y24)
+ , (I# y25, I# y26, I# y27, I# y28, I# y29, I# y30, I# y31, I# y32) )
+
+-- 32 mixed: 8 groups of (Int, Int#, Double#, Float#), all register classes
+-- spill = 14 words (10 vanilla + 2 double + 2 float)
+type TMIX32 = Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> (# Int, Int#, Double#, Float#
+ , Int, Int#, Double#, Float#
+ , Int, Int#, Double#, Float#
+ , Int, Int#, Double#, Float#
+ , Int, Int#, Double#, Float#
+ , Int, Int#, Double#, Float#
+ , Int, Int#, Double#, Float#
+ , Int, Int#, Double#, Float# #)
+
+{-# NOINLINE mix32 #-}
+mix32 :: TMIX32
+mix32 x1 (I# x2) (D# x3) (F# x4)
+ x5 (I# x6) (D# x7) (F# x8)
+ x9 (I# x10) (D# x11) (F# x12)
+ x13 (I# x14) (D# x15) (F# x16)
+ x17 (I# x18) (D# x19) (F# x20)
+ x21 (I# x22) (D# x23) (F# x24)
+ x25 (I# x26) (D# x27) (F# x28)
+ x29 (I# x30) (D# x31) (F# x32) =
+ (# x1, x2, x3, x4
+ , x5, x6, x7, x8
+ , x9, x10, x11, x12
+ , x13, x14, x15, x16
+ , x17, x18, x19, x20
+ , x21, x22, x23, x24
+ , x25, x26, x27, x28
+ , x29, x30, x31, x32 #)
+
+{-# NOINLINE mix32_a #-}
+mix32_a :: TMIX32
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> Int -> Int -> Double -> Float
+ -> ((Int,Int,Double,Float)
+ ,(Int,Int,Double,Float)
+ ,(Int,Int,Double,Float)
+ ,(Int,Int,Double,Float)
+ ,(Int,Int,Double,Float)
+ ,(Int,Int,Double,Float)
+ ,(Int,Int,Double,Float)
+ ,(Int,Int,Double,Float))
+mix32_a f x1 x2 x3 x4 x5 x6 x7 x8
+ x9 x10 x11 x12 x13 x14 x15 x16
+ x17 x18 x19 x20 x21 x22 x23 x24
+ x25 x26 x27 x28 x29 x30 x31 x32 =
+ case f x1 x2 x3 x4 x5 x6 x7 x8
+ x9 x10 x11 x12 x13 x14 x15 x16
+ x17 x18 x19 x20 x21 x22 x23 x24
+ x25 x26 x27 x28 x29 x30 x31 x32 of
+ (# y1, y2, y3, y4
+ , y5, y6, y7, y8
+ , y9, y10, y11, y12
+ , y13, y14, y15, y16
+ , y17, y18, y19, y20
+ , y21, y22, y23, y24
+ , y25, y26, y27, y28
+ , y29, y30, y31, y32 #) ->
+ ( (y1, I# y2, D# y3, F# y4)
+ , (y5, I# y6, D# y7, F# y8)
+ , (y9, I# y10, D# y11, F# y12)
+ , (y13, I# y14, D# y15, F# y16)
+ , (y17, I# y18, D# y19, F# y20)
+ , (y21, I# y22, D# y23, F# y24)
+ , (y25, I# y26, D# y27, F# y28)
+ , (y29, I# y30, D# y31, F# y32) )
=====================================
testsuite/tests/bytecode/tuplestress/Obj.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fobject-code #-}
+
+#include "MachDeps.h"
+
+module Obj where
+
+import GHC.Exts
+import GHC.Word
+
+#include "Common.hs-incl"
=====================================
testsuite/tests/bytecode/tuplestress/TupleStress.hs
=====================================
@@ -0,0 +1,631 @@
+{-# LANGUAGE UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fbyte-code #-}
+
+{-
+ Stress test for unboxed tuples in the bytecode interpreter.
+
+ Tests various sized tuples with different element types,
+ focusing on converting tuples between native code and
+ interpreted code in all four combinations:
+ ByteCode producer x ByteCode consumer
+ ByteCode producer x Object consumer
+ Object producer x ByteCode consumer
+ Object producer x Object consumer
+
+ See Note [Unboxed tuple stress test] in Common.hs-incl.
+ -}
+
+module Main where
+
+import qualified Obj as O
+import qualified ByteCode as B
+
+import GHC.Exts
+import GHC.Word
+import Control.Exception (try, evaluate, catch, SomeException)
+import Control.Concurrent
+import System.IO.Unsafe (unsafePerformIO)
+
+main :: IO ()
+main = do
+
+ -- ========================================================
+ -- Pure tuple tests: all 4 combinations (BB/BO/OB/OO)
+ -- ========================================================
+
+ testX "p7"
+ B.p7_a O.p7_a
+ B.p7 O.p7
+ (\f -> f (1::Int) 2 3 4 5 6 7)
+
+ testX "n2"
+ B.n2_a O.n2_a
+ B.n2 O.n2
+ (\f -> f 1 2)
+
+ testX "n7"
+ B.n7_a O.n7_a
+ B.n7 O.n7
+ (\f -> f 1 2 3 4 5 6 7)
+
+ testX "n15"
+ B.n15_a O.n15_a
+ B.n15 O.n15
+ (\f -> f 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+
+ testX "d7"
+ B.d7_a O.d7_a
+ B.d7 O.d7
+ (\f -> f 1.5 2.5 3.5 4.5 5.5 6.5 7.5)
+
+ testX "fl7"
+ B.fl7_a O.fl7_a
+ B.fl7 O.fl7
+ (\f -> f 1.25 2.25 3.25 4.25 5.25 6.25 7.25)
+
+ testX "w7"
+ B.w7_a O.w7_a
+ B.w7 O.w7
+ (\f -> f 100 200 300 400 500 600 700)
+
+ testX "mpi6"
+ B.mpi6_a O.mpi6_a
+ B.mpi6 O.mpi6
+ (\f -> f 1 2 3 4 5 6)
+
+ testX "mpd6"
+ B.mpd6_a O.mpd6_a
+ B.mpd6 O.mpd6
+ (\f -> f 1 1.5 2 2.5 3 3.5)
+
+ testX "mall8"
+ B.mall8_a O.mall8_a
+ B.mall8 O.mall8
+ (\f -> f 1 2 3.0 4.0 5 6 7.0 8.0)
+
+ testX "sub5"
+ B.sub5_a O.sub5_a
+ B.sub5 O.sub5
+ (\f -> f 42 1000 70000 99 100)
+
+ testX "vd6"
+ B.vd6_a O.vd6_a
+ B.vd6 O.vd6
+ (\f -> f 11 22 33)
+
+ -- 14 Int#: exactly at stg_ctoi_t8 boundary (last small frame)
+ testX "n14"
+ B.n14_a O.n14_a
+ B.n14 O.n14
+ (\f -> f 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
+
+ -- 20 Int#: generic frame, all non-pointer
+ testX "n20"
+ B.n20_a O.n20_a
+ B.n20 O.n20
+ (\f -> f 1 2 3 4 5 6 7 8 9 10
+ 11 12 13 14 15 16 17 18 19 20)
+
+ -- 32 Int#: very large generic frame (spill = 26 words)
+ testX "n32"
+ B.n32_a O.n32_a
+ B.n32 O.n32
+ (\f -> f 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
+ 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32)
+
+ -- 32 mixed (ptr+Int#+Double#+Float#): all register classes (spill = 14)
+ testX "mix32"
+ B.mix32_a O.mix32_a
+ B.mix32 O.mix32
+ (\f -> f 1 2 3.0 4.0 5 6 7.0 8.0 9 10 11.0 12.0
+ 13 14 15.0 16.0 17 18 19.0 20.0 21 22 23.0 24.0
+ 25 26 27.0 28.0 29 30 31.0 32.0)
+
+ -- ========================================================
+ -- Loop tests: repeated calls to detect state corruption
+ -- ========================================================
+
+ -- Pointer 7-tuple loop, alternating B->O and O->B directions
+ let loop_p7_ok = and
+ [ (if even i then O.p7_a B.p7 else B.p7_a O.p7)
+ i (i+1) (i+2) (i+3) (i+4) (i+5) (i+6)
+ == (i, i+1, i+2, i+3, i+4, i+5, i+6)
+ | i <- [0 :: Int, 7 .. 700]
+ ]
+ putStrLn $ "loop_p7 " ++ show loop_p7_ok
+
+ -- Mixed ptr+Double# loop
+ let loop_mpd_ok = and
+ [ O.mpd6_a B.mpd6 i (fromIntegral i + 0.5)
+ (i+1) (fromIntegral (i+1) + 0.5)
+ (i+2) (fromIntegral (i+2) + 0.5)
+ == ( i, fromIntegral i + 0.5
+ , i+1, fromIntegral (i+1) + 0.5
+ , i+2, fromIntegral (i+2) + 0.5 )
+ | i <- [0 :: Int, 3 .. 300]
+ ]
+ putStrLn $ "loop_mpd " ++ show loop_mpd_ok
+
+ -- 32-element Int# loop: exercises very large generic frame
+ let loop_n32_ok = and
+ [ B.n32_a O.n32
+ i (i+1) (i+2) (i+3) (i+4) (i+5) (i+6) (i+7)
+ (i+8) (i+9) (i+10) (i+11) (i+12) (i+13) (i+14) (i+15)
+ (i+16) (i+17) (i+18) (i+19) (i+20) (i+21) (i+22) (i+23)
+ (i+24) (i+25) (i+26) (i+27) (i+28) (i+29) (i+30) (i+31)
+ == ( (i,i+1,i+2,i+3,i+4,i+5,i+6,i+7)
+ , (i+8,i+9,i+10,i+11,i+12,i+13,i+14,i+15)
+ , (i+16,i+17,i+18,i+19,i+20,i+21,i+22,i+23)
+ , (i+24,i+25,i+26,i+27,i+28,i+29,i+30,i+31) )
+ | i <- [0 :: Int, 32 .. 3200]
+ ]
+ putStrLn $ "loop_n32 " ++ show loop_n32_ok
+
+ -- ========================================================
+ -- Chain tests: output of one call feeds into the next
+ -- ========================================================
+
+ -- 7-tuple chain with arithmetic
+ let (c1,c2,c3,c4,c5,c6,c7) = O.p7_a B.p7 (10::Int) 20 30 40 50 60 70
+ putStrLn $ "chain_arith " ++ show
+ (B.p7_a O.p7 (c1+c7) (c2+c6) (c3+c5) c4 (c5+c3) (c6+c2) (c7+c1))
+
+ -- 100 alternating swaps across bytecode/native boundary
+ putStrLn $ "swap_stress " ++ show (swapStress (100 :: Int) (1 :: Int, 2))
+
+ -- ========================================================
+ -- Recursive tuple tests
+ -- ========================================================
+
+ -- 4-element mixed accumulation: 50 steps alternating B/O
+ -- rec_step4 (x1,x2,x3,x4) = (x1+1, x2+2, x3+0.5, x4+1.5)
+ -- After 50 steps from (0,0,0,0): (50, 100, 25.0, 75.0)
+ let recMixed x1 x2 x3 x4 0 = (x1, x2, x3, x4)
+ recMixed x1 x2 x3 x4 n
+ | even n = let (a,b,c,d) = B.rec_step4_a O.rec_step4 x1 x2 x3 x4
+ in recMixed a b c d (n-1)
+ | otherwise = let (a,b,c,d) = O.rec_step4_a B.rec_step4 x1 x2 x3 x4
+ in recMixed a b c d (n-1)
+ putStrLn $ "rec_mixed " ++ show
+ (recMixed (0::Int) (0::Int) (0.0::Double) (0.0::Double) (50::Int))
+
+ -- Fibonacci via 2-tuples, 30 levels crossing boundaries at each level
+ let fibCross 0 = B.n2_a O.n2 0 1
+ fibCross 1 = O.n2_a B.n2 1 0
+ fibCross n =
+ let (a, b) = fibCross (n-1)
+ in if even n
+ then B.n2_a O.n2 (a+b) a
+ else O.n2_a B.n2 (a+b) a
+ putStrLn $ "fib_cross " ++ show (fst (fibCross (30::Int)))
+
+ -- ========================================================
+ -- Exception tests: verify stack state is restored
+ -- ========================================================
+
+ -- Exception in 7-element Int# tuple (small frame), B->O
+ do r <- tryEval (B.n7_a O.n7 (error "exc") 2 3 4 5 6 7)
+ let threw = case r of { Left _ -> True; Right _ -> False }
+ let ok = B.n7_a O.n7 1 2 3 4 5 6 7 == (1,2,3,4,5,6,7)
+ putStrLn $ "exc_n7_bo " ++ show (threw && ok)
+
+ -- Exception in 15-element Int# tuple (generic frame), B->O
+ do r <- tryEval (B.n15_a O.n15 (error "exc") 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15)
+ let threw = case r of { Left _ -> True; Right _ -> False }
+ let ok = B.n15_a O.n15 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
+ == ((1,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15))
+ putStrLn $ "exc_n15_bo " ++ show (threw && ok)
+
+ -- Exception in mixed ptr+Double# tuple, B->O
+ do r <- tryEval (B.mpd6_a O.mpd6 1 (error "exc") 2 2.5 3 3.5)
+ let threw = case r of { Left _ -> True; Right _ -> False }
+ let ok = B.mpd6_a O.mpd6 1 1.5 2 2.5 3 3.5 == (1,1.5,2,2.5,3,3.5)
+ putStrLn $ "exc_mpd_bo " ++ show (threw && ok)
+
+ -- Repeated exceptions: throw 50 times, then verify recovery
+ do let throwOnce = tryEval (B.n7_a O.n7 (error "exc") 2 3 4 5 6 7)
+ results <- sequence [throwOnce | _ <- [1..50::Int]]
+ let allThrew = all (\r -> case r of { Left _ -> True; Right _ -> False })
+ results
+ let final = O.n7_a B.n7 10 20 30 40 50 60 70
+ putStrLn $ "exc_repeat " ++ show (allThrew && final == (10,20,30,40,50,60,70))
+
+ -- Exception at stg_ctoi_t8 boundary (14 Int#, last small frame)
+ do r <- tryEval (B.n14_a O.n14 (error "exc") 2 3 4 5 6 7
+ 8 9 10 11 12 13 14)
+ let threw = case r of { Left _ -> True; Right _ -> False }
+ let ok = B.n14_a O.n14 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+ == ((1,2,3,4,5,6,7),(8,9,10,11,12,13,14))
+ putStrLn $ "exc_n14_bo " ++ show (threw && ok)
+
+ -- Exception with 32-element Int# tuple (very large generic frame)
+ do r <- tryEval (B.n32_a O.n32 (error "exc") 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15 16
+ 17 18 19 20 21 22 23 24
+ 25 26 27 28 29 30 31 32)
+ let threw = case r of { Left _ -> True; Right _ -> False }
+ let ok = B.n32_a O.n32 1 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15 16
+ 17 18 19 20 21 22 23 24
+ 25 26 27 28 29 30 31 32
+ == ((1,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16),
+ (17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32))
+ putStrLn $ "exc_n32_bo " ++ show (threw && ok)
+
+ -- ========================================================
+ -- Nested generic ctoi exception tests
+ -- ========================================================
+ -- Tests that exception unwinding correctly restores
+ -- ctoi_tuple_spill_words when passing through multiple
+ -- stg_ctoi_t frames.
+ -- See Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm.
+
+ -- Exception through 2 nested generic ctoi frames (n15 inside n20).
+ do let l1 = case B.n15_a O.n15 (error "exc") 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15
+ of ((a,_,_,_,_),_,_) -> a
+ r <- tryEval (B.n20_a O.n20 l1 2 3 4 5 6 7 8 9 10
+ 11 12 13 14 15 16 17 18 19 20)
+ let threw = case r of { Left _ -> True; Right _ -> False }
+ let ok = B.n20_a O.n20 1 2 3 4 5 6 7 8 9 10
+ 11 12 13 14 15 16 17 18 19 20
+ == ((1,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20))
+ putStrLn $ "exc_nested_2gen " ++ show (threw && ok)
+
+ -- Exception caught between 2 generic ctoi frames.
+ -- A catch handler sits between ctoi(n20,spill=14) and ctoi(n15,spill=9).
+ -- The error in O.n15 unwinds through ctoi(n15), which must restore
+ -- ctoi_tuple_spill_words to the outer frame's spill count before
+ -- hitting the catch. If the restore is missing, ctoi(n20) reads the
+ -- wrong number of spill words and corrupts the stack.
+ do let inner_result :: Int
+ inner_result = unsafePerformIO $
+ catch (evaluate (case B.n15_a O.n15 (error "exc") 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15
+ of ((a,_,_,_,_),_,_) -> a))
+ (const (return 99) :: SomeException -> IO Int)
+ result <- evaluate (B.n20_a O.n20 inner_result 2 3 4 5 6 7 8 9 10
+ 11 12 13 14 15 16 17 18 19 20)
+ putStrLn $ "exc_catch_between " ++ show
+ (result == ((99,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20)))
+
+ -- ========================================================
+ -- Async exception / AP_STACK replay tests
+ -- ========================================================
+
+ apStackTest "async_n7" (42 :: Int)
+ (\b -> B.n7_a O.n7 b 2 3 4 5 6 7)
+ (42,2,3,4,5,6,7)
+
+ -- AP_STACK replayed in a third thread (not the killer, not the killed)
+ do entered <- newEmptyMVar
+ gate <- newEmptyMVar
+ resultVar <- newEmptyMVar
+ let thunk = B.n7_a O.n7
+ (unsafePerformIO $ do
+ _ <- tryPutMVar entered ()
+ takeMVar gate)
+ 2 3 4 5 6 7
+ tid <- forkIO $ do
+ _ <- tryEval thunk
+ return ()
+ takeMVar entered
+ killThread tid
+ threadDelay 10000
+ putMVar gate 42
+ _ <- forkIO $ do
+ result <- evaluate thunk
+ putMVar resultVar result
+ result <- takeMVar resultVar
+ putStrLn $ "async_other " ++ show (result == (42,2,3,4,5,6,7))
+
+ -- AP_STACK at stg_ctoi_t8 boundary (14 Int#, last small frame)
+ apStackTest "async_n14" (42 :: Int)
+ (\b -> B.n14_a O.n14 b 2 3 4 5 6 7 8 9 10 11 12 13 14)
+ ((42,2,3,4,5,6,7),(8,9,10,11,12,13,14))
+
+ -- Nested async: interrupt the AP_STACK replay itself.
+ -- Round 1: blocks on arg1; Round 2: blocks on arg2; Round 3: completes
+ do entered1 <- newEmptyMVar
+ entered2 <- newEmptyMVar
+ gate1 <- newEmptyMVar
+ gate2 <- newEmptyMVar
+ let thunk = B.n7_a O.n7
+ (unsafePerformIO $ do
+ _ <- tryPutMVar entered1 ()
+ takeMVar gate1)
+ (unsafePerformIO $ do
+ _ <- tryPutMVar entered2 ()
+ takeMVar gate2)
+ 3 4 5 6 7
+ tid1 <- forkIO $ do
+ _ <- tryEval thunk
+ return ()
+ takeMVar entered1
+ killThread tid1
+ threadDelay 10000
+ putMVar gate1 100
+ tid2 <- forkIO $ do
+ _ <- tryEval thunk
+ return ()
+ takeMVar entered2
+ killThread tid2
+ threadDelay 10000
+ putMVar gate2 200
+ result <- evaluate thunk
+ putStrLn $ "async_nested " ++ show (result == (100,200,3,4,5,6,7))
+
+ -- Async + sync exception combo: async replay, then sync throw, then normal
+ do entered <- newEmptyMVar
+ gate <- newEmptyMVar
+ let thunk = B.n7_a O.n7
+ (unsafePerformIO $ do
+ _ <- tryPutMVar entered ()
+ takeMVar gate)
+ 2 3 4 5 6 7
+ tid <- forkIO $ do
+ _ <- tryEval thunk
+ return ()
+ takeMVar entered
+ killThread tid
+ threadDelay 10000
+ putMVar gate 42
+ rAsync <- evaluate thunk
+ rSync <- tryEval (B.n7_a O.n7 (error "sync") 2 3 4 5 6 7)
+ let syncThrew = case rSync of { Left _ -> True; Right _ -> False }
+ let rNormal = O.n7_a B.n7 10 20 30 40 50 60 70
+ putStrLn $ "async_exc_combo " ++ show
+ (rAsync == (42,2,3,4,5,6,7) && syncThrew &&
+ rNormal == (10,20,30,40,50,60,70))
+
+ -- Async loop: create, kill, and replay AP_STACKs 20 times
+ do let oneRound i = do
+ entered <- newEmptyMVar
+ gate <- newEmptyMVar
+ let thunk = B.n7_a O.n7
+ (unsafePerformIO $ do
+ _ <- tryPutMVar entered ()
+ takeMVar gate)
+ (i+1) (i+2) (i+3) (i+4) (i+5) (i+6)
+ tid <- forkIO $ do
+ _ <- tryEval thunk
+ return ()
+ takeMVar entered
+ killThread tid
+ threadDelay 5000
+ putMVar gate i
+ r <- tryEval thunk
+ return (isRight (i,i+1,i+2,i+3,i+4,i+5,i+6) r)
+ results <- mapM oneRound [1000 :: Int, 1001 .. 1019]
+ putStrLn $ "async_loop " ++ show (and results)
+
+ -- ========================================================
+ -- Multi-ctoi AP_STACK tests
+ -- ========================================================
+
+ -- 2 ctoi frames: B.n2_a->O.n2 inside B.n7_a->O.n7
+ apStackTest "async_2ctoi" (42 :: Int)
+ (\b -> let l1 = case B.n2_a O.n2 b 2 of (a, _) -> a
+ in B.n7_a O.n7 l1 20 30 40 50 60 70)
+ (42,20,30,40,50,60,70)
+
+ -- 3 ctoi frames with different sizes:
+ -- innermost: stg_ctoi_t0 (n2, spill=0)
+ -- middle: stg_ctoi_t1 (n7, spill=1)
+ -- outermost: stg_ctoi_t (n15, generic, spill=9)
+ apStackTest "async_3ctoi" (42 :: Int)
+ (\b -> let l1 = case B.n2_a O.n2 b 2 of (a, _) -> a
+ l2 = case B.n7_a O.n7 l1 2 3 4 5 6 7 of (a,_,_,_,_,_,_) -> a
+ in B.n15_a O.n15 l2 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+ ((42,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15))
+
+ -- Nested async with multi-ctoi: 2 rounds of interruption,
+ -- each with different numbers of ctoi frames on the stack.
+ do entered1 <- newEmptyMVar
+ entered2 <- newEmptyMVar
+ gate1 <- newEmptyMVar
+ gate2 <- newEmptyMVar
+ let blocking1 = unsafePerformIO $ do
+ _ <- tryPutMVar entered1 ()
+ takeMVar gate1
+ let blocking2 = unsafePerformIO $ do
+ _ <- tryPutMVar entered2 ()
+ takeMVar gate2
+ let l1 = case B.n2_a O.n2 blocking1 2 of (a, _) -> a
+ let thunk = B.n7_a O.n7 l1 blocking2 3 4 5 6 7
+ tid1 <- forkIO $ do
+ _ <- tryEval thunk
+ return ()
+ takeMVar entered1
+ killThread tid1
+ threadDelay 10000
+ putMVar gate1 100
+ tid2 <- forkIO $ do
+ _ <- tryEval thunk
+ return ()
+ takeMVar entered2
+ killThread tid2
+ threadDelay 10000
+ putMVar gate2 200
+ result <- evaluate thunk
+ putStrLn $ "async_nested_ctoi " ++ show
+ (result == (100,200,3,4,5,6,7))
+
+ -- ========================================================
+ -- All-generic multi-ctoi AP_STACK tests (32+ element tuples)
+ -- ========================================================
+
+ -- Single 32-element generic ctoi frame (spill = 26)
+ apStackTest "async_n32" (42 :: Int)
+ (\b -> B.n32_a O.n32 b 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15 16
+ 17 18 19 20 21 22 23 24
+ 25 26 27 28 29 30 31 32)
+ ((42,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16),
+ (17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32))
+
+ -- 2 generic ctoi frames: n20 (spill=14) inside n32 (spill=26)
+ apStackTest "async_2gen32" (42 :: Int)
+ (\b -> let l1 = case B.n20_a O.n20 b 2 3 4 5 6 7 8 9 10
+ 11 12 13 14 15 16 17 18 19 20
+ of ((a,_,_,_,_),_,_,_) -> a
+ in B.n32_a O.n32 l1 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15 16
+ 17 18 19 20 21 22 23 24
+ 25 26 27 28 29 30 31 32)
+ ((42,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16),
+ (17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32))
+
+ -- 2 generic ctoi frames with mixed types: n15 (spill=9) inside mix32 (spill=14)
+ apStackTest "async_gen_mix" (42 :: Int)
+ (\b -> let l1 = case B.n15_a O.n15 b 2 3 4 5 6 7 8 9 10 11 12 13 14 15
+ of ((a,_,_,_,_),_,_) -> a
+ in B.mix32_a O.mix32
+ 1 l1 3.0 4.0 5 6 7.0 8.0 9 10 11.0 12.0
+ 13 14 15.0 16.0 17 18 19.0 20.0 21 22 23.0 24.0
+ 25 26 27.0 28.0 29 30 31.0 32.0)
+ ((1,42,3.0,4.0),(5,6,7.0,8.0),(9,10,11.0,12.0),
+ (13,14,15.0,16.0),(17,18,19.0,20.0),(21,22,23.0,24.0),
+ (25,26,27.0,28.0),(29,30,31.0,32.0))
+
+ -- ========================================================
+ -- AP_STACK replay with non-zero base TSO state
+ -- ========================================================
+ -- These tests replay AP_STACKs inside an outer generic ctoi frame,
+ -- so restoreStackInvariants must patch the saved old_spill in the
+ -- replayed segment to match the outer frame's spill count.
+ -- See Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm.
+
+ -- AP_STACK with generic ctoi(n15, spill=9) replayed inside
+ -- ctoi(n20, spill=14). If restoreStackInvariants doesn't patch
+ -- n15's old_spill to 14, n15's return restores TSO to 0 (from the
+ -- killed thread's context), and ctoi(n20) reads 0 spill words
+ -- instead of 14 -> stack corruption.
+ do entered <- newEmptyMVar
+ gate <- newEmptyMVar
+ let innerThunk = B.n15_a O.n15
+ (unsafePerformIO $ do
+ _ <- tryPutMVar entered ()
+ takeMVar gate)
+ 2 3 4 5 6 7 8 9 10 11 12 13 14 15
+ tid <- forkIO $ do
+ _ <- tryEval innerThunk
+ return ()
+ takeMVar entered
+ killThread tid
+ threadDelay 10000
+ putMVar gate 42
+ -- Force innerThunk (AP_STACK replay) inside generic ctoi(n20)
+ let l1 = case innerThunk of ((a,_,_,_,_),_,_) -> a
+ result <- evaluate (B.n20_a O.n20 l1 2 3 4 5 6 7 8 9 10
+ 11 12 13 14 15 16 17 18 19 20)
+ putStrLn $ "async_replay_base " ++ show
+ (result == ((42,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20)))
+
+ -- AP_STACK with 2 generic ctoi frames (n15+n20) replayed inside
+ -- ctoi(n32, spill=26). restoreStackInvariants must patch the outermost
+ -- replayed frame's (n20) old_spill to 26.
+ do entered <- newEmptyMVar
+ gate <- newEmptyMVar
+ let blocking = unsafePerformIO $ do
+ _ <- tryPutMVar entered ()
+ takeMVar gate
+ let l1 = case B.n15_a O.n15 blocking 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15
+ of ((a,_,_,_,_),_,_) -> a
+ let innerThunk = B.n20_a O.n20 l1 2 3 4 5 6 7 8 9 10
+ 11 12 13 14 15 16 17 18 19 20
+ tid <- forkIO $ do
+ _ <- tryEval innerThunk
+ return ()
+ takeMVar entered
+ killThread tid
+ threadDelay 10000
+ putMVar gate 42
+ -- Force inside generic ctoi(n32, spill=26); replays 2 inner frames
+ let l2 = case innerThunk of ((a,_,_,_,_),_,_,_) -> a
+ result <- evaluate (B.n32_a O.n32 l2 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15 16
+ 17 18 19 20 21 22 23 24
+ 25 26 27 28 29 30 31 32)
+ putStrLn $ "async_replay_2inner " ++ show
+ (result == ((42,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16),
+ (17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32)))
+
+ -- AP_STACK replay inside ctoi(n20), where the replay triggers an
+ -- exception caught between the restored ctoi(n15) and outer ctoi(n20).
+ -- Tests restoreStackInvariants patching AND exception unwinding through
+ -- the patched frame: if n15's old_spill is wrong, the unwind restores
+ -- the wrong value, and ctoi(n20) reads the wrong spill count.
+ do entered <- newEmptyMVar
+ gate <- newEmptyMVar
+ let innerThunk = B.n15_a O.n15
+ (unsafePerformIO $ do
+ _ <- tryPutMVar entered ()
+ takeMVar gate)
+ 2 3 4 5 6 7 8 9 10 11 12 13 14 15
+ tid <- forkIO $ do
+ _ <- tryEval innerThunk
+ return ()
+ takeMVar entered
+ killThread tid
+ threadDelay 10000
+ putMVar gate (error "exc")
+ -- Force inside ctoi(n20); replay throws, caught between frames
+ let l1 :: Int
+ l1 = unsafePerformIO $
+ catch (evaluate innerThunk >>= \r ->
+ case r of ((a,_,_,_,_),_,_) -> return a)
+ (const (return 99) :: SomeException -> IO Int)
+ result <- evaluate (B.n20_a O.n20 l1 2 3 4 5 6 7 8 9 10
+ 11 12 13 14 15 16 17 18 19 20)
+ putStrLn $ "async_replay_catch " ++ show
+ (result == ((99,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20)))
+
+-- ========================================================
+-- Helpers
+-- ========================================================
+
+swapStress :: Int -> (Int, Int) -> (Int, Int)
+swapStress n (a, b)
+ | n <= 0 = (a, b)
+ | even n = swapStress (n-1) (B.p2_a O.p2 b a)
+ | otherwise = swapStress (n-1) (O.p2_a B.p2 b a)
+
+testX :: (Eq a, Show a)
+ => String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO ()
+testX msg a1 a2 b1 b2 ap =
+ let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]]
+ in putStrLn (msg ++ " " ++ show (all (==r) rs) ++ " " ++ show r)
+
+-- | Evaluate an expression and catch any exception.
+tryEval :: a -> IO (Either SomeException a)
+tryEval x = try (evaluate x)
+
+-- | Check that an Either SomeException result is Right with the expected value.
+isRight :: Eq a => a -> Either SomeException a -> Bool
+isRight expected (Right v) = v == expected
+isRight _ (Left _) = False
+
+-- | Run an AP_STACK replay test. @mkThunk@ receives a blocking value (backed
+-- by an MVar) and should build a thunk that forces it during evaluation.
+-- The thunk is evaluated in a thread that gets killed (creating an AP_STACK),
+-- then the MVar is filled with @unblockVal@ and the AP_STACK is replayed.
+apStackTest :: Eq a => String -> b -> (b -> a) -> a -> IO ()
+apStackTest name unblockVal mkThunk expected = do
+ entered <- newEmptyMVar
+ gate <- newEmptyMVar
+ let blocking = unsafePerformIO $ do
+ _ <- tryPutMVar entered ()
+ takeMVar gate
+ let thunk = mkThunk blocking
+ tid <- forkIO $ do
+ _ <- tryEval thunk
+ return ()
+ takeMVar entered
+ killThread tid
+ threadDelay 10000
+ putMVar gate unblockVal
+ r <- tryEval thunk
+ putStrLn $ name ++ " " ++ show (isRight expected r)
=====================================
testsuite/tests/bytecode/tuplestress/TupleStress.stdout
=====================================
@@ -0,0 +1,46 @@
+p7 True (1,2,3,4,5,6,7)
+n2 True (1,2)
+n7 True (1,2,3,4,5,6,7)
+n15 True ((1,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15))
+d7 True (1.5,2.5,3.5,4.5,5.5,6.5,7.5)
+fl7 True (1.25,2.25,3.25,4.25,5.25,6.25,7.25)
+w7 True (100,200,300,400,500,600,700)
+mpi6 True (1,2,3,4,5,6)
+mpd6 True (1,1.5,2,2.5,3,3.5)
+mall8 True (1,2,3.0,4.0,5,6,7.0,8.0)
+sub5 True (42,1000,70000,99,100)
+vd6 True (11,22,33)
+n14 True ((1,2,3,4,5,6,7),(8,9,10,11,12,13,14))
+n20 True ((1,2,3,4,5),(6,7,8,9,10),(11,12,13,14,15),(16,17,18,19,20))
+n32 True ((1,2,3,4,5,6,7,8),(9,10,11,12,13,14,15,16),(17,18,19,20,21,22,23,24),(25,26,27,28,29,30,31,32))
+mix32 True ((1,2,3.0,4.0),(5,6,7.0,8.0),(9,10,11.0,12.0),(13,14,15.0,16.0),(17,18,19.0,20.0),(21,22,23.0,24.0),(25,26,27.0,28.0),(29,30,31.0,32.0))
+loop_p7 True
+loop_mpd True
+loop_n32 True
+chain_arith (80,80,80,40,80,80,80)
+swap_stress (1,2)
+rec_mixed (50,100,25.0,75.0)
+fib_cross 832040
+exc_n7_bo True
+exc_n15_bo True
+exc_mpd_bo True
+exc_repeat True
+exc_n14_bo True
+exc_n32_bo True
+exc_nested_2gen True
+exc_catch_between True
+async_n7 True
+async_other True
+async_n14 True
+async_nested True
+async_exc_combo True
+async_loop True
+async_2ctoi True
+async_3ctoi True
+async_nested_ctoi True
+async_n32 True
+async_2gen32 True
+async_gen_mix True
+async_replay_base True
+async_replay_2inner True
+async_replay_catch True
=====================================
testsuite/tests/bytecode/tuplestress/all.T
=====================================
@@ -0,0 +1,10 @@
+test('TupleStress',
+ [ extra_files(['Obj.hs', 'ByteCode.hs', 'Common.hs-incl']),
+ req_interp,
+ req_bco,
+ only_ways(ghci_ways),
+ extra_ways(ghci_ways),
+ ],
+ compile_and_run,
+ ['']
+ )
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -476,6 +476,7 @@ wanteds os = concat
,closureField Both "StgTSO" "alloc_limit"
,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs"
,closureField Both "StgTSO" "stackobj"
+ ,closureField Both "StgTSO" "ctoi_tuple_spill_words"
,closureField Both "StgStack" "sp"
,closureFieldOffset Both "StgStack" "stack"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe6e76c5e0155b9b34948957476b0b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe6e76c5e0155b9b34948957476b0b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0