[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: interpreter: Fix underflow frame lookups
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Feb 25 19:43:36 UTC 2025
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f4da90f1 by Matthew Pickering at 2025-02-25T14:11:21-05:00
interpreter: Fix underflow frame lookups
BCOs can be nested, resulting in nested BCO stack frames where the inner most
stack frame can refer to variables stored on earlier stack frames via the
PUSH_L instruction.
|---------|
| BCO_1 | -<-┐
|---------|
......... |
|---------| | PUSH_L <n>
| BCO_N | ->-┘
|---------|
Here BCO_N is syntactically nested within the code for BCO_1 and will result
in code that references the prior stack frame of BCO_1 for some of it's local
variables. If a stack overflow happens between the creation of the stack frame
for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving
BCO_1 in place, invalidating a simple offset based reference to the outer stack
frames.
Therefore `ReadSpW` first performs a bounds check to ensure that accesses onto
the stack will succeed. If the target address would not be a valid location for
the current stack chunk then `slow_spw` function is called, which dereferences
the underflow frame to adjust the offset before performing the lookup.
┌->--x | CHK_1 |
| CHK_2 | | | |---------|
|---------| | └-> | BCO_1 |
| UD_FLOW | -- x |---------|
|---------| |
| ...... | |
|---------| | PUSH_L <n>
| BCO_ N | ->-┘
|---------|
Fixes #25750
- - - - -
c3f2d284 by Vladislav Zavialov at 2025-02-25T14:11:58-05:00
Remove ArgPatBuilder
ArgPatBuilder in Parser/PostProcess.hs became redundant with the
introduction of InvisPat (36a75b80eb).
This small refactoring removes it.
- - - - -
011b8162 by sheaf at 2025-02-25T14:42:58-05:00
Propagate long distance info to guarded let binds
This commit ensures that we propagate the enclosing long distance
information to let bindings inside guards, in order to get accurate
pattern-match checking warnings, in particular incomplete record
selector warnings.
Example:
data D = K0 | K1 { fld :: Int }
f :: D -> Int
f d@(K1 {})
| let i = fld d
= i
f _ = 3
We now correctly recognise that the field selector 'fld' cannot fail,
due to the outer pattern match which guarantees that the value 'd' has
the field 'fld'.
Fixes #25749
- - - - -
de427830 by Fangyi Zhou at 2025-02-25T14:43:03-05:00
wasm: use primitive opcodes for fabs and sqrt
- Add new `WasmInstr` constructor `WasmSqrt` for sqrt, corresponding to
primitivie operations in wasm.
- When lowering CallishMachOp, use `WasmAbs` and `WasmSqrt` for F32 and
F64 fabs and sqrt.
- - - - -
5024b919 by Cheng Shao at 2025-02-25T14:43:03-05:00
hadrian: enable building stage1 haddock for cross ghc
This commit enables building stage1 haddock for cross ghc. Without
this change, hadrian would panic with "Unknown program" error when
building the _build/stage1/bin/cross-prefix-haddock program needed by
the docs-haddock target, even if it only needs to copy from
_build/stage0/bin/cross-prefix-haddock.
- - - - -
6e04d4c6 by Cheng Shao at 2025-02-25T14:43:03-05:00
hadrian: enable building docs for cross targets
Hadrian used to omit the docs target as a part of binary-dist-dir for
cross targets. This commit enables docs to be built as a part of cross
bindists and it works just fine in CI.
- - - - -
311f6a91 by Cheng Shao at 2025-02-25T14:43:03-05:00
ci: build haddock/sphinx-html for wasm jobs
This commit enables building haddock & sphinx-html documentation for
wasm targets. The docs are useful for end users and should be tested
in CI.
I've omitted pdf & manpage generation for the wasm target; I've never
found the pdf version of docs to be useful, and the manpage only
contains `ghc.1` where we really want `wasm32-wasi-ghc.1` but that
should be a separate issue to fix.
- - - - -
fdb18bbf by Cheng Shao at 2025-02-25T14:43:03-05:00
ghci: remove unused showBreakArray function
GHCi.BreakArray.showBreakArray is not used anywhere, hence the
housecleaning.
- - - - -
e2017eee by Cheng Shao at 2025-02-25T14:43:04-05:00
ghc-heap: fix HalfWord incompatible Binary instances for cross GHC
ghc-heap defines HalfWord as Word32/Word16 depending on host word
size. For cross GHC with different host/target word sizes, the Binary
instances are incompatible and breaks iserv serialization of any
message type that involves HalfWord, breaking the ghci debugger. This
patch fixes the issue and has been tested to fix ghci debugger
functionality of the wasm backend. Fixes #25420 #25781.
- - - - -
15 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/CmmToAsm/Wasm/Asm.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/Wasm/Types.hs
- compiler/GHC/HsToCore/GuardedRHSs.hs
- compiler/GHC/Parser/PostProcess.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Settings/Default.hs
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
- libraries/ghci/GHCi/BreakArray.hs
- libraries/ghci/GHCi/Message.hs
- rts/Interpreter.c
- + testsuite/tests/pmcheck/should_compile/T25749.hs
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -1276,7 +1276,7 @@ cross_jobs = [
make_wasm_jobs cfg =
modifyJobs
( delVariable "BROKEN_TESTS"
- . setVariable "HADRIAN_ARGS" "--docs=none"
+ . setVariable "HADRIAN_ARGS" "--docs=no-sphinx-pdfs --docs=no-sphinx-man --haddock-for-hackage"
. delVariable "INSTALL_CONFIGURE_ARGS"
)
$ addValidateRule WasmBackend $ validateBuilds Amd64 (Linux AlpineWasm) cfg
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1462,7 +1462,7 @@
"BUILD_FLAVOUR": "release+host_fully_static+text_simdutf",
"CONFIGURE_ARGS": "--with-intree-gmp --with-system-libffi --enable-strict-ghc-toolchain-check",
"CROSS_TARGET": "wasm32-wasi",
- "HADRIAN_ARGS": "--docs=none",
+ "HADRIAN_ARGS": "--docs=no-sphinx-pdfs --docs=no-sphinx-man --haddock-for-hackage",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-linux-alpine3_20-wasm-cross_wasm32-wasi-release+host_fully_static+text_simdutf",
"XZ_OPT": "-9"
@@ -1526,7 +1526,7 @@
"BUILD_FLAVOUR": "release+host_fully_static+text_simdutf",
"CONFIGURE_ARGS": "--with-intree-gmp --with-system-libffi --enable-strict-ghc-toolchain-check",
"CROSS_TARGET": "wasm32-wasi",
- "HADRIAN_ARGS": "--docs=none",
+ "HADRIAN_ARGS": "--docs=no-sphinx-pdfs --docs=no-sphinx-man --haddock-for-hackage",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-linux-alpine3_20-wasm-int_native-cross_wasm32-wasi-release+host_fully_static+text_simdutf",
"XZ_OPT": "-9"
@@ -1590,7 +1590,7 @@
"BUILD_FLAVOUR": "release+host_fully_static+text_simdutf",
"CONFIGURE_ARGS": "--enable-unregisterised --with-intree-gmp --with-system-libffi --enable-strict-ghc-toolchain-check",
"CROSS_TARGET": "wasm32-wasi",
- "HADRIAN_ARGS": "--docs=none",
+ "HADRIAN_ARGS": "--docs=no-sphinx-pdfs --docs=no-sphinx-man --haddock-for-hackage",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-linux-alpine3_20-wasm-unreg-cross_wasm32-wasi-release+host_fully_static+text_simdutf",
"XZ_OPT": "-9"
@@ -5731,7 +5731,7 @@
"BUILD_FLAVOUR": "release+host_fully_static+text_simdutf",
"CONFIGURE_ARGS": "--with-intree-gmp --with-system-libffi --enable-strict-ghc-toolchain-check",
"CROSS_TARGET": "wasm32-wasi",
- "HADRIAN_ARGS": "--docs=none",
+ "HADRIAN_ARGS": "--docs=no-sphinx-pdfs --docs=no-sphinx-man --haddock-for-hackage",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-linux-alpine3_20-wasm-cross_wasm32-wasi-release+host_fully_static+text_simdutf"
}
@@ -5795,7 +5795,7 @@
"BUILD_FLAVOUR": "release+host_fully_static+text_simdutf",
"CONFIGURE_ARGS": "--with-intree-gmp --with-system-libffi --enable-strict-ghc-toolchain-check",
"CROSS_TARGET": "wasm32-wasi",
- "HADRIAN_ARGS": "--docs=none",
+ "HADRIAN_ARGS": "--docs=no-sphinx-pdfs --docs=no-sphinx-man --haddock-for-hackage",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-linux-alpine3_20-wasm-int_native-cross_wasm32-wasi-release+host_fully_static+text_simdutf"
}
@@ -5859,7 +5859,7 @@
"BUILD_FLAVOUR": "release+host_fully_static+text_simdutf",
"CONFIGURE_ARGS": "--enable-unregisterised --with-intree-gmp --with-system-libffi --enable-strict-ghc-toolchain-check",
"CROSS_TARGET": "wasm32-wasi",
- "HADRIAN_ARGS": "--docs=none",
+ "HADRIAN_ARGS": "--docs=no-sphinx-pdfs --docs=no-sphinx-man --haddock-for-hackage",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-linux-alpine3_20-wasm-unreg-cross_wasm32-wasi-release+host_fully_static+text_simdutf"
}
=====================================
compiler/GHC/CmmToAsm/Wasm/Asm.hs
=====================================
@@ -374,6 +374,7 @@ asmTellWasmInstr ty_word instr = case instr of
WasmF32DemoteF64 -> asmTellLine "f32.demote_f64"
WasmF64PromoteF32 -> asmTellLine "f64.promote_f32"
WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs"
+ WasmSqrt ty -> asmTellLine $ asmFromWasmType ty <> ".sqrt"
WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg"
WasmMin ty -> asmTellLine $ asmFromWasmType ty <> ".min"
WasmMax ty -> asmTellLine $ asmFromWasmType ty <> ".max"
=====================================
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
=====================================
@@ -1108,6 +1108,28 @@ lower_CMO_Un_Homo lbl op [reg] [x] = do
x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri
lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable"
+-- | Lower an unary homogeneous 'CallishMachOp' to a primitive operation.
+lower_CMO_Un_Homo_Prim ::
+ CLabel ->
+ ( forall pre t.
+ WasmTypeTag t ->
+ WasmInstr
+ w
+ (t : pre)
+ (t : pre)
+ ) ->
+ WasmTypeTag t ->
+ [CmmFormal] ->
+ [CmmActual] ->
+ WasmCodeGenM w (WasmStatements w)
+lower_CMO_Un_Homo_Prim lbl op ty [reg] [x] = do
+ (ri, _) <- onCmmLocalReg reg
+ WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
+ pure $
+ WasmStatements $
+ x_instr `WasmConcat` op ty `WasmConcat` WasmLocalSet ty ri
+lower_CMO_Un_Homo_Prim _ _ _ _ _ = panic "lower_CMO_Bin_Homo_Prim: unreachable"
+
-- | Lower a binary homogeneous 'CallishMachOp' to a ccall.
lower_CMO_Bin_Homo ::
CLabel ->
@@ -1211,8 +1233,8 @@ lower_CallishMachOp lbl MO_F64_Log rs xs = lower_CMO_Un_Homo lbl "log" rs xs
lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs
lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs
lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs
-lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo lbl "fabs" rs xs
-lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrt" rs xs
+lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF64 rs xs
+lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF64 rs xs
lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs
lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs
lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs
@@ -1235,8 +1257,8 @@ lower_CallishMachOp lbl MO_F32_Log1P rs xs =
lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs
lower_CallishMachOp lbl MO_F32_ExpM1 rs xs =
lower_CMO_Un_Homo lbl "expm1f" rs xs
-lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo lbl "fabsf" rs xs
-lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrtf" rs xs
+lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF32 rs xs
+lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF32 rs xs
lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs
lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop
lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop
=====================================
compiler/GHC/CmmToAsm/Wasm/Types.hs
=====================================
@@ -310,6 +310,7 @@ data WasmInstr :: WasmType -> [WasmType] -> [WasmType] -> Type where
WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre)
WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre)
WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)
+ WasmSqrt :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)
WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)
WasmMin :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
WasmMax :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -76,7 +76,8 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM (MatchResult CoreExpr)
dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
- = matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty
+ = updPmNablas rhs_nablas $
+ matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
{-
************************************************************************
@@ -88,7 +89,6 @@ dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
matchGuards :: [GuardStmt GhcTc] -- Guard
-> HsMatchContextRn -- Context
- -> Nablas -- The RHS's covered set for PmCheck
-> LHsExpr GhcTc -- RHS
-> Type -- Type of RHS of guard
-> DsM (MatchResult CoreExpr)
@@ -96,8 +96,8 @@ matchGuards :: [GuardStmt GhcTc] -- Guard
-- See comments with HsExpr.Stmt re what a BodyStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
-matchGuards [] _ nablas rhs _
- = do { core_rhs <- updPmNablas nablas (dsLExpr rhs)
+matchGuards [] _ rhs _
+ = do { core_rhs <- dsLExpr rhs
; return (cantFailMatchResult core_rhs) }
-- BodyStmts must be guards
@@ -107,42 +107,50 @@ matchGuards [] _ nablas rhs _
-- NB: The success of this clause depends on the typechecker not
-- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-- If it does, you'll get bogus overlap warnings
-matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty
+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
| Just addTicks <- isTrueLHsExpr e = do
- match_result <- matchGuards stmts ctx nablas rhs rhs_ty
+ match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs addTicks match_result)
-matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do
- match_result <- matchGuards stmts ctx nablas rhs rhs_ty
+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
+ match_result <- matchGuards stmts ctx rhs rhs_ty
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
-matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do
- match_result <- matchGuards stmts ctx nablas rhs rhs_ty
- return (adjustMatchResultDs (dsLocalBinds binds) match_result)
+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
+ ldi_nablas <- getPmNablas
+ match_result <- matchGuards stmts ctx rhs rhs_ty
+ -- Propagate long-distance information when desugaring let bindings, e.g.
+ --
+ -- f r@(K1 {})
+ -- | let g = fld r
+ -- = g
+ --
+ -- Failing to do so resulted in #25749.
+ return (adjustMatchResultDs (updPmNablas ldi_nablas . dsLocalBinds binds) match_result)
-- NB the dsLet occurs inside the match_result
-- Reason: dsLet takes the body expression as its argument
-- so we can't desugar the bindings without the
-- body expression in hand
-matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do
+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do
let upat = unLoc pat
match_var <- selectMatchVar ManyTy upat
-- We only allow unrestricted patterns in guards, hence the `Many`
-- above. It isn't clear what linear patterns would mean, maybe we will
-- figure it out in the future.
- match_result <- matchGuards stmts ctx nablas rhs rhs_ty
+ match_result <- matchGuards stmts ctx rhs rhs_ty
core_rhs <- dsLExpr bind_rhs
match_result' <-
matchSinglePatVar match_var (Just core_rhs) (StmtCtxt $ PatGuard ctx)
pat rhs_ty match_result
return $ bindNonRec match_var core_rhs <$> match_result'
-matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"
-matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt"
-matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
-matchGuards (RecStmt {} : _) _ _ _ _ = panic "matchGuards RecStmt"
-matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ _ =
+matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
+matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
+matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
+matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ =
panic "matchGuards ApplicativeLastStmt"
{-
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1257,10 +1257,6 @@ checkPattern = runPV . checkLPat
checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)
-checkLArgPat :: LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLArgPat (L l (ArgPatBuilderVisPat p)) = checkLPat (L l p)
-checkLArgPat (L l (ArgPatBuilderArgPat p)) = return (L l p)
-
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat (L l@(EpAnn anc an _) p) = do
(L l' p', cs) <- checkPat (EpAnn anc an emptyComments) emptyComments (L l p) [] []
@@ -1398,11 +1394,11 @@ checkFunBind :: SrcSpan
-> AnnFunRhs
-> LocatedN RdrName
-> LexicalFixity
- -> LocatedE [LocatedA (ArgPatBuilder GhcPs)]
+ -> LocatedE [LocatedA (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
checkFunBind locF ann_fun (L lf fun) is_infix (L lp pats) (L _ grhss)
- = do ps <- runPV_details extraDetails (mapM checkLArgPat pats)
+ = do ps <- runPV_details extraDetails (mapM checkLPat pats)
let match_span = noAnnSrcSpan $ locF
return (makeFunBind (L (l2l lf) fun) (L (noAnnSrcSpan $ locA match_span)
[L match_span (Match { m_ext = noExtField
@@ -1483,20 +1479,18 @@ checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
isFunLhs :: LocatedA (PatBuilder GhcPs)
-> P (Maybe (LocatedN RdrName, LexicalFixity,
- [LocatedA (ArgPatBuilder GhcPs)],[EpToken "("],[EpToken ")"]))
+ [LocatedA (PatBuilder GhcPs)],[EpToken "("],[EpToken ")"]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
isFunLhs e = go e [] [] []
where
- mk = fmap ArgPatBuilderVisPat
-
go (L l (PatBuilderVar (L loc f))) es ops cps
| not (isRdrDataCon f) = do
let (_l, loc') = transferCommentsOnlyA l loc
return (Just (L loc' f, Prefix, es, (reverse ops), cps))
go (L l (PatBuilderApp (L lf f) e)) es ops cps = do
let (_l, lf') = transferCommentsOnlyA l lf
- go (L lf' f) (mk e:es) ops cps
+ go (L lf' f) (e:es) ops cps
go (L l (PatBuilderPar _ (L le e) _)) es@(_:_) ops cps = go (L le' e) es (o:ops) (c:cps)
-- NB: es@(_:_) means that there must be an arg after the parens for the
-- LHS to be a function LHS. This corresponds to the Haskell Report's definition
@@ -1507,33 +1501,25 @@ isFunLhs e = go e [] [] []
go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r (os,cs))) es ops cps
| not (isRdrDataCon op) -- We have found the function!
= do { let (_l, ll') = transferCommentsOnlyA loc ll
- ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (os ++ reverse ops), (cs ++ cps))) }
+ ; return (Just (L loc' op, Infix, ((L ll' l):r:es), (os ++ reverse ops), (cs ++ cps))) }
| otherwise -- Infix data con; keep going
= do { let (_l, ll') = transferCommentsOnlyA loc ll
; mb_l <- go (L ll' l) es ops cps
; return (reassociate =<< mb_l) }
where
- reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', ops', cps')
+ reassociate (op', Infix, j : L k_loc k : es', ops', cps')
= Just (op', Infix, j : op_app : es', ops', cps')
where
- op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)
+ op_app = L loc (PatBuilderOpApp (L k_loc k)
(L loc' op) r (reverse ops, cps))
reassociate _other = Nothing
go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
- = go (L lp' pat) (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
+ = go (L lp' pat) (L (EpAnn anc' ann cs) (PatBuilderPat invis_pat) : es) ops cps
where invis_pat = InvisPat (tok, SpecifiedSpec) ty_pat
anc' = widenAnchorT anc tok
(_l, lp') = transferCommentsOnlyA l lp
go _ _ _ _ = return Nothing
-data ArgPatBuilder p
- = ArgPatBuilderVisPat (PatBuilder p)
- | ArgPatBuilderArgPat (Pat p)
-
-instance Outputable (ArgPatBuilder GhcPs) where
- ppr (ArgPatBuilderVisPat p) = ppr p
- ppr (ArgPatBuilderArgPat p) = ppr p
-
mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy tok_loc strictness =
HsBangTy ((noAnn, noAnn, tok_loc), NoSourceText) (HsBang NoSrcUnpack strictness)
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -159,7 +159,7 @@ bindistRules = do
let lib_exe_targets = (lib_targets ++ (map (\(_, p) -> p) (bin_targets ++ iserv_targets)))
- let doc_target = if cross then [] else ["docs"]
+ let doc_target = ["docs"]
let other_targets = map (bindistFilesDir -/-) (["configure", "Makefile"] ++ bindistInstallFiles)
let all_targets = lib_exe_targets ++ doc_target ++ other_targets
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -156,6 +156,7 @@ stage1Packages = do
, ghcInternal
, ghcPkg
, ghcPrim
+ , haddock
, haskeline
, hp2ps
, hsc2hs
@@ -174,8 +175,7 @@ stage1Packages = do
, if winTarget then win32 else unix
]
, when (not cross)
- [ haddock
- , hpcBin
+ [ hpcBin
, iserv
, runGhc
, ghcToolchainBin
=====================================
libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
=====================================
@@ -1,8 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module GHC.Exts.Heap.InfoTable.Types
( StgInfoTable(..)
, EntryFunPtr
- , HalfWord
+ , HalfWord(..)
, ItblCodes
) where
@@ -18,13 +21,16 @@ type ItblCodes = Either [Word8] [Word32]
#include "ghcautoconf.h"
-- Ultra-minimalist version specially for constructors
#if SIZEOF_VOID_P == 8
-type HalfWord = Word32
+type HalfWord' = Word32
#elif SIZEOF_VOID_P == 4
-type HalfWord = Word16
+type HalfWord' = Word16
#else
#error Unknown SIZEOF_VOID_P
#endif
+newtype HalfWord = HalfWord HalfWord'
+ deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable)
+
type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
-- | This is a somewhat faithful representation of an info table. See
=====================================
libraries/ghci/GHCi/BreakArray.hs
=====================================
@@ -30,11 +30,9 @@ module GHCi.BreakArray
, setupBreakpoint
, breakOn
, breakOff
- , showBreakArray
) where
import Prelude -- See note [Why do we import Prelude here?]
-import Control.Monad
import GHC.Exts
import GHC.IO ( IO(..) )
@@ -48,13 +46,6 @@ breakOff, breakOn :: Int
breakOn = 0
breakOff = -1
-showBreakArray :: BreakArray -> IO ()
-showBreakArray array = do
- forM_ [0 .. (size array - 1)] $ \i -> do
- val <- readBreakArray array i
- putStr $ ' ' : show val
- putStr "\n"
-
setupBreakpoint :: BreakArray -> Int -> Int -> IO Bool
setupBreakpoint breakArray ind val
| safeIndex breakArray ind = do
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -498,6 +498,10 @@ instance Binary (FunPtr a) where
put = put . castFunPtrToPtr
get = castPtrToFunPtr <$> get
+instance Binary Heap.HalfWord where
+ put x = put (fromIntegral x :: Word32)
+ get = fromIntegral <$> (get :: Get Word32)
+
-- Binary instances to support the GetClosure message
instance Binary Heap.StgTSOProfInfo
instance Binary Heap.CostCentreStack
=====================================
rts/Interpreter.c
=====================================
@@ -171,6 +171,54 @@ tag functions as tag inference currently doesn't rely on those being properly ta
#define SpW(n) (*(StgWord*)(Sp_plusW(n)))
#define SpB(n) (*(StgWord*)(Sp_plusB(n)))
+#define WITHIN_CAP_CHUNK_BOUNDS(n) WITHIN_CHUNK_BOUNDS(n, cap->r.rCurrentTSO->stackobj)
+
+#define WITHIN_CHUNK_BOUNDS(n, s) \
+ (RTS_LIKELY((StgWord*)(Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
+
+
+/* Note [PUSH_L underflow]
+ ~~~~~~~~~~~~~~~~~~~~~~~
+BCOs can be nested, resulting in nested BCO stack frames where the inner most
+stack frame can refer to variables stored on earlier stack frames via the
+PUSH_L instruction.
+
+|---------|
+| BCO_1 | -<-┐
+|---------|
+ ......... |
+|---------| | PUSH_L <n>
+| BCO_N | ->-┘
+|---------|
+
+Here BCO_N is syntactically nested within the code for BCO_1 and will result
+in code that references the prior stack frame of BCO_1 for some of it's local
+variables. If a stack overflow happens between the creation of the stack frame
+for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving
+BCO_1 in place, invalidating a simple offset based reference to the outer stack
+frames.
+Therefore `ReadSpW` first performs a bounds check to ensure that accesses onto
+the stack will succeed. If the target address would not be a valid location for
+the current stack chunk then `slow_spw` function is called, which dereferences
+the underflow frame to adjust the offset before performing the lookup.
+
+ ┌->--x | CHK_1 |
+| CHK_2 | | | |---------|
+|---------| | └-> | BCO_1 |
+| UD_FLOW | -- x |---------|
+|---------| |
+| ...... | |
+|---------| | PUSH_L <n>
+| BCO_ N | ->-┘
+|---------|
+See ticket #25750
+
+*/
+
+#define ReadSpW(n) \
+ ((WITHIN_CAP_CHUNK_BOUNDS(n)) ? SpW(n): slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n))
+
+
STATIC_INLINE StgPtr
allocate_NONUPD (Capability *cap, int n_words)
{
@@ -193,6 +241,8 @@ unsigned long it_retto_BCO;
unsigned long it_retto_UPDATE;
unsigned long it_retto_other;
+unsigned long it_underflow_lookups;
+
unsigned long it_slides;
unsigned long it_insns;
unsigned long it_BCO_entries;
@@ -209,6 +259,7 @@ void interp_startup ( void )
int i, j;
it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
it_total_entries = it_total_unknown_entries = 0;
+ it_underflow_lookups = 0;
for (i = 0; i < N_CLOSURE_TYPES; i++)
it_unknown_entries[i] = 0;
it_slides = it_insns = it_BCO_entries = 0;
@@ -229,6 +280,7 @@ void interp_shutdown ( void )
it_retto_BCO, it_retto_UPDATE, it_retto_other );
debugBelch("%lu total entries, %lu unknown entries \n",
it_total_entries, it_total_unknown_entries);
+ debugBelch("%lu lookups past the end of the stack frame\n", it_underflow_lookups);
for (i = 0; i < N_CLOSURE_TYPES; i++) {
if (it_unknown_entries[i] == 0) continue;
debugBelch(" type %2d: unknown entries (%4.1f%%) == %lu\n",
@@ -320,6 +372,53 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap)
#endif
+// See Note [PUSH_L underflow] for in which situations this
+// slow lookup is needed
+static StgWord
+slow_spw(void *Sp, StgStack *cur_stack, StgWord offset){
+ // 1. If in range, access the item from the current stack chunk
+ if (WITHIN_CHUNK_BOUNDS(offset, cur_stack)) {
+ return SpW(offset);
+ }
+ // 2. Not in this stack chunk, so access the underflow frame.
+ else {
+ StgWord stackWords;
+ StgUnderflowFrame *frame;
+ StgStack *new_stack;
+
+ frame = (StgUnderflowFrame*)(cur_stack->stack + cur_stack->stack_size
+ - sizeofW(StgUnderflowFrame));
+
+ // 2a. Check it is an underflow frame (the top stack chunk won't have one).
+ if( frame->info == &stg_stack_underflow_frame_d_info
+ || frame->info == &stg_stack_underflow_frame_v16_info
+ || frame->info == &stg_stack_underflow_frame_v32_info
+ || frame->info == &stg_stack_underflow_frame_v64_info )
+ {
+
+ INTERP_TICK(it_underflow_lookups);
+
+ new_stack = (StgStack*)frame->next_chunk;
+
+ // How many words were on the stack
+ stackWords = (StgWord *)frame - (StgWord *) Sp;
+ ASSERT(offset > stackWords);
+
+ // Recursive, in the very unlikely case we have to traverse two
+ // stack chunks.
+ return slow_spw(new_stack->sp, new_stack, offset-stackWords);
+ }
+ // 2b. Access the element if there is no underflow frame, it must be right
+ // at the top of the stack.
+ else {
+ // Not actually in the underflow case
+ return SpW(offset);
+ }
+
+ }
+
+}
+
// Compute the pointer tag for the constructor and tag the pointer;
// see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure.
//
@@ -401,7 +500,7 @@ interpretBCO (Capability* cap)
// +---------------+
//
else if (SpW(0) == (W_)&stg_apply_interp_info) {
- obj = UNTAG_CLOSURE((StgClosure *)SpW(1));
+ obj = UNTAG_CLOSURE((StgClosure *)ReadSpW(1));
Sp_addW(2);
goto run_BCO_fun;
}
@@ -413,7 +512,7 @@ interpretBCO (Capability* cap)
// do_return_pointer, below.
//
else if (SpW(0) == (W_)&stg_ret_p_info) {
- tagged_obj = (StgClosure *)SpW(1);
+ tagged_obj = (StgClosure *)ReadSpW(1);
Sp_addW(2);
goto do_return_pointer;
}
@@ -429,7 +528,7 @@ interpretBCO (Capability* cap)
// Evaluate the object on top of the stack.
eval:
- tagged_obj = (StgClosure*)SpW(0); Sp_addW(1);
+ tagged_obj = (StgClosure*)ReadSpW(0); Sp_addW(1);
eval_obj:
obj = UNTAG_CLOSURE(tagged_obj);
@@ -630,7 +729,7 @@ do_return_pointer:
info == (StgInfoTable *)&stg_restore_cccs_v32_info ||
info == (StgInfoTable *)&stg_restore_cccs_v64_info ||
info == (StgInfoTable *)&stg_restore_cccs_eval_info) {
- cap->r.rCCCS = (CostCentreStack*)SpW(1);
+ cap->r.rCCCS = (CostCentreStack*)ReadSpW(1);
Sp_addW(2);
goto do_return_pointer;
}
@@ -694,7 +793,7 @@ do_return_pointer:
INTERP_TICK(it_retto_BCO);
Sp_subW(1);
SpW(0) = (W_)tagged_obj;
- obj = (StgClosure*)SpW(2);
+ obj = (StgClosure*)ReadSpW(2);
ASSERT(get_itbl(obj)->type == BCO);
goto run_BCO_return_pointer;
@@ -741,12 +840,12 @@ do_return_nonpointer:
{
int offset;
- ASSERT( SpW(0) == (W_)&stg_ret_v_info
- || SpW(0) == (W_)&stg_ret_n_info
- || SpW(0) == (W_)&stg_ret_f_info
- || SpW(0) == (W_)&stg_ret_d_info
- || SpW(0) == (W_)&stg_ret_l_info
- || SpW(0) == (W_)&stg_ret_t_info
+ ASSERT( ReadSpW(0) == (W_)&stg_ret_v_info
+ || ReadSpW(0) == (W_)&stg_ret_n_info
+ || ReadSpW(0) == (W_)&stg_ret_f_info
+ || ReadSpW(0) == (W_)&stg_ret_d_info
+ || ReadSpW(0) == (W_)&stg_ret_l_info
+ || ReadSpW(0) == (W_)&stg_ret_t_info
);
IF_DEBUG(interpreter,
@@ -773,7 +872,7 @@ do_return_nonpointer:
// so the returned value is at the top of the stack, and start
// executing the BCO.
INTERP_TICK(it_retto_BCO);
- obj = (StgClosure*)SpW(offset+1);
+ obj = (StgClosure*)ReadSpW(offset+1);
ASSERT(get_itbl(obj)->type == BCO);
goto run_BCO_return_nonpointer;
@@ -835,7 +934,7 @@ do_apply:
// Shuffle the args for this function down, and put
// the appropriate info table in the gap.
for (i = 0; i < arity; i++) {
- SpW((int)i-1) = SpW(i);
+ SpW((int)i-1) = ReadSpW(i);
// ^^^^^ careful, i-1 might be negative, but i is unsigned
}
SpW(arity-1) = app_ptrs_itbl[n-arity-1];
@@ -874,7 +973,7 @@ do_apply:
new_pap->payload[i] = pap->payload[i];
}
for (i = 0; i < m; i++) {
- new_pap->payload[pap->n_args + i] = (StgClosure *)SpW(i);
+ new_pap->payload[pap->n_args + i] = (StgClosure *)ReadSpW(i);
}
// No write barrier is needed here as this is a new allocation
SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS);
@@ -898,7 +997,7 @@ do_apply:
// Shuffle the args for this function down, and put
// the appropriate info table in the gap.
for (i = 0; i < arity; i++) {
- SpW((int)i-1) = SpW(i);
+ SpW((int)i-1) = ReadSpW(i);
// ^^^^^ careful, i-1 might be negative, but i is unsigned
}
SpW(arity-1) = app_ptrs_itbl[n-arity-1];
@@ -917,7 +1016,7 @@ do_apply:
pap->fun = obj;
pap->n_args = m;
for (i = 0; i < m; i++) {
- pap->payload[i] = (StgClosure *)SpW(i);
+ pap->payload[i] = (StgClosure *)ReadSpW(i);
}
// No write barrier is needed here as this is a new allocation
SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS);
@@ -1034,7 +1133,7 @@ run_BCO_return_nonpointer:
*/
if(SpW(0) == (W_)&stg_ret_t_info) {
- cap->r.rCCCS = (CostCentreStack*)SpW(stack_frame_sizeW((StgClosure *)Sp) + 4);
+ cap->r.rCCCS = (CostCentreStack*)ReadSpW(stack_frame_sizeW((StgClosure *)Sp) + 4);
}
#endif
@@ -1101,7 +1200,7 @@ run_BCO:
if (0) { int i;
debugBelch("\n");
for (i = 8; i >= 0; i--) {
- debugBelch("%d %p\n", i, (void *) SpW(i));
+ debugBelch("%d %p\n", i, (void *) ReadSpW(i));
}
debugBelch("\n");
}
@@ -1203,7 +1302,7 @@ run_BCO:
// copy the contents of the top stack frame into the AP_STACK
for (i = 2; i < size_words; i++)
{
- new_aps->payload[i] = (StgClosure *)SpW(i-2);
+ new_aps->payload[i] = (StgClosure *)ReadSpW(i-2);
}
// No write barrier is needed here as this is a new allocation
@@ -1276,7 +1375,7 @@ run_BCO:
case bci_PUSH_L: {
W_ o1 = BCO_GET_LARGE_ARG;
- SpW(-1) = SpW(o1);
+ SpW(-1) = ReadSpW(o1);
Sp_subW(1);
goto nextInsn;
}
@@ -1284,8 +1383,8 @@ run_BCO:
case bci_PUSH_LL: {
W_ o1 = BCO_GET_LARGE_ARG;
W_ o2 = BCO_GET_LARGE_ARG;
- SpW(-1) = SpW(o1);
- SpW(-2) = SpW(o2);
+ SpW(-1) = ReadSpW(o1);
+ SpW(-2) = ReadSpW(o2);
Sp_subW(2);
goto nextInsn;
}
@@ -1294,9 +1393,9 @@ run_BCO:
W_ o1 = BCO_GET_LARGE_ARG;
W_ o2 = BCO_GET_LARGE_ARG;
W_ o3 = BCO_GET_LARGE_ARG;
- SpW(-1) = SpW(o1);
- SpW(-2) = SpW(o2);
- SpW(-3) = SpW(o3);
+ SpW(-1) = ReadSpW(o1);
+ SpW(-2) = ReadSpW(o2);
+ SpW(-3) = ReadSpW(o3);
Sp_subW(3);
goto nextInsn;
}
@@ -1650,7 +1749,7 @@ run_BCO:
* a_1 ... a_n, k
*/
while(n-- > 0) {
- SpW(n+by) = SpW(n);
+ SpW(n+by) = ReadSpW(n);
}
Sp_addW(by);
INTERP_TICK(it_slides);
@@ -1702,9 +1801,9 @@ run_BCO:
StgHalfWord i;
W_ stkoff = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
- StgAP* ap = (StgAP*)SpW(stkoff);
+ StgAP* ap = (StgAP*)ReadSpW(stkoff);
ASSERT(ap->n_args == n_payload);
- ap->fun = (StgClosure*)SpW(0);
+ ap->fun = (StgClosure*)ReadSpW(0);
// The function should be a BCO, and its bitmap should
// cover the payload of the AP correctly.
@@ -1712,7 +1811,7 @@ run_BCO:
&& BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
for (i = 0; i < n_payload; i++) {
- ap->payload[i] = (StgClosure*)SpW(i+1);
+ ap->payload[i] = (StgClosure*)ReadSpW(i+1);
}
Sp_addW(n_payload+1);
IF_DEBUG(interpreter,
@@ -1726,9 +1825,9 @@ run_BCO:
StgHalfWord i;
W_ stkoff = BCO_GET_LARGE_ARG;
StgHalfWord n_payload = BCO_GET_LARGE_ARG;
- StgPAP* pap = (StgPAP*)SpW(stkoff);
+ StgPAP* pap = (StgPAP*)ReadSpW(stkoff);
ASSERT(pap->n_args == n_payload);
- pap->fun = (StgClosure*)SpW(0);
+ pap->fun = (StgClosure*)ReadSpW(0);
// The function should be a BCO
if (get_itbl(pap->fun)->type != BCO) {
@@ -1739,7 +1838,7 @@ run_BCO:
}
for (i = 0; i < n_payload; i++) {
- pap->payload[i] = (StgClosure*)SpW(i+1);
+ pap->payload[i] = (StgClosure*)ReadSpW(i+1);
}
Sp_addW(n_payload+1);
IF_DEBUG(interpreter,
@@ -1753,7 +1852,7 @@ run_BCO:
/* Unpack N ptr words from t.o.s constructor */
W_ i;
W_ n_words = BCO_GET_LARGE_ARG;
- StgClosure* con = UNTAG_CLOSURE((StgClosure*)SpW(0));
+ StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
Sp_subW(n_words);
for (i = 0; i < n_words; i++) {
SpW(i) = (W_)con->payload[i];
@@ -1777,7 +1876,7 @@ run_BCO:
ASSERT(n_ptrs + n_nptrs > 0);
//ASSERT(n_words > 0); // We shouldn't ever need to allocate nullary constructors
for (W_ i = 0; i < n_words; i++) {
- con->payload[i] = (StgClosure*)SpW(i);
+ con->payload[i] = (StgClosure*)ReadSpW(i);
}
Sp_addW(n_words);
Sp_subW(1);
@@ -1799,7 +1898,7 @@ run_BCO:
case bci_TESTLT_P: {
unsigned int discr = BCO_NEXT;
int failto = BCO_GET_LARGE_ARG;
- StgClosure* con = UNTAG_CLOSURE((StgClosure*)SpW(0));
+ StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
if (GET_TAG(con) >= discr) {
bciPtr = failto;
}
@@ -1809,7 +1908,7 @@ run_BCO:
case bci_TESTEQ_P: {
unsigned int discr = BCO_NEXT;
int failto = BCO_GET_LARGE_ARG;
- StgClosure* con = UNTAG_CLOSURE((StgClosure*)SpW(0));
+ StgClosure* con = UNTAG_CLOSURE((StgClosure*)ReadSpW(0));
if (GET_TAG(con) != discr) {
bciPtr = failto;
}
@@ -1819,7 +1918,7 @@ run_BCO:
case bci_TESTLT_I: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- I_ stackInt = (I_)SpW(0);
+ I_ stackInt = (I_)ReadSpW(0);
if (stackInt >= (I_)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
@@ -1864,7 +1963,7 @@ run_BCO:
case bci_TESTEQ_I: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- I_ stackInt = (I_)SpW(0);
+ I_ stackInt = (I_)ReadSpW(0);
if (stackInt != (I_)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -1914,7 +2013,7 @@ run_BCO:
case bci_TESTLT_W: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- W_ stackWord = (W_)SpW(0);
+ W_ stackWord = (W_)ReadSpW(0);
if (stackWord >= (W_)BCO_LIT(discr))
bciPtr = failto;
goto nextInsn;
@@ -1959,7 +2058,7 @@ run_BCO:
case bci_TESTEQ_W: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- W_ stackWord = (W_)SpW(0);
+ W_ stackWord = (W_)ReadSpW(0);
if (stackWord != (W_)BCO_LIT(discr)) {
bciPtr = failto;
}
@@ -2068,7 +2167,7 @@ run_BCO:
goto eval;
case bci_RETURN_P:
- tagged_obj = (StgClosure *)SpW(0);
+ tagged_obj = (StgClosure *)ReadSpW(0);
Sp_addW(1);
goto do_return_pointer;
@@ -2195,7 +2294,7 @@ run_BCO:
}
// this is the function we're going to call
- fn = (void(*)(void))SpW(ret_size);
+ fn = (void(*)(void))ReadSpW(ret_size);
// Restore the Haskell thread's current value of errno
errno = cap->r.rCurrentTSO->saved_errno;
@@ -2246,7 +2345,7 @@ run_BCO:
// Re-load the pointer to the BCO from the stg_ret_p frame,
// it might have moved during the call. Also reload the
// pointers to the components of the BCO.
- obj = (StgClosure*)SpW(1);
+ obj = (StgClosure*)ReadSpW(1);
// N.B. this is a BCO and therefore is by definition not tagged
bco = (StgBCO*)obj;
instrs = (StgWord16*)(bco->instrs->payload);
=====================================
testsuite/tests/pmcheck/should_compile/T25749.hs
=====================================
@@ -0,0 +1,18 @@
+module T25749 where
+
+data D = K0 | K1 { fld :: Int }
+
+foo :: D -> Int
+foo K0 = 3
+foo d
+ | let i = fld d
+ = let j = fld d
+ in i + j + k
+ where k = fld d
+
+bar :: D -> Int
+bar d@(K1 {})
+ | let i | let i' = fld d = i'
+ = let j = fld d in i + j + k
+ where k = fld d
+bar _ = 3
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -170,6 +170,7 @@ test('EmptyCase010', [], compile, [overlapping_incomplete])
test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors'])
test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors'])
test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])
+test('T25749', normal, compile, ['-Wincomplete-record-selectors'])
test('DoubleMatch', normal, compile, [overlapping_incomplete])
test('T24817', normal, compile, [overlapping_incomplete])
test('T24824', normal, compile, ['-package ghc -Wincomplete-record-selectors'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbd056513388d47160334947caa4f16a78690cb5...e2017eee257a9a4dca25c84fd3821b106230e610
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbd056513388d47160334947caa4f16a78690cb5...e2017eee257a9a4dca25c84fd3821b106230e610
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250225/46c07abe/attachment-0001.html>
More information about the ghc-commits
mailing list