[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Add support for -debug in the testsuite
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Apr 12 09:01:31 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00
Add support for -debug in the testsuite
Confusingly, GhcDebugged referred to GhcDebugAssertions.
- - - - -
b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00
Add missing cases in -Di prettyprinter
Fixes #23142
- - - - -
6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00
compiler: make WasmCodeGenM an instance of MonadUnique
- - - - -
05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00
compiler: apply cmm node-splitting for wasm backend
This patch applies cmm node-splitting for wasm32 NCG, which is
required when handling irreducible CFGs. Fixes #23237.
- - - - -
f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00
Set base 'maintainer' field to CLC
- - - - -
ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00
Clarify a couple of Notes about 'nospec'
- - - - -
e8617a2f by Sebastian Graf at 2023-04-12T05:01:14-04:00
DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208)
In #23208 we observed that the demand signature of a binder occuring in a RULE
wasn't unleashed, leading to a transitively used binder being discarded as
absent. The solution was to use the same code path that we already use for
handling exported bindings.
See the changes to `Note [Absence analysis for stable unfoldings and RULES]`
for more details.
There is a single regression in T18894 because we are more conservative around
stable unfoldings now. Unfortunately it is not easily fixed; let's wait until
there is a concrete motivation before invest more time.
Fixes #23208.
- - - - -
3b3a7c83 by Rodrigo Mesquita at 2023-04-12T05:01:15-04:00
Add regression test for #23229
- - - - -
27 changed files:
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/Wasm/Types.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
- hadrian/src/Oracles/TestSettings.hs
- hadrian/src/Settings/Builders/RunTest.hs
- libraries/base/base.cabal
- rts/Printer.c
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/ghc-config/ghc-config.hs
- testsuite/mk/test.mk
- + testsuite/tests/ghci/should_run/T23229.hs
- + testsuite/tests/ghci/should_run/T23229.script
- testsuite/tests/ghci/should_run/all.T
- testsuite/tests/rts/Makefile
- + testsuite/tests/rts/T23142.hs
- + testsuite/tests/rts/T23142.stdout
- testsuite/tests/rts/all.T
- testsuite/tests/stranal/should_compile/T18894.stderr
- + testsuite/tests/stranal/should_run/T23208.hs
- + testsuite/tests/stranal/should_run/T23208.stderr
- + testsuite/tests/stranal/should_run/T23208_Lib.hs
- testsuite/tests/stranal/should_run/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Types.ForeignCall
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
+import GHC.Types.Unique.Supply
import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Panic
import GHC.Wasm.ControlFlow.FromCmm
@@ -1328,7 +1329,7 @@ lower_CmmUnsafeForeignCall_Drop ::
[CmmActual] ->
WasmCodeGenM w (WasmStatements w)
lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do
- ret_uniq <- wasmUniq
+ ret_uniq <- getUniqueM
let ret_local = LocalReg ret_uniq ret_cmm_ty
lower_CmmUnsafeForeignCall
lbl
@@ -1528,9 +1529,11 @@ lower_CmmGraph :: CLabel -> CmmGraph -> WasmCodeGenM w (FuncBody w)
lower_CmmGraph lbl g = do
ty_word <- wasmWordTypeM
platform <- wasmPlatformM
+ us <- getUniqueSupplyM
body <-
structuredControl
platform
+ us
(\_ -> lower_CmmExpr_Typed lbl ty_word)
(lower_CmmActions lbl)
g
=====================================
compiler/GHC/CmmToAsm/Wasm/Types.hs
=====================================
@@ -45,7 +45,6 @@ module GHC.CmmToAsm.Wasm.Types
wasmStateM,
wasmModifyM,
wasmExecM,
- wasmUniq,
)
where
@@ -466,10 +465,18 @@ wasmStateM = coerce . State
wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w ()
wasmModifyM = coerce . modify
+wasmEvalM :: WasmCodeGenM w a -> WasmCodeGenState w -> a
+wasmEvalM (WasmCodeGenM s) = evalState s
+
wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w
wasmExecM (WasmCodeGenM s) = execState s
-wasmUniq :: WasmCodeGenM w Unique
-wasmUniq = wasmStateM $
- \s at WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of
- (u, us) -> (# u, s {wasmUniqSupply = us} #)
+instance MonadUnique (WasmCodeGenM w) where
+ getUniqueSupplyM = wasmGetsM wasmUniqSupply
+ getUniqueM = wasmStateM $
+ \s at WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of
+ (u, us) -> (# u, s {wasmUniqSupply = us} #)
+ getUniquesM = do
+ u <- getUniqueM
+ s <- WasmCodeGenM get
+ pure $ u:(wasmEvalM getUniquesM s)
=====================================
compiler/GHC/Core/InstEnv.hs
=====================================
@@ -849,8 +849,10 @@ Here are the moving parts:
* `GHC.HsToCore.Binds.dsHsWrapper` desugars the evidence application (f d) into
(nospec f d) if `d` is incoherent. It has to do a dependency analysis to
- determine transitive dependencies, but we need to do that anway.
+ determine transitive dependencies, but we need to do that anyway.
See Note [Desugaring incoherent evidence] in GHC.HsToCore.Binds.
+
+ See also Note [nospecId magic] in GHC.Types.Id.Make.
-}
type DFunInstType = Maybe Type
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -97,28 +97,33 @@ dmdAnalProgram opts fam_envs rules binds
where
anal_body env'
| WithDmdType body_ty bs' <- go env' bs
- = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs'
+ = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs'
cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]
cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs')
- add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType
- add_exported_uses env = foldl' (add_exported_use env)
-
- -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@
- -- corresponds to the demand type of @(id, e)@, but is a lot more direct.
- -- See Note [Analysing top-level bindings].
- add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType
- add_exported_use env dmd_ty id
- | isExportedId id || elemVarSet id rule_fvs
- -- See Note [Absence analysis for stable unfoldings and RULES]
- = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))
- | otherwise
- = dmd_ty
+ keep_alive_roots :: AnalEnv -> [Id] -> PlusDmdArg
+ -- See Note [Absence analysis for stable unfoldings and RULES]
+ -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in
+ -- orphan RULES
+ keep_alive_roots env ids = keepAlive env (filter is_root ids)
+
+ is_root :: Id -> Bool
+ is_root id = isExportedId id || elemVarSet id rule_fvs
rule_fvs :: IdSet
rule_fvs = rulesRhsFreeIds rules
+keepAlive :: AnalEnv -> [Id] -> PlusDmdArg
+-- See Note [Absence analysis for stable unfoldings and RULES]
+keepAlive _ [] = (emptyVarEnv, topDiv)
+keepAlive env ids
+ = foldl1' plusDmdArg $ fmap (fst . dmdAnalStar env topDmd . Var) ids
+
+keepAliveSet :: AnalEnv -> IdSet -> PlusDmdArg
+keepAliveSet env ids = keepAlive env (nonDetEltsUniqSet ids)
+ -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative
+
-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings
-- that satisfy this function.
--
@@ -343,7 +348,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec
-- See Note [Absence analysis for stable unfoldings and RULES]
rule_fvs = bndrRuleAndUnfoldingIds id
- final_ty = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs
+ final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` keepAliveSet env rule_fvs
-- | Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
@@ -415,7 +420,7 @@ dmdAnalStar env (n :* sd) e
, n' <- anticipateANF e n
-- See Note [Anticipating ANF in demand analysis]
-- and Note [Analysing with absent demand]
- = (toPlusDmdArg $ multDmdType n' dmd_ty, e')
+ = (discardArgDmds $ multDmdType n' dmd_ty, e')
-- Main Demand Analysis machinery
dmdAnal, dmdAnal' :: AnalEnv
@@ -532,7 +537,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs])
= alt_ty2
WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut
- res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty
+ res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty
in
-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
-- , text "dmd" <+> ppr dmd
@@ -569,7 +574,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
= deferAfterPreciseException alt_ty1
| otherwise
= alt_ty1
- res_ty = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty
+ res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2
in
-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
@@ -1103,7 +1108,8 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
NonRecursive -> rhs_fv
-- See Note [Absence analysis for stable unfoldings and RULES]
- rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id
+ -- Since the result of keepAliveSet will have topDiv, rhs_div == _rhs_div'
+ (rhs_fv2, _rhs_div') = (rhs_fv1, rhs_div) `plusDmdArg` keepAliveSet env (bndrRuleAndUnfoldingIds id)
-- See Note [Lazy and unleashable free variables]
!(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
@@ -1365,8 +1371,8 @@ GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity.
Note [Absence analysis for stable unfoldings and RULES]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticket #18638 shows that it's really important to do absence analysis
-for stable unfoldings. Consider
+Among others, tickets #18638 and #23208 show that it's really important to do
+absence analysis for stable unfoldings. Consider
g = blah
@@ -1383,9 +1389,8 @@ and transform to
Now if f is subsequently inlined, we'll use 'g' and ... disaster.
-SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands
-on its free variables) so that no variable mentioned in its unfolding
-is Absent. This is done by the function Demand.keepAliveDmdEnv.
+SOLUTION: if f has a stable unfolding, analyse every free variable as if it
+was a variable occuring in a 'topDmd' context. This is done in `keepAlive`.
ALSO: do the same for Ids free in the RHS of any RULES for f.
@@ -1401,6 +1406,28 @@ Now f's optimised RHS will be \x.a, but if we change g to (error "..")
disaster. But regardless, #18638 was a more complicated version of
this, that actually happened in practice.
+PPS: You might wonder why we don't simply take the free vars of the
+unfolding/RULE and map them to topDmd. The reason is that any of the free vars
+might have demand signatures themselves that in turn keep transitive free
+variables alive and that we hence need to unleash! This came up in #23208.
+Consider
+
+ err :: Int -> b
+ err = error "really important message"
+
+ sg :: Int -> Int
+ sg _ = case err of {} -- Str=<1B>b {err:->S}
+
+ g :: a -> a -- g is exported
+ g x = x
+ {-# RULES "g" g @Int = sg #-}
+
+Here, `err` is only kept alive by `sg`'s demand signature: It doesn't occur
+in the lazy_fvs of `sg`'s RHS at all. Hence when we `keepAlive` `sg` because it
+occurs in the RULEs of `g` (which is exported), we better unleash the demand
+signature of `sg`, too! In #23208 we failed to do so and observed an absent
+error instead of the `really important message`.
+
Note [DmdAnal for DataCon wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We give DataCon wrappers a (necessarily flat) demand signature in
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -44,8 +44,7 @@ module GHC.Types.Demand (
unboxDeeplyDmd,
-- * Demand environments
- DmdEnv, emptyDmdEnv,
- keepAliveDmdEnv, reuseEnv,
+ DmdEnv, emptyDmdEnv, reuseEnv,
-- * Divergence
Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv,
@@ -56,10 +55,9 @@ module GHC.Types.Demand (
nopDmdType, botDmdType,
lubDmdType, plusDmdType, multDmdType,
-- *** PlusDmdArg
- PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,
+ PlusDmdArg, mkPlusDmdArg, discardArgDmds, plusDmdArg,
-- ** Other operations
peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,
- keepAliveDmdType,
-- * Demand signatures
DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig,
@@ -85,9 +83,8 @@ module GHC.Types.Demand (
import GHC.Prelude
-import GHC.Types.Var ( Var, Id )
+import GHC.Types.Var
import GHC.Types.Var.Env
-import GHC.Types.Var.Set
import GHC.Types.Unique.FM
import GHC.Types.Basic
import GHC.Data.Maybe ( orElse )
@@ -1466,7 +1463,7 @@ lubDivergence _ _ = Dunno
-- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2
-- (See Note [Default demand on free variables and arguments] for why)
--- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'
+-- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence'
-- needs to be symmetric.
-- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv at .
-- But that regresses in too many places (every infinite loop, basically) to be
@@ -1750,23 +1747,6 @@ multDmdEnv n env = mapVarEnv (multDmd n) env
reuseEnv :: DmdEnv -> DmdEnv
reuseEnv = multDmdEnv C_1N
--- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have
--- /some/ usage in the returned demand types -- they are not Absent.
--- See Note [Absence analysis for stable unfoldings and RULES]
--- in "GHC.Core.Opt.DmdAnal".
-keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv
-keepAliveDmdEnv env vs
- = nonDetStrictFoldVarSet add env vs
- where
- add :: Id -> DmdEnv -> DmdEnv
- add v env = extendVarEnv_C add_dmd env v topDmd
-
- add_dmd :: Demand -> Demand -> Demand
- -- If the existing usage is Absent, make it used
- -- Otherwise leave it alone
- add_dmd dmd _ | isAbsDmd dmd = topDmd
- | otherwise = dmd
-
-- | Characterises how an expression
--
-- * Evaluates its free variables ('dt_env')
@@ -1811,20 +1791,27 @@ type PlusDmdArg = (DmdEnv, Divergence)
mkPlusDmdArg :: DmdEnv -> PlusDmdArg
mkPlusDmdArg env = (env, topDiv)
-toPlusDmdArg :: DmdType -> PlusDmdArg
-toPlusDmdArg (DmdType fv _ r) = (fv, r)
+discardArgDmds :: DmdType -> PlusDmdArg
+discardArgDmds (DmdType fv _ r) = (fv, r)
plusDmdType :: DmdType -> PlusDmdArg -> DmdType
-plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)
- -- See Note [Asymmetry of 'plus*']
- -- 'plus' takes the argument/result info from its *first* arg,
- -- using its second arg just for its free-var info.
- | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd
- = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient
+plusDmdType (DmdType fv ds d) pda
+ -- See Note [Asymmetry of plusDmdType]
+ -- 'plus' takes the argument demands from its *first* arg, using its second
+ -- arg just for its free-var info and divergence.
+ | (fv', d') <- plusDmdArg (fv,d) pda
+ = DmdType fv' ds d'
+
+plusDmdArg :: PlusDmdArg -> PlusDmdArg -> PlusDmdArg
+plusDmdArg (fv1, d1) (fv2, d2)
+ -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric.
+ | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd
+ = (fv1, d1 `plusDivergence` d2) -- a very common case that is much more efficient
+ | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd
+ = (fv2, d1 `plusDivergence` d2) -- another very common case that is much more efficient
| otherwise
- = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))
- ds1
- (r1 `plusDivergence` t2)
+ = ( plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)
+ , d1 `plusDivergence` d2)
botDmdType :: DmdType
botDmdType = DmdType emptyDmdEnv [] botDiv
@@ -1914,11 +1901,6 @@ findIdDemand (DmdType fv _ res) id
deferAfterPreciseException :: DmdType -> DmdType
deferAfterPreciseException = lubDmdType exnDmdType
--- | See 'keepAliveDmdEnv'.
-keepAliveDmdType :: DmdType -> VarSet -> DmdType
-keepAliveDmdType (DmdType fvs ds res) vars =
- DmdType (fvs `keepAliveDmdEnv` vars) ds res
-
{- Note [deferAfterPreciseException]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The big picture is in Note [Precise exceptions and strictness analysis]
@@ -1999,7 +1981,7 @@ Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD',
involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the
other.
-Note [Asymmetry of 'plus*']
+Note [Asymmetry of plusDmdType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
'plus' for DmdTypes is *asymmetrical*, because there can only one
be one type contributing argument demands! For example, given (e1 e2), we get
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -2002,10 +2002,15 @@ Note that this happens *after* unfoldings are exposed in the interface file.
This is crucial: otherwise, we could import an unfolding in which
'nospec' has been inlined (= erased), and we would lose the benefit.
-'nospec' is used in the implementation of 'withDict': we insert 'nospec'
-so that the typeclass specialiser doesn't assume any two evidence terms
-of the same type are equal. See Note [withDict] in GHC.Tc.Instance.Class,
-and see test case T21575b for an example.
+'nospec' is used:
+
+* In the implementation of 'withDict': we insert 'nospec' so that the
+ typeclass specialiser doesn't assume any two evidence terms of the
+ same type are equal. See Note [withDict] in GHC.Tc.Instance.Class,
+ and see test case T21575b for an example.
+
+* To defeat the specialiser when we have incoherent instances.
+ See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv.
Note [The oneShot function]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -19,12 +19,13 @@ import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dominators
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Reducibility
import GHC.Cmm.Switch
import GHC.CmmToAsm.Wasm.Types
import GHC.Platform
-
+import GHC.Types.Unique.Supply
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr
@@ -140,15 +141,19 @@ emptyPost _ = False
structuredControl :: forall expr stmt m .
Applicative m
=> Platform -- ^ needed for offset calculation
+ -> UniqSupply
-> (Label -> CmmExpr -> m expr) -- ^ translator for expressions
-> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code
-> CmmGraph -- ^ CFG to be translated
-> m (WasmControl stmt expr '[] '[ 'I32])
-structuredControl platform txExpr txBlock g =
+structuredControl platform us txExpr txBlock g' =
doTree returns dominatorTree emptyContext
where
+ g :: CmmGraph
+ g = gwd_graph gwd
+
gwd :: GraphWithDominators CmmNode
- gwd = graphWithDominators g
+ gwd = initUs_ us $ asReducible $ graphWithDominators g'
dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted
-- with highest reverse-postorder number first
=====================================
hadrian/src/Oracles/TestSettings.hs
=====================================
@@ -25,8 +25,9 @@ data TestSetting = TestHostOS
| TestTARGETPLATFORM
| TestTargetOS_CPP
| TestTargetARCH_CPP
+ | TestRTSWay
| TestGhcStage
- | TestGhcDebugged
+ | TestGhcDebugAssertions
| TestGhcWithNativeCodeGen
| TestGhcWithInterpreter
| TestGhcWithRtsLinker
@@ -56,8 +57,9 @@ testSetting key = do
TestTARGETPLATFORM -> "TARGETPLATFORM"
TestTargetOS_CPP -> "TargetOS_CPP"
TestTargetARCH_CPP -> "TargetARCH_CPP"
+ TestRTSWay -> "RTSWay"
TestGhcStage -> "GhcStage"
- TestGhcDebugged -> "GhcDebugged"
+ TestGhcDebugAssertions -> "GhcDebugAssertions"
TestGhcWithNativeCodeGen -> "GhcWithNativeCodeGen"
TestGhcWithInterpreter -> "GhcWithInterpreter"
TestGhcWithRtsLinker -> "GhcWithRtsLinker"
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -69,6 +69,9 @@ data TestCompilerArgs = TestCompilerArgs{
, unregisterised :: Bool
, tables_next_to_code :: Bool
, targetWithSMP :: Bool -- does the target support SMP
+ , debugged :: Bool
+ -- ^ Whether the compiler has the debug RTS,
+ -- corresponding to the -debug option.
, debugAssertions :: Bool
-- ^ Whether the compiler has debug assertions enabled,
-- corresponding to the -DDEBUG option.
@@ -104,6 +107,7 @@ inTreeCompilerArgs stg = do
let ghcStage = succStage stg
debugAssertions <- ghcDebugAssertions <$> flavour <*> pure ghcStage
+ debugged <- ghcDebugged <$> flavour <*> pure ghcStage
profiled <- ghcProfiled <$> flavour <*> pure ghcStage
os <- setting HostOs
@@ -149,12 +153,14 @@ outOfTreeCompilerArgs = do
unregisterised <- getBooleanSetting TestGhcUnregisterised
tables_next_to_code <- getBooleanSetting TestGhcTablesNextToCode
targetWithSMP <- targetSupportsSMP
- debugAssertions <- getBooleanSetting TestGhcDebugged
+ debugAssertions <- getBooleanSetting TestGhcDebugAssertions
os <- getTestSetting TestHostOS
arch <- getTestSetting TestTargetARCH_CPP
platform <- getTestSetting TestTARGETPLATFORM
wordsize <- getTestSetting TestWORDSIZE
+ rtsWay <- getTestSetting TestRTSWay
+ let debugged = "debug" `isInfixOf` rtsWay
llc_cmd <- getTestSetting TestLLC
have_llvm <- liftIO (isJust <$> findExecutable llc_cmd)
@@ -243,6 +249,7 @@ runTestBuilderArgs = builder Testsuite ? do
, arg "-e", arg $ "config.accept_os=" ++ show acceptOS
, arg "-e", arg $ "config.exeext=" ++ quote (if null exe then "" else "."<>exe)
, arg "-e", arg $ "config.compiler_debugged=" ++ show debugAssertions
+ , arg "-e", arg $ "config.debug_rts=" ++ show debugged
-- MP: TODO, we do not need both, they get aliased to the same thing.
, arg "-e", arg $ asBool "ghc_with_native_codegen=" withNativeCodeGen
=====================================
libraries/base/base.cabal
=====================================
@@ -5,8 +5,8 @@ version: 4.18.0.0
license: BSD-3-Clause
license-file: LICENSE
-maintainer: libraries at haskell.org
-bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new
+maintainer: Core Libraries Committee <core-libraries-committee at haskell.org>
+bug-reports: https://github.com/haskell/core-libraries-committee/issues
synopsis: Basic libraries
category: Prelude
build-type: Configure
=====================================
rts/Printer.c
=====================================
@@ -297,6 +297,45 @@ printClosure( const StgClosure *obj )
break;
}
+ case ATOMICALLY_FRAME:
+ {
+ StgAtomicallyFrame* u = (StgAtomicallyFrame*)obj;
+ debugBelch("ATOMICALLY_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(",");
+ printPtr((StgPtr)u->code);
+ debugBelch(",");
+ printPtr((StgPtr)u->result);
+ debugBelch(")\n");
+ break;
+ }
+
+ case CATCH_RETRY_FRAME:
+ {
+ StgCatchRetryFrame* u = (StgCatchRetryFrame*)obj;
+ debugBelch("CATCH_RETRY_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(",");
+ printPtr((StgPtr)u->first_code);
+ debugBelch(",");
+ printPtr((StgPtr)u->alt_code);
+ debugBelch(")\n");
+ break;
+ }
+
+ case CATCH_STM_FRAME:
+ {
+ StgCatchSTMFrame* u = (StgCatchSTMFrame*)obj;
+ debugBelch("CATCH_STM_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(",");
+ printPtr((StgPtr)u->code);
+ debugBelch(",");
+ printPtr((StgPtr)u->handler);
+ debugBelch(")\n");
+ break;
+ }
+
case ARR_WORDS:
{
StgWord i;
@@ -319,6 +358,10 @@ printClosure( const StgClosure *obj )
debugBelch("MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
break;
+ case MUT_ARR_PTRS_FROZEN_DIRTY:
+ debugBelch("MUT_ARR_PTRS_FROZEN_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
+ break;
+
case SMALL_MUT_ARR_PTRS_CLEAN:
debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
(W_)((StgSmallMutArrPtrs *)obj)->ptrs);
@@ -334,6 +377,11 @@ printClosure( const StgClosure *obj )
(W_)((StgSmallMutArrPtrs *)obj)->ptrs);
break;
+ case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
+ debugBelch("SMALL_MUT_ARR_PTRS_FROZEN_DIRTY(size=%" FMT_Word ")\n",
+ (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+ break;
+
case MVAR_CLEAN:
case MVAR_DIRTY:
{
@@ -533,6 +581,9 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
case CATCH_FRAME:
case UNDERFLOW_FRAME:
case STOP_FRAME:
+ case ATOMICALLY_FRAME:
+ case CATCH_RETRY_FRAME:
+ case CATCH_STM_FRAME:
printClosure((StgClosure*)sp);
continue;
=====================================
testsuite/driver/testglobals.py
=====================================
@@ -64,6 +64,9 @@ class TestConfig:
# Was the compiler compiled with DEBUG?
self.compiler_debugged = False
+ # Was the compiler compiled with -debug?
+ self.debug_rts = False
+
# Was the compiler compiled with LLVM?
self.ghc_built_by_llvm = False
=====================================
testsuite/driver/testlib.py
=====================================
@@ -681,6 +681,9 @@ def compiler_profiled( ) -> bool:
def compiler_debugged( ) -> bool:
return config.compiler_debugged
+def debug_rts( ) -> bool:
+ return config.debug_rts
+
def have_gdb( ) -> bool:
return config.have_gdb
=====================================
testsuite/ghc-config/ghc-config.hs
=====================================
@@ -13,12 +13,13 @@ main = do
getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform"
getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture"
+ getGhcFieldOrFail fields "RTSWay" "RTS way"
info <- readProcess ghc ["--info"] ""
let fields = read info :: [(String,String)]
getGhcFieldOrFail fields "GhcStage" "Stage"
- getGhcFieldOrFail fields "GhcDebugged" "Debug on"
+ getGhcFieldOrFail fields "GhcDebugAssertions" "Debug on"
getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
getGhcFieldOrFail fields "GhcWithRtsLinker" "target has RTS linker"
=====================================
testsuite/mk/test.mk
=====================================
@@ -78,7 +78,7 @@ endif
RUNTEST_OPTS += -e "ghc_compiler_always_flags='$(TEST_HC_OPTS)'"
-ifeq "$(GhcDebugged)" "YES"
+ifeq "$(GhcDebugAssertions)" "YES"
RUNTEST_OPTS += -e "config.compiler_debugged=True"
else
RUNTEST_OPTS += -e "config.compiler_debugged=False"
=====================================
testsuite/tests/ghci/should_run/T23229.hs
=====================================
@@ -0,0 +1 @@
+instance Num Bool
=====================================
testsuite/tests/ghci/should_run/T23229.script
=====================================
@@ -0,0 +1 @@
+:l T23229
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -88,3 +88,4 @@ test('UnliftedDataType2', just_ghci, compile_and_run, [''])
test('SizedLiterals', [req_interp, extra_files(["SizedLiteralsA.hs"]),extra_hc_opts("-O -fbyte-code-and-object-code -fprefer-byte-code")], compile_and_run, [''])
test('T22829', just_ghci + [extra_hc_opts("-Wmissing-import-lists -Werror")], compile_and_run, [''])
+test('T23229', just_ghci + [extra_hc_opts("-this-unit-id my-package -Wno-missing-methods T23229")], ghci_script, ['T23229.script'])
=====================================
testsuite/tests/rts/Makefile
=====================================
@@ -147,3 +147,13 @@ EventlogOutput_IPE:
"$(TEST_HC)" -debug -finfo-table-map -v0 EventlogOutput.hs
./EventlogOutput +RTS -va 2> EventlogOutput_IPE.stderr.log
grep "IPE:" EventlogOutput_IPE.stderr.log
+
+.PHONY: T23142
+T23142:
+ # Test that the -Di output contains different frames
+ "$(TEST_HC)" --run -ignore-dot-ghci T23142.hs +RTS -Di -RTS 2> T23142.log
+ grep -m1 -c "ATOMICALLY_FRAME" T23142.log
+ grep -m1 -c "CATCH_RETRY_FRAME" T23142.log
+ grep -m1 -c "CATCH_STM_FRAME" T23142.log
+ grep -m1 -c "MUT_ARR_PTRS_FROZEN_DIRTY" T23142.log
+ grep -m1 -c "SMALL_MUT_ARR_PTRS_FROZEN_DIRTY" T23142.log
=====================================
testsuite/tests/rts/T23142.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE UnboxedTuples, MagicHash #-}
+module T23142 where
+
+import GHC.IO
+import GHC.Exts
+
+main :: IO ()
+main = IO (\s -> case newArray# 10# (2 :: Int) s of
+ (# s', a #) -> case unsafeFreezeArray# a s' of
+ (# s'', _ #) -> (# s'', () #))
+ >>
+ IO (\s -> case newSmallArray# 10# (2 :: Int) s of
+ (# s', a #) -> case unsafeFreezeSmallArray# a s' of
+ (# s'', _ #) -> (# s'', () #))
+ >>
+ IO (atomically# (\s -> catchSTM# (\s -> (# s, () #)) (\_ s -> (# s, () #)) s))
+ >>
+ IO (atomically# (\s -> catchRetry# (\s -> (# s, () #)) (\s -> (# s, () #)) s))
=====================================
testsuite/tests/rts/T23142.stdout
=====================================
@@ -0,0 +1,5 @@
+1
+1
+1
+1
+1
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -575,3 +575,5 @@ test('T22795b', [only_ways(['normal']), js_skip], compile_and_run, ['-single-thr
test('T22795c', [only_ways(['normal']), js_skip], compile_and_run, ['-threaded -single-threaded'])
test('T17574', [js_skip], compile_and_run, ['-with-rtsopts -T'])
+
+test('T23142', [unless(debug_rts(), skip), req_interp], makefile_test, ['T23142'])
=====================================
testsuite/tests/stranal/should_compile/T18894.stderr
=====================================
@@ -1,48 +1,54 @@
-==================== Demand analysis ====================
-Result size of Demand analysis
+==================== Demand analysis (including Boxity) ====================
+Result size of Demand analysis (including Boxity)
= {terms: 189, types: 95, coercions: 0, joins: 0/2}
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
$trModule = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
$trModule = "T18894"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T18894.$trModule :: GHC.Types.Module
[LclIdX,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18894.$trModule = GHC.Types.Module $trModule $trModule
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 42, types: 15, coercions: 0, joins: 0/1}
@@ -51,8 +57,9 @@ g2 [InlPrag=NOINLINE, Dmd=LC(S,C(1,!P(M!P(L),1!P(L))))]
[LclId,
Arity=2,
Str=<L><1!P(1L)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 106 20}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20 20] 106 20}]
g2
= \ (m :: Int) (ds [Dmd=1!P(1L)] :: Int) ->
case ds of { GHC.Types.I# ds [Dmd=1L] ->
@@ -64,8 +71,9 @@ g2
let {
c1# :: GHC.Prim.Int#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 2 0}]
c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in
case GHC.Prim.-# (GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild) c1#
of ds2
@@ -81,22 +89,25 @@ g2
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 2#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 2#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 36, types: 19, coercions: 0, joins: 0/0}
@@ -104,8 +115,9 @@ h2 :: Int -> Int
[LclIdX,
Arity=1,
Str=<1P(SL)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 162 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20] 162 10}]
h2
= \ (ds [Dmd=1P(SL)] :: Int) ->
case ds of wild { GHC.Types.I# ds [Dmd=SL] ->
@@ -128,22 +140,25 @@ h2
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 15#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
lvl :: (Int, Int)
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = (lvl, lvl)
-- RHS size: {terms: 36, types: 10, coercions: 0, joins: 0/1}
@@ -151,8 +166,9 @@ g1 [InlPrag=NOINLINE, Dmd=LC(L,!P(L,L))] :: Int -> (Int, Int)
[LclId,
Arity=1,
Str=<1!P(1L)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 86 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20] 86 10}]
g1
= \ (ds [Dmd=1!P(1L)] :: Int) ->
case ds of { GHC.Types.I# ds [Dmd=1L] ->
@@ -164,8 +180,9 @@ g1
let {
c1# :: GHC.Prim.Int#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 2 0}]
c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in
case GHC.Prim.-# (GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild) c1#
of ds2
@@ -181,15 +198,17 @@ g1
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
lvl :: (Int, Int)
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 30 0}]
lvl = g1 (GHC.Types.I# 2#)
-- RHS size: {terms: 28, types: 18, coercions: 0, joins: 0/0}
@@ -197,8 +216,9 @@ h1 :: Int -> Int
[LclIdX,
Arity=1,
Str=<1!P(SL)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 111 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20] 111 10}]
h1
= \ (ds [Dmd=1!P(SL)] :: Int) ->
case ds of wild [Dmd=M!P(1L)] { GHC.Types.I# ds [Dmd=SL] ->
@@ -224,43 +244,49 @@ Result size of Demand analysis
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
$trModule = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
$trModule = "T18894"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T18894.$trModule :: GHC.Types.Module
[LclIdX,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18894.$trModule = GHC.Types.Module $trModule $trModule
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 39, types: 17, coercions: 0, joins: 0/1}
@@ -269,8 +295,9 @@ $wg2 [InlPrag=NOINLINE, Dmd=LC(S,C(1,!P(M!P(L),1!P(L))))]
[LclId[StrictWorker([])],
Arity=2,
Str=<L><1L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 30] 76 20}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20 30] 76 20}]
$wg2
= \ (m :: Int) (ww [Dmd=1L] :: GHC.Prim.Int#) ->
case ww of ds [Dmd=ML] {
@@ -281,8 +308,9 @@ $wg2
let {
c1# :: GHC.Prim.Int#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 2 0}]
c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in
case GHC.Prim.-# (GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild) c1#
of ds2
@@ -297,8 +325,9 @@ $wg2
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
lvl = GHC.Types.I# 2#
-- RHS size: {terms: 36, types: 23, coercions: 0, joins: 0/0}
@@ -306,8 +335,9 @@ h2 :: Int -> Int
[LclIdX,
Arity=1,
Str=<1P(SL)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 162 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20] 162 10}]
h2
= \ (ds [Dmd=1P(SL)] :: Int) ->
case ds of wild { GHC.Types.I# ds [Dmd=SL] ->
@@ -333,8 +363,9 @@ $wg1 [InlPrag=NOINLINE, Dmd=LC(L,!P(L,L))]
[LclId[StrictWorker([])],
Arity=1,
Str=<1L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 56 20}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [30] 56 20}]
$wg1
= \ (ww [Dmd=1L] :: GHC.Prim.Int#) ->
case ww of ds {
@@ -345,8 +376,9 @@ $wg1
let {
c1# :: GHC.Prim.Int#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 2 0}]
c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in
case GHC.Prim.-# (GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild) c1#
of ds2
@@ -361,17 +393,19 @@ $wg1
-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
lvl :: (Int, Int)
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 50 10}]
lvl = case $wg1 2# of { (# ww, ww #) -> (GHC.Types.I# ww, ww) }
-- RHS size: {terms: 22, types: 16, coercions: 0, joins: 0/0}
-$wh1 [InlPrag=[2], Dmd=LC(S,!P(L))] :: GHC.Prim.Int# -> Int
+$wh1 [InlPrag=[2]] :: GHC.Prim.Int# -> Int
[LclId[StrictWorker([])],
Arity=1,
Str=<1L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [50] 91 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [50] 91 10}]
$wh1
= \ (ww [Dmd=1L] :: GHC.Prim.Int#) ->
case ww of ds [Dmd=ML] {
@@ -388,8 +422,8 @@ h1 [InlPrag=[2]] :: Int -> Int
[LclIdX,
Arity=1,
Str=<1!P(1L)>,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (ds [Occ=Once1!, Dmd=S!P(SL)] :: Int) ->
case ds of { GHC.Types.I# ww [Occ=Once1, Dmd=SL] -> $wh1 ww }}]
=====================================
testsuite/tests/stranal/should_run/T23208.hs
=====================================
@@ -0,0 +1,4 @@
+import T23208_Lib
+
+main = print $ g (15 :: Int)
+
=====================================
testsuite/tests/stranal/should_run/T23208.stderr
=====================================
@@ -0,0 +1,3 @@
+T23208: really important message
+CallStack (from HasCallStack):
+ error, called at T23208_Lib.hs:4:7 in main:T23208_Lib
=====================================
testsuite/tests/stranal/should_run/T23208_Lib.hs
=====================================
@@ -0,0 +1,12 @@
+module T23208_Lib (g) where
+
+err :: Int -> b
+err = error "really important message"
+
+sg :: Int -> Int
+sg n = err n
+{-# NOINLINE sg #-}
+g :: a -> a
+g x = x
+{-# NOINLINE g #-}
+{-# RULES "g" g @Int = sg #-}
=====================================
testsuite/tests/stranal/should_run/all.T
=====================================
@@ -32,3 +32,4 @@ test('T22475', normal, compile_and_run, [''])
test('T22475b', normal, compile_and_run, [''])
# T22549: Do not strictify DFuns, otherwise we will <<loop>>
test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise'])
+test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e6ab90e6a4dd8902d8f785f5e6a421f1d95cb844...3b3a7c83711ea7479f02ec5271cfc0e0b686cc34
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e6ab90e6a4dd8902d8f785f5e6a421f1d95cb844...3b3a7c83711ea7479f02ec5271cfc0e0b686cc34
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/20230412/73a2b4b0/attachment-0001.html>
More information about the ghc-commits
mailing list