[Git][ghc/ghc][wip/T24726] 10 commits: ghc-internal: add MonadFix instance for (,)
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Apr 30 09:02:46 UTC 2024
Simon Peyton Jones pushed to branch wip/T24726 at Glasgow Haskell Compiler / GHC
Commits:
a6d5f9da by Naïm Favier at 2024-04-27T17:52:40-04:00
ghc-internal: add MonadFix instance for (,)
Closes https://gitlab.haskell.org/ghc/ghc/-/issues/24288, implements CLC
proposal https://github.com/haskell/core-libraries-committee/issues/238.
Adds a MonadFix instance for tuples, permitting value recursion in the
"native" writer monad and bringing consistency with the existing
instance for transformers's WriterT (and, to a lesser extent, for Solo).
- - - - -
64feadcd by Rodrigo Mesquita at 2024-04-27T17:53:16-04:00
bindist: Fix xattr cleaning
The original fix (725343aa) was incorrect because it used the shell
bracket syntax which is the quoting syntax in autoconf, making the test
for existence be incorrect and therefore `xattr` was never run.
Fixes #24554
- - - - -
e2094df3 by damhiya at 2024-04-28T23:52:00+09:00
Make read accepts binary integer formats
CLC proposal : https://github.com/haskell/core-libraries-committee/issues/177
- - - - -
1c2fd963 by Alan Zimmerman at 2024-04-29T23:17:00-04:00
EPA: Preserve comments in Match Pats
Closes #24708
Closes #24715
Closes #24734
- - - - -
4189d17e by Sylvain Henry at 2024-04-29T23:17:42-04:00
LLVM: better unreachable default destination in Switch (#24717)
See added note.
Co-authored-by: Siddharth Bhat <siddu.druid at gmail.com>
- - - - -
a3725c88 by Cheng Shao at 2024-04-29T23:18:20-04:00
ci: enable wasm jobs for MRs with wasm label
This patch enables wasm jobs for MRs with wasm label. Previously the
wasm label didn't actually have any effect on the CI pipeline, and
full-ci needed to be applied to run wasm jobs which was a waste of
runners when working on the wasm backend, hence the fix here.
- - - - -
702f7964 by Matthew Pickering at 2024-04-29T23:18:56-04:00
Make interface files and object files depend on inplace .conf file
A potential fix for #24737
- - - - -
8b3508d7 by Simon Peyton Jones at 2024-04-30T10:02:16+01:00
Track in-scope variables in ruleCheckProgram
This small patch fixes #24726, by tracking in-scope variables
properly in -drule-check. Not hard to do!
- - - - -
125f97e2 by Simon Peyton Jones at 2024-04-30T10:02:16+01:00
Add a couple more HasCallStack constraints in SimpleOpt
Just for debugging, no effect on normal code
- - - - -
d5d664bd by Simon Peyton Jones at 2024-04-30T10:02:16+01:00
Add comments to Prep.hs
This documentation patch fixes a TODO left over from !12364
- - - - -
29 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- distrib/configure.ac.in
- docs/users_guide/bugs.rst
- hadrian/src/Rules/Compile.hs
- libraries/base/changelog.md
- libraries/base/tests/char001.hs
- libraries/base/tests/char001.stdout
- libraries/base/tests/lex001.hs
- libraries/base/tests/lex001.stdout
- libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs
- libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/MatchPatComments.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/simplCore/should_compile/T24726.hs
- + testsuite/tests/simplCore/should_compile/T24726.stderr
- testsuite/tests/simplCore/should_compile/all.T
- utils/check-exact/Main.hs
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -603,6 +603,7 @@ data ValidateRule =
FullCI -- ^ Run this job when the "full-ci" label is present.
| LLVMBackend -- ^ Run this job when the "LLVM backend" label is present
| JSBackend -- ^ Run this job when the "javascript" label is present
+ | WasmBackend -- ^ Run this job when the "wasm" label is present
| FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
| NonmovingGc -- ^ Run this job when the "non-moving GC" label is set.
| IpeData -- ^ Run this job when the "IPE" label is set
@@ -649,6 +650,7 @@ validateRuleString FullCI = or_all ([ labelString "full-ci"
validateRuleString LLVMBackend = labelString "LLVM backend"
validateRuleString JSBackend = labelString "javascript"
+validateRuleString WasmBackend = labelString "wasm"
validateRuleString FreeBSDLabel = labelString "FreeBSD"
validateRuleString NonmovingGc = labelString "non-moving GC"
validateRuleString IpeData = labelString "IPE"
@@ -1048,7 +1050,7 @@ job_groups =
. setVariable "HADRIAN_ARGS" "--docs=none"
. delVariable "INSTALL_CONFIGURE_ARGS"
)
- $ validateBuilds Amd64 (Linux AlpineWasm) cfg
+ $ addValidateRule WasmBackend $ validateBuilds Amd64 (Linux AlpineWasm) cfg
wasm_build_config =
(crossConfig "wasm32-wasi" NoEmulatorNeeded Nothing)
=====================================
.gitlab/jobs.yaml
=====================================
@@ -4502,7 +4502,7 @@
],
"rules": [
{
- "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*wasm.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
"when": "on_success"
}
],
@@ -4566,7 +4566,7 @@
"rules": [
{
"allow_failure": true,
- "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*wasm.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
"when": "manual"
}
],
@@ -4630,7 +4630,7 @@
"rules": [
{
"allow_failure": true,
- "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*wasm.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
"when": "manual"
}
],
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -56,6 +56,7 @@ data Signage = Signed | Unsigned deriving (Eq, Show)
genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
genLlvmProc (CmmProc infos lbl live graph) = do
let blocks = toBlockListEntryFirstFalseFallthrough graph
+
(lmblocks, lmdata) <- basicBlocksCodeGen live blocks
let info = mapLookup (g_entry graph) infos
proc = CmmProc info lbl live (ListGraph lmblocks)
@@ -67,6 +68,11 @@ genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
-- * Block code generation
--
+-- | Unreachable basic block
+--
+-- See Note [Unreachable block as default destination in Switch]
+newtype UnreachableBlockId = UnreachableBlockId BlockId
+
-- | Generate code for a list of blocks that make up a complete
-- procedure. The first block in the list is expected to be the entry
-- point.
@@ -82,20 +88,27 @@ basicBlocksCodeGen live cmmBlocks
(prologue, prologueTops) <- funPrologue live cmmBlocks
let entryBlock = BasicBlock bid (fromOL prologue)
+ -- allocate one unreachable basic block that can be used as a default
+ -- destination in exhaustive switches.
+ --
+ -- See Note [Unreachable block as default destination in Switch]
+ ubid@(UnreachableBlockId ubid') <- (UnreachableBlockId . mkBlockId) <$> getUniqueM
+ let ubblock = BasicBlock ubid' [Unreachable]
+
-- Generate code
- (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
+ (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) cmmBlocks
-- Compose
- return (entryBlock : blocks, prologueTops ++ concat topss)
+ return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)
-- | Generate code for one block
-basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
-basicBlockCodeGen block
+basicBlockCodeGen :: UnreachableBlockId -> CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen ubid block
= do let (_, nodes, tail) = blockSplit block
id = entryLabel block
- (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
- (tail_instrs, top') <- stmtToInstrs tail
+ (mid_instrs, top) <- stmtsToInstrs ubid $ blockToList nodes
+ (tail_instrs, top') <- stmtToInstrs ubid tail
let instrs = fromOL (mid_instrs `appOL` tail_instrs)
return (BasicBlock id instrs, top' ++ top)
@@ -110,15 +123,15 @@ type StmtData = (LlvmStatements, [LlvmCmmDecl])
-- | Convert a list of CmmNode's to LlvmStatement's
-stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
-stmtsToInstrs stmts
- = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
+stmtsToInstrs :: UnreachableBlockId -> [CmmNode e x] -> LlvmM StmtData
+stmtsToInstrs ubid stmts
+ = do (instrss, topss) <- fmap unzip $ mapM (stmtToInstrs ubid) stmts
return (concatOL instrss, concat topss)
-- | Convert a CmmStmt to a list of LlvmStatement's
-stmtToInstrs :: CmmNode e x -> LlvmM StmtData
-stmtToInstrs stmt = case stmt of
+stmtToInstrs :: UnreachableBlockId -> CmmNode e x -> LlvmM StmtData
+stmtToInstrs ubid stmt = case stmt of
CmmComment _ -> return (nilOL, []) -- nuke comments
CmmTick _ -> return (nilOL, [])
@@ -131,7 +144,7 @@ stmtToInstrs stmt = case stmt of
CmmBranch id -> genBranch id
CmmCondBranch arg true false likely
-> genCondBranch arg true false likely
- CmmSwitch arg ids -> genSwitch arg ids
+ CmmSwitch arg ids -> genSwitch ubid arg ids
-- Foreign Call
CmmUnsafeForeignCall target res args
@@ -1305,21 +1318,38 @@ For a real example of this, see ./rts/StgStdThunks.cmm
-- | Switch branch
-genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
-genSwitch cond ids = do
+genSwitch :: UnreachableBlockId -> CmmExpr -> SwitchTargets -> LlvmM StmtData
+genSwitch (UnreachableBlockId ubid) cond ids = do
(vc, stmts, top) <- exprToVar cond
let ty = getVarType vc
let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
| (ix, b) <- switchTargetsCases ids ]
- -- out of range is undefined, so let's just branch to first label
let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
- | otherwise = snd (head labels)
+ | otherwise = blockIdToLlvm ubid
+ -- switch to an unreachable basic block for exhaustive
+ -- switches. See Note [Unreachable block as default destination
+ -- in Switch]
let s1 = Switch vc defLbl labels
return $ (stmts `snocOL` s1, top)
+-- Note [Unreachable block as default destination in Switch]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- LLVM IR requires a default destination (a block label) for its Switch
+-- operation, even if the switch is exhaustive. An LLVM switch is considered
+-- exhausitve (e.g. to omit range checks for bit tests [1]) if the default
+-- destination is unreachable.
+--
+-- When we codegen a Cmm function, we always reserve an unreachable basic block
+-- that is used as a default destination for exhaustive Cmm switches in
+-- genSwitch. See #24717
+--
+-- [1] https://reviews.llvm.org/D68131
+
+
+
-- -----------------------------------------------------------------------------
-- * CmmExpr code generation
--
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -47,7 +47,7 @@ import GHC.Driver.Ppr( showSDoc )
import GHC.Core -- All of it
import GHC.Core.Subst
import GHC.Core.SimpleOpt ( exprIsLambda_maybe )
-import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars
+import GHC.Core.FVs ( exprFreeVars, bindFreeVars
, rulesFreeVarsDSet, exprsOrphNames )
import GHC.Core.Utils ( exprType, mkTick, mkTicks
, stripTicksTopT, stripTicksTopE
@@ -1887,41 +1887,59 @@ ruleCheckProgram ropts phase rule_pat rules binds
vcat [ p $$ line | p <- bagToList results ]
]
where
+ line = text (replicate 20 '-')
env = RuleCheckEnv { rc_is_active = isActive phase
, rc_id_unf = idUnfolding -- Not quite right
-- Should use activeUnfolding
, rc_pattern = rule_pat
, rc_rules = rules
, rc_ropts = ropts
- }
- results = unionManyBags (map (ruleCheckBind env) binds)
- line = text (replicate 20 '-')
+ , rc_in_scope = emptyInScopeSet }
+
+ results = go env binds
+
+ go _ [] = emptyBag
+ go env (bind:binds) = let (env', ds) = ruleCheckBind env bind
+ in ds `unionBags` go env' binds
+
+data RuleCheckEnv = RuleCheckEnv
+ { rc_is_active :: Activation -> Bool
+ , rc_id_unf :: IdUnfoldingFun
+ , rc_pattern :: String
+ , rc_rules :: Id -> [CoreRule]
+ , rc_ropts :: RuleOpts
+ , rc_in_scope :: InScopeSet }
+
+extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv
+extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v
+ = env { rc_in_scope = in_scope `extendInScopeSet` v }
-data RuleCheckEnv = RuleCheckEnv {
- rc_is_active :: Activation -> Bool,
- rc_id_unf :: IdUnfoldingFun,
- rc_pattern :: String,
- rc_rules :: Id -> [CoreRule],
- rc_ropts :: RuleOpts
-}
+extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv
+extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs
+ = env { rc_in_scope = in_scope `extendInScopeSetList` vs }
-ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
+ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc)
-- The Bag returned has one SDoc for each call site found
-ruleCheckBind env (NonRec _ r) = ruleCheck env r
-ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]
+ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r)
+ruleCheckBind env (Rec prs) = (env', unionManyBags (map (ruleCheck env') rhss))
+ where
+ (bs, rhss) = unzip prs
+ env' = env `extendInScopeListRC` bs
ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
-ruleCheck _ (Var _) = emptyBag
-ruleCheck _ (Lit _) = emptyBag
-ruleCheck _ (Type _) = emptyBag
-ruleCheck _ (Coercion _) = emptyBag
-ruleCheck env (App f a) = ruleCheckApp env (App f a) []
-ruleCheck env (Tick _ e) = ruleCheck env e
-ruleCheck env (Cast e _) = ruleCheck env e
-ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
-ruleCheck env (Lam _ e) = ruleCheck env e
-ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
- unionManyBags [ruleCheck env r | Alt _ _ r <- as]
+ruleCheck _ (Var _) = emptyBag
+ruleCheck _ (Lit _) = emptyBag
+ruleCheck _ (Type _) = emptyBag
+ruleCheck _ (Coercion _) = emptyBag
+ruleCheck env (App f a) = ruleCheckApp env (App f a) []
+ruleCheck env (Tick _ e) = ruleCheck env e
+ruleCheck env (Cast e _) = ruleCheck env e
+ruleCheck env (Let bd e) = let (env', ds) = ruleCheckBind env bd
+ in ds `unionBags` ruleCheck env' e
+ruleCheck env (Lam b e) = ruleCheck (env `extendInScopeRC` b) e
+ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags`
+ unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r
+ | Alt _ bs r <- as]
ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
@@ -1945,8 +1963,9 @@ ruleAppCheck_help env fn args rules
vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
vcat (map check_rule rules)]
where
- n_args = length args
- i_args = args `zip` [1::Int ..]
+ in_scope = rc_in_scope env
+ n_args = length args
+ i_args = args `zip` [1::Int ..]
rough_args = map roughTopName args
check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule
@@ -1976,10 +1995,8 @@ ruleAppCheck_help env fn args rules
mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
not (isJust (match_fn rule_arg arg))]
- lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl
where
- in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)
renv = RV { rv_lcl = mkRnEnv2 in_scope
, rv_tmpls = mkVarSet rule_bndrs
, rv_fltR = mkEmptySubst in_scope
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -228,7 +228,8 @@ enterRecGroupRHSs env bndrs k
(env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}
---------------
-simple_opt_clo :: InScopeSet
+simple_opt_clo :: HasCallStack
+ => InScopeSet
-> SimpleClo
-> OutExpr
simple_opt_clo in_scope (e_env, e)
@@ -397,7 +398,8 @@ simple_app env (Let bind body) args
simple_app env e as
= finish_app env (simple_opt_expr env e) as
-finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
+finish_app :: HasCallStack
+ => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
-- See Note [Eliminate casts in function position]
finish_app env (Cast (Lam x e) co) as@(_:_)
| not (isTyVar x) && not (isCoVar x)
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -2354,45 +2354,49 @@ we are optimizing away 'lazy' (see Note [lazyId magic], and also
'cpeRhsE'.) Then, we could have started with:
let x :: ()
- x = lazy @ () y
+ x = lazy @() y
-which is a perfectly fine, non-trivial thunk, but then CorePrep will
-drop 'lazy', giving us 'x = y' which is trivial and impermissible.
-The solution is CorePrep to have a miniature inlining pass which deals
-with cases like this. We can then drop the let-binding altogether.
+which is a perfectly fine, non-trivial thunk, but then CorePrep will drop
+'lazy', giving us 'x = y' which is trivial and impermissible. The solution is
+CorePrep to have a miniature inlining pass which deals with cases like this.
+We can then drop the let-binding altogether.
-Why does the removal of 'lazy' have to occur in CorePrep?
-The gory details are in Note [lazyId magic] in GHC.Types.Id.Make, but the
-main reason is that lazy must appear in unfoldings (optimizer
-output) and it must prevent call-by-value for catch# (which
-is implemented by CorePrep.)
+Why does the removal of 'lazy' have to occur in CorePrep? The gory details
+are in Note [lazyId magic] in GHC.Types.Id.Make, but the main reason is that
+lazy must appear in unfoldings (optimizer output) and it must prevent
+call-by-value for catch# (which is implemented by CorePrep.)
-An alternate strategy for solving this problem is to have the
-inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
-We decided not to adopt this solution to keep the definition
-of 'exprIsTrivial' simple.
+An alternate strategy for solving this problem is to have the inliner treat
+'lazy e' as a trivial expression if 'e' is trivial. We decided not to adopt
+this solution to keep the definition of 'exprIsTrivial' simple.
There is ONE caveat however: for top-level bindings we have
to preserve the binding so that we float the (hacky) non-recursive
binding for data constructors; see Note [Data constructor workers].
-Note [CorePrep inlines trivial CoreExpr not Id]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-TODO
-Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
-IdEnv Id? Naively, we might conjecture that trivial updatable thunks
-as per Note [Inlining in CorePrep] always have the form
-'lazy @ SomeType gbl_id'. But this is not true: the following is
-perfectly reasonable Core:
+Note [CorePrepEnv: cpe_subst]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+CorePrepEnv carries a substitution `Subst` in the `cpe_subst1 field,
+for these reasons:
- let x :: ()
- x = lazy @ (forall a. a) y @ Bool
+1. To support cloning of local Ids so that they are
+ all unique (see Note [Cloning in CorePrep])
+
+2. To support beta-reduction of runRW, see Note [runRW magic] and
+ Note [runRW arg].
+
+3. To let us inline trivial RHSs of non top-level let-bindings,
+ see Note [lazyId magic], Note [Inlining in CorePrep] (#12076)
-When we inline 'x' after eliminating 'lazy', we need to replace
-occurrences of 'x' with 'y @ bool', not just 'y'. Situations like
-this can easily arise with higher-rank types; thus, cpe_env must
-map to CoreExprs, not Ids.
+ Note that, if (y::forall a. a->a), we could get
+ x = lazy @(forall a.a) y @Bool
+ so after eliminating `lazy`, we need to replace occurrences of `x` with
+ `y @Bool`, not just `y`. Situations like this can easily arise with
+ higher-rank types; thus, `cpe_subst` must map to CoreExprs, not Ids, which
+ oc course it does
+4. The TyCoVar part of the substitution is used only for
+ Note [Cloning CoVars and TyVars]
-}
data CorePrepConfig = CorePrepConfig
@@ -2418,23 +2422,9 @@ data CorePrepEnv
-- the case where a function we think should bottom
-- unexpectedly returns.
- , cpe_subst :: Subst
- -- ^ The IdEnv part of the substitution is used for three operations:
- --
- -- 1. To support cloning of local Ids so that they are
- -- all unique (see Note [Cloning in CorePrep])
- --
- -- 2. To support beta-reduction of runRW, see
- -- Note [runRW magic] and Note [runRW arg].
- --
- -- 3. To let us inline trivial RHSs of non top-level let-bindings,
- -- see Note [lazyId magic], Note [Inlining in CorePrep]
- -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
- --
- -- The TyCoVar part of the substitution is used only for
- -- Note [Cloning CoVars and TyVars]
+ , cpe_subst :: Subst -- ^ See Note [CorePrepEnv: cpe_subst]
- , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
+ , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
}
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -1244,7 +1244,7 @@ transferAnnsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')
-- | Transfer comments from the annotations in the
-- first 'SrcSpanAnnA' argument to those in the second.
-transferCommentsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferCommentsOnlyA :: EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')
= (EpAnn a an emptyComments, EpAnn a' an' (cs <> cs'))
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1220,19 +1220,23 @@ checkLPat e@(L l _) = checkPat l e [] []
checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
- | isRdrDataCon c = return . L loc $ ConPat
- { pat_con_ext = noAnn -- AZ: where should this come from?
- , pat_con = L ln c
- , pat_args = PrefixCon tyargs args
- }
+ | isRdrDataCon c = do
+ let (_l', loc') = transferCommentsOnlyA l loc
+ return . L loc' $ ConPat
+ { pat_con_ext = noAnn -- AZ: where should this come from?
+ , pat_con = L ln c
+ , pat_args = PrefixCon tyargs args
+ }
| (not (null args) && patIsRec c) = do
ctx <- askParseContext
patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
-checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args =
- checkPat loc f (HsConPatTyArg at t : tyargs) args
-checkPat loc (L _ (PatBuilderApp f e)) [] args = do
- p <- checkLPat e
- checkPat loc f [] (p : args)
+checkPat loc (L _ (PatBuilderAppType (L lf f) at t)) tyargs args = do
+ let (loc', lf') = transferCommentsOnlyA loc lf
+ checkPat loc' (L lf' f) (HsConPatTyArg at t : tyargs) args
+checkPat loc (L _ (PatBuilderApp f (L le e))) [] args = do
+ let (loc', le') = transferCommentsOnlyA loc le
+ p <- checkLPat (L le' e)
+ checkPat loc' f [] (p : args)
checkPat loc (L l e) [] [] = do
p <- checkAPat loc e
return (L l p)
@@ -1432,20 +1436,27 @@ isFunLhs e = go e [] [] []
where
mk = fmap ArgPatBuilderVisPat
- go (L _ (PatBuilderVar (L loc f))) es ops cps
- | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))
- go (L _ (PatBuilderApp f e)) es ops cps = go f (mk e:es) ops cps
- go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps = go e es (o:ops) (c:cps)
+ 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 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
-- of funlhs.
where
+ (_l, le') = transferCommentsOnlyA l le
(o,c) = mkParensEpAnn (realSrcSpan $ locA l)
- go (L loc (PatBuilderOpApp l (L loc' op) r anns)) es ops cps
+ go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r anns)) es ops cps
| not (isRdrDataCon op) -- We have found the function!
- = return (Just (L loc' op, Infix, (mk l:mk r:es), (anns ++ reverse ops ++ cps)))
+ = do { let (_l, ll') = transferCommentsOnlyA loc ll
+ ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (anns ++ reverse ops ++ cps))) }
| otherwise -- Infix data con; keep going
- = do { mb_l <- go l es ops cps
+ = 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', anns')
@@ -1454,12 +1465,13 @@ isFunLhs e = go e [] [] []
op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)
(L loc' op) r (reverse ops ++ cps))
reassociate _other = Nothing
- go (L _ (PatBuilderAppType pat tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
- = go pat (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
+ 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
where invis_pat = InvisPat tok ty_pat
anc' = case tok of
NoEpTok -> anc
EpTok l -> widenAnchor anc [AddEpAnn AnnAnyclass l]
+ (_l, lp') = transferCommentsOnlyA l lp
go _ _ _ _ = return Nothing
data ArgPatBuilder p
=====================================
distrib/configure.ac.in
=====================================
@@ -114,16 +114,16 @@ if test "$HostOS" = "darwin"; then
# The following is the work around suggested by @carter in #17418 during
# install time. This should help us with code signing issues by removing
# extended attributes from all files.
- XATTR=${XATTR:-/usr/bin/xattr}
+ XATTR="${XATTR:-/usr/bin/xattr}"
- if [ -e "${XATTR}" ]; then
+ if test -e "${XATTR}"; then
# Instead of cleaning the attributes of the ghc-toolchain binary only,
# we clean them from all files in the bin/ and lib/ directories, as it additionally future
# proofs running executables from the bindist besides ghc-toolchain at configure time, and
# we can avoid figuring out the path to the ghc-toolchain dynlib specifically.
- /usr/bin/xattr -rc bin/
- /usr/bin/xattr -rc lib/
+ "$XATTR" -rc bin/
+ "$XATTR" -rc lib/
fi
fi
=====================================
docs/users_guide/bugs.rst
=====================================
@@ -445,15 +445,15 @@ In ``Prelude`` support
``Read``\ ing integers
GHC's implementation of the ``Read`` class for integral types
- accepts hexadecimal and octal literals (the code in the Haskell 98
+ accepts hexadecimal, octal and binary literals (the code in the Haskell 98
report doesn't). So, for example, ::
read "0xf00" :: Int
works in GHC.
- A possible reason for this is that ``readLitChar`` accepts hex and
- octal escapes, so it seems inconsistent not to do so for integers
+ This is to maintain consistency with the language's syntax. Haskell98
+ accepts hexadecimal and octal formats, and GHC2021 accepts binary formats
too.
``isAlpha``
=====================================
hadrian/src/Rules/Compile.hs
=====================================
@@ -218,6 +218,9 @@ compileHsObjectAndHi rs objpath = do
ctxPath <- contextPath ctx
(src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
need (src:deps)
+ -- The .conf file is needed when template-haskell is implicitly added as a dependency
+ -- when a module in the template-haskell package is compiled. (See #24737)
+ when (isLibrary (C.package ctx)) (need . (:[]) =<< pkgConfFile ctx)
-- The .dependencies file lists indicating inputs. ghc will
-- generally read more *.hi and *.hi-boot files (direct inputs).
=====================================
libraries/base/changelog.md
=====================================
@@ -1,7 +1,9 @@
# Changelog for [`base` package](http://hackage.haskell.org/package/base)
## 4.21.0.0 *TBA*
+ * Add the `MonadFix` instance for `(,) a`, similar to the one for `Writer a` ([CLC proposal #238](https://github.com/haskell/core-libraries-committee/issues/238))
* Improve `toInteger :: Word32 -> Integer` on 64-bit platforms ([CLC proposal #259](https://github.com/haskell/core-libraries-committee/issues/259))
+ * Make `read` accept binary integer notation ([CLC proposal #177](https://github.com/haskell/core-libraries-committee/issues/177))
## 4.20.0.0 *TBA*
* Deprecate `GHC.Pack` ([#21461](https://gitlab.haskell.org/ghc/ghc/-/issues/21461))
=====================================
libraries/base/tests/char001.hs
=====================================
@@ -1,7 +1,8 @@
-- !!! Testing the behaviour of Char.lexLitChar a little..
--- [March 2003] We now allow \X and \O as escapes although the
--- spec only permits \x and \o. Seems more consistent.
+-- [March 2003] We now allow \X and \O as escapes although the
+-- spec only permits \x and \o. Seems more consistent.
+-- [January 2024] Binary character literals, something like '\b100' are not permitted.
module Main where
@@ -33,9 +34,15 @@ octs = do
lex' "'\\o14b'"
lex' "'\\0a4bg'"
+-- Binaries are NOT supported. '\b' stands for backspace.
+bins = do
+ lex' "'\\b'"
+ lex' "'\\b00'"
+
main = do
hexes
octs
+ bins
=====================================
libraries/base/tests/char001.stdout
=====================================
@@ -16,3 +16,5 @@ lex '\O000024' = [("'\\O000024'","")]
lex '\024b' = []
lex '\o14b' = []
lex '\0a4bg' = []
+lex '\b' = [("'\\b'","")]
+lex '\b00' = []
=====================================
libraries/base/tests/lex001.hs
=====================================
@@ -27,7 +27,23 @@ testStrings
"035e-3x",
"35e+3y",
"83.3e-22",
- "083.3e-22"
+ "083.3e-22",
+
+ "0b001",
+ "0b100",
+ "0b110",
+ "0B001",
+ "0B100",
+ "0B110",
+
+ "78_91",
+ "678_346",
+ "0x23d_fa4",
+ "0X23d_fa4",
+ "0o01_253",
+ "0O304_367",
+ "0b0101_0110",
+ "0B11_010_0110"
]
main = mapM test testStrings
=====================================
libraries/base/tests/lex001.stdout
=====================================
@@ -82,3 +82,58 @@
[("083.3e-22","")]
[(Number (MkDecimal [0,8,3] (Just [3]) (Just (-22))),"")]
+"0b001"
+[("0b001","")]
+[(Number (MkNumber 2 [0,0,1]),"")]
+
+"0b100"
+[("0b100","")]
+[(Number (MkNumber 2 [1,0,0]),"")]
+
+"0b110"
+[("0b110","")]
+[(Number (MkNumber 2 [1,1,0]),"")]
+
+"0B001"
+[("0B001","")]
+[(Number (MkNumber 2 [0,0,1]),"")]
+
+"0B100"
+[("0B100","")]
+[(Number (MkNumber 2 [1,0,0]),"")]
+
+"0B110"
+[("0B110","")]
+[(Number (MkNumber 2 [1,1,0]),"")]
+
+"78_91"
+[("78","_91")]
+[(Number (MkDecimal [7,8] Nothing Nothing),"_91")]
+
+"678_346"
+[("678","_346")]
+[(Number (MkDecimal [6,7,8] Nothing Nothing),"_346")]
+
+"0x23d_fa4"
+[("0x23d","_fa4")]
+[(Number (MkNumber 16 [2,3,13]),"_fa4")]
+
+"0X23d_fa4"
+[("0X23d","_fa4")]
+[(Number (MkNumber 16 [2,3,13]),"_fa4")]
+
+"0o01_253"
+[("0o01","_253")]
+[(Number (MkNumber 8 [0,1]),"_253")]
+
+"0O304_367"
+[("0O304","_367")]
+[(Number (MkNumber 8 [3,0,4]),"_367")]
+
+"0b0101_0110"
+[("0b0101","_0110")]
+[(Number (MkNumber 2 [0,1,0,1]),"_0110")]
+
+"0B11_010_0110"
+[("0B11","_010_0110")]
+[(Number (MkNumber 2 [1,1]),"_010_0110")]
=====================================
libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs
=====================================
@@ -30,13 +30,13 @@ module GHC.Internal.Control.Monad.Fix (
import GHC.Internal.Data.Either
import GHC.Internal.Data.Function ( fix )
import GHC.Internal.Data.Maybe
-import GHC.Internal.Data.Monoid ( Dual(..), Sum(..), Product(..)
+import GHC.Internal.Data.Monoid ( Monoid, Dual(..), Sum(..), Product(..)
, First(..), Last(..), Alt(..), Ap(..) )
import GHC.Internal.Data.Ord ( Down(..) )
+import GHC.Internal.Data.Tuple ( Solo(..), snd )
import GHC.Internal.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) )
import GHC.Internal.Generics
import GHC.Internal.List ( head, drop )
-import GHC.Tuple (Solo (..))
import GHC.Internal.Control.Monad.ST.Imp
import GHC.Internal.System.IO
@@ -72,6 +72,11 @@ instance MonadFix Solo where
mfix f = let a = f (unSolo a) in a
where unSolo (MkSolo x) = x
+-- | @since base-4.21
+instance Monoid a => MonadFix ((,) a) where
+ -- See the CLC proposal thread for discussion and proofs of the laws: https://github.com/haskell/core-libraries-committee/issues/238
+ mfix f = let a = f (snd a) in a
+
-- | @since base-2.01
instance MonadFix Maybe where
mfix f = let a = f (unJust a) in a
=====================================
libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs
=====================================
@@ -300,6 +300,17 @@ lexCharE =
n <- lexInteger base
guard (n <= toInteger (ord maxBound))
return (chr (fromInteger n))
+ where
+ -- Slightly different variant of lexBaseChar that denies binary format.
+ -- Binary formats are not allowed for character/string literal.
+ lexBaseChar = do
+ c <- get
+ case c of
+ 'o' -> return 8
+ 'O' -> return 8
+ 'x' -> return 16
+ 'X' -> return 16
+ _ -> pfail
lexCntrlChar =
do _ <- char '^'
@@ -415,27 +426,28 @@ type Digits = [Int]
lexNumber :: ReadP Lexeme
lexNumber
- = lexHexOct <++ -- First try for hex or octal 0x, 0o etc
+ = lexHexOctBin <++ -- First try for hex, octal or binary 0x, 0o, 0b etc
-- If that fails, try for a decimal number
lexDecNumber -- Start with ordinary digits
-lexHexOct :: ReadP Lexeme
-lexHexOct
+lexHexOctBin :: ReadP Lexeme
+lexHexOctBin
= do _ <- char '0'
base <- lexBaseChar
digits <- lexDigits base
return (Number (MkNumber base digits))
-
-lexBaseChar :: ReadP Int
--- Lex a single character indicating the base; fail if not there
-lexBaseChar = do
- c <- get
- case c of
- 'o' -> return 8
- 'O' -> return 8
- 'x' -> return 16
- 'X' -> return 16
- _ -> pfail
+ where
+ -- Lex a single character indicating the base; fail if not there
+ lexBaseChar = do
+ c <- get
+ case c of
+ 'b' -> return 2
+ 'B' -> return 2
+ 'o' -> return 8
+ 'O' -> return 8
+ 'x' -> return 16
+ 'X' -> return 16
+ _ -> pfail
lexDecNumber :: ReadP Lexeme
lexDecNumber =
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -11383,6 +11383,7 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Int
instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.ST.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance GHC.Internal.Control.Monad.Fix.MonadFix Solo -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Fix’
+instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Control.Monad.Fix.MonadFix ((,) a) -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.ST.Lazy.Imp’
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Complex.Complex -- Defined in ‘Data.Complex’
instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Data.Functor.Identity’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -14418,6 +14418,7 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Int
instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.ST.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance GHC.Internal.Control.Monad.Fix.MonadFix Solo -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Fix’
+instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Control.Monad.Fix.MonadFix ((,) a) -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.ST.Lazy.Imp’
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Complex.Complex -- Defined in ‘Data.Complex’
instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Data.Functor.Identity’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -11647,6 +11647,7 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Int
instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.ST.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance GHC.Internal.Control.Monad.Fix.MonadFix Solo -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Fix’
+instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Control.Monad.Fix.MonadFix ((,) a) -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.ST.Lazy.Imp’
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Complex.Complex -- Defined in ‘Data.Complex’
instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Data.Functor.Identity’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -11383,6 +11383,7 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Int
instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.ST.ST s) -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance GHC.Internal.Control.Monad.Fix.MonadFix Solo -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Fix’
+instance forall a. GHC.Internal.Base.Monoid a => GHC.Internal.Control.Monad.Fix.MonadFix ((,) a) -- Defined in ‘GHC.Internal.Control.Monad.Fix’
instance forall s. GHC.Internal.Control.Monad.Fix.MonadFix (GHC.Internal.Control.Monad.ST.Lazy.Imp.ST s) -- Defined in ‘GHC.Internal.Control.Monad.ST.Lazy.Imp’
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Complex.Complex -- Defined in ‘Data.Complex’
instance GHC.Internal.Control.Monad.Fix.MonadFix GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Data.Functor.Identity’
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -831,3 +831,8 @@ PprLetIn:
CaseAltComments:
$(CHECK_PPR) $(LIBDIR) CaseAltComments.hs
$(CHECK_EXACT) $(LIBDIR) CaseAltComments.hs
+
+.PHONY: MatchPatComments
+MatchPatComments:
+ $(CHECK_PPR) $(LIBDIR) MatchPatComments.hs
+ $(CHECK_EXACT) $(LIBDIR) MatchPatComments.hs
=====================================
testsuite/tests/printer/MatchPatComments.hs
=====================================
@@ -0,0 +1,16 @@
+module MatchPatComments where
+
+expandProcess
+ outCHAs -- c0
+ locationDescr =
+ blah
+
+next
+ ( steps -- c1
+ , ys -- c2
+ ) x -- c3
+ = (steps, x, ys)
+
+makeProjection
+ Function{funMutual = VV, -- c4
+ funAbstr = ConcreteDef} = undefined
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -199,3 +199,4 @@ test('AnnotationNoListTuplePuns', [ignore_stderr, req_ppr_deps], makefile_test,
test('Test24533', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24533'])
test('PprLetIn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprLetIn'])
test('CaseAltComments', [ignore_stderr, req_ppr_deps], makefile_test, ['CaseAltComments'])
+test('MatchPatComments', [ignore_stderr, req_ppr_deps], makefile_test, ['MatchPatComments'])
=====================================
testsuite/tests/simplCore/should_compile/T24726.hs
=====================================
@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -drule-check concatMap #-}
+ -- This rule-check thing crashed #24726
+
+module T24726 where
+
+data Stream a = forall s. Stream (s -> ()) s
+
+concatMapS :: (a -> Stream b) -> Stream a -> Stream b
+concatMapS f (Stream next0 s0) = Stream undefined undefined
+{-# INLINE [1] concatMapS #-}
+
+concatMapS' :: (s -> ()) -> (a -> s) -> Stream a -> Stream b
+concatMapS' = undefined
+
+{-# RULES "concatMap" forall step f. concatMapS (\x -> Stream step (f x)) = concatMapS' step f #-}
+
+replicateStep :: a -> b
+replicateStep _ = undefined
+{-# INLINE replicateStep #-}
+
+replicateS :: Int -> a -> Stream a
+replicateS n x0 = Stream replicateStep undefined
+{-# INLINE replicateS #-}
+
+foo1 :: Stream Int -> Stream Int
+foo1 = concatMapS (replicateS 2)
=====================================
testsuite/tests/simplCore/should_compile/T24726.stderr
=====================================
@@ -0,0 +1,36 @@
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -514,3 +514,4 @@ test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24370', normal, compile, ['-O'])
test('T24551', normal, compile, ['-O -dcore-lint'])
+test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
=====================================
utils/check-exact/Main.hs
=====================================
@@ -128,7 +128,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr034.hs" Nothing
-- "../../testsuite/tests/printer/Ppr035.hs" Nothing
-- "../../testsuite/tests/printer/Ppr036.hs" Nothing
- "../../testsuite/tests/printer/Ppr037.hs" Nothing
+ "../../testsuite/tests/printer/MatchPatComments.hs" Nothing
-- "../../testsuite/tests/printer/Ppr038.hs" Nothing
-- "../../testsuite/tests/printer/Ppr039.hs" Nothing
-- "../../testsuite/tests/printer/Ppr040.hs" Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8a8e6bbb656339524a5ec23be06df7ff243833d5...d5d664bd5ad70c26d169c8df8389d9f8c547ddb6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8a8e6bbb656339524a5ec23be06df7ff243833d5...d5d664bd5ad70c26d169c8df8389d9f8c547ddb6
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/20240430/e8532ce3/attachment-0001.html>
More information about the ghc-commits
mailing list