01 Mar '26
Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC
Commits:
ec201fd2 by Apoorv Ingle at 2026-03-01T14:24:33-06:00
ErrCtxtMsg to CtOrigin
- - - - -
10 changed files:
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
Changes:
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -640,11 +640,12 @@ deriving instance Eq (IE GhcRn)
deriving instance Eq (IE GhcTc)
-- ---------------------------------------------------------------------
-
+-- TODO: I think we still need instances for StmtCtxt, ExprCtxt and PatCtxt ctors of ErrCtxtMsg
instance Data ErrCtxtMsg where
gunfold _ _ _ = error "no gunfold for ErrCtxtMsg"
gfoldl _ _ _ = error "no goldl for ErrCtxtMsg"
-
+ toConstr = error "no toConstr for ErrCtxtMsg"
+ dataTypeOf = error "no dataTypeOf for ErrCtxtMsg"
deriving instance Data XXExprGhcRn
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -20,6 +20,7 @@ import GHC.Hs
import GHC.Tc.Gen.Head
import GHC.Tc.Errors.Types
+import GHC.Tc.Errors.Ppr
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate
@@ -275,7 +276,7 @@ tcApp works like this:
2. Use tcInferAppHead to infer the type of the function,
as an (uninstantiated) TcSigmaType
There are special cases for
- HsVar, HsRecSel, and ExprWithTySig
+ HsVar, HsRecSel, and ExprWithTySig and XExpr
Otherwise, delegate back to tcExpr, which
infers an (instantiated) TcRhoType
@@ -2050,6 +2051,7 @@ mk_origin fun_lspan_arg rn_fun_arg rn_fun
= return $ exprCtOrigin rn_fun_arg
| otherwise
= do { code_orig <- getSrcCodeOrigin
+ ; traceTc "mk_origin" (case (pprErrCtxtMsg <$> code_orig) of { Just e -> e; _ -> text "Nothing"})
; return $ srcCodeOriginCtOrigin rn_fun code_orig
}
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -213,7 +213,7 @@ mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) =
fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn
fail_op_expr dflags pat@(L pat_lspan _) fail_op
- = L pat_lspan $ mkExpandedPatRn doFlav (unLoc pat) stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
+ = L pat_lspan $ mkExpandedPatRn doFlav pat stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
mk_fail_msg_expr dflags pat
@@ -481,7 +481,7 @@ It stores the original statement (with location) and the expanded expression
-}
-mkExpandedPatRn :: HsDoFlavour -> Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+mkExpandedPatRn :: HsDoFlavour -> LPat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedPatRn flav pat stmt e = XExpr $ ExpandedThingRn
{ xrn_orig = StmtErrCtxtPat (HsDoStmt flav) stmt pat
, xrn_expanded = e}
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -430,6 +430,7 @@ tcInferAppHead :: (HsExpr GhcRn, SrcSpan)
-- * A bare identifier (just look it up)
-- This case also covers a record selector HsRecSel
-- * An expression with a type signature (e :: ty)
+-- * An XExpr where 'f' is actually an expanded out expression
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
--
-- Note that [] and (,,) are both HsVar:
@@ -452,6 +453,8 @@ tcInferAppHead_maybe :: HsExpr GhcRn
-> TcM (Maybe (HsExpr GhcTc, DeepSubsumptionFlag, TcSigmaType))
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-- Returns Nothing for a complicated head
+-- XExpr's although complicated needs to be looked through, useful for QL things when
+-- the argument is an XExpr
tcInferAppHead_maybe fun = case fun of
HsVar _ nm -> Just <$> with_get_ds (tcInferId nm)
ExprWithTySig _ e hs_ty -> Just <$> with_get_ds (tcExprWithSig e hs_ty)
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1,5 +1,4 @@
{-# LANGUAGE PatternSynonyms #-}
-
{-
(c) The University of Glasgow 2006-2012
(c) The GRASP Project, Glasgow University, 1992-2002
=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -340,7 +340,7 @@ data ErrCtxtMsg
| DoStmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn)
-- | In patten of the do statement. (c.f. MonadFailErrors)
- | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (Pat GhcRn)
+ | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (LPat GhcRn)
-- | In an rebindable syntax expression.
| SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan
=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -211,11 +211,12 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec)
-- See Note [ErrCtxtStack Manipulation]
setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt
setLclCtxtSrcCodeOrigin ec lclCtxt
- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt
- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec
- = lclCtxt { tcl_err_ctxt = ec : ecs }
- | MkErrCtxt ExpansionCodeCtxt _ : ecs <- tcl_err_ctxt lclCtxt
- , MkErrCtxt ExpansionCodeCtxt _ <- ec
+ -- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt
+ -- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec
+ -- = lclCtxt { tcl_err_ctxt = ec : ecs }
+ -- never stack 2 statement error contexts on top of each other
+ | MkErrCtxt _ DoStmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt
+ , MkErrCtxt _ DoStmtErrCtxt{} <- ec
= lclCtxt { tcl_err_ctxt = ec : ecs }
| otherwise
= lclCtxt { tcl_err_ctxt = ec : tcl_err_ctxt lclCtxt }
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -455,7 +455,7 @@ data CtOrigin
-- `ty1` to `ty2`.
| DefaultOrigin -- Typechecking a default decl
- | DoStmtOrigin -- Arising from a do expression
+ | DoStmtOrigin -- Arising from a do statement
| DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in
-- a do expression
| MCompOrigin -- Arising from a monad comprehension
@@ -690,12 +690,22 @@ exprCtOrigin e@(HsIf {}) = ExpansionOrigin (ExprCtxt e)
exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (ExprCtxt e)
exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (ExprCtxt e)
exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (ExprCtxt e)
-exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
+exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o
exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe ErrCtxtMsg -> CtOrigin
srcCodeOriginCtOrigin e Nothing = exprCtOrigin e
-srcCodeOriginCtOrigin _ (Just o) = ExpansionOrigin o
+srcCodeOriginCtOrigin _ (Just o) = errCtxtCtOrigin o
+
+
+errCtxtCtOrigin :: ErrCtxtMsg -> CtOrigin
+errCtxtCtOrigin (ExprCtxt e) = exprCtOrigin e
+errCtxtCtOrigin (FunAppCtxt (FunAppCtxtExpr _ e) _) = exprCtOrigin e
+errCtxtCtOrigin (StmtErrCtxt{}) = DoStmtOrigin
+errCtxtCtOrigin (DoStmtErrCtxt{}) = DoStmtOrigin
+errCtxtCtOrigin (StmtErrCtxtPat _ _ p) = DoPatOrigin p
+errCtxtCtOrigin _ = Shouldn'tHappenOrigin "errCtxtCtOrigin"
+
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -731,6 +741,8 @@ pprCtOrigin (ExpansionOrigin o)
what = case o of
StmtErrCtxt{} ->
text "a do statement"
+ DoStmtErrCtxt{} ->
+ text "a do statement"
StmtErrCtxtPat _ _ p ->
text "a do statement" $$
text "with the failable pattern" <+> quotes (ppr p)
@@ -744,6 +756,7 @@ pprCtOrigin (ExpansionOrigin o)
ExprCtxt (HsProjection _ p) -> text "the record selector" <+>
quotes (ppr ((FieldLabelStrings $ fmap noLocA p)))
ExprCtxt e -> text "the expression" <+> (ppr e)
+ RecordUpdCtxt{} -> text "a record update"
_ -> text "shouldn't happen ExpansionOrigin pprCtOrigin"
pprCtOrigin (GivenSCOrigin sk d blk)
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -52,7 +52,6 @@ import GHC.Core.FamInstEnv
import GHC.Core ( isOrphan ) -- For the Coercion constructor
import GHC.Core.Type
import GHC.Core.TyCo.Ppr ( debugPprType )
-import GHC.Core.TyCo.Tidy ( tidyType )
import GHC.Core.Class( Class )
import GHC.Core.Coercion.Axiom
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1330,27 +1330,28 @@ addLExprCtxt lspan e thing_inside
= setSrcSpan lspan $ add_expr_ctxt e thing_inside
| otherwise -- no op in generated code
= thing_inside
+ where
+ add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
+ add_expr_ctxt e thing_inside
+ = case e of
+ -- The HsHole special case addresses situations like
+ -- f x = _
+ -- when we don't want to say "In the expression: _",
+ -- because it is mentioned in the error message itself
+ HsHole{} -> thing_inside
+
+ -- There is a special case for expressions with signatures to avoid having too verbose
+ -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded.
+ -- c.f. RecordDotSyntaxFail9
+ ExprWithTySig _ (L _ e') _
+ | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside
+
+ -- Flip error ctxt into expansion mode
+ XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
+
+ _ -> addErrCtxt (ExprCtxt e) thing_inside
+
--- | !Caution!: Users should not call add_expr_ctxt, they ought to use addLExprCtxt
-add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
-add_expr_ctxt e thing_inside
- = case e of
- HsHole{} -> thing_inside
- -- The HsHole special case addresses situations like
- -- f x = _
- -- when we don't want to say "In the expression: _",
- -- because it is mentioned in the error message itself
-
- ExprWithTySig _ (L _ e') _
- | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside
- -- There is a special case for expressions with signatures to avoid having too verbose
- -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded.
- -- c.f. RecordDotSyntaxFail9
-
- XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
- -- Flip error ctxt into expansion mode
-
- _ -> addErrCtxt (ExprCtxt e) thing_inside
getErrCtxt :: TcM [ErrCtxt]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec201fd2f14a2ff83fcca19c2e51ee9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec201fd2f14a2ff83fcca19c2e51ee9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
01 Mar '26
Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC
Commits:
e9109729 by Apoorv Ingle at 2026-03-01T14:10:35-06:00
ErrCtxtMsg to CtOrigin
- - - - -
10 changed files:
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
Changes:
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -640,11 +640,12 @@ deriving instance Eq (IE GhcRn)
deriving instance Eq (IE GhcTc)
-- ---------------------------------------------------------------------
-
+-- TODO: I think we still need instances for StmtCtxt, ExprCtxt and PatCtxt ctors of ErrCtxtMsg
instance Data ErrCtxtMsg where
gunfold _ _ _ = error "no gunfold for ErrCtxtMsg"
gfoldl _ _ _ = error "no goldl for ErrCtxtMsg"
-
+ toConstr = error "no toConstr for ErrCtxtMsg"
+ dataTypeOf = err "no dataTypeOf for ErrCtxtMsg"
deriving instance Data XXExprGhcRn
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -20,6 +20,7 @@ import GHC.Hs
import GHC.Tc.Gen.Head
import GHC.Tc.Errors.Types
+import GHC.Tc.Errors.Ppr
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate
@@ -275,7 +276,7 @@ tcApp works like this:
2. Use tcInferAppHead to infer the type of the function,
as an (uninstantiated) TcSigmaType
There are special cases for
- HsVar, HsRecSel, and ExprWithTySig
+ HsVar, HsRecSel, and ExprWithTySig and XExpr
Otherwise, delegate back to tcExpr, which
infers an (instantiated) TcRhoType
@@ -2050,6 +2051,7 @@ mk_origin fun_lspan_arg rn_fun_arg rn_fun
= return $ exprCtOrigin rn_fun_arg
| otherwise
= do { code_orig <- getSrcCodeOrigin
+ ; traceTc "mk_origin" (case (pprErrCtxtMsg <$> code_orig) of { Just e -> e; _ -> text "Nothing"})
; return $ srcCodeOriginCtOrigin rn_fun code_orig
}
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -213,7 +213,7 @@ mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) =
fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn
fail_op_expr dflags pat@(L pat_lspan _) fail_op
- = L pat_lspan $ mkExpandedPatRn doFlav (unLoc pat) stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
+ = L pat_lspan $ mkExpandedPatRn doFlav pat stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
mk_fail_msg_expr dflags pat
@@ -481,7 +481,7 @@ It stores the original statement (with location) and the expanded expression
-}
-mkExpandedPatRn :: HsDoFlavour -> Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+mkExpandedPatRn :: HsDoFlavour -> LPat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedPatRn flav pat stmt e = XExpr $ ExpandedThingRn
{ xrn_orig = StmtErrCtxtPat (HsDoStmt flav) stmt pat
, xrn_expanded = e}
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -430,6 +430,7 @@ tcInferAppHead :: (HsExpr GhcRn, SrcSpan)
-- * A bare identifier (just look it up)
-- This case also covers a record selector HsRecSel
-- * An expression with a type signature (e :: ty)
+-- * An XExpr where 'f' is actually an expanded out expression
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
--
-- Note that [] and (,,) are both HsVar:
@@ -452,6 +453,8 @@ tcInferAppHead_maybe :: HsExpr GhcRn
-> TcM (Maybe (HsExpr GhcTc, DeepSubsumptionFlag, TcSigmaType))
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-- Returns Nothing for a complicated head
+-- XExpr's although complicated needs to be looked through, useful for QL things when
+-- the argument is an XExpr
tcInferAppHead_maybe fun = case fun of
HsVar _ nm -> Just <$> with_get_ds (tcInferId nm)
ExprWithTySig _ e hs_ty -> Just <$> with_get_ds (tcExprWithSig e hs_ty)
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1,5 +1,4 @@
{-# LANGUAGE PatternSynonyms #-}
-
{-
(c) The University of Glasgow 2006-2012
(c) The GRASP Project, Glasgow University, 1992-2002
=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -340,7 +340,7 @@ data ErrCtxtMsg
| DoStmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn)
-- | In patten of the do statement. (c.f. MonadFailErrors)
- | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (Pat GhcRn)
+ | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (LPat GhcRn)
-- | In an rebindable syntax expression.
| SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan
=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -211,11 +211,12 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec)
-- See Note [ErrCtxtStack Manipulation]
setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt
setLclCtxtSrcCodeOrigin ec lclCtxt
- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt
- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec
- = lclCtxt { tcl_err_ctxt = ec : ecs }
- | MkErrCtxt ExpansionCodeCtxt _ : ecs <- tcl_err_ctxt lclCtxt
- , MkErrCtxt ExpansionCodeCtxt _ <- ec
+ -- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt
+ -- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec
+ -- = lclCtxt { tcl_err_ctxt = ec : ecs }
+ -- never stack 2 statement error contexts on top of each other
+ | MkErrCtxt _ DoStmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt
+ , MkErrCtxt _ DoStmtErrCtxt{} <- ec
= lclCtxt { tcl_err_ctxt = ec : ecs }
| otherwise
= lclCtxt { tcl_err_ctxt = ec : tcl_err_ctxt lclCtxt }
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -455,7 +455,7 @@ data CtOrigin
-- `ty1` to `ty2`.
| DefaultOrigin -- Typechecking a default decl
- | DoStmtOrigin -- Arising from a do expression
+ | DoStmtOrigin -- Arising from a do statement
| DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in
-- a do expression
| MCompOrigin -- Arising from a monad comprehension
@@ -690,12 +690,22 @@ exprCtOrigin e@(HsIf {}) = ExpansionOrigin (ExprCtxt e)
exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (ExprCtxt e)
exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (ExprCtxt e)
exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (ExprCtxt e)
-exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
+exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o
exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe ErrCtxtMsg -> CtOrigin
srcCodeOriginCtOrigin e Nothing = exprCtOrigin e
-srcCodeOriginCtOrigin _ (Just o) = ExpansionOrigin o
+srcCodeOriginCtOrigin _ (Just o) = errCtxtCtOrigin o
+
+
+errCtxtCtOrigin :: ErrCtxtMsg -> CtOrigin
+errCtxtCtOrigin (ExprCtxt e) = exprCtOrigin e
+errCtxtCtOrigin (FunAppCtxt (FunAppCtxtExpr _ e) _) = exprCtOrigin e
+errCtxtCtOrigin (StmtErrCtxt{}) = DoStmtOrigin
+errCtxtCtOrigin (DoStmtErrCtxt{}) = DoStmtOrigin
+errCtxtCtOrigin (StmtErrCtxtPat _ _ p) = DoPatOrigin p
+errCtxtCtOrigin _ = Shouldn'tHappenOrigin "errCtxtCtOrigin"
+
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -731,6 +741,8 @@ pprCtOrigin (ExpansionOrigin o)
what = case o of
StmtErrCtxt{} ->
text "a do statement"
+ DoStmtErrCtxt{} ->
+ text "a do statement"
StmtErrCtxtPat _ _ p ->
text "a do statement" $$
text "with the failable pattern" <+> quotes (ppr p)
@@ -744,6 +756,7 @@ pprCtOrigin (ExpansionOrigin o)
ExprCtxt (HsProjection _ p) -> text "the record selector" <+>
quotes (ppr ((FieldLabelStrings $ fmap noLocA p)))
ExprCtxt e -> text "the expression" <+> (ppr e)
+ RecordUpdCtxt{} -> text "a record update"
_ -> text "shouldn't happen ExpansionOrigin pprCtOrigin"
pprCtOrigin (GivenSCOrigin sk d blk)
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -52,7 +52,6 @@ import GHC.Core.FamInstEnv
import GHC.Core ( isOrphan ) -- For the Coercion constructor
import GHC.Core.Type
import GHC.Core.TyCo.Ppr ( debugPprType )
-import GHC.Core.TyCo.Tidy ( tidyType )
import GHC.Core.Class( Class )
import GHC.Core.Coercion.Axiom
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1330,27 +1330,28 @@ addLExprCtxt lspan e thing_inside
= setSrcSpan lspan $ add_expr_ctxt e thing_inside
| otherwise -- no op in generated code
= thing_inside
+ where
+ add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
+ add_expr_ctxt e thing_inside
+ = case e of
+ -- The HsHole special case addresses situations like
+ -- f x = _
+ -- when we don't want to say "In the expression: _",
+ -- because it is mentioned in the error message itself
+ HsHole{} -> thing_inside
+
+ -- There is a special case for expressions with signatures to avoid having too verbose
+ -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded.
+ -- c.f. RecordDotSyntaxFail9
+ ExprWithTySig _ (L _ e') _
+ | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside
+
+ -- Flip error ctxt into expansion mode
+ XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
+
+ _ -> addErrCtxt (ExprCtxt e) thing_inside
+
--- | !Caution!: Users should not call add_expr_ctxt, they ought to use addLExprCtxt
-add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
-add_expr_ctxt e thing_inside
- = case e of
- HsHole{} -> thing_inside
- -- The HsHole special case addresses situations like
- -- f x = _
- -- when we don't want to say "In the expression: _",
- -- because it is mentioned in the error message itself
-
- ExprWithTySig _ (L _ e') _
- | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside
- -- There is a special case for expressions with signatures to avoid having too verbose
- -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded.
- -- c.f. RecordDotSyntaxFail9
-
- XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside
- -- Flip error ctxt into expansion mode
-
- _ -> addErrCtxt (ExprCtxt e) thing_inside
getErrCtxt :: TcM [ErrCtxt]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9109729aa290b2334f34282abb0b9b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9109729aa290b2334f34282abb0b9b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/int-index/ppr-hstype-quote
by Vladislav Zavialov (＠int-index) 01 Mar '26
by Vladislav Zavialov (＠int-index) 01 Mar '26
01 Mar '26
Vladislav Zavialov pushed new branch wip/int-index/ppr-hstype-quote at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/ppr-hstype-quote
You're receiving this email because of your account on gitlab.haskell.org.
1
0
01 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
08bc245b by sheaf at 2026-03-01T11:11:54-05:00
Clean up join points, casts & ticks
This commit shores up the logic dealing with casts and ticks occurring
in between a join point binding and a jump.
Fixes #26642 #26929 #26693
Makes progress on #14610 #26157 #26422
Changes:
- Remove 'GHC.Types.Tickish.TickishScoping' in favour of simpler
predicates 'tickishHasNoScope'/'tickishHasSoftScope', as things were
before commit 993975d3. This makes the code easier to read and
document (fewer indirections).
- Introduce 'canCollectArgsThroughTick' for consistent handling of
ticks around PrimOps and other 'Id's that cannot be eta-reduced.
See overhauled Note [Ticks and mandatory eta expansion].
- New Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt that explains
robustness of JoinId vs fragility of TailCallInfo.
- Allow casts/non-soft-scoped ticks to occur in between a join point
binder and a jump, but only in Core Prep.
See Note [Join points, casts, and ticks] and
Note [Join points, casts, and ticks... in Core Prep]
in GHC.Core.Opt.Simplify.Iteration.
Also update Core Lint to account for this.
See Note [Linting join points with casts or ticks] in GHC.Core.Lint.
- Update 'GHC.Core.Utils.mergeCaseAlts' to avoid pushing a cast in
between a join point binding and its jumps. This fixes #26642.
See the new (MC5) and (MC6) in Note [Merge Nested Cases].
- Update float out to properly handle source note ticks. They are now
properly floated out instead of being discarded.
This increases the number of ticks in certain tests with -g.
Test cases: T26642 and TrickyJoins.
Metric increase due to more source note ticks with -g:
-------------------------
Metric Increase:
libdir
size_hello_artifact
size_hello_unicode
-------------------------
- - - - -
21 changed files:
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Tickish.hs
- testsuite/tests/codeGen/should_compile/debug.stdout
- + testsuite/tests/simplCore/should_compile/T26642.hs
- + testsuite/tests/simplCore/should_compile/TrickyJoins.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Cmm/Node.hs
=====================================
@@ -819,8 +819,8 @@ data CmmTickScope
| SubScope !U.Unique CmmTickScope
-- ^ Constructs a new sub-scope to an existing scope. This allows
- -- us to translate Core-style scoping rules (see @tickishScoped@)
- -- into the Cmm world. Suppose the following code:
+ -- us to translate Core-style scoping rules (see Note [Scoping ticks and counting ticks]
+ -- in GHC.Types.Tickish) into the Cmm world. Suppose the following code:
--
-- tick<1> case ... of
-- A -> tick<2> ...
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1035,6 +1035,143 @@ tail position: A cast changes the type, but the type must be the same. But
operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for
ideas how to fix this.
+Note [Join points, casts, and ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Point (1) of Note [Invariants on join points] says that a join point
+must always be tail called. But what precisely does "tail called" mean
+in the presence of (a) casts and (b) ticks?
+
+Example (CAST)
+ let j x = rhs in
+ case y of { True -> j 1 |> co; False -> j 2 }
+
+Example (TICK)
+ let j x = rhs in
+ case y of { True -> <tick t> (j 1); False -> j 2 }
+
+Answer: in Core:
+
+ (JCT1) A tail call cannot be under a cast.
+
+ Thus, in (CAST), `j` is not a join point.
+
+ (JCT2) A tail call cannot be under a cost-centre-scoped tick.
+
+ Thus, in (TICK), `j` is a join point only if tick `t` has soft scope
+ (as per Note [Scoping ticks and counting ticks] in GHC.Tickish).
+
+The Big Reason for these choices is that the Simplifier moves the continuation
+into the RHS of a join point, as explained in Note [Join points and case-of-case]
+in GHC.Core.Opt.Simplify.Iteration:
+
+ K[ join j x = rhs in body ] --> join j x = K[rhs] in K[body]
+
+and K then evaporates when it encounters the tail call:
+
+ K[jump j v] --> jump j v
+
+These transformations:
+ * Are ill-typed if the tail is under a cast, hence (JCT1)
+ * Change cost semantics if the tick has cost-centre scope, hence (JCT2)
+
+The occurrence analyser is careful not to treat an occurrence as a tail call if
+it falls under (JCT1) or (JCT2), by using 'markAllNonTail'.
+
+However, during /code generation/ the key thing about a join point is that
+ * The binding does no allocation
+ * A tail call can be implemented by "adjust stack pointer and jump".
+
+This code-gen strategy works fine even if the "tail call" occurs under
+/arbitrary/ ticks and casts. Hence:
+
+(JCT3) In CorePrep, the occurrence analyser is called with a special flag that
+ /does/ treat `j` as tail-called in Example (CAST) and Example (TICK).
+ Core Prep then uses 'joinPointBinding_maybe', which turns always-tail-called
+ let bindings into join points, thus recovering join-point-hood.
+
+See also Note [Linting join points with casts or ticks] in GHC.Core.Lint.
+
+Examples
+========
+
+ Join point jumps under ticks (#14242, #26157, #26642, #26693)
+ ============================
+ In #26693 we had:
+
+ join { j :: Bool -> Int -> IO (); j _ = guts }
+ in case b of
+ False -> scc<foo> jump j True
+ True -> jump j False
+
+ If we try to push the application to an argument 'arg :: Int' into this
+ expression, we first get:
+
+ join { j :: Bool -> IO (); j _ = guts arg ] }
+ in case b of
+ False -> (scc<foo> jump j True) arg
+ True -> jump j False arg
+
+ We then rely on 'trimJoinCont' to remove the argument. In this case, this fails
+ for the first branch, because 'trimJoinCont' doesn't look through profiling
+ ticks. Were we to address this, it's still not clear what code we would want to
+ end up with, as we don't want to misattribute profiling costs.
+ We could plausibly transform to the following:
+
+ join { j :: Bool -> IO (); j scc_or_null _ = (setSCC# scc_or_null guts) arg ] }
+ in case b of
+ False -> jump j <foo> True
+ True -> jump j null False
+
+ where `setSCC#` is a new primop that would set the current cost centre pointer
+ (or no-op if the given pointer is null). However:
+ - this primop doesn't exist today,
+ - it requires adding an argument to the join point (hence changing its arity)
+
+ Note that soft scope ticks are floated out by the simplifier (see the
+ 'tickishHasSoftScope' guard in 'GHC.Core.Opt.Simplify.Iteration.simplTick'),
+ so don't suffer from the same problem.
+
+ Join point jumps under casts (#14610, #21716, #26422)
+ ============================
+ Consider:
+
+ newtype Age = MkAge Int -- axAge :: Age ~ Int
+ f :: Int -> ...
+
+ f (join j :: Bool -> Age
+ j x = (rhs1 :: Age)
+ in case v of
+ Just x -> ((j x) |> axAge) :: Int
+ Nothing -> rhs2)
+
+ If we try to use the case of case transformation to push 'f' inwards, we would
+ get:
+
+ join j' x = f (rhs1 :: Age)
+ in case v of
+ Just x -> (j' x |> axAge)
+ Nothing -> f rhs2
+
+ which is utterly bogus, as we are now passing an argument of type 'Age' to
+ 'f', which expects an 'Int'.
+
+ The alternative would be to implement a transformation of the form
+
+ join { j x = blah }
+ in case e of
+ False -> j True |> co1
+ True -> j False |> co2
+
+ ====>
+
+ join { j x co = blah |> co }
+ in case e of
+ False -> j True co1
+ True -> j False co2
+
+ by adding a coercion argument to the join point. We don't do this currently.
+
+
Note [Strict fields in Core]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Core, evaluating a data constructor worker evaluates its strict fields.
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -106,6 +106,7 @@ import Data.List.NonEmpty ( NonEmpty(..), groupWith, nonEmpty )
import Data.Maybe
import Data.IntMap.Strict ( IntMap )
import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )
+import GHC.Types.Unique.Map
{-
Note [Core Lint guarantee]
@@ -914,8 +915,8 @@ lintCoreExpr (Lit lit)
; return (literalType lit, zeroUE) }
lintCoreExpr (Cast expr co)
- = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr)
- -- markAllJoinsBad: see Note [Join points and casts]
+ = do { (expr_ty, ue) <- markAllJoinsUnderCast (lintCoreExpr expr)
+ -- markAllJoinsUnderCast: see Note [Linting join points with casts or ticks]
; lintCoercion co
; lintRole co Representational (coercionRole co)
@@ -929,14 +930,7 @@ lintCoreExpr (Tick tickish expr)
= do { case tickish of
Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0
_ -> return ()
- ; markAllJoinsBadIf block_joins $ lintCoreExpr expr }
- where
- block_joins = not (tickish `tickishScopesLike` SoftScope)
- -- TODO Consider whether this is the correct rule. It is consistent with
- -- the simplifier's behaviour - cost-centre-scoped ticks become part of
- -- the continuation, and thus they behave like part of an evaluation
- -- context, but soft-scoped and non-scoped ticks simply wrap the result
- -- (see Simplify.simplTick).
+ ; markAllJoinsUnderTick tickish $ lintCoreExpr expr }
lintCoreExpr (Let (NonRec tv (Type ty)) body)
| isTyVar tv
@@ -1017,22 +1011,16 @@ lintCoreExpr e@(App _ _)
; return app_pair}
where
- skipTick t = case collectFunSimple e of
- (Var v) -> etaExpansionTick v t
- _ -> tickishFloatable t
- (fun, args, _source_ticks) = collectArgsTicks skipTick e
- -- We must look through source ticks to avoid #21152, for example:
- --
- -- reallyUnsafePtrEquality
- -- = \ @a ->
- -- (src<loc> reallyUnsafePtrEquality#)
- -- @Lifted @a @Lifted @a
+ skipTick t =
+ case collectFunSimple e of
+ Var v -> canCollectArgsThroughTick v t
+ _ -> tickishFloatable t
+ (fun, args, _ticks) = collectArgsTicks skipTick e
+ -- We must look through ticks, otherwise we may fail to spot a
+ -- saturated application. We use 'canCollectArgsThroughTicks', which is
+ -- the same predicate that Core Prep uses.
--
- -- To do this, we use `collectArgsTicks tickishFloatable` to match
- -- the eta expansion behaviour, as per Note [Eta expansion and source notes]
- -- in GHC.Core.Opt.Arity.
- -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow.
- -- See Note [Ticks and mandatory eta expansion]
+ -- See Note [Ticks and mandatory eta expansion] in GHC.CoreToStg.Prep.
lintCoreExpr (Lam var expr)
= markAllJoinsBad $
@@ -1131,7 +1119,7 @@ checkDeadIdOcc id
------------------
lintJoinBndrType :: OutType -- Type of the body
-> OutId -- Possibly a join Id
- -> LintM ()
+ -> LintM ()
-- Checks that the return type of a join Id matches the body
-- E.g. join j x = rhs in body
-- The type of 'rhs' must be the same as the type of 'body'
@@ -1139,13 +1127,29 @@ lintJoinBndrType body_ty bndr
| JoinPoint arity <- idJoinPointHood bndr
, let bndr_ty = idType bndr
, (bndrs, res) <- splitPiTys bndr_ty
- = do let msg =
- hang (text "Join point returns different type than body")
- 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
- , text "Join arity:" <+> ppr arity
- , text "Body type:" <+> ppr body_ty ])
- checkL (length bndrs >= arity) msg
- ensureEqTys body_ty (mkPiTys (drop arity bndrs) res) msg
+ = do let
+ ty_msg =
+ hang (text "Join point returns different type than body")
+ 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
+ , text "Join arity:" <+> ppr arity
+ , text "Body type:" <+> ppr body_ty ])
+ arity_msg =
+ hang (text "Join point is not saturated")
+ 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
+ , text "Join arity:" <+> ppr arity
+ , text "Arguments:" <+> ppr bndrs ])
+
+ mb_join_info <- lookupJoinId bndr
+ case mb_join_info of
+ Nothing ->
+ pprPanic "lintJoinBndrType: valid join marked bad" (ppr bndr)
+ Just (_, occ_info) -> do
+ checkL (length bndrs >= arity) arity_msg
+
+ -- See Note [Linting join points with casts or ticks] for why
+ -- we skip this check if there is an intervening cast.
+ unless (occ_info == JoinOccUnderCast) $
+ ensureEqTys body_ty (mkPiTys (drop arity bndrs) res) ty_msg
| otherwise
= return ()
@@ -1156,11 +1160,11 @@ checkJoinOcc var n_args
| JoinPoint join_arity_occ <- idJoinPointHood var
= do { mb_join_arity_bndr <- lookupJoinId var
; case mb_join_arity_bndr of {
- NotJoinPoint -> do { join_set <- getValidJoins
- ; addErrL (text "join set " <+> ppr join_set $$
- invalidJoinOcc var) } ;
+ Nothing -> do { valid_joins <- getValidJoins
+ ; addErrL (text "valid joins:" <+> ppr valid_joins $$
+ invalidJoinOcc var) } ;
- JoinPoint join_arity_bndr ->
+ Just (join_arity_bndr, _join_occ) ->
do { checkL (join_arity_bndr == join_arity_occ) $
-- Arity differs at binding site and occurrence
@@ -1333,39 +1337,34 @@ checkLinearity body_ue lam_var =
return body_ue'
Nothing -> return body_ue -- A type variable
-{- Note [Join points and casts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might think that this should be OK:
- join j x = rhs
- in (case e of
- A -> alt1
- B x -> (jump j x) |> co)
+{- Note [Linting join points with casts or ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As per Note [Join points, casts, and ticks] in GHC.Core, we have to be careful
+when a cast or tick occurs in between a join point binding and a corresponding
+join point occurrence.
-You might think that, since the cast is ultimately erased, the jump to
-`j` should still be OK as a join point. But no! See #21716. Suppose
+Generally speaking:
- newtype Age = MkAge Int -- axAge :: Age ~ Int
- f :: Int -> ... -- f strict in it's first argument
+ - The simplifier cannot handle intervening casts or non-soft-scope ticks, so
+ we must check for that to avoid producing invalid Core.
+ - However, as per (JCT3), Core Prep **can** produce join points with
+ intervening casts or non-soft-scope ticks, which means we must expect them.
-and consider the expression
+Casts present an additional challenge. Consider for example:
- f (join j :: Bool -> Age
- j x = (rhs1 :: Age)
- in case v of
- Just x -> (j x |> axAge :: Int)
- Nothing -> rhs2)
+ join { j :: Bool -> Age; j x = (blah :: Age) }
+ in case e of
+ False -> j True |> (co1 :: Age ~ Int)
+ True -> other :: Int
-Then, if the Simplifier pushes the strict call into the join points
-and alternatives we'll get
+It is **not** the case that the type of 'blah' is the same as the type of
+the body of the join point binding! Indeed:
- join j' x = f (rhs1 :: Age)
- in case v of
- Just x -> j' x |> axAge
- Nothing -> f rhs2
+ - RHS of the join-point binding: blah :: Age
+ - The body of the join point has type Int.
-Utterly bogus. `f` expects an `Int` and we are giving it an `Age`.
-No no no. Casts destroy the tail-call property. Henc markAllJoinsBad
-in the (Cast expr co) case of lintCoreExpr.
+So we skip the 'exprType(join_rhs) == exprType(join_body)' check when casts
+occur in between.
Note [No alternatives lint check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2977,9 +2976,10 @@ data LintEnv
-- type variables, and coercion variables)
-- Used at an occurrence of the InVar
- , le_joins :: IdSet -- Join points in scope that are valid
- -- A subset of the InScopeSet in le_subst
- -- See Note [Join points]
+ , le_joins :: UniqMap Id JoinOcc
+ -- ^ Join points in scope that are valid
+ -- A subset of the InScopeSet in le_subst
+ -- See Note [Join points]
, le_ue_aliases :: NameEnv UsageEnv
-- See Note [Linting linearity]
@@ -2999,6 +2999,7 @@ data LintFlags
, lf_check_linearity :: Bool -- ^ See Note [Linting linearity]
, lf_check_fixed_rep :: Bool -- ^ See Note [Checking for representation polymorphism]
, lf_check_rubbish_lits :: Bool -- ^ See Note [Checking for rubbish literals]
+ , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks]
}
-- See Note [Checking StaticPtrs]
@@ -3307,6 +3308,20 @@ data LintLocInfo
| InCo Coercion -- Inside a coercion
| InAxiom (CoAxiom Branched) -- Inside a CoAxiom
+-- | Does this join point 'Id' occur inside a cast?
+--
+-- See Note [Linting join points with casts or ticks].
+data JoinOcc
+ -- | A normal occurrence of a 'JoinId'.
+ = NormalJoinOcc
+ -- | An occurrence of a 'JoinId' with an intervening cast between the
+ -- join point binder definition and the jump.
+ | JoinOccUnderCast
+ deriving stock Eq
+instance Outputable JoinOcc where
+ ppr NormalJoinOcc = text "Normal"
+ ppr JoinOccUnderCast = text "UnderCast"
+
data LintConfig = LintConfig
{ l_diagOpts :: !DiagOpts -- ^ Diagnostics opts
, l_platform :: !Platform -- ^ Target platform
@@ -3328,7 +3343,7 @@ initL cfg m
env = LE { le_flags = l_flags cfg
, le_subst = mkEmptySubst (mkInScopeSetList vars)
, le_in_vars = mkVarEnv [ (v,(v, varType v)) | v <- vars ]
- , le_joins = emptyVarSet
+ , le_joins = emptyUniqMap
, le_loc = []
, le_ue_aliases = emptyNameEnv
, le_platform = l_platform cfg
@@ -3428,11 +3443,11 @@ addInScopeId in_id out_ty thing_inside
in unLintM (thing_inside out_id) env' errs
where
- add env@(LE { le_in_vars = id_vars, le_joins = join_set
+ add env@(LE { le_in_vars = id_vars, le_joins = valid_joins
, le_ue_aliases = aliases, le_subst = subst })
= (out_id, env1)
where
- env1 = env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' }
+ env1 = env { le_in_vars = in_vars', le_joins = valid_joins', le_ue_aliases = aliases' }
in_vars' = extendVarEnv id_vars in_id (in_id, out_ty)
aliases' = delFromNameEnv aliases (idName in_id)
@@ -3446,9 +3461,9 @@ addInScopeId in_id out_ty thing_inside
out_id | isEmptyTCvSubst subst = in_id
| otherwise = setIdType in_id out_ty
- join_set'
- | isJoinId out_id = extendVarSet join_set in_id -- Overwrite with new arity
- | otherwise = delVarSet join_set in_id -- Remove any existing binding
+ valid_joins'
+ | isJoinId out_id = addToUniqMap valid_joins in_id NormalJoinOcc -- Overwrite with new arity
+ | otherwise = delFromUniqMap valid_joins in_id -- Remove any existing binding
addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a
-- This function clones to avoid shadowing of TyCoVars
@@ -3485,13 +3500,35 @@ extendTvSubstL tv ty m
markAllJoinsBad :: LintM a -> LintM a
markAllJoinsBad m
- = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs
+ = LintM $ \ env errs -> unLintM m (env { le_joins = emptyUniqMap }) errs
+
+-- | Mark all join points as occurring under a tick.
+--
+-- See Note [Linting join points with casts or ticks].
+markAllJoinsUnderTick :: CoreTickish -> LintM a -> LintM a
+markAllJoinsUnderTick tick m
+ = LintM $ \ env errs ->
+ let env' = if tickishHasSoftScope tick || lf_allow_weak_joins (le_flags env)
+ then env
+ else env { le_joins = emptyUniqMap }
+ in unLintM m env' errs
+
+-- | Mark all join points as occurring under a cast.
+--
+-- See Note [Linting join points with casts or ticks].
+markAllJoinsUnderCast :: LintM a -> LintM a
+markAllJoinsUnderCast m
+ = LintM $ \ env errs ->
+ let !env' = if lf_allow_weak_joins (le_flags env)
+ then env { le_joins = fmap (const JoinOccUnderCast) (le_joins env) }
+ else env { le_joins = emptyUniqMap }
+ in unLintM m env' errs
markAllJoinsBadIf :: Bool -> LintM a -> LintM a
markAllJoinsBadIf True m = markAllJoinsBad m
markAllJoinsBadIf False m = m
-getValidJoins :: LintM IdSet
+getValidJoins :: LintM (UniqMap Id JoinOcc)
getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))
getSubst :: LintM Subst
@@ -3552,14 +3589,14 @@ lintVarOcc v_occ
| otherwise
= return ()
-lookupJoinId :: Id -> LintM JoinPointHood
+lookupJoinId :: Id -> LintM (Maybe (JoinArity, JoinOcc))
-- Look up an Id which should be a join point, valid here
-- If so, return its arity, if not return Nothing
lookupJoinId id
- = do { join_set <- getValidJoins
- ; case lookupVarSet join_set id of
- Just id' -> return (idJoinPointHood id')
- Nothing -> return NotJoinPoint }
+ = do { valid_joins <- getValidJoins
+ ; case lookupUniqMap valid_joins id of
+ Just join_occ -> return $ Just (idJoinArity id, join_occ)
+ Nothing -> return Nothing }
addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a
addAliasUE id ue thing_inside = LintM $ \ env errs ->
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -90,7 +90,6 @@ import GHC.Utils.Misc
import Data.List.NonEmpty ( nonEmpty )
import qualified Data.List.NonEmpty as NE
-import Data.Maybe( isJust )
{-
************************************************************************
@@ -2835,21 +2834,6 @@ tryEtaReduce rec_ids bndrs body eval_sd
ok_arg _ _ _ _ = Nothing
--- | Can we eta-reduce the given function
--- See Note [Eta reduction soundness], criteria (B), (J), and (W).
-cantEtaReduceFun :: Id -> Bool
-cantEtaReduceFun fun
- = hasNoBinding fun -- (B)
- -- Don't undersaturate functions with no binding.
-
- || isJoinId fun -- (J)
- -- Don't undersaturate join points.
- -- See Note [Invariants on join points] in GHC.Core, and #20599
-
- || (isJust (idCbvMarks_maybe fun)) -- (W)
- -- Don't undersaturate StrictWorkerIds.
- -- See Note [CBV Function Ids: overview] in GHC.Types.Id.Info.
-
{- *********************************************************************
* *
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -375,7 +375,7 @@ We don't float lets inwards past an SCC.
-}
fiExpr platform to_drop (_, AnnTick tickish expr)
- | tickish `tickishScopesLike` SoftScope
+ | tickishHasSoftScope tickish
= Tick tickish (fiExpr platform to_drop expr)
| otherwise -- Wimp out for now - we could push values in
=====================================
compiler/GHC/Core/Opt/FloatOut.hs
=====================================
@@ -365,25 +365,28 @@ floatExpr lam@(Lam (TB _ lam_spec) _)
(add_to_stats fs floats, floats, mkLams bndrs body') }
floatExpr (Tick tickish expr)
- | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
+ -- If possible, float out past the tick
+ | let float_out_of_tick
+ -- See Note [Floating past breakpoints]
+ | Breakpoint{} <- tickish
+ = True
+ | otherwise
+ -- We can float code out of non-scoped ticks
+ = tickishHasNoScope tickish
+ , float_out_of_tick
= case (floatExpr expr) of { (fs, floating_defns, expr') ->
(fs, floating_defns, Tick tickish expr') }
- | not (tickishCounts tickish) || tickishCanSplit tickish
- = case (floatExpr expr) of { (fs, floating_defns, expr') ->
- let -- Annotate bindings floated outwards past an scc expression
- -- with the cc. We mark that cc as "duplicated", though.
- annotated_defns = wrapTick (mkNoCount tickish) floating_defns
+ -- We can't move code out of the tick
+ | otherwise
+ = assert (not (tickishCounts tickish) || tickishCanSplit tickish) $
+ case (floatExpr expr) of { (fs, floating_defns, expr') ->
+ -- Wrap floated code with the correct tick scope, but using 'mkNoCount'
+ -- to ensure we don't duplicate counters.
+ let annotated_defns = wrapTick (mkNoCount tickish) floating_defns
in
(fs, annotated_defns, Tick tickish expr') }
- -- See Note [Floating past breakpoints]
- | Breakpoint{} <- tickish
- = case (floatExpr expr) of { (fs, floating_defns, expr') ->
- (fs, floating_defns, Tick tickish expr') }
-
- | otherwise
- = pprPanic "floatExpr tick" (ppr tickish)
floatExpr (Cast expr co)
= case (floatExpr expr) of { (fs, floating_defns, expr') ->
@@ -661,7 +664,8 @@ partitionByLevel (Level major minor) (FB tops defns)
wrapTick :: CoreTickish -> FloatBinds -> FloatBinds
wrapTick t (FB tops defns)
- = FB (mapBag wrap_bind tops)
+ = assert (not $ tickishCounts t) $
+ FB (mapBag wrap_bind tops)
(M.map (M.map wrap_defns) defns)
where
wrap_defns = mapBag wrap_one
@@ -672,10 +676,13 @@ wrapTick t (FB tops defns)
wrap_one (FloatLet bind) = FloatLet (wrap_bind bind)
wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
- maybe_tick e | exprIsHNF e = tickHNFArgs t e
- | otherwise = mkTick t e
- -- we don't need to wrap a tick around an HNF when we float it
- -- outside a tick: that is an invariant of the tick semantics
+ maybe_tick
+ -- We don't need to wrap an SCC tick around HNFs that we floated out of
+ -- the SCC, as that is an invariant of the semantics for SCCs.
-- Conversely, inlining of HNFs inside an SCC is allowed, and
-- indeed the HNF we're floating here might well be inlined back
-- again, and we don't want to end up with duplicate ticks.
+ | tickishPlace t == PlaceCostCentre
+ = mkTickNoHNF t
+ | otherwise
+ = mkTick t
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -27,7 +27,7 @@ core expression with (hopefully) improved usage information.
module GHC.Core.Opt.OccurAnal (
occurAnalysePgm,
- occurAnalyseExpr,
+ occurAnalyseExpr, occurAnalyseExpr_Prep,
zapLambdaBndrs
) where
@@ -85,6 +85,15 @@ occurAnalyseExpr expr = expr'
where
WUD _ expr' = occAnal initOccEnv expr
+-- | A version of 'occurAnalyseExpr' suitable for CorePrep.
+--
+-- Different from 'occurAnalyseExpr' due to (JCT3)
+-- in Note [Join points, casts, and ticks] in GHC.Core.
+occurAnalyseExpr_Prep :: CoreExpr -> CoreExpr
+occurAnalyseExpr_Prep expr = expr'
+ where
+ WUD _ expr' = occAnal (initOccEnv { occ_allow_weak_joins = True }) expr
+
occurAnalysePgm :: Module -- Used only in debug output
-> (Id -> Bool) -- Active unfoldings
-> (ActivationGhc -> Bool) -- Active rules
@@ -2300,12 +2309,8 @@ occ_anal_lam_tail env (Cast expr co)
Var {} | isRhsEnv env -> markAllMany usage1
_ -> usage1
- -- usage3: you might think this was not necessary, because of
- -- the markAllNonTail in adjustTailUsage; but not so! For a
- -- join point, adjustTailUsage doesn't do this; yet if there is
- -- a cast, we must! Also: why markAllNonTail? See
- -- GHC.Core.Lint: Note Note [Join points and casts]
- usage3 = markAllNonTail usage2
+ -- usage3: see (JCT1) in Note [Join points, casts, and ticks] in GHC.Core.
+ usage3 = markAllNonTail_CastOrTick env usage2
in WUD usage3 (Cast expr' co)
@@ -2587,42 +2592,39 @@ But it is not necessary to gather CoVars from the types of other binders.
-}
occAnal env (Tick tickish body)
- = WUD usage' (Tick tickish body')
+ = WUD usage2 (Tick tickish body')
where
WUD usage body' = occAnal env body
- usage'
- | tickish `tickishScopesLike` SoftScope
- = usage -- For soft-scoped ticks (including SourceNotes) we don't want
- -- to lose join-point-hood, so we don't mess with `usage` (#24078)
+ usage1
+ -- We don't want to lose join-point-hood. We can move soft-scoped ticks
+ -- out of the way, so don't mess with `usage` (#24078).
+ | tickishHasSoftScope tickish
+ = usage
- -- For a non-soft tick scope, we can inline lambdas only, so we
- -- abandon tail calls, and do markAllInsideLam too: usage_lam
+ -- Otherwise, we can inline lambdas only, so use 'markAllInsideLam'.
+ | otherwise
+ = markAllNonTail_CastOrTick env $ markAllInsideLam usage
+ -- markAllNonTail_CastOrTick: abandon tail calls.
+ -- See (JCT2) in Note [Join points, casts, and ticks] in GHC.Core.
+ usage2
| Breakpoint _ _ ids <- tickish
= -- Never substitute for any of the Ids in a Breakpoint
- addManyOccs usage_lam (mkVarSet ids)
+ addManyOccs usage1 (mkVarSet ids)
| otherwise
- = usage_lam
-
- usage_lam = markAllNonTail (markAllInsideLam usage)
-
- -- TODO There may be ways to make ticks and join points play
- -- nicer together, but right now there are problems:
- -- let j x = ... in tick<t> (j 1)
- -- Making j a join point may cause the simplifier to drop t
- -- (if the tick is put into the continuation). So we don't
- -- count j 1 as a tail call.
- -- See #14242.
+ = usage1
occAnal env (Cast expr co)
- = let (WUD usage expr') = occAnal env expr
- usage1 = addManyOccs usage (coVarsOfCo co)
- -- usage2: see Note [Gather occurrences of coercion variables]
- usage2 = markAllNonTail usage1
- -- usage3: calls inside expr aren't tail calls any more
- in WUD usage2 (Cast expr' co)
+ = let
+ WUD usage expr' = occAnal env expr
+ -- usage1: see Note [Gather occurrences of coercion variables]
+ usage1 = addManyOccs usage (coVarsOfCo co)
+ -- usage2: see (JCT1) in Note [Join points, casts, and ticks] in GHC.Core.
+ usage2 = markAllNonTail_CastOrTick env usage1
+ in
+ WUD usage2 (Cast expr' co)
occAnal env app@(App _ _)
= occAnalApp env (collectArgsTicks tickishFloatable app)
@@ -2936,6 +2938,11 @@ data OccEnv
, occ_rule_act :: ActivationGhc -> Bool -- Which rules are active
-- See Note [Finding rule RHS free vars]
+ , occ_allow_weak_joins :: !Bool
+ -- ^ Allow a join point jump to occur inside casts or profiling ticks?
+ --
+ -- See (JCT3) in Note [Join points, casts, and ticks] in GHC.Core.Opt.
+
-- See Note [The binder-swap substitution]
-- If x :-> (y, co) is in the env,
-- then please replace x by (y |> mco)
@@ -3003,6 +3010,8 @@ initOccEnv
, occ_unf_act = \_ -> True
, occ_rule_act = \_ -> True
+ , occ_allow_weak_joins = False
+
, occ_join_points = emptyVarEnv
, occ_bs_env = emptyVarEnv
, occ_bs_rng = emptyVarSet
@@ -3026,6 +3035,15 @@ setScrutCtxt !env alts
-- non-default alternative. That in turn influences
-- pre/postInlineUnconditionally. Grep for "occ_int_cxt"!
+-- | Mark occurrences under a cast/non-soft-scope tick as non-tail-called,
+-- except if 'occ_allow_weak_joins = True'.
+--
+-- See Note [Join points, casts, and ticks] in GHC.Core.
+markAllNonTail_CastOrTick :: OccEnv -> UsageDetails -> UsageDetails
+markAllNonTail_CastOrTick env =
+ markAllNonTailIf
+ (not $ occ_allow_weak_joins env)
+
{- Note [The OccEnv for a right hand side]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
How do we create the OccEnv for a RHS (in mkRhsOccEnv)?
@@ -4075,7 +4093,10 @@ okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool
-- See Note [Invariants on join points]; invariants cited by number below.
-- Invariant 2 is always satisfiable by the simplifier by eta expansion.
okForJoinPoint lvl bndr tail_call_info
- | isJoinId bndr -- A current join point should still be one!
+ -- A current join point should still be one!
+ --
+ -- See Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt.
+ | isJoinId bndr
= warnPprTrace lost_join "Lost join point" lost_join_doc $
True
| valid_join
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -814,9 +814,9 @@ prepareRhs env top_lvl occ rhs0
= return (emptyLetFloats, Var fun)
anfise (Tick t rhs)
- -- We want to be able to float bindings past this
- -- tick. Non-scoping ticks don't care.
- | tickishScoped t == NoScope
+ -- We want to be able to float bindings past this tick.
+ -- Non-scoping ticks don't care.
+ | tickishHasNoScope t
= do { (floats, rhs') <- anfise rhs
; return (floats, Tick t rhs') }
@@ -1413,7 +1413,7 @@ simplTick env tickish expr cont
-- bottom, then rebuildCall will discard the continuation.
--------------------------
--- | tickishScoped tickish && not (tickishCounts tickish)
+-- | not (tickishHasNoScope tickish) && not (tickishCounts tickish)
-- = simplExprF env expr (TickIt tickish cont)
-- XXX: we cannot do this, because the simplifier assumes that
-- the context can be pushed into a case with a single branch. e.g.
@@ -1425,12 +1425,11 @@ simplTick env tickish expr cont
-- simplifier iterations that necessary in some cases.
--------------------------
- -- For unscoped or soft-scoped ticks, we are allowed to float in new
- -- cost, so we simply push the continuation inside the tick. This
- -- has the effect of moving the tick to the outside of a case or
- -- application context, allowing the normal case and application
- -- optimisations to fire.
- | tickish `tickishScopesLike` SoftScope
+ -- For soft-scoped ticks, we are allowed to float in new cost, so we simply
+ -- push the continuation inside the tick. This has the effect of moving the
+ -- tick to the outside of a case or application context, allowing the normal
+ -- 'case' and 'application' optimisations to fire.
+ | tickishHasSoftScope tickish
= do { (floats, expr') <- simplExprF env expr cont
; return (floats, mkTick tickish expr')
}
@@ -1459,14 +1458,14 @@ simplTick env tickish expr cont
_other -> Nothing
where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)
movable t = not (tickishCounts t) ||
- t `tickishScopesLike` NoScope ||
+ tickishHasNoScope t ||
tickishCanSplit t
tickScrut e = foldr mkTick e ticks
-- Alternatives get annotated with all ticks that scope in some way,
-- but we don't want to count entries.
tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)
ts_scope = map mkNoCount $
- filter (not . (`tickishScopesLike` NoScope)) ticks
+ filter (not . tickishHasNoScope) ticks
no_floating_past_tick =
do { let (inc,outc) = splitCont cont
@@ -2180,16 +2179,15 @@ evaluation context E):
As is evident from the example, there are two components to this behavior:
- 1. When entering the RHS of a join point, copy the context inside.
- 2. When a join point is invoked, discard the outer context.
+ (wrapJoinCont) When entering the RHS of a join point, copy the context inside.
+ (trimJoinCont) When a join point is invoked, discard the outer context.
We need to be very careful here to remain consistent---neither part is
optional!
-We need do make the continuation E duplicable (since we are duplicating it)
+We need to make the continuation E duplicable (since we are duplicating it)
with mkDupableCont.
-
Note [Join points with -fno-case-of-case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Supose case-of-case is switched off, and we are simplifying
@@ -2213,7 +2211,8 @@ case-of-case we may then end up with this totally bogus result
This would be OK in the language of the paper, but not in GHC: j is no longer
a join point. We can only do the "push continuation into the RHS of the
join point j" if we also push the continuation right down to the /jumps/ to
-j, so that it can evaporate there. If we are doing case-of-case, we'll get to
+j, so that it can evaporate there (trimJoinCont). Then, if we are doing
+case-of-case, we'll get to:
join x = case <j-rhs> of <outer-alts> in
case y of
@@ -3656,9 +3655,11 @@ addBinderUnfolding env bndr unf
= modifyInScope env (bndr `setIdUnfolding` unf)
zapBndrOccInfo :: Bool -> Id -> Id
--- Consider case e of b { (a,b) -> ... }
--- Then if we bind b to (a,b) in "...", and b is not dead,
--- then we must zap the deadness info on a,b
+-- ^ Consider:
+-- > case e of e' { (a,b) -> rhs }
+--
+-- We bind @e'@ to @(a,b)@ in @rhs@. If @e'@ is not dead,
+-- then we must zap the deadness info on @a@ and @b@.
zapBndrOccInfo keep_occ_info pat_id
| keep_occ_info = pat_id
| otherwise = zapIdOccInfo pat_id
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -437,7 +437,7 @@ simple_app env e@(Lam {}) []
simple_app env (Tick t e) as
-- Okay to do "(Tick t e) x ==> Tick t (e x)"?
- | t `tickishScopesLike` SoftScope
+ | tickishHasSoftScope t
= mkTick t $ simple_app env e as
-- (let x = e in b) a1 .. an => let x = e in (b a1 .. an)
@@ -1059,23 +1059,33 @@ and again its arity increases (#15517)
-}
--- | Returns Just (bndr,rhs) if the binding is a join point:
--- If it's a JoinId, just return it
--- If it's not yet a JoinId but is always tail-called,
--- make it into a JoinId and return it.
+-- | Returns @Just (bndr, rhs)@ if the binding is a join point, or can be made
+-- into a join poin. Returns @Nothing@ otherwise.
+--
+-- - If the input binder is a 'JoinId', just return it;
+-- - if it's not yet a 'JoinId' but is always tail-called,
+-- make it into a 'JoinId' and return that.
+--
-- In the latter case, eta-expand the RHS if necessary, to make the
--- lambdas explicit, as is required for join points
+-- lambdas explicit, as is required for join points.
+--
+-- Precondition: the 'TailCallInfo' of the 'InBndr' is conservative:
--
--- Precondition: the InBndr has been occurrence-analysed,
--- so its OccInfo is valid
+-- - if it says 'AlwaysTailCalled', it is definitely always tail called,
+-- - if it says 'NoTailCallInfo', then we're not sure.
+--
+-- See Note [JoinId vs TailCallInfo].
joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
joinPointBinding_maybe bndr rhs
| not (isId bndr)
= Nothing
+ -- Being a JoinId is robust: preserve that. See Note [JoinId vs TailCallInfo].
| isJoinId bndr
= Just (bndr, rhs)
+ -- If the 'TailCallInfo' of 'bndr' says 'AlwaysTailCalled', then we know for
+ -- sure that it can be made into a join point.
| AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
, (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
, let str_sig = idDmdSig bndr
@@ -1091,6 +1101,48 @@ joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
joinPointBindings_maybe bndrs
= mapM (uncurry joinPointBinding_maybe) bndrs
+{- Note [JoinId vs TailCallInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Occurrence information is /fundamentally fragile/; that is, it may
+ be invalidated by the Simplifier.
+ Example 1:
+ \y -> let x = y in ...x..x...
+ Here `y` is marked "occurs exactly once" but, after inlining `x`,
+ `y` now occurs many times.
+ Example 2:
+ f (let h x = ... in case y of { True -> h 1; False -> h 2 })
+ Here `h` is tail-called; but if `f` is strict we could transform to
+ let h x = ... in
+ case y of { True -> f (h 1); False -> f (h 2) }
+ Now `h` is not tail called any more.
+
+ Exception: Dead things (with no occurrences) usually stay dead.
+ There are exceptions e.g.
+ case x of y { (a,b) -> case y of (p,q) -> p }
+ Here `a` and `b` look dead, but we may well transform to
+ case x of y { (a,b) -> a }
+
+ Because occurrence info is fragile, we recompute occurrence info
+ (including tail call info) before each run of the Simplifier.
+
+ Whenever the simplifier performs a transformation that **might** invalidate
+ occurrence information, it calls 'zapFragileIdInfo'. This sets the
+ 'TailCallInfo' to 'NoTailCallInfo' (among other things).
+
+* Being a JoinId is /robust/, and is rigorously maintained by the
+ Simplifier. In Example 2 above, if `h` was marked as a JoinId,
+ that transformation would not have happened. Instead we'd have
+ transformed to
+ let h x = f (...) in
+ case y of { True -> h 1; False -> h 2 }
+
+ The Simplifier takes an Id whose occurrences are marked as
+ `AlwaysTailCalled` and turns it into robust `JoinId`. This is
+ done by `joinPointBinding_maybe`.
+
+ There is one exception: float-out, the only caller of 'zapJoinId'.
+ See Note [Zapping JoinId when floating].
+-}
{- *********************************************************************
* *
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -34,7 +34,8 @@ module GHC.Core.Utils (
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
exprIsUnaryClassFun, isUnaryClassId,
- altsAreExhaustive, etaExpansionTick,
+ altsAreExhaustive,
+ canCollectArgsThroughTick, cantEtaReduceFun,
-- * Equality
cheapEqExpr, cheapEqExpr', diffBinds,
@@ -680,7 +681,7 @@ mergeCaseAlts :: CoreExpr -> Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
| Just (joins, inner_alts) <- go deflt_rhs
, Just aux_binds <- mk_aux_binds joins
- = Just ( aux_binds ++ joins, mergeAlts outer_alts inner_alts )
+ = Just (aux_binds ++ joins, mergeAlts outer_alts inner_alts )
-- NB: mergeAlts gives priority to the left
-- case x of
-- A -> e1
@@ -727,7 +728,7 @@ mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
, Just tc <- tyConAppTyCon_maybe type_arg
, Just (dc1:dcs) <- tyConDataCons_maybe tc -- At least one data constructor
, dcs `lengthAtMost` 3 -- Arbitrary
- = return ( [], mk_alts dc1 dcs)
+ = return ([], mk_alts dc1 dcs)
where
mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc
mk_rhs dc = Var (dataConWorkId dc)
@@ -748,11 +749,16 @@ mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
| otherwise
= Nothing
- -- We don't want ticks to get in the way; just push them inwards.
- -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#)
+ -- Push ticks **inwards** (when possible).
+ -- See (MC5) in Note [Merge Nested Cases].
go (Tick t body)
- = do { (joins, alts) <- go body
- ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) }
+ = do { (joins, alts) <- go body -- (MC4): any join points inside are floated out of the tick.
+
+ -- Abort if this would put a non-soft-scope tick in between
+ -- a join point binding and its jumps. See (MC6).
+ ; guard $ null joins || tickishHasSoftScope t
+ ; return (joins, [Alt con bs (mkTick t rhs) | Alt con bs rhs <- alts])
+ }
go _ = Nothing
@@ -974,12 +980,74 @@ Wrinkles
So `mergeCaseAlts` floats out any join points. It doesn't float out
non-join-points unless the /outer/ case has just one alternative; doing
- so would risk more allocation
+ so would risk more allocation.
+
+ Note also that `mergeCaseAlts` floats join points out of ticks, for which
+ we need to be extra careful; see (MC6).
Floating out join points isn't entirely straightforward.
See Note [Floating join points out of DEFAULT alternatives]
-(MC5) See Note [Cascading case merge]
+(MC5) We want to move ticks out of the way if possible, to prevent them from
+ inhibiting optimisation. For example, say we have:
+
+ case expensive of r {
+ C1 -> rhs1; -- happy path
+ _ -> scctick<doEdgeCase> (case r of { C2 -> rhs2; C3 -> rhs3 })
+ }
+
+ In this situation, we push the "doEdgeCase" tick **inwards** and proceed
+ to merge cases, like so:
+
+ case expensive of
+ C1 -> rhs1
+ C2 -> scctick<doEdgeCase> rhs2
+ C3 -> scctick<doEdgeCase> rhs3
+
+ This preserves the tick semantics (see Note [Scoping ticks and counting ticks]
+ in GHC.Types.Tickish), because this transformation:
+
+ 1. preserves counts,
+ 2. does not move cost in or out of the tick scope.
+
+ (1) is clear: we will tick 'doEdgeCase' exactly in the C2/C3 alternatives,
+ and we won't otherwise.
+ For (2), recall that case is strict in Core. We already evaluated 'expensive',
+ so re-scrutinising 'r' is free.
+
+ This means that, perhaps surprisingly, this transformation is valid for
+ **all** ticks, including non-floatable ones.
+
+ In contrast, we would not want to move the tick outwards, because this:
+
+ - will lead to additional counting of 'doEdgeCase' in the 'C1' (happy path) case,
+ - risks attributing the cost of evaluating 'expensive' to 'doEdgeCase'.
+
+(MC6) There is a dangerous interaction between (MC4) and (MC5), which can lead
+ to invalid Core (as reported in #26642, #26929). Suppose we have:
+
+ case f x of r ->
+ scctick<foo>
+ join j y = rhs in
+ case r of { C1 -> j 1; C2 -> bar }
+
+ If we naively carried out (MC4) and (MC5) together, this would result in:
+
+ join j y = rhs in
+ case f x of
+ C1 -> scctick<foo> (j 1)
+ C2 -> scctick<foo> bar
+
+ This has moved the tick in between the join point binding 'j' and the
+ join point jump, which is invalid as per Note [Join points, casts, and ticks]
+ in GHC.Core. The simplifier cannot deal with such Core, resulting in #26642.
+
+ The solution: abort whenever we would position a non-soft-scope tick
+ inside a join point in this manner.
+ An alternative would be to float the tick outwards, but as we saw in (MC5)
+ this risks a grave misattribution of profiling costs, so we don't do that.
+
+(MC7) See Note [Cascading case merge]
See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils
@@ -2076,14 +2144,31 @@ altsAreExhaustive (Alt con1 _ _ : alts)
-- we behave conservatively here -- I don't think it's important
-- enough to deserve special treatment
--- | Should we look past this tick when eta-expanding the given function?
+-- | Should we look past this tick when collecting arguments
+-- for the given function?
--
-- See Note [Ticks and mandatory eta expansion]
--- Takes the function we are applying as argument.
-etaExpansionTick :: Id -> GenTickish pass -> Bool
-etaExpansionTick id t
- = hasNoBinding id &&
- ( tickishFloatable t || isProfTick t )
+canCollectArgsThroughTick
+ :: Id -- ^ function at the head of the application
+ -> GenTickish pass -- ^ tick we want to collect arguments past
+ -> Bool
+canCollectArgsThroughTick id t
+ = tickishFloatable t || cantEtaReduceFun id
+
+-- | Can we eta-reduce the given function?
+-- See Note [Eta reduction soundness], criteria (B), (J), and (W).
+cantEtaReduceFun :: Id -> Bool
+cantEtaReduceFun fun
+ = hasNoBinding fun -- (B)
+ -- Don't undersaturate functions with no binding.
+
+ || isJoinId fun -- (J)
+ -- Don't undersaturate join points.
+ -- See Note [Invariants on join points] in GHC.Core, and #20599
+
+ || isJust (idCbvMarks_maybe fun) -- (W)
+ -- Don't undersaturate StrictWorkerIds.
+ -- See Note [CBV Function Ids: overview] in GHC.Types.Id.Info.
{- Note [exprOkForSpeculation and type classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -39,7 +39,8 @@ import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.DataCon
-import GHC.Core.Opt.OccurAnal
+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr_Prep )
+import GHC.Core.SimpleOpt ( joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Data.Maybe
import GHC.Data.OrdList
@@ -575,7 +576,18 @@ cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
Maybe CoreBind) -- Just bind' <=> returned new bind; no float
-- Nothing <=> added bind' to floats instead
cpeBind top_lvl env (NonRec bndr rhs)
- | not (isJoinId bndr)
+ -- A join point.
+ -- NB: use 'joinPointBinding_maybe' instead of 'isJoinId' as per the plan
+ -- described in (JCT3) in Note [Join points, casts, and ticks].
+ | Just (bndr, rhs) <- joinPointBinding_maybe bndr rhs
+ = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point; see Note [Join points and floating]
+ do { (_, bndr1) <- cpCloneBndr env bndr
+ ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
+ ; return (extendCorePrepEnv env bndr bndr2,
+ emptyFloats,
+ Just (NonRec bndr2 rhs1)) }
+
+ | otherwise
= do { (env1, bndr1) <- cpCloneBndr env bndr
; let dmd = idDemandInfo bndr
lev = typeLevity (idType bndr)
@@ -594,16 +606,23 @@ cpeBind top_lvl env (NonRec bndr rhs)
; return (env2, floats1, Nothing) }
- | otherwise -- A join point; see Note [Join points and floating]
- = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point
- do { (_, bndr1) <- cpCloneBndr env bndr
- ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
- ; return (extendCorePrepEnv env bndr bndr2,
- emptyFloats,
- Just (NonRec bndr2 rhs1)) }
-
cpeBind top_lvl env (Rec pairs)
- | not (isJoinId (head bndrs))
+ -- A recursive join point.
+ -- NB: use 'joinPointBindings_maybe' instead of 'isJoinId' as per the plan
+ -- described in (JCT3) in Note [Join points, casts, and ticks].
+ | Just pairs <- joinPointBindings_maybe pairs
+ , let (bndrs, rhss) = unzip pairs
+ = do { (env, bndrs1) <- cpCloneBndrs env bndrs
+ ; let env' = enterRecGroupRHSs env bndrs1
+ ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
+
+ ; let bndrs2 = map fst pairs1
+ -- use env below, so that we reset cpe_rec_ids
+ ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
+ emptyFloats,
+ Just (Rec pairs1)) }
+ | otherwise
+ , let (bndrs, rhss) = unzip pairs
= do { (env, bndrs1) <- cpCloneBndrs env bndrs
; let env' = enterRecGroupRHSs env bndrs1
; stuff <- zipWithM (cpePair top_lvl Recursive topDmd Lifted env')
@@ -626,19 +645,9 @@ cpeBind top_lvl env (Rec pairs)
(Float (Rec all_pairs) LetBound TopLvlFloatable),
Nothing) }
- | otherwise -- See Note [Join points and floating]
- = do { (env, bndrs1) <- cpCloneBndrs env bndrs
- ; let env' = enterRecGroupRHSs env bndrs1
- ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
-
- ; let bndrs2 = map fst pairs1
- -- use env below, so that we reset cpe_rec_ids
- ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
- emptyFloats,
- Just (Rec pairs1)) }
where
- (bndrs, rhss) = unzip pairs
-
+ -- See Note [Join points and floating]
+ --
-- Flatten all the floats, and the current
-- group into a single giant Rec
add_float (Float bind bound _) prs2
@@ -653,7 +662,6 @@ cpeBind top_lvl env (Rec pairs)
Rec prs1 -> prs1 ++ prs2
add_float f _ = pprPanic "cpeBind" (ppr f)
-
---------------
cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
-> CorePrepEnv -> OutId -> CoreExpr
@@ -661,7 +669,7 @@ cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
-- Used for all bindings
-- The binder is already cloned, hence an OutId
cpePair top_lvl is_rec dmd lev env0 bndr rhs
- = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair
+ = assert (isNothing $ joinPointBinding_maybe bndr rhs) $ -- those should use cpeJoinPair
do { (floats1, rhs1) <- cpeRhsE env rhs
-- See if we are allowed to float this stuff out of the RHS
@@ -926,7 +934,7 @@ rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody)
-- Remove top level lambdas by let-binding
rhsToBody env (Tick t expr)
- | tickishScoped t == NoScope -- only float out of non-scoped annotations
+ | tickishHasNoScope t -- only float out of non-scoped annotations
= do { (floats, expr') <- rhsToBody env expr
; return (floats, mkTick t expr') }
@@ -984,43 +992,74 @@ instance Outputable ArgInfo where
{- Note [Ticks and mandatory eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Something like
- `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`
-caused a compiler panic in #20938. Why did this happen?
-The simplifier will eta-reduce the rhs giving us a partial
-application of tagToEnum#. The tick is then pushed inside the
-type argument. That is we get
- `(Tick<foo> tagToEnum#) @Bool`
+We must look through ticks when they get in the way of seeing the arguments to
+'Id's that cannot be eta-reduced.
+
+For example, we may have
+
+ myReallyUnsafePtrEquality
+ = \ @a x y ->
+ (src<loc> reallyUnsafePtrEquality#)
+ @Lifted @a @Lifted @a x y
+
+If we don't move the SourceNote out of the way, this looks like an unsaturated
+occurrence of the PrimOp "reallyUnsafePtrEquality#", which we cannot generate
+code for.
+
+Moreover, we must also move out non-floatable ticks. Case in point: #20938,
+of the form:
+
+ foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool
+
+If we don't look past the tick "foo", the simplifier will eta-reduce the RHS,
+giving us a partial application of 'tagToEnum#'. The tick is then pushed inside
+the type argument, resulting in:
+
+ (Tick<foo> tagToEnum#) @Bool
+
CorePrep would go on to see a undersaturated tagToEnum# application
-and eta expand the expression under the tick. Giving us:
+and eta-expand the expression under the tick. Giving us:
+
(Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool
-Suddenly tagToEnum# is applied to a polymorphic type and the code generator
+
+Suddenly, 'tagToEnum#' is applied to a polymorphic type and the code generator
panics as it needs a concrete type to determine the representation.
-The problem in my eyes was that the tick covers a partial application
-of a primop. There is no clear semantic for such a construct as we can't
-partially apply a primop since they do not have bindings.
-We fix this by expanding the scope of such ticks slightly to cover the body
-of the eta-expanded expression.
-
-We do this by:
-* Checking if an application is headed by a primOpish thing.
-* If so we collect floatable ticks and usually but also profiling ticks
- along with regular arguments.
-* When rebuilding the application we check if any profiling ticks appear
- before the primop is fully saturated.
-* If the primop isn't fully satured we eta expand the primop application
- and scope the tick to scope over the body of the saturated expression.
-
-Going back to #20938 this means starting with
- `(Tick<foo> tagToEnum#) @Bool`
-we check if the function head is a primop (yes). This means we collect the
-profiling tick like if it was floatable. Giving us
- (tagToEnum#, [CpeTick foo, CpeApp @Bool]).
+The problem was that the tick covered a partial application of a primop.
+There is no clear semantic for such a construct: we can't partially apply a
+primop, since primops do not have bindings.
+
+To fix this, we expand the scope of ticks slightly to cover the body
+of the eta-expanded expression, even when the tick isn't normally floatable.
+
+This is achieved by using 'GHC.Core.Utils.canCollectArgsThroughTick', which
+responds 'True' in the following two situations:
+
+ - The tick is floatable (i.e. satisfies 'tickishFloatable'), meaning that it
+ is OK to float it out slightly, moving in more code under it.
+ See also Note [Eta expansion and source notes] in GHC.Core.Opt.Arity.
+ - The tick is around an application that is headed by an 'Id' that cannot be
+ undersaturated, such as a PrimOp (see 'GHC.Core.Utils.cantEtaReduceFun').
+
+This solves #20938. Indeed, starting with
+
+ (scctick<foo> tagToEnum#) @Bool
+
+we see that the head of the application is 'tagToEnum#', which is a PrimOp and
+thus satisfies 'hasNoBinding = True'. As a result, we collect the profiling tick
+as if it was floatable, resulting in
+
+ (tagToEnum#, [CpeTick foo, CpeApp @Bool])
+
cpe_app filters out the tick as a underscoped tick on the expression
-`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the
-body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.
+`tagToEnum# @Bool`. During eta-expansion, we put that tick back onto the
+body of the eta-expansion lambda, resulting in
+
+ \x -> scctick<foo> (tagToEnum# @Bool x)
+
+which is unproblematic.
-}
+
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- May return a CpeRhs (instead of CpeApp) because of saturating primops
cpeApp top_env expr
@@ -1045,15 +1084,14 @@ cpeApp top_env expr
go (Cast fun co) as
= go fun (AICast co : as)
go (Tick tickish fun) as
- -- Profiling ticks are slightly less strict so we expand their scope
- -- if they cover partial applications of things like primOps.
- -- See Note [Ticks and mandatory eta expansion]
- -- Here we look inside `fun` before we make the final decision about
- -- floating the tick which isn't optimal for perf. But this only makes
- -- a difference if we have a non-floatable tick which is somewhat rare.
+ -- Try to move a tick out of the way, if:
+ -- - the tick can be floated out of the way ('tickishFloatable'), or
+ -- - the tick must be moved out of the way because it stands in between
+ -- an 'Id' that must be saturated and some of its arguments;
+ -- see Note [Ticks and mandatory eta expansion].
| Var vh <- head
- , Var head' <- lookupCorePrepEnv top_env vh
- , etaExpansionTick head' tickish
+ , Just head' <- getIdFromTrivialExpr_maybe (lookupCorePrepEnv top_env vh)
+ , canCollectArgsThroughTick head' tickish
= (head,as')
where
(head,as') = go fun (AITick tickish : as)
@@ -1130,7 +1168,10 @@ cpeApp top_env expr
hd = getIdFromTrivialExpr_maybe e2
-- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
min_arity = case hd of
- Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing
+ Just v_hd ->
+ if cantEtaReduceFun v_hd
+ then Just $! idArity v_hd
+ else Nothing
Nothing -> Nothing
-- ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))
; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity
@@ -2293,8 +2334,8 @@ deFloatTop floats
get b _ = pprPanic "deFloatTop" (ppr b)
-- See Note [Dead code in CorePrep]
- get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e)
- get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
+ get_bind (NonRec x e) = NonRec x (occurAnalyseExpr_Prep e)
+ get_bind (Rec xes) = Rec [(x, occurAnalyseExpr_Prep e) | (x, e) <- xes]
---------------------------------------------------------------------------
=====================================
compiler/GHC/Driver/Config/Core/Lint.hs
=====================================
@@ -115,7 +115,8 @@ perPassFlags dflags pass
, lf_check_inline_loop_breakers = check_lbs
, lf_check_static_ptrs = check_static_ptrs
, lf_check_linearity = check_linearity
- , lf_check_rubbish_lits = check_rubbish }
+ , lf_check_rubbish_lits = check_rubbish
+ , lf_allow_weak_joins = allow_weak_joins }
where
-- See Note [Checking for global Ids]
check_globals = case pass of
@@ -152,6 +153,11 @@ perPassFlags dflags pass
CorePrep -> True
_ -> False
+ -- See Note [Linting join points with casts or ticks] in GHC.Core.Lint
+ allow_weak_joins = case pass of
+ CorePrep -> True
+ _ -> False
+
initLintConfig :: DynFlags -> [Var] -> LintConfig
initLintConfig dflags vars =LintConfig
{ l_diagOpts = initDiagOpts dflags
@@ -168,4 +174,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False
, lf_report_unsat_syns = True
, lf_check_fixed_rep = True
, lf_check_rubbish_lits = True
+ , lf_allow_weak_joins = False
}
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -1272,7 +1272,7 @@ tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
is_external = isExternalName name
--------- OccInfo ------------
- robust_occ_info = zapFragileOcc (occInfo idinfo)
+ robust_occ_info = zapFragileOccInfo (occInfo idinfo)
-- It's important to keep loop-breaker information
-- when we are doing -fexpose-all-unfoldings
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -1273,5 +1273,5 @@ cgTick tick
ProfNote cc t p -> emitSetCCC cc t p
HpcTick m n -> emit (mkTickBox platform m n)
SourceNote s n -> emitTick $ SourceNote s n
- _other -> return () -- ignore
+ Breakpoint {} -> return () -- ignore
}
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -66,7 +66,7 @@ module GHC.Types.Basic (
noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
bestOneShot, worstOneShot,
- OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,
+ OccInfo(..), noOccInfo, seqOccInfo, zapFragileOccInfo, isOneOcc,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
isNoOccInfo, strongLoopBreaker, weakLoopBreaker,
@@ -980,10 +980,13 @@ isOneOcc :: OccInfo -> Bool
isOneOcc (OneOcc {}) = True
isOneOcc _ = False
-zapFragileOcc :: OccInfo -> OccInfo
--- Keep only the most robust data: deadness, loop-breaker-hood
-zapFragileOcc (OneOcc {}) = noOccInfo
-zapFragileOcc occ = zapOccTailCallInfo occ
+-- | Keep only the most robust occurrence info: deadness, loop-breaker-hood.
+--
+-- In particular, it zaps 'TailCallInfo': see Note [JoinId vs TailCallInfo]
+-- in 'GHC.Core.Opt.Simplify.Env'.
+zapFragileOccInfo :: OccInfo -> OccInfo
+zapFragileOccInfo (OneOcc {}) = noOccInfo
+zapFragileOccInfo occ = zapOccTailCallInfo occ
instance Outputable OccInfo where
-- only used for debugging; never parsed. KSW 1999-07
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -914,14 +914,15 @@ zapUsedOnceInfo info
, demandInfo = zapUsedOnceDemand (demandInfo info) }
zapFragileInfo :: IdInfo -> Maybe IdInfo
--- ^ Zap info that depends on free variables
+-- ^ Zap fragile 'IdInfo', such as info that depends on free variables
+-- or fragile occurrence info (see 'zapFragileOccInfo').
zapFragileInfo info@(IdInfo { occInfo = occ, realUnfoldingInfo = unf })
= new_unf `seq` -- The unfolding field is not (currently) strict, so we
-- force it here to avoid a (zapFragileUnfolding unf) thunk
-- which might leak space
Just (info `setRuleInfo` emptyRuleInfo
`setUnfoldingInfo` new_unf
- `setOccInfo` zapFragileOcc occ)
+ `setOccInfo` zapFragileOccInfo occ)
where
new_unf = zapFragileUnfolding unf
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -6,9 +6,8 @@ module GHC.Types.Tickish (
CoreTickish, StgTickish, CmmTickish,
XTickishId,
tickishCounts,
- TickishScoping(..),
- tickishScoped,
- tickishScopesLike,
+ tickishHasNoScope,
+ tickishHasSoftScope,
tickishFloatable,
tickishCanSplit,
mkNoCount,
@@ -206,103 +205,177 @@ instance Binary BreakpointId where
--------------------------------------------------------------------------------
--- | A "counting tick" (where tickishCounts is True) is one that
+-- | A "counting tick" (for which 'tickishCounts' is True) is one that
-- counts evaluations in some way. We cannot discard a counting tick,
--- and the compiler should preserve the number of counting ticks as
--- far as possible.
+-- and the compiler should preserve the number of counting ticks (as
+-- far as possible).
--
--- However, we still allow the simplifier to increase or decrease
--- sharing, so in practice the actual number of ticks may vary, except
--- that we never change the value from zero to non-zero or vice versa.
+-- See Note [Counting ticks]
tickishCounts :: GenTickish pass -> Bool
-tickishCounts n@ProfNote{} = profNoteCount n
-tickishCounts HpcTick{} = True
-tickishCounts Breakpoint{} = True
-tickishCounts _ = False
-
-
--- | Specifies the scoping behaviour of ticks. This governs the
--- behaviour of ticks that care about the covered code and the cost
--- associated with it. Important for ticks relating to profiling.
-data TickishScoping =
- -- | No scoping: The tick does not care about what code it
- -- covers. Transformations can freely move code inside as well as
- -- outside without any additional annotation obligations
- NoScope
-
- -- | Soft scoping: We want all code that is covered to stay
- -- covered. Note that this scope type does not forbid
- -- transformations from happening, as long as all results of
- -- the transformations are still covered by this tick or a copy of
- -- it. For example
- --
- -- let x = tick<...> (let y = foo in bar) in baz
- -- ===>
- -- let x = tick<...> bar; y = tick<...> foo in baz
- --
- -- Is a valid transformation as far as "bar" and "foo" is
- -- concerned, because both still are scoped over by the tick.
- --
- -- Note though that one might object to the "let" not being
- -- covered by the tick any more. However, we are generally lax
- -- with this - constant costs don't matter too much, and given
- -- that the "let" was effectively merged we can view it as having
- -- lost its identity anyway.
- --
- -- Also note that this scoping behaviour allows floating a tick
- -- "upwards" in pretty much any situation. For example:
- --
- -- case foo of x -> tick<...> bar
- -- ==>
- -- tick<...> case foo of x -> bar
- --
- -- While this is always legal, we want to make a best effort to
- -- only make us of this where it exposes transformation
- -- opportunities.
- | SoftScope
-
- -- | Cost centre scoping: We don't want any costs to move to other
- -- cost-centre stacks. This means we not only want no code or cost
- -- to get moved out of their cost centres, but we also object to
- -- code getting associated with new cost-centre ticks - or
- -- changing the order in which they get applied.
- --
- -- A rule of thumb is that we don't want any code to gain new
- -- annotations. However, there are notable exceptions, for
- -- example:
- --
- -- let f = \y -> foo in tick<...> ... (f x) ...
- -- ==>
- -- tick<...> ... foo[x/y] ...
- --
- -- In-lining lambdas like this is always legal, because inlining a
- -- function does not change the cost-centre stack when the
- -- function is called.
- | CostCentreScope
-
- deriving (Eq)
-
--- | Returns the intended scoping rule for a Tickish
-tickishScoped :: GenTickish pass -> TickishScoping
-tickishScoped n@ProfNote{}
- | profNoteScope n = CostCentreScope
- | otherwise = NoScope
-tickishScoped HpcTick{} = NoScope
-tickishScoped Breakpoint{} = CostCentreScope
- -- Breakpoints are scoped: eventually we're going to do call
- -- stacks, but also this helps prevent the simplifier from moving
- -- breakpoints around and changing their result type (see #1531).
-tickishScoped SourceNote{} = SoftScope
-
--- | Returns whether the tick scoping rule is at least as permissive
--- as the given scoping rule.
-tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool
-tickishScopesLike t scope = tickishScoped t `like` scope
- where NoScope `like` _ = True
- _ `like` NoScope = False
- SoftScope `like` _ = True
- _ `like` SoftScope = False
- CostCentreScope `like` _ = True
+tickishCounts = \case
+ ProfNote { profNoteCount = counts } -> counts
+ HpcTick {} -> True
+ Breakpoint {} -> True
+ SourceNote {} -> False
+
+-- | Is this a non-scoping tick, for which we don't care about precisely
+-- the extent of code that the tick encompasses?
+--
+-- See Note [Scoped ticks]
+tickishHasNoScope :: GenTickish pass -> Bool
+tickishHasNoScope = \case
+ ProfNote { profNoteScope = scopes } -> not scopes
+ HpcTick {} -> True
+ Breakpoint {} -> False
+ SourceNote {} -> False
+
+-- | A "tick with soft scoping" (for which 'tickishHasSoftScope' is True) is
+-- one that either does not scope at all (for which 'tickishHasNoScope' is True),
+-- or that has a "soft" scope: we allow new code to be floated into to the scope,
+-- as long as all code that was covered remains covered.
+--
+-- See Note [Scoped ticks]
+tickishHasSoftScope :: GenTickish pass -> Bool
+tickishHasSoftScope = \case
+ ProfNote { profNoteScope = scopes } -> not scopes
+ HpcTick {} -> True
+ Breakpoint {} -> False
+ SourceNote {} -> True
+
+{- Note [Scoping ticks and counting ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticks have two independent attributes:
+
+ * Whether the tick /counts/.
+ Counting ticks are used when we want a counter to be bumped, e.g. counting
+ how many times a function is called.
+
+ See Note [Counting ticks]
+
+ * What kind of /scope/ the tick has:
+ * Cost-centre scope: you cannot move a redex into the scope of the tick,
+ nor can you float a redex out.
+ * Soft scope: you can move a redex /into/ the scope of a tick,
+ but you cannot float a redex /out/
+ * No scope: there are no restrictions on floating in or out.
+
+ See Note [Scoped ticks]
+
+Note [Counting ticks]
+~~~~~~~~~~~~~~~~~~~~
+The following ticks count:
+ - ProfNote ticks with profNoteCounts = True
+ - HPC ticks
+ - Breakpoints
+
+Going past a counting tick implies bumping a counter.
+Generally, the simplifier attempts to preserve counts when transforming
+programs and moving ticks, for example by transforming:
+
+ case <tick> e of
+ alt1 -> rhs1
+ alt2 -> rhs2
+
+to
+
+ case e of
+ alt1 -> <tick> rhs1
+ alt2 -> <tick> rhs2
+
+which preserves the total count (as exactly one branch of the case
+will be taken).
+
+However, we still allow the simplifier to increase or decrease
+sharing, so in practice the actual number of ticks may vary, except
+that we never change the value from zero to non-zero or vice-versa.
+
+Note [Scoped ticks]
+~~~~~~~~~~~~~~~~~~~~
+The following ticks are scoped:
+ - ProfNote ticks with profNoteScope = True
+ - Breakpoints
+ - Source notes
+
+A scoped tick is one that scopes over a portion of code. For example,
+an SCC anotation sets the cost centre for the code within; any allocations
+within that piece of code should get attributed to that cost centre.
+
+When the simplifier deals with a scoping tick, it ensures that all code that
+was covered remains covered. For example
+
+ let x = tick<...> (let y = foo in bar) in baz
+ ===>
+ let x = tick<...> bar; y = tick<...> foo in baz
+
+is a valid transformation as far as "bar" and "foo" are concerned, because
+both still are scoped over by the tick. One might object to the "let" not
+being covered by the tick any more. However, we are generally lax with this;
+constant costs don't matter too much, and given that the "let" was effectively
+merged we can view it as having lost its identity anyway.
+
+Perhaps surprisingly, breakpoints are considered to be scoped, because we
+don't want the simplifier to move them around, changing their result type (see #1531).
+
+We specifically forbid floating code outside of a scoping tick, as cost
+associated with the floated-out code would no longer be attributed to the
+appropriate scope.
+
+Whether we are allowed to float in additional cost depends on the tick:
+
+ Cost-centre scope ticks
+ - ProfNote with profNoteScope = True
+ - Breakpoints
+
+ A tick with cost-centre scope is one for which we can neither move
+ redexes into or move redexes outside of the tick. For example, we don't
+ want profiling costs to move to other cost-centre stacks.
+ Morever, we also object to changing the order in which such ticks
+ are applied.
+
+ A rule of thumb is that we don't want any code to gain new
+ lexically-enclosing ticks. For example, we should not transform:
+
+ f (scctick<foo> a) ==> scctick<foo> (f a)
+
+ as this would attribute the cost of evaluating the application 'f a'
+ to the cost centre 'foo'.
+
+ However, there are notable exceptions, for example:
+
+ let f = \y -> foo in tick<...> ... (f x) ...
+ ==>
+ tick<...> ... foo[x/y] ...
+
+ Inlining lambdas like this is always legal, because inlining a function
+ does not change the cost-centre stack when the function is called.
+
+ Soft scope ticks
+ - Source notes
+
+ A tick with soft scope is one for which we can move redexes inside the
+ tick, but cannot float redexes outside the tick. This is a slightly more
+ lenient notion of scoping than cost-centres, and is used only for source
+ note ticks (they are used to provide DWARF debug symbols, and for those
+ it matters less if code from outside gets moved under the tick).
+
+ Examples:
+
+ - FloatIn (GHC.Core.Opt.FloatIn.fiExpr)
+
+ let x = rhs in <tick> body
+ ==>
+ <tick> (let x = rhs in body)
+
+ - Moving a tick outside of a case or of an application
+ (GHC.Core.Opt.Simplify.Iteration.simplTick)
+
+ case <tick> e of alts ==> <tick> case e of alts
+
+ (<tick> e1) e2 ==> <tick> (e1 e2)
+
+ While these transformations are legal, we want to make a best effort to
+ only make use of them where it exposes transformation opportunities.
+-}
-- | Returns @True@ for ticks that can be floated upwards easily even
-- where it might change execution counts, such as:
@@ -311,12 +384,11 @@ tickishScopesLike t scope = tickishScoped t `like` scope
-- ==>
-- tick<...> (Just foo)
--
--- This is a combination of @tickishSoftScope@ and
--- @tickishCounts@. Note that in principle splittable ticks can become
--- floatable using @mkNoTick@ -- even though there's currently no
--- tickish for which that is the case.
+-- This is a combination of @tickishHasSoftScope@ and @tickishCounts@.
+-- Note that in principle splittable ticks can become floatable using @mkNoTick@,
+-- even though there's currently no tickish for which that is the case.
tickishFloatable :: GenTickish pass -> Bool
-tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)
+tickishFloatable t = tickishHasSoftScope t && not (tickishCounts t)
-- | Returns @True@ for a tick that is both counting /and/ scoping and
-- can be split into its (tick, scope) parts using 'mkNoScope' and
@@ -334,7 +406,7 @@ mkNoCount n@ProfNote{} = let n' = n {profNoteCount = False}
mkNoCount _ = panic "mkNoCount: Undefined split!"
mkNoScope :: GenTickish pass -> GenTickish pass
-mkNoScope n | tickishScoped n == NoScope = n
+mkNoScope n | tickishHasNoScope n = n
| not (tickishCanSplit n) = panic "mkNoScope: Cannot split!"
mkNoScope n@ProfNote{} = let n' = n {profNoteScope = False}
in assert (profNoteCount n) n'
@@ -357,7 +429,9 @@ mkNoScope _ = panic "mkNoScope: Undefined split!"
-- translate the code as if it found the latter.
tickishIsCode :: GenTickish pass -> Bool
tickishIsCode SourceNote{} = False
-tickishIsCode _tickish = True -- all the rest for now
+tickishIsCode ProfNote{} = True
+tickishIsCode Breakpoint{} = True
+tickishIsCode HpcTick{} = True
isProfTick :: GenTickish pass -> Bool
isProfTick ProfNote{} = True
=====================================
testsuite/tests/codeGen/should_compile/debug.stdout
=====================================
@@ -18,7 +18,6 @@ src<debug.hs:4:9>
src<debug.hs:5:21-29>
src<debug.hs:5:9-29>
src<debug.hs:6:1-21>
-src<debug.hs:6:16-21>
== CBE ==
src<debug.hs:4:9>
89
=====================================
testsuite/tests/simplCore/should_compile/T26642.hs
=====================================
@@ -0,0 +1,46 @@
+module T26642 ( saveClobberedTemps ) where
+
+import Prelude ( IO, Bool(..), Int, (>>=), (==), return )
+import Data.Word ( Word64 )
+
+-------------------------------------------------------------------------------
+
+data Word64Map a
+ = Bin (Word64Map a) (Word64Map a)
+ | Tip a
+ | Nil
+
+{-# NOINLINE myFoldr #-}
+myFoldr :: (a -> b -> b) -> b -> Word64Map a -> b
+myFoldr f = go
+ where
+ {-# NOINLINE go #-}
+ go z' Nil = z'
+ go z' (Tip x) = f x z'
+ go z' (Bin l r) = go (go z' r) l
+
+{-# NOINLINE nonDetFold #-}
+nonDetFold :: (b -> elt -> IO b) -> b -> Word64Map elt -> IO b
+nonDetFold f z0 xs = myFoldr c return xs z0
+ where
+ {-# NOINLINE c #-}
+ c x k z = f z x >>= k
+
+{-# NOINLINE myFalse #-}
+myFalse :: Bool
+myFalse = False
+
+type RealReg = Int
+data Loc = InReg RealReg | InMem
+
+saveClobberedTemps :: forall instr. [RealReg] -> IO [instr]
+saveClobberedTemps clobbered = nonDetFold maybe_spill [] Nil
+ where
+ {-# NOINLINE maybe_spill #-}
+ maybe_spill :: [instr] -> Loc -> IO [instr]
+ maybe_spill instrs !loc =
+ case loc of
+ InReg reg
+ | myFalse
+ -> return []
+ _ -> return instrs
=====================================
testsuite/tests/simplCore/should_compile/TrickyJoins.hs
=====================================
@@ -0,0 +1,154 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module TrickyJoinPoints where
+
+import Data.Coerce
+ ( coerce )
+import Data.Kind
+ ( Type )
+
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+-----------------------------------
+-- Join points and profiling ticks
+
+data ModGuts2 = MkModGuts2
+
+runCorePasses3 :: Bool -> ModGuts2 -> IO ModGuts2
+runCorePasses3 pass guts = doCorePass3 pass guts
+
+doCorePass3 :: Bool -> ModGuts2 -> IO ModGuts2
+doCorePass3 pass guts = do
+ _ <- putStrLn "hi"
+
+ let
+ updateBinds _ = return guts
+
+ case pass of
+ True -> {-# SCC "XXX3" #-} updateBinds False
+ _ -> {-# SCC "YYY3" #-} updateBinds True
+
+--------------------------
+-- Join points & casts
+
+newtype AdjacencyMap a = AM {
+ adjacencyMap :: Map a (Set.Set a) }
+
+overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a
+overlays = AM . Map.unionsWith Set.union . map adjacencyMap
+
+
+type SBool :: Bool -> Type
+data SBool b where
+ SFalse :: SBool False
+ STrue :: SBool True
+
+type N :: Bool -> Type
+data family N b
+newtype instance N False = NF ( Int -> Int )
+newtype instance N True = NT ( Int -> Int )
+
+testCast :: forall b. SBool b -> Int -> Int
+testCast b n =
+ case
+ ( let
+ {-# NOINLINE juliet #-}
+ juliet :: Int -> Int -> Int
+ juliet x = \ y -> x + y + n
+ in
+ case b of
+ SFalse -> NF (juliet 1)
+ STrue -> NT (juliet 2)
+ ) :: N b of
+ n | SFalse <- b
+ , NF f <- n
+ -> f 100
+ | STrue <- b
+ , NT g <- n
+ -> g 200
+
+
+------------------------------------------
+-- Join points, profiling ticks and casts
+
+newtype M = M ( Int -> Int -> Int )
+
+testCastTick :: forall b. SBool b -> Int -> Int
+testCastTick b n =
+ case
+ ( let
+ {-# NOINLINE j #-}
+ j :: Int -> Int -> Int
+ j x = \ y -> x + y + n
+ {-# NOINLINE k #-}
+ k :: M
+ k = coerce j
+ in
+ case b of
+ SFalse -> {-# SCC "ticked" #-} NF ( coerce @M @( Int -> Int -> Int ) k 1 )
+ STrue -> NT ( coerce @M @( Int -> Int -> Int ) k 2 )
+ ) :: N b of
+ n | SFalse <- b
+ , NF f <- n
+ -> f 100
+ | STrue <- b
+ , NT g <- n
+ -> g 200
+
+------------------------------------------
+
+{-# NOINLINE testJoinTransitivity #-}
+testJoinTransitivity :: Bool -> Int -> Int
+testJoinTransitivity b n =
+ let
+ f x = x ^ ( 99 :: Int ) + 7 * ( x - 19 )
+ {-# NOINLINE f #-}
+ in
+ f (
+ let
+ j1 :: Int -> Int
+ j1 x = x + n
+ {-# NOINLINE j1 #-}
+
+ j2 :: Int -> Int
+ j2 y = j1 (y * 2)
+ {-# NOINLINE j2 #-}
+
+ j3 :: Int -> Int
+ j3 z = j2 (z * 3)
+ {-# NOINLINE j3 #-}
+
+ in case b of
+ True -> {-# SCC "ticked" #-} j3 10
+ False -> j3 20
+ )
+
+--------------------------------------------------------------------------------
+-- Test relating to Note [JoinId vs TailCallInfo]
+
+expt :: Int -> Int
+expt _ = 3
+{-# NOINLINE expt #-}
+
+repro :: (Int, Int) -> (Int, Int)
+repro (f0,e0) =
+ let
+ (f,e) =
+ let n = e0
+ in
+ case n > 0 of
+ True -> (f0, e0 + n)
+ False -> (f0, e0)
+ r = let be = expt e in f * be
+ in
+ (r, 7)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -470,6 +470,9 @@ test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings
# go should become a join point
test('T22428', [grep_errmsg(r'jump go') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds -dsuppress-unfoldings'])
+test('TrickyJoins', normal, compile, [''])
+test('T26642', [unless(have_profiling(), skip)], compile, ['-O -prof -fprof-auto-calls'])
+
test('T22459', normal, compile, [''])
test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
test('T22662', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/08bc245be70d95801bc1138804ed1de…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/08bc245be70d95801bc1138804ed1de…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
01 Mar '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ea4c2cbd by Brandon Chinn at 2026-02-27T16:22:38-08:00
Implement QualifiedStrings (#26503)
See Note [Implementation of QualifiedStrings]
- - - - -
67 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/String.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- + compiler/GHC/Rename/Lit.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.16.1-notes.rst
- + docs/users_guide/exts/qualified_strings.rst
- libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
- testsuite/tests/driver/T4437.hs
- testsuite/tests/ghc-api/annotations-literals/literals.stdout
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- + testsuite/tests/qualified-strings/Makefile
- + testsuite/tests/qualified-strings/should_compile/Example/Length.hs
- + testsuite/tests/qualified-strings/should_compile/all.T
- + testsuite/tests/qualified-strings/should_compile/qstrings_redundant_pattern.hs
- + testsuite/tests/qualified-strings/should_compile/qstrings_redundant_pattern.stderr
- + testsuite/tests/qualified-strings/should_fail/Example/Length.hs
- + testsuite/tests/qualified-strings/should_fail/Makefile
- + testsuite/tests/qualified-strings/should_fail/all.T
- + testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.hs
- + testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.stderr
- + testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.hs
- + testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.stderr
- + testsuite/tests/qualified-strings/should_fail/qstrings_multiline_no_ext.hs
- + testsuite/tests/qualified-strings/should_fail/qstrings_multiline_no_ext.stderr
- + testsuite/tests/qualified-strings/should_run/Example/ByteStringAscii.hs
- + testsuite/tests/qualified-strings/should_run/Example/ByteStringUtf8.hs
- + testsuite/tests/qualified-strings/should_run/Example/Text.hs
- + testsuite/tests/qualified-strings/should_run/Makefile
- + testsuite/tests/qualified-strings/should_run/all.T
- + testsuite/tests/qualified-strings/should_run/qstrings_expr.hs
- + testsuite/tests/qualified-strings/should_run/qstrings_expr.stdout
- + testsuite/tests/qualified-strings/should_run/qstrings_pat.hs
- + testsuite/tests/qualified-strings/should_run/qstrings_pat.stdout
- + testsuite/tests/qualified-strings/should_run/qstrings_th.hs
- + testsuite/tests/qualified-strings/should_run/qstrings_th.stdout
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea4c2cbde13ad7b8944ac9d16146ead…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea4c2cbde13ad7b8944ac9d16146ead…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] Clean up join points, casts & ticks
by Marge Bot (＠marge-bot) 01 Mar '26
by Marge Bot (＠marge-bot) 01 Mar '26
01 Mar '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
77b48b37 by sheaf at 2026-03-01T06:30:28-05:00
Clean up join points, casts & ticks
This commit shores up the logic dealing with casts and ticks occurring
in between a join point binding and a jump.
Fixes #26642 #26929 #26693
Makes progress on #14610 #26157 #26422
Changes:
- Remove 'GHC.Types.Tickish.TickishScoping' in favour of simpler
predicates 'tickishHasNoScope'/'tickishHasSoftScope', as things were
before commit 993975d3. This makes the code easier to read and
document (fewer indirections).
- Introduce 'canCollectArgsThroughTick' for consistent handling of
ticks around PrimOps and other 'Id's that cannot be eta-reduced.
See overhauled Note [Ticks and mandatory eta expansion].
- New Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt that explains
robustness of JoinId vs fragility of TailCallInfo.
- Allow casts/non-soft-scoped ticks to occur in between a join point
binder and a jump, but only in Core Prep.
See Note [Join points, casts, and ticks] and
Note [Join points, casts, and ticks... in Core Prep]
in GHC.Core.Opt.Simplify.Iteration.
Also update Core Lint to account for this.
See Note [Linting join points with casts or ticks] in GHC.Core.Lint.
- Update 'GHC.Core.Utils.mergeCaseAlts' to avoid pushing a cast in
between a join point binding and its jumps. This fixes #26642.
See the new (MC5) and (MC6) in Note [Merge Nested Cases].
- Update float out to properly handle source note ticks. They are now
properly floated out instead of being discarded.
This increases the number of ticks in certain tests with -g.
Test cases: T26642 and TrickyJoins.
Metric increase due to more source note ticks with -g:
-------------------------
Metric Increase:
libdir
size_hello_artifact
size_hello_unicode
-------------------------
- - - - -
21 changed files:
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Tickish.hs
- testsuite/tests/codeGen/should_compile/debug.stdout
- + testsuite/tests/simplCore/should_compile/T26642.hs
- + testsuite/tests/simplCore/should_compile/TrickyJoins.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Cmm/Node.hs
=====================================
@@ -819,8 +819,8 @@ data CmmTickScope
| SubScope !U.Unique CmmTickScope
-- ^ Constructs a new sub-scope to an existing scope. This allows
- -- us to translate Core-style scoping rules (see @tickishScoped@)
- -- into the Cmm world. Suppose the following code:
+ -- us to translate Core-style scoping rules (see Note [Scoping ticks and counting ticks]
+ -- in GHC.Types.Tickish) into the Cmm world. Suppose the following code:
--
-- tick<1> case ... of
-- A -> tick<2> ...
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1035,6 +1035,143 @@ tail position: A cast changes the type, but the type must be the same. But
operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for
ideas how to fix this.
+Note [Join points, casts, and ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Point (1) of Note [Invariants on join points] says that a join point
+must always be tail called. But what precisely does "tail called" mean
+in the presence of (a) casts and (b) ticks?
+
+Example (CAST)
+ let j x = rhs in
+ case y of { True -> j 1 |> co; False -> j 2 }
+
+Example (TICK)
+ let j x = rhs in
+ case y of { True -> <tick t> (j 1); False -> j 2 }
+
+Answer: in Core:
+
+ (JCT1) A tail call cannot be under a cast.
+
+ Thus, in (CAST), `j` is not a join point.
+
+ (JCT2) A tail call cannot be under a cost-centre-scoped tick.
+
+ Thus, in (TICK), `j` is a join point only if tick `t` has soft scope
+ (as per Note [Scoping ticks and counting ticks] in GHC.Tickish).
+
+The Big Reason for these choices is that the Simplifier moves the continuation
+into the RHS of a join point, as explained in Note [Join points and case-of-case]
+in GHC.Core.Opt.Simplify.Iteration:
+
+ K[ join j x = rhs in body ] --> join j x = K[rhs] in K[body]
+
+and K then evaporates when it encounters the tail call:
+
+ K[jump j v] --> jump j v
+
+These transformations:
+ * Are ill-typed if the tail is under a cast, hence (JCT1)
+ * Change cost semantics if the tick has cost-centre scope, hence (JCT2)
+
+The occurrence analyser is careful not to treat an occurrence as a tail call if
+it falls under (JCT1) or (JCT2), by using 'markAllNonTail'.
+
+However, during /code generation/ the key thing about a join point is that
+ * The binding does no allocation
+ * A tail call can be implemented by "adjust stack pointer and jump".
+
+This code-gen strategy works fine even if the "tail call" occurs under
+/arbitrary/ ticks and casts. Hence:
+
+(JCT3) In CorePrep, the occurrence analyser is called with a special flag that
+ /does/ treat `j` as tail-called in Example (CAST) and Example (TICK).
+ Core Prep then uses 'joinPointBinding_maybe', which turns always-tail-called
+ let bindings into join points, thus recovering join-point-hood.
+
+See also Note [Linting join points with casts or ticks] in GHC.Core.Lint.
+
+Examples
+========
+
+ Join point jumps under ticks (#14242, #26157, #26642, #26693)
+ ============================
+ In #26693 we had:
+
+ join { j :: Bool -> Int -> IO (); j _ = guts }
+ in case b of
+ False -> scc<foo> jump j True
+ True -> jump j False
+
+ If we try to push the application to an argument 'arg :: Int' into this
+ expression, we first get:
+
+ join { j :: Bool -> IO (); j _ = guts arg ] }
+ in case b of
+ False -> (scc<foo> jump j True) arg
+ True -> jump j False arg
+
+ We then rely on 'trimJoinCont' to remove the argument. In this case, this fails
+ for the first branch, because 'trimJoinCont' doesn't look through profiling
+ ticks. Were we to address this, it's still not clear what code we would want to
+ end up with, as we don't want to misattribute profiling costs.
+ We could plausibly transform to the following:
+
+ join { j :: Bool -> IO (); j scc_or_null _ = (setSCC# scc_or_null guts) arg ] }
+ in case b of
+ False -> jump j <foo> True
+ True -> jump j null False
+
+ where `setSCC#` is a new primop that would set the current cost centre pointer
+ (or no-op if the given pointer is null). However:
+ - this primop doesn't exist today,
+ - it requires adding an argument to the join point (hence changing its arity)
+
+ Note that soft scope ticks are floated out by the simplifier (see the
+ 'tickishHasSoftScope' guard in 'GHC.Core.Opt.Simplify.Iteration.simplTick'),
+ so don't suffer from the same problem.
+
+ Join point jumps under casts (#14610, #21716, #26422)
+ ============================
+ Consider:
+
+ newtype Age = MkAge Int -- axAge :: Age ~ Int
+ f :: Int -> ...
+
+ f (join j :: Bool -> Age
+ j x = (rhs1 :: Age)
+ in case v of
+ Just x -> ((j x) |> axAge) :: Int
+ Nothing -> rhs2)
+
+ If we try to use the case of case transformation to push 'f' inwards, we would
+ get:
+
+ join j' x = f (rhs1 :: Age)
+ in case v of
+ Just x -> (j' x |> axAge)
+ Nothing -> f rhs2
+
+ which is utterly bogus, as we are now passing an argument of type 'Age' to
+ 'f', which expects an 'Int'.
+
+ The alternative would be to implement a transformation of the form
+
+ join { j x = blah }
+ in case e of
+ False -> j True |> co1
+ True -> j False |> co2
+
+ ====>
+
+ join { j x co = blah |> co }
+ in case e of
+ False -> j True co1
+ True -> j False co2
+
+ by adding a coercion argument to the join point. We don't do this currently.
+
+
Note [Strict fields in Core]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Core, evaluating a data constructor worker evaluates its strict fields.
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -106,6 +106,7 @@ import Data.List.NonEmpty ( NonEmpty(..), groupWith, nonEmpty )
import Data.Maybe
import Data.IntMap.Strict ( IntMap )
import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )
+import GHC.Types.Unique.Map
{-
Note [Core Lint guarantee]
@@ -914,8 +915,8 @@ lintCoreExpr (Lit lit)
; return (literalType lit, zeroUE) }
lintCoreExpr (Cast expr co)
- = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr)
- -- markAllJoinsBad: see Note [Join points and casts]
+ = do { (expr_ty, ue) <- markAllJoinsUnderCast (lintCoreExpr expr)
+ -- markAllJoinsUnderCast: see Note [Linting join points with casts or ticks]
; lintCoercion co
; lintRole co Representational (coercionRole co)
@@ -929,14 +930,7 @@ lintCoreExpr (Tick tickish expr)
= do { case tickish of
Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0
_ -> return ()
- ; markAllJoinsBadIf block_joins $ lintCoreExpr expr }
- where
- block_joins = not (tickish `tickishScopesLike` SoftScope)
- -- TODO Consider whether this is the correct rule. It is consistent with
- -- the simplifier's behaviour - cost-centre-scoped ticks become part of
- -- the continuation, and thus they behave like part of an evaluation
- -- context, but soft-scoped and non-scoped ticks simply wrap the result
- -- (see Simplify.simplTick).
+ ; markAllJoinsUnderTick tickish $ lintCoreExpr expr }
lintCoreExpr (Let (NonRec tv (Type ty)) body)
| isTyVar tv
@@ -1017,22 +1011,16 @@ lintCoreExpr e@(App _ _)
; return app_pair}
where
- skipTick t = case collectFunSimple e of
- (Var v) -> etaExpansionTick v t
- _ -> tickishFloatable t
- (fun, args, _source_ticks) = collectArgsTicks skipTick e
- -- We must look through source ticks to avoid #21152, for example:
- --
- -- reallyUnsafePtrEquality
- -- = \ @a ->
- -- (src<loc> reallyUnsafePtrEquality#)
- -- @Lifted @a @Lifted @a
+ skipTick t =
+ case collectFunSimple e of
+ Var v -> canCollectArgsThroughTick v t
+ _ -> tickishFloatable t
+ (fun, args, _ticks) = collectArgsTicks skipTick e
+ -- We must look through ticks, otherwise we may fail to spot a
+ -- saturated application. We use 'canCollectArgsThroughTicks', which is
+ -- the same predicate that Core Prep uses.
--
- -- To do this, we use `collectArgsTicks tickishFloatable` to match
- -- the eta expansion behaviour, as per Note [Eta expansion and source notes]
- -- in GHC.Core.Opt.Arity.
- -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow.
- -- See Note [Ticks and mandatory eta expansion]
+ -- See Note [Ticks and mandatory eta expansion] in GHC.CoreToStg.Prep.
lintCoreExpr (Lam var expr)
= markAllJoinsBad $
@@ -1131,7 +1119,7 @@ checkDeadIdOcc id
------------------
lintJoinBndrType :: OutType -- Type of the body
-> OutId -- Possibly a join Id
- -> LintM ()
+ -> LintM ()
-- Checks that the return type of a join Id matches the body
-- E.g. join j x = rhs in body
-- The type of 'rhs' must be the same as the type of 'body'
@@ -1139,13 +1127,29 @@ lintJoinBndrType body_ty bndr
| JoinPoint arity <- idJoinPointHood bndr
, let bndr_ty = idType bndr
, (bndrs, res) <- splitPiTys bndr_ty
- = do let msg =
- hang (text "Join point returns different type than body")
- 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
- , text "Join arity:" <+> ppr arity
- , text "Body type:" <+> ppr body_ty ])
- checkL (length bndrs >= arity) msg
- ensureEqTys body_ty (mkPiTys (drop arity bndrs) res) msg
+ = do let
+ ty_msg =
+ hang (text "Join point returns different type than body")
+ 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
+ , text "Join arity:" <+> ppr arity
+ , text "Body type:" <+> ppr body_ty ])
+ arity_msg =
+ hang (text "Join point is not saturated")
+ 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
+ , text "Join arity:" <+> ppr arity
+ , text "Arguments:" <+> ppr bndrs ])
+
+ mb_join_info <- lookupJoinId bndr
+ case mb_join_info of
+ Nothing ->
+ pprPanic "lintJoinBndrType: valid join marked bad" (ppr bndr)
+ Just (_, occ_info) -> do
+ checkL (length bndrs >= arity) arity_msg
+
+ -- See Note [Linting join points with casts or ticks] for why
+ -- we skip this check if there is an intervening cast.
+ unless (occ_info == JoinOccUnderCast) $
+ ensureEqTys body_ty (mkPiTys (drop arity bndrs) res) ty_msg
| otherwise
= return ()
@@ -1156,11 +1160,11 @@ checkJoinOcc var n_args
| JoinPoint join_arity_occ <- idJoinPointHood var
= do { mb_join_arity_bndr <- lookupJoinId var
; case mb_join_arity_bndr of {
- NotJoinPoint -> do { join_set <- getValidJoins
- ; addErrL (text "join set " <+> ppr join_set $$
- invalidJoinOcc var) } ;
+ Nothing -> do { valid_joins <- getValidJoins
+ ; addErrL (text "valid joins:" <+> ppr valid_joins $$
+ invalidJoinOcc var) } ;
- JoinPoint join_arity_bndr ->
+ Just (join_arity_bndr, _join_occ) ->
do { checkL (join_arity_bndr == join_arity_occ) $
-- Arity differs at binding site and occurrence
@@ -1333,39 +1337,34 @@ checkLinearity body_ue lam_var =
return body_ue'
Nothing -> return body_ue -- A type variable
-{- Note [Join points and casts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might think that this should be OK:
- join j x = rhs
- in (case e of
- A -> alt1
- B x -> (jump j x) |> co)
+{- Note [Linting join points with casts or ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As per Note [Join points, casts, and ticks] in GHC.Core, we have to be careful
+when a cast or tick occurs in between a join point binding and a corresponding
+join point occurrence.
-You might think that, since the cast is ultimately erased, the jump to
-`j` should still be OK as a join point. But no! See #21716. Suppose
+Generally speaking:
- newtype Age = MkAge Int -- axAge :: Age ~ Int
- f :: Int -> ... -- f strict in it's first argument
+ - The simplifier cannot handle intervening casts or non-soft-scope ticks, so
+ we must check for that to avoid producing invalid Core.
+ - However, as per (JCT3), Core Prep **can** produce join points with
+ intervening casts or non-soft-scope ticks, which means we must expect them.
-and consider the expression
+Casts present an additional challenge. Consider for example:
- f (join j :: Bool -> Age
- j x = (rhs1 :: Age)
- in case v of
- Just x -> (j x |> axAge :: Int)
- Nothing -> rhs2)
+ join { j :: Bool -> Age; j x = (blah :: Age) }
+ in case e of
+ False -> j True |> (co1 :: Age ~ Int)
+ True -> other :: Int
-Then, if the Simplifier pushes the strict call into the join points
-and alternatives we'll get
+It is **not** the case that the type of 'blah' is the same as the type of
+the body of the join point binding! Indeed:
- join j' x = f (rhs1 :: Age)
- in case v of
- Just x -> j' x |> axAge
- Nothing -> f rhs2
+ - RHS of the join-point binding: blah :: Age
+ - The body of the join point has type Int.
-Utterly bogus. `f` expects an `Int` and we are giving it an `Age`.
-No no no. Casts destroy the tail-call property. Henc markAllJoinsBad
-in the (Cast expr co) case of lintCoreExpr.
+So we skip the 'exprType(join_rhs) == exprType(join_body)' check when casts
+occur in between.
Note [No alternatives lint check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2977,9 +2976,10 @@ data LintEnv
-- type variables, and coercion variables)
-- Used at an occurrence of the InVar
- , le_joins :: IdSet -- Join points in scope that are valid
- -- A subset of the InScopeSet in le_subst
- -- See Note [Join points]
+ , le_joins :: UniqMap Id JoinOcc
+ -- ^ Join points in scope that are valid
+ -- A subset of the InScopeSet in le_subst
+ -- See Note [Join points]
, le_ue_aliases :: NameEnv UsageEnv
-- See Note [Linting linearity]
@@ -2999,6 +2999,7 @@ data LintFlags
, lf_check_linearity :: Bool -- ^ See Note [Linting linearity]
, lf_check_fixed_rep :: Bool -- ^ See Note [Checking for representation polymorphism]
, lf_check_rubbish_lits :: Bool -- ^ See Note [Checking for rubbish literals]
+ , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks]
}
-- See Note [Checking StaticPtrs]
@@ -3307,6 +3308,20 @@ data LintLocInfo
| InCo Coercion -- Inside a coercion
| InAxiom (CoAxiom Branched) -- Inside a CoAxiom
+-- | Does this join point 'Id' occur inside a cast?
+--
+-- See Note [Linting join points with casts or ticks].
+data JoinOcc
+ -- | A normal occurrence of a 'JoinId'.
+ = NormalJoinOcc
+ -- | An occurrence of a 'JoinId' with an intervening cast between the
+ -- join point binder definition and the jump.
+ | JoinOccUnderCast
+ deriving stock Eq
+instance Outputable JoinOcc where
+ ppr NormalJoinOcc = text "Normal"
+ ppr JoinOccUnderCast = text "UnderCast"
+
data LintConfig = LintConfig
{ l_diagOpts :: !DiagOpts -- ^ Diagnostics opts
, l_platform :: !Platform -- ^ Target platform
@@ -3328,7 +3343,7 @@ initL cfg m
env = LE { le_flags = l_flags cfg
, le_subst = mkEmptySubst (mkInScopeSetList vars)
, le_in_vars = mkVarEnv [ (v,(v, varType v)) | v <- vars ]
- , le_joins = emptyVarSet
+ , le_joins = emptyUniqMap
, le_loc = []
, le_ue_aliases = emptyNameEnv
, le_platform = l_platform cfg
@@ -3428,11 +3443,11 @@ addInScopeId in_id out_ty thing_inside
in unLintM (thing_inside out_id) env' errs
where
- add env@(LE { le_in_vars = id_vars, le_joins = join_set
+ add env@(LE { le_in_vars = id_vars, le_joins = valid_joins
, le_ue_aliases = aliases, le_subst = subst })
= (out_id, env1)
where
- env1 = env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' }
+ env1 = env { le_in_vars = in_vars', le_joins = valid_joins', le_ue_aliases = aliases' }
in_vars' = extendVarEnv id_vars in_id (in_id, out_ty)
aliases' = delFromNameEnv aliases (idName in_id)
@@ -3446,9 +3461,9 @@ addInScopeId in_id out_ty thing_inside
out_id | isEmptyTCvSubst subst = in_id
| otherwise = setIdType in_id out_ty
- join_set'
- | isJoinId out_id = extendVarSet join_set in_id -- Overwrite with new arity
- | otherwise = delVarSet join_set in_id -- Remove any existing binding
+ valid_joins'
+ | isJoinId out_id = addToUniqMap valid_joins in_id NormalJoinOcc -- Overwrite with new arity
+ | otherwise = delFromUniqMap valid_joins in_id -- Remove any existing binding
addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a
-- This function clones to avoid shadowing of TyCoVars
@@ -3485,13 +3500,35 @@ extendTvSubstL tv ty m
markAllJoinsBad :: LintM a -> LintM a
markAllJoinsBad m
- = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs
+ = LintM $ \ env errs -> unLintM m (env { le_joins = emptyUniqMap }) errs
+
+-- | Mark all join points as occurring under a tick.
+--
+-- See Note [Linting join points with casts or ticks].
+markAllJoinsUnderTick :: CoreTickish -> LintM a -> LintM a
+markAllJoinsUnderTick tick m
+ = LintM $ \ env errs ->
+ let env' = if tickishHasSoftScope tick || lf_allow_weak_joins (le_flags env)
+ then env
+ else env { le_joins = emptyUniqMap }
+ in unLintM m env' errs
+
+-- | Mark all join points as occurring under a cast.
+--
+-- See Note [Linting join points with casts or ticks].
+markAllJoinsUnderCast :: LintM a -> LintM a
+markAllJoinsUnderCast m
+ = LintM $ \ env errs ->
+ let !env' = if lf_allow_weak_joins (le_flags env)
+ then env { le_joins = fmap (const JoinOccUnderCast) (le_joins env) }
+ else env { le_joins = emptyUniqMap }
+ in unLintM m env' errs
markAllJoinsBadIf :: Bool -> LintM a -> LintM a
markAllJoinsBadIf True m = markAllJoinsBad m
markAllJoinsBadIf False m = m
-getValidJoins :: LintM IdSet
+getValidJoins :: LintM (UniqMap Id JoinOcc)
getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))
getSubst :: LintM Subst
@@ -3552,14 +3589,14 @@ lintVarOcc v_occ
| otherwise
= return ()
-lookupJoinId :: Id -> LintM JoinPointHood
+lookupJoinId :: Id -> LintM (Maybe (JoinArity, JoinOcc))
-- Look up an Id which should be a join point, valid here
-- If so, return its arity, if not return Nothing
lookupJoinId id
- = do { join_set <- getValidJoins
- ; case lookupVarSet join_set id of
- Just id' -> return (idJoinPointHood id')
- Nothing -> return NotJoinPoint }
+ = do { valid_joins <- getValidJoins
+ ; case lookupUniqMap valid_joins id of
+ Just join_occ -> return $ Just (idJoinArity id, join_occ)
+ Nothing -> return Nothing }
addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a
addAliasUE id ue thing_inside = LintM $ \ env errs ->
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -90,7 +90,6 @@ import GHC.Utils.Misc
import Data.List.NonEmpty ( nonEmpty )
import qualified Data.List.NonEmpty as NE
-import Data.Maybe( isJust )
{-
************************************************************************
@@ -2835,21 +2834,6 @@ tryEtaReduce rec_ids bndrs body eval_sd
ok_arg _ _ _ _ = Nothing
--- | Can we eta-reduce the given function
--- See Note [Eta reduction soundness], criteria (B), (J), and (W).
-cantEtaReduceFun :: Id -> Bool
-cantEtaReduceFun fun
- = hasNoBinding fun -- (B)
- -- Don't undersaturate functions with no binding.
-
- || isJoinId fun -- (J)
- -- Don't undersaturate join points.
- -- See Note [Invariants on join points] in GHC.Core, and #20599
-
- || (isJust (idCbvMarks_maybe fun)) -- (W)
- -- Don't undersaturate StrictWorkerIds.
- -- See Note [CBV Function Ids: overview] in GHC.Types.Id.Info.
-
{- *********************************************************************
* *
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -375,7 +375,7 @@ We don't float lets inwards past an SCC.
-}
fiExpr platform to_drop (_, AnnTick tickish expr)
- | tickish `tickishScopesLike` SoftScope
+ | tickishHasSoftScope tickish
= Tick tickish (fiExpr platform to_drop expr)
| otherwise -- Wimp out for now - we could push values in
=====================================
compiler/GHC/Core/Opt/FloatOut.hs
=====================================
@@ -365,25 +365,28 @@ floatExpr lam@(Lam (TB _ lam_spec) _)
(add_to_stats fs floats, floats, mkLams bndrs body') }
floatExpr (Tick tickish expr)
- | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
+ -- If possible, float out past the tick
+ | let float_out_of_tick
+ -- See Note [Floating past breakpoints]
+ | Breakpoint{} <- tickish
+ = True
+ | otherwise
+ -- We can float code out of non-scoped ticks
+ = tickishHasNoScope tickish
+ , float_out_of_tick
= case (floatExpr expr) of { (fs, floating_defns, expr') ->
(fs, floating_defns, Tick tickish expr') }
- | not (tickishCounts tickish) || tickishCanSplit tickish
- = case (floatExpr expr) of { (fs, floating_defns, expr') ->
- let -- Annotate bindings floated outwards past an scc expression
- -- with the cc. We mark that cc as "duplicated", though.
- annotated_defns = wrapTick (mkNoCount tickish) floating_defns
+ -- We can't move code out of the tick
+ | otherwise
+ = assert (not (tickishCounts tickish) || tickishCanSplit tickish) $
+ case (floatExpr expr) of { (fs, floating_defns, expr') ->
+ -- Wrap floated code with the correct tick scope, but using 'mkNoCount'
+ -- to ensure we don't duplicate counters.
+ let annotated_defns = wrapTick (mkNoCount tickish) floating_defns
in
(fs, annotated_defns, Tick tickish expr') }
- -- See Note [Floating past breakpoints]
- | Breakpoint{} <- tickish
- = case (floatExpr expr) of { (fs, floating_defns, expr') ->
- (fs, floating_defns, Tick tickish expr') }
-
- | otherwise
- = pprPanic "floatExpr tick" (ppr tickish)
floatExpr (Cast expr co)
= case (floatExpr expr) of { (fs, floating_defns, expr') ->
@@ -661,7 +664,8 @@ partitionByLevel (Level major minor) (FB tops defns)
wrapTick :: CoreTickish -> FloatBinds -> FloatBinds
wrapTick t (FB tops defns)
- = FB (mapBag wrap_bind tops)
+ = assert (not $ tickishCounts t) $
+ FB (mapBag wrap_bind tops)
(M.map (M.map wrap_defns) defns)
where
wrap_defns = mapBag wrap_one
@@ -672,10 +676,13 @@ wrapTick t (FB tops defns)
wrap_one (FloatLet bind) = FloatLet (wrap_bind bind)
wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
- maybe_tick e | exprIsHNF e = tickHNFArgs t e
- | otherwise = mkTick t e
- -- we don't need to wrap a tick around an HNF when we float it
- -- outside a tick: that is an invariant of the tick semantics
+ maybe_tick
+ -- We don't need to wrap an SCC tick around HNFs that we floated out of
+ -- the SCC, as that is an invariant of the semantics for SCCs.
-- Conversely, inlining of HNFs inside an SCC is allowed, and
-- indeed the HNF we're floating here might well be inlined back
-- again, and we don't want to end up with duplicate ticks.
+ | tickishPlace t == PlaceCostCentre
+ = mkTickNoHNF t
+ | otherwise
+ = mkTick t
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -27,7 +27,7 @@ core expression with (hopefully) improved usage information.
module GHC.Core.Opt.OccurAnal (
occurAnalysePgm,
- occurAnalyseExpr,
+ occurAnalyseExpr, occurAnalyseExpr_Prep,
zapLambdaBndrs
) where
@@ -85,6 +85,15 @@ occurAnalyseExpr expr = expr'
where
WUD _ expr' = occAnal initOccEnv expr
+-- | A version of 'occurAnalyseExpr' suitable for CorePrep.
+--
+-- Different from 'occurAnalyseExpr' due to (JCT3)
+-- in Note [Join points, casts, and ticks] in GHC.Core.
+occurAnalyseExpr_Prep :: CoreExpr -> CoreExpr
+occurAnalyseExpr_Prep expr = expr'
+ where
+ WUD _ expr' = occAnal (initOccEnv { occ_allow_weak_joins = True }) expr
+
occurAnalysePgm :: Module -- Used only in debug output
-> (Id -> Bool) -- Active unfoldings
-> (ActivationGhc -> Bool) -- Active rules
@@ -2300,12 +2309,8 @@ occ_anal_lam_tail env (Cast expr co)
Var {} | isRhsEnv env -> markAllMany usage1
_ -> usage1
- -- usage3: you might think this was not necessary, because of
- -- the markAllNonTail in adjustTailUsage; but not so! For a
- -- join point, adjustTailUsage doesn't do this; yet if there is
- -- a cast, we must! Also: why markAllNonTail? See
- -- GHC.Core.Lint: Note Note [Join points and casts]
- usage3 = markAllNonTail usage2
+ -- usage3: see (JCT1) in Note [Join points, casts, and ticks] in GHC.Core.
+ usage3 = markAllNonTail_CastOrTick env usage2
in WUD usage3 (Cast expr' co)
@@ -2587,42 +2592,39 @@ But it is not necessary to gather CoVars from the types of other binders.
-}
occAnal env (Tick tickish body)
- = WUD usage' (Tick tickish body')
+ = WUD usage2 (Tick tickish body')
where
WUD usage body' = occAnal env body
- usage'
- | tickish `tickishScopesLike` SoftScope
- = usage -- For soft-scoped ticks (including SourceNotes) we don't want
- -- to lose join-point-hood, so we don't mess with `usage` (#24078)
+ usage1
+ -- We don't want to lose join-point-hood. We can move soft-scoped ticks
+ -- out of the way, so don't mess with `usage` (#24078).
+ | tickishHasSoftScope tickish
+ = usage
- -- For a non-soft tick scope, we can inline lambdas only, so we
- -- abandon tail calls, and do markAllInsideLam too: usage_lam
+ -- Otherwise, we can inline lambdas only, so use 'markAllInsideLam'.
+ | otherwise
+ = markAllNonTail_CastOrTick env $ markAllInsideLam usage
+ -- markAllNonTail_CastOrTick: abandon tail calls.
+ -- See (JCT2) in Note [Join points, casts, and ticks] in GHC.Core.
+ usage2
| Breakpoint _ _ ids <- tickish
= -- Never substitute for any of the Ids in a Breakpoint
- addManyOccs usage_lam (mkVarSet ids)
+ addManyOccs usage1 (mkVarSet ids)
| otherwise
- = usage_lam
-
- usage_lam = markAllNonTail (markAllInsideLam usage)
-
- -- TODO There may be ways to make ticks and join points play
- -- nicer together, but right now there are problems:
- -- let j x = ... in tick<t> (j 1)
- -- Making j a join point may cause the simplifier to drop t
- -- (if the tick is put into the continuation). So we don't
- -- count j 1 as a tail call.
- -- See #14242.
+ = usage1
occAnal env (Cast expr co)
- = let (WUD usage expr') = occAnal env expr
- usage1 = addManyOccs usage (coVarsOfCo co)
- -- usage2: see Note [Gather occurrences of coercion variables]
- usage2 = markAllNonTail usage1
- -- usage3: calls inside expr aren't tail calls any more
- in WUD usage2 (Cast expr' co)
+ = let
+ WUD usage expr' = occAnal env expr
+ -- usage1: see Note [Gather occurrences of coercion variables]
+ usage1 = addManyOccs usage (coVarsOfCo co)
+ -- usage2: see (JCT1) in Note [Join points, casts, and ticks] in GHC.Core.
+ usage2 = markAllNonTail_CastOrTick env usage1
+ in
+ WUD usage2 (Cast expr' co)
occAnal env app@(App _ _)
= occAnalApp env (collectArgsTicks tickishFloatable app)
@@ -2936,6 +2938,11 @@ data OccEnv
, occ_rule_act :: ActivationGhc -> Bool -- Which rules are active
-- See Note [Finding rule RHS free vars]
+ , occ_allow_weak_joins :: !Bool
+ -- ^ Allow a join point jump to occur inside casts or profiling ticks?
+ --
+ -- See (JCT3) in Note [Join points, casts, and ticks] in GHC.Core.Opt.
+
-- See Note [The binder-swap substitution]
-- If x :-> (y, co) is in the env,
-- then please replace x by (y |> mco)
@@ -3003,6 +3010,8 @@ initOccEnv
, occ_unf_act = \_ -> True
, occ_rule_act = \_ -> True
+ , occ_allow_weak_joins = False
+
, occ_join_points = emptyVarEnv
, occ_bs_env = emptyVarEnv
, occ_bs_rng = emptyVarSet
@@ -3026,6 +3035,15 @@ setScrutCtxt !env alts
-- non-default alternative. That in turn influences
-- pre/postInlineUnconditionally. Grep for "occ_int_cxt"!
+-- | Mark occurrences under a cast/non-soft-scope tick as non-tail-called,
+-- except if 'occ_allow_weak_joins = True'.
+--
+-- See Note [Join points, casts, and ticks] in GHC.Core.
+markAllNonTail_CastOrTick :: OccEnv -> UsageDetails -> UsageDetails
+markAllNonTail_CastOrTick env =
+ markAllNonTailIf
+ (not $ occ_allow_weak_joins env)
+
{- Note [The OccEnv for a right hand side]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
How do we create the OccEnv for a RHS (in mkRhsOccEnv)?
@@ -4075,7 +4093,10 @@ okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool
-- See Note [Invariants on join points]; invariants cited by number below.
-- Invariant 2 is always satisfiable by the simplifier by eta expansion.
okForJoinPoint lvl bndr tail_call_info
- | isJoinId bndr -- A current join point should still be one!
+ -- A current join point should still be one!
+ --
+ -- See Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt.
+ | isJoinId bndr
= warnPprTrace lost_join "Lost join point" lost_join_doc $
True
| valid_join
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -814,9 +814,9 @@ prepareRhs env top_lvl occ rhs0
= return (emptyLetFloats, Var fun)
anfise (Tick t rhs)
- -- We want to be able to float bindings past this
- -- tick. Non-scoping ticks don't care.
- | tickishScoped t == NoScope
+ -- We want to be able to float bindings past this tick.
+ -- Non-scoping ticks don't care.
+ | tickishHasNoScope t
= do { (floats, rhs') <- anfise rhs
; return (floats, Tick t rhs') }
@@ -1413,7 +1413,7 @@ simplTick env tickish expr cont
-- bottom, then rebuildCall will discard the continuation.
--------------------------
--- | tickishScoped tickish && not (tickishCounts tickish)
+-- | not (tickishHasNoScope tickish) && not (tickishCounts tickish)
-- = simplExprF env expr (TickIt tickish cont)
-- XXX: we cannot do this, because the simplifier assumes that
-- the context can be pushed into a case with a single branch. e.g.
@@ -1425,12 +1425,11 @@ simplTick env tickish expr cont
-- simplifier iterations that necessary in some cases.
--------------------------
- -- For unscoped or soft-scoped ticks, we are allowed to float in new
- -- cost, so we simply push the continuation inside the tick. This
- -- has the effect of moving the tick to the outside of a case or
- -- application context, allowing the normal case and application
- -- optimisations to fire.
- | tickish `tickishScopesLike` SoftScope
+ -- For soft-scoped ticks, we are allowed to float in new cost, so we simply
+ -- push the continuation inside the tick. This has the effect of moving the
+ -- tick to the outside of a case or application context, allowing the normal
+ -- 'case' and 'application' optimisations to fire.
+ | tickishHasSoftScope tickish
= do { (floats, expr') <- simplExprF env expr cont
; return (floats, mkTick tickish expr')
}
@@ -1459,14 +1458,14 @@ simplTick env tickish expr cont
_other -> Nothing
where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)
movable t = not (tickishCounts t) ||
- t `tickishScopesLike` NoScope ||
+ tickishHasNoScope t ||
tickishCanSplit t
tickScrut e = foldr mkTick e ticks
-- Alternatives get annotated with all ticks that scope in some way,
-- but we don't want to count entries.
tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)
ts_scope = map mkNoCount $
- filter (not . (`tickishScopesLike` NoScope)) ticks
+ filter (not . tickishHasNoScope) ticks
no_floating_past_tick =
do { let (inc,outc) = splitCont cont
@@ -2180,16 +2179,15 @@ evaluation context E):
As is evident from the example, there are two components to this behavior:
- 1. When entering the RHS of a join point, copy the context inside.
- 2. When a join point is invoked, discard the outer context.
+ (wrapJoinCont) When entering the RHS of a join point, copy the context inside.
+ (trimJoinCont) When a join point is invoked, discard the outer context.
We need to be very careful here to remain consistent---neither part is
optional!
-We need do make the continuation E duplicable (since we are duplicating it)
+We need to make the continuation E duplicable (since we are duplicating it)
with mkDupableCont.
-
Note [Join points with -fno-case-of-case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Supose case-of-case is switched off, and we are simplifying
@@ -2213,7 +2211,8 @@ case-of-case we may then end up with this totally bogus result
This would be OK in the language of the paper, but not in GHC: j is no longer
a join point. We can only do the "push continuation into the RHS of the
join point j" if we also push the continuation right down to the /jumps/ to
-j, so that it can evaporate there. If we are doing case-of-case, we'll get to
+j, so that it can evaporate there (trimJoinCont). Then, if we are doing
+case-of-case, we'll get to:
join x = case <j-rhs> of <outer-alts> in
case y of
@@ -3656,9 +3655,11 @@ addBinderUnfolding env bndr unf
= modifyInScope env (bndr `setIdUnfolding` unf)
zapBndrOccInfo :: Bool -> Id -> Id
--- Consider case e of b { (a,b) -> ... }
--- Then if we bind b to (a,b) in "...", and b is not dead,
--- then we must zap the deadness info on a,b
+-- ^ Consider:
+-- > case e of e' { (a,b) -> rhs }
+--
+-- We bind @e'@ to @(a,b)@ in @rhs@. If @e'@ is not dead,
+-- then we must zap the deadness info on @a@ and @b@.
zapBndrOccInfo keep_occ_info pat_id
| keep_occ_info = pat_id
| otherwise = zapIdOccInfo pat_id
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -437,7 +437,7 @@ simple_app env e@(Lam {}) []
simple_app env (Tick t e) as
-- Okay to do "(Tick t e) x ==> Tick t (e x)"?
- | t `tickishScopesLike` SoftScope
+ | tickishHasSoftScope t
= mkTick t $ simple_app env e as
-- (let x = e in b) a1 .. an => let x = e in (b a1 .. an)
@@ -1059,23 +1059,33 @@ and again its arity increases (#15517)
-}
--- | Returns Just (bndr,rhs) if the binding is a join point:
--- If it's a JoinId, just return it
--- If it's not yet a JoinId but is always tail-called,
--- make it into a JoinId and return it.
+-- | Returns @Just (bndr, rhs)@ if the binding is a join point, or can be made
+-- into a join poin. Returns @Nothing@ otherwise.
+--
+-- - If the input binder is a 'JoinId', just return it;
+-- - if it's not yet a 'JoinId' but is always tail-called,
+-- make it into a 'JoinId' and return that.
+--
-- In the latter case, eta-expand the RHS if necessary, to make the
--- lambdas explicit, as is required for join points
+-- lambdas explicit, as is required for join points.
+--
+-- Precondition: the 'TailCallInfo' of the 'InBndr' is conservative:
--
--- Precondition: the InBndr has been occurrence-analysed,
--- so its OccInfo is valid
+-- - if it says 'AlwaysTailCalled', it is definitely always tail called,
+-- - if it says 'NoTailCallInfo', then we're not sure.
+--
+-- See Note [JoinId vs TailCallInfo].
joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
joinPointBinding_maybe bndr rhs
| not (isId bndr)
= Nothing
+ -- Being a JoinId is robust: preserve that. See Note [JoinId vs TailCallInfo].
| isJoinId bndr
= Just (bndr, rhs)
+ -- If the 'TailCallInfo' of 'bndr' says 'AlwaysTailCalled', then we know for
+ -- sure that it can be made into a join point.
| AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
, (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
, let str_sig = idDmdSig bndr
@@ -1091,6 +1101,48 @@ joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
joinPointBindings_maybe bndrs
= mapM (uncurry joinPointBinding_maybe) bndrs
+{- Note [JoinId vs TailCallInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Occurrence information is /fundamentally fragile/; that is, it may
+ be invalidated by the Simplifier.
+ Example 1:
+ \y -> let x = y in ...x..x...
+ Here `y` is marked "occurs exactly once" but, after inlining `x`,
+ `y` now occurs many times.
+ Example 2:
+ f (let h x = ... in case y of { True -> h 1; False -> h 2 })
+ Here `h` is tail-called; but if `f` is strict we could transform to
+ let h x = ... in
+ case y of { True -> f (h 1); False -> f (h 2) }
+ Now `h` is not tail called any more.
+
+ Exception: Dead things (with no occurrences) usually stay dead.
+ There are exceptions e.g.
+ case x of y { (a,b) -> case y of (p,q) -> p }
+ Here `a` and `b` look dead, but we may well transform to
+ case x of y { (a,b) -> a }
+
+ Because occurrence info is fragile, we recompute occurrence info
+ (including tail call info) before each run of the Simplifier.
+
+ Whenever the simplifier performs a transformation that **might** invalidate
+ occurrence information, it calls 'zapFragileIdInfo'. This sets the
+ 'TailCallInfo' to 'NoTailCallInfo' (among other things).
+
+* Being a JoinId is /robust/, and is rigorously maintained by the
+ Simplifier. In Example 2 above, if `h` was marked as a JoinId,
+ that transformation would not have happened. Instead we'd have
+ transformed to
+ let h x = f (...) in
+ case y of { True -> h 1; False -> h 2 }
+
+ The Simplifier takes an Id whose occurrences are marked as
+ `AlwaysTailCalled` and turns it into robust `JoinId`. This is
+ done by `joinPointBinding_maybe`.
+
+ There is one exception: float-out, the only caller of 'zapJoinId'.
+ See Note [Zapping JoinId when floating].
+-}
{- *********************************************************************
* *
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -34,7 +34,8 @@ module GHC.Core.Utils (
exprIsTickedString, exprIsTickedString_maybe,
exprIsTopLevelBindable,
exprIsUnaryClassFun, isUnaryClassId,
- altsAreExhaustive, etaExpansionTick,
+ altsAreExhaustive,
+ canCollectArgsThroughTick, cantEtaReduceFun,
-- * Equality
cheapEqExpr, cheapEqExpr', diffBinds,
@@ -680,7 +681,7 @@ mergeCaseAlts :: CoreExpr -> Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
| Just (joins, inner_alts) <- go deflt_rhs
, Just aux_binds <- mk_aux_binds joins
- = Just ( aux_binds ++ joins, mergeAlts outer_alts inner_alts )
+ = Just (aux_binds ++ joins, mergeAlts outer_alts inner_alts )
-- NB: mergeAlts gives priority to the left
-- case x of
-- A -> e1
@@ -727,7 +728,7 @@ mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
, Just tc <- tyConAppTyCon_maybe type_arg
, Just (dc1:dcs) <- tyConDataCons_maybe tc -- At least one data constructor
, dcs `lengthAtMost` 3 -- Arbitrary
- = return ( [], mk_alts dc1 dcs)
+ = return ([], mk_alts dc1 dcs)
where
mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc
mk_rhs dc = Var (dataConWorkId dc)
@@ -748,11 +749,16 @@ mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
| otherwise
= Nothing
- -- We don't want ticks to get in the way; just push them inwards.
- -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#)
+ -- Push ticks **inwards** (when possible).
+ -- See (MC5) in Note [Merge Nested Cases].
go (Tick t body)
- = do { (joins, alts) <- go body
- ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) }
+ = do { (joins, alts) <- go body -- (MC4): any join points inside are floated out of the tick.
+
+ -- Abort if this would put a non-soft-scope tick in between
+ -- a join point binding and its jumps. See (MC6).
+ ; guard $ null joins || tickishHasSoftScope t
+ ; return (joins, [Alt con bs (mkTick t rhs) | Alt con bs rhs <- alts])
+ }
go _ = Nothing
@@ -974,12 +980,74 @@ Wrinkles
So `mergeCaseAlts` floats out any join points. It doesn't float out
non-join-points unless the /outer/ case has just one alternative; doing
- so would risk more allocation
+ so would risk more allocation.
+
+ Note also that `mergeCaseAlts` floats join points out of ticks, for which
+ we need to be extra careful; see (MC6).
Floating out join points isn't entirely straightforward.
See Note [Floating join points out of DEFAULT alternatives]
-(MC5) See Note [Cascading case merge]
+(MC5) We want to move ticks out of the way if possible, to prevent them from
+ inhibiting optimisation. For example, say we have:
+
+ case expensive of r {
+ C1 -> rhs1; -- happy path
+ _ -> scctick<doEdgeCase> (case r of { C2 -> rhs2; C3 -> rhs3 })
+ }
+
+ In this situation, we push the "doEdgeCase" tick **inwards** and proceed
+ to merge cases, like so:
+
+ case expensive of
+ C1 -> rhs1
+ C2 -> scctick<doEdgeCase> rhs2
+ C3 -> scctick<doEdgeCase> rhs3
+
+ This preserves the tick semantics (see Note [Scoping ticks and counting ticks]
+ in GHC.Types.Tickish), because this transformation:
+
+ 1. preserves counts,
+ 2. does not move cost in or out of the tick scope.
+
+ (1) is clear: we will tick 'doEdgeCase' exactly in the C2/C3 alternatives,
+ and we won't otherwise.
+ For (2), recall that case is strict in Core. We already evaluated 'expensive',
+ so re-scrutinising 'r' is free.
+
+ This means that, perhaps surprisingly, this transformation is valid for
+ **all** ticks, including non-floatable ones.
+
+ In contrast, we would not want to move the tick outwards, because this:
+
+ - will lead to additional counting of 'doEdgeCase' in the 'C1' (happy path) case,
+ - risks attributing the cost of evaluating 'expensive' to 'doEdgeCase'.
+
+(MC6) There is a dangerous interaction between (MC4) and (MC5), which can lead
+ to invalid Core (as reported in #26642, #26929). Suppose we have:
+
+ case f x of r ->
+ scctick<foo>
+ join j y = rhs in
+ case r of { C1 -> j 1; C2 -> bar }
+
+ If we naively carried out (MC4) and (MC5) together, this would result in:
+
+ join j y = rhs in
+ case f x of
+ C1 -> scctick<foo> (j 1)
+ C2 -> scctick<foo> bar
+
+ This has moved the tick in between the join point binding 'j' and the
+ join point jump, which is invalid as per Note [Join points, casts, and ticks]
+ in GHC.Core. The simplifier cannot deal with such Core, resulting in #26642.
+
+ The solution: abort whenever we would position a non-soft-scope tick
+ inside a join point in this manner.
+ An alternative would be to float the tick outwards, but as we saw in (MC5)
+ this risks a grave misattribution of profiling costs, so we don't do that.
+
+(MC7) See Note [Cascading case merge]
See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils
@@ -2076,14 +2144,31 @@ altsAreExhaustive (Alt con1 _ _ : alts)
-- we behave conservatively here -- I don't think it's important
-- enough to deserve special treatment
--- | Should we look past this tick when eta-expanding the given function?
+-- | Should we look past this tick when collecting arguments
+-- for the given function?
--
-- See Note [Ticks and mandatory eta expansion]
--- Takes the function we are applying as argument.
-etaExpansionTick :: Id -> GenTickish pass -> Bool
-etaExpansionTick id t
- = hasNoBinding id &&
- ( tickishFloatable t || isProfTick t )
+canCollectArgsThroughTick
+ :: Id -- ^ function at the head of the application
+ -> GenTickish pass -- ^ tick we want to collect arguments past
+ -> Bool
+canCollectArgsThroughTick id t
+ = tickishFloatable t || cantEtaReduceFun id
+
+-- | Can we eta-reduce the given function?
+-- See Note [Eta reduction soundness], criteria (B), (J), and (W).
+cantEtaReduceFun :: Id -> Bool
+cantEtaReduceFun fun
+ = hasNoBinding fun -- (B)
+ -- Don't undersaturate functions with no binding.
+
+ || isJoinId fun -- (J)
+ -- Don't undersaturate join points.
+ -- See Note [Invariants on join points] in GHC.Core, and #20599
+
+ || isJust (idCbvMarks_maybe fun) -- (W)
+ -- Don't undersaturate StrictWorkerIds.
+ -- See Note [CBV Function Ids: overview] in GHC.Types.Id.Info.
{- Note [exprOkForSpeculation and type classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -39,7 +39,8 @@ import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.DataCon
-import GHC.Core.Opt.OccurAnal
+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr_Prep )
+import GHC.Core.SimpleOpt ( joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Data.Maybe
import GHC.Data.OrdList
@@ -575,7 +576,18 @@ cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
Maybe CoreBind) -- Just bind' <=> returned new bind; no float
-- Nothing <=> added bind' to floats instead
cpeBind top_lvl env (NonRec bndr rhs)
- | not (isJoinId bndr)
+ -- A join point.
+ -- NB: use 'joinPointBinding_maybe' instead of 'isJoinId' as per the plan
+ -- described in (JCT3) in Note [Join points, casts, and ticks].
+ | Just (bndr, rhs) <- joinPointBinding_maybe bndr rhs
+ = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point; see Note [Join points and floating]
+ do { (_, bndr1) <- cpCloneBndr env bndr
+ ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
+ ; return (extendCorePrepEnv env bndr bndr2,
+ emptyFloats,
+ Just (NonRec bndr2 rhs1)) }
+
+ | otherwise
= do { (env1, bndr1) <- cpCloneBndr env bndr
; let dmd = idDemandInfo bndr
lev = typeLevity (idType bndr)
@@ -594,16 +606,23 @@ cpeBind top_lvl env (NonRec bndr rhs)
; return (env2, floats1, Nothing) }
- | otherwise -- A join point; see Note [Join points and floating]
- = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point
- do { (_, bndr1) <- cpCloneBndr env bndr
- ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
- ; return (extendCorePrepEnv env bndr bndr2,
- emptyFloats,
- Just (NonRec bndr2 rhs1)) }
-
cpeBind top_lvl env (Rec pairs)
- | not (isJoinId (head bndrs))
+ -- A recursive join point.
+ -- NB: use 'joinPointBindings_maybe' instead of 'isJoinId' as per the plan
+ -- described in (JCT3) in Note [Join points, casts, and ticks].
+ | Just pairs <- joinPointBindings_maybe pairs
+ , let (bndrs, rhss) = unzip pairs
+ = do { (env, bndrs1) <- cpCloneBndrs env bndrs
+ ; let env' = enterRecGroupRHSs env bndrs1
+ ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
+
+ ; let bndrs2 = map fst pairs1
+ -- use env below, so that we reset cpe_rec_ids
+ ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
+ emptyFloats,
+ Just (Rec pairs1)) }
+ | otherwise
+ , let (bndrs, rhss) = unzip pairs
= do { (env, bndrs1) <- cpCloneBndrs env bndrs
; let env' = enterRecGroupRHSs env bndrs1
; stuff <- zipWithM (cpePair top_lvl Recursive topDmd Lifted env')
@@ -626,19 +645,9 @@ cpeBind top_lvl env (Rec pairs)
(Float (Rec all_pairs) LetBound TopLvlFloatable),
Nothing) }
- | otherwise -- See Note [Join points and floating]
- = do { (env, bndrs1) <- cpCloneBndrs env bndrs
- ; let env' = enterRecGroupRHSs env bndrs1
- ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
-
- ; let bndrs2 = map fst pairs1
- -- use env below, so that we reset cpe_rec_ids
- ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
- emptyFloats,
- Just (Rec pairs1)) }
where
- (bndrs, rhss) = unzip pairs
-
+ -- See Note [Join points and floating]
+ --
-- Flatten all the floats, and the current
-- group into a single giant Rec
add_float (Float bind bound _) prs2
@@ -653,7 +662,6 @@ cpeBind top_lvl env (Rec pairs)
Rec prs1 -> prs1 ++ prs2
add_float f _ = pprPanic "cpeBind" (ppr f)
-
---------------
cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
-> CorePrepEnv -> OutId -> CoreExpr
@@ -661,7 +669,7 @@ cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
-- Used for all bindings
-- The binder is already cloned, hence an OutId
cpePair top_lvl is_rec dmd lev env0 bndr rhs
- = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair
+ = assert (isNothing $ joinPointBinding_maybe bndr rhs) $ -- those should use cpeJoinPair
do { (floats1, rhs1) <- cpeRhsE env rhs
-- See if we are allowed to float this stuff out of the RHS
@@ -926,7 +934,7 @@ rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody)
-- Remove top level lambdas by let-binding
rhsToBody env (Tick t expr)
- | tickishScoped t == NoScope -- only float out of non-scoped annotations
+ | tickishHasNoScope t -- only float out of non-scoped annotations
= do { (floats, expr') <- rhsToBody env expr
; return (floats, mkTick t expr') }
@@ -984,43 +992,74 @@ instance Outputable ArgInfo where
{- Note [Ticks and mandatory eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Something like
- `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`
-caused a compiler panic in #20938. Why did this happen?
-The simplifier will eta-reduce the rhs giving us a partial
-application of tagToEnum#. The tick is then pushed inside the
-type argument. That is we get
- `(Tick<foo> tagToEnum#) @Bool`
+We must look through ticks when they get in the way of seeing the arguments to
+'Id's that cannot be eta-reduced.
+
+For example, we may have
+
+ myReallyUnsafePtrEquality
+ = \ @a x y ->
+ (src<loc> reallyUnsafePtrEquality#)
+ @Lifted @a @Lifted @a x y
+
+If we don't move the SourceNote out of the way, this looks like an unsaturated
+occurrence of the PrimOp "reallyUnsafePtrEquality#", which we cannot generate
+code for.
+
+Moreover, we must also move out non-floatable ticks. Case in point: #20938,
+of the form:
+
+ foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool
+
+If we don't look past the tick "foo", the simplifier will eta-reduce the RHS,
+giving us a partial application of 'tagToEnum#'. The tick is then pushed inside
+the type argument, resulting in:
+
+ (Tick<foo> tagToEnum#) @Bool
+
CorePrep would go on to see a undersaturated tagToEnum# application
-and eta expand the expression under the tick. Giving us:
+and eta-expand the expression under the tick. Giving us:
+
(Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool
-Suddenly tagToEnum# is applied to a polymorphic type and the code generator
+
+Suddenly, 'tagToEnum#' is applied to a polymorphic type and the code generator
panics as it needs a concrete type to determine the representation.
-The problem in my eyes was that the tick covers a partial application
-of a primop. There is no clear semantic for such a construct as we can't
-partially apply a primop since they do not have bindings.
-We fix this by expanding the scope of such ticks slightly to cover the body
-of the eta-expanded expression.
-
-We do this by:
-* Checking if an application is headed by a primOpish thing.
-* If so we collect floatable ticks and usually but also profiling ticks
- along with regular arguments.
-* When rebuilding the application we check if any profiling ticks appear
- before the primop is fully saturated.
-* If the primop isn't fully satured we eta expand the primop application
- and scope the tick to scope over the body of the saturated expression.
-
-Going back to #20938 this means starting with
- `(Tick<foo> tagToEnum#) @Bool`
-we check if the function head is a primop (yes). This means we collect the
-profiling tick like if it was floatable. Giving us
- (tagToEnum#, [CpeTick foo, CpeApp @Bool]).
+The problem was that the tick covered a partial application of a primop.
+There is no clear semantic for such a construct: we can't partially apply a
+primop, since primops do not have bindings.
+
+To fix this, we expand the scope of ticks slightly to cover the body
+of the eta-expanded expression, even when the tick isn't normally floatable.
+
+This is achieved by using 'GHC.Core.Utils.canCollectArgsThroughTick', which
+responds 'True' in the following two situations:
+
+ - The tick is floatable (i.e. satisfies 'tickishFloatable'), meaning that it
+ is OK to float it out slightly, moving in more code under it.
+ See also Note [Eta expansion and source notes] in GHC.Core.Opt.Arity.
+ - The tick is around an application that is headed by an 'Id' that cannot be
+ undersaturated, such as a PrimOp (see 'GHC.Core.Utils.cantEtaReduceFun').
+
+This solves #20938. Indeed, starting with
+
+ (scctick<foo> tagToEnum#) @Bool
+
+we see that the head of the application is 'tagToEnum#', which is a PrimOp and
+thus satisfies 'hasNoBinding = True'. As a result, we collect the profiling tick
+as if it was floatable, resulting in
+
+ (tagToEnum#, [CpeTick foo, CpeApp @Bool])
+
cpe_app filters out the tick as a underscoped tick on the expression
-`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the
-body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.
+`tagToEnum# @Bool`. During eta-expansion, we put that tick back onto the
+body of the eta-expansion lambda, resulting in
+
+ \x -> scctick<foo> (tagToEnum# @Bool x)
+
+which is unproblematic.
-}
+
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- May return a CpeRhs (instead of CpeApp) because of saturating primops
cpeApp top_env expr
@@ -1045,15 +1084,14 @@ cpeApp top_env expr
go (Cast fun co) as
= go fun (AICast co : as)
go (Tick tickish fun) as
- -- Profiling ticks are slightly less strict so we expand their scope
- -- if they cover partial applications of things like primOps.
- -- See Note [Ticks and mandatory eta expansion]
- -- Here we look inside `fun` before we make the final decision about
- -- floating the tick which isn't optimal for perf. But this only makes
- -- a difference if we have a non-floatable tick which is somewhat rare.
+ -- Try to move a tick out of the way, if:
+ -- - the tick can be floated out of the way ('tickishFloatable'), or
+ -- - the tick must be moved out of the way because it stands in between
+ -- an 'Id' that must be saturated and some of its arguments;
+ -- see Note [Ticks and mandatory eta expansion].
| Var vh <- head
- , Var head' <- lookupCorePrepEnv top_env vh
- , etaExpansionTick head' tickish
+ , Just head' <- getIdFromTrivialExpr_maybe (lookupCorePrepEnv top_env vh)
+ , canCollectArgsThroughTick head' tickish
= (head,as')
where
(head,as') = go fun (AITick tickish : as)
@@ -1130,7 +1168,10 @@ cpeApp top_env expr
hd = getIdFromTrivialExpr_maybe e2
-- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
min_arity = case hd of
- Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing
+ Just v_hd ->
+ if cantEtaReduceFun v_hd
+ then Just $! idArity v_hd
+ else Nothing
Nothing -> Nothing
-- ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))
; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity
@@ -2293,8 +2334,8 @@ deFloatTop floats
get b _ = pprPanic "deFloatTop" (ppr b)
-- See Note [Dead code in CorePrep]
- get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e)
- get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
+ get_bind (NonRec x e) = NonRec x (occurAnalyseExpr_Prep e)
+ get_bind (Rec xes) = Rec [(x, occurAnalyseExpr_Prep e) | (x, e) <- xes]
---------------------------------------------------------------------------
=====================================
compiler/GHC/Driver/Config/Core/Lint.hs
=====================================
@@ -115,7 +115,8 @@ perPassFlags dflags pass
, lf_check_inline_loop_breakers = check_lbs
, lf_check_static_ptrs = check_static_ptrs
, lf_check_linearity = check_linearity
- , lf_check_rubbish_lits = check_rubbish }
+ , lf_check_rubbish_lits = check_rubbish
+ , lf_allow_weak_joins = allow_weak_joins }
where
-- See Note [Checking for global Ids]
check_globals = case pass of
@@ -152,6 +153,11 @@ perPassFlags dflags pass
CorePrep -> True
_ -> False
+ -- See Note [Linting join points with casts or ticks] in GHC.Core.Lint
+ allow_weak_joins = case pass of
+ CorePrep -> True
+ _ -> False
+
initLintConfig :: DynFlags -> [Var] -> LintConfig
initLintConfig dflags vars =LintConfig
{ l_diagOpts = initDiagOpts dflags
@@ -168,4 +174,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False
, lf_report_unsat_syns = True
, lf_check_fixed_rep = True
, lf_check_rubbish_lits = True
+ , lf_allow_weak_joins = False
}
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -1272,7 +1272,7 @@ tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
is_external = isExternalName name
--------- OccInfo ------------
- robust_occ_info = zapFragileOcc (occInfo idinfo)
+ robust_occ_info = zapFragileOccInfo (occInfo idinfo)
-- It's important to keep loop-breaker information
-- when we are doing -fexpose-all-unfoldings
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -1273,5 +1273,5 @@ cgTick tick
ProfNote cc t p -> emitSetCCC cc t p
HpcTick m n -> emit (mkTickBox platform m n)
SourceNote s n -> emitTick $ SourceNote s n
- _other -> return () -- ignore
+ Breakpoint {} -> return () -- ignore
}
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -66,7 +66,7 @@ module GHC.Types.Basic (
noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
bestOneShot, worstOneShot,
- OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,
+ OccInfo(..), noOccInfo, seqOccInfo, zapFragileOccInfo, isOneOcc,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
isNoOccInfo, strongLoopBreaker, weakLoopBreaker,
@@ -980,10 +980,13 @@ isOneOcc :: OccInfo -> Bool
isOneOcc (OneOcc {}) = True
isOneOcc _ = False
-zapFragileOcc :: OccInfo -> OccInfo
--- Keep only the most robust data: deadness, loop-breaker-hood
-zapFragileOcc (OneOcc {}) = noOccInfo
-zapFragileOcc occ = zapOccTailCallInfo occ
+-- | Keep only the most robust occurrence info: deadness, loop-breaker-hood.
+--
+-- In particular, it zaps 'TailCallInfo': see Note [JoinId vs TailCallInfo]
+-- in 'GHC.Core.Opt.Simplify.Env'.
+zapFragileOccInfo :: OccInfo -> OccInfo
+zapFragileOccInfo (OneOcc {}) = noOccInfo
+zapFragileOccInfo occ = zapOccTailCallInfo occ
instance Outputable OccInfo where
-- only used for debugging; never parsed. KSW 1999-07
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -914,14 +914,15 @@ zapUsedOnceInfo info
, demandInfo = zapUsedOnceDemand (demandInfo info) }
zapFragileInfo :: IdInfo -> Maybe IdInfo
--- ^ Zap info that depends on free variables
+-- ^ Zap fragile 'IdInfo', such as info that depends on free variables
+-- or fragile occurrence info (see 'zapFragileOccInfo').
zapFragileInfo info@(IdInfo { occInfo = occ, realUnfoldingInfo = unf })
= new_unf `seq` -- The unfolding field is not (currently) strict, so we
-- force it here to avoid a (zapFragileUnfolding unf) thunk
-- which might leak space
Just (info `setRuleInfo` emptyRuleInfo
`setUnfoldingInfo` new_unf
- `setOccInfo` zapFragileOcc occ)
+ `setOccInfo` zapFragileOccInfo occ)
where
new_unf = zapFragileUnfolding unf
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -6,9 +6,8 @@ module GHC.Types.Tickish (
CoreTickish, StgTickish, CmmTickish,
XTickishId,
tickishCounts,
- TickishScoping(..),
- tickishScoped,
- tickishScopesLike,
+ tickishHasNoScope,
+ tickishHasSoftScope,
tickishFloatable,
tickishCanSplit,
mkNoCount,
@@ -206,103 +205,177 @@ instance Binary BreakpointId where
--------------------------------------------------------------------------------
--- | A "counting tick" (where tickishCounts is True) is one that
+-- | A "counting tick" (for which 'tickishCounts' is True) is one that
-- counts evaluations in some way. We cannot discard a counting tick,
--- and the compiler should preserve the number of counting ticks as
--- far as possible.
+-- and the compiler should preserve the number of counting ticks (as
+-- far as possible).
--
--- However, we still allow the simplifier to increase or decrease
--- sharing, so in practice the actual number of ticks may vary, except
--- that we never change the value from zero to non-zero or vice versa.
+-- See Note [Counting ticks]
tickishCounts :: GenTickish pass -> Bool
-tickishCounts n@ProfNote{} = profNoteCount n
-tickishCounts HpcTick{} = True
-tickishCounts Breakpoint{} = True
-tickishCounts _ = False
-
-
--- | Specifies the scoping behaviour of ticks. This governs the
--- behaviour of ticks that care about the covered code and the cost
--- associated with it. Important for ticks relating to profiling.
-data TickishScoping =
- -- | No scoping: The tick does not care about what code it
- -- covers. Transformations can freely move code inside as well as
- -- outside without any additional annotation obligations
- NoScope
-
- -- | Soft scoping: We want all code that is covered to stay
- -- covered. Note that this scope type does not forbid
- -- transformations from happening, as long as all results of
- -- the transformations are still covered by this tick or a copy of
- -- it. For example
- --
- -- let x = tick<...> (let y = foo in bar) in baz
- -- ===>
- -- let x = tick<...> bar; y = tick<...> foo in baz
- --
- -- Is a valid transformation as far as "bar" and "foo" is
- -- concerned, because both still are scoped over by the tick.
- --
- -- Note though that one might object to the "let" not being
- -- covered by the tick any more. However, we are generally lax
- -- with this - constant costs don't matter too much, and given
- -- that the "let" was effectively merged we can view it as having
- -- lost its identity anyway.
- --
- -- Also note that this scoping behaviour allows floating a tick
- -- "upwards" in pretty much any situation. For example:
- --
- -- case foo of x -> tick<...> bar
- -- ==>
- -- tick<...> case foo of x -> bar
- --
- -- While this is always legal, we want to make a best effort to
- -- only make us of this where it exposes transformation
- -- opportunities.
- | SoftScope
-
- -- | Cost centre scoping: We don't want any costs to move to other
- -- cost-centre stacks. This means we not only want no code or cost
- -- to get moved out of their cost centres, but we also object to
- -- code getting associated with new cost-centre ticks - or
- -- changing the order in which they get applied.
- --
- -- A rule of thumb is that we don't want any code to gain new
- -- annotations. However, there are notable exceptions, for
- -- example:
- --
- -- let f = \y -> foo in tick<...> ... (f x) ...
- -- ==>
- -- tick<...> ... foo[x/y] ...
- --
- -- In-lining lambdas like this is always legal, because inlining a
- -- function does not change the cost-centre stack when the
- -- function is called.
- | CostCentreScope
-
- deriving (Eq)
-
--- | Returns the intended scoping rule for a Tickish
-tickishScoped :: GenTickish pass -> TickishScoping
-tickishScoped n@ProfNote{}
- | profNoteScope n = CostCentreScope
- | otherwise = NoScope
-tickishScoped HpcTick{} = NoScope
-tickishScoped Breakpoint{} = CostCentreScope
- -- Breakpoints are scoped: eventually we're going to do call
- -- stacks, but also this helps prevent the simplifier from moving
- -- breakpoints around and changing their result type (see #1531).
-tickishScoped SourceNote{} = SoftScope
-
--- | Returns whether the tick scoping rule is at least as permissive
--- as the given scoping rule.
-tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool
-tickishScopesLike t scope = tickishScoped t `like` scope
- where NoScope `like` _ = True
- _ `like` NoScope = False
- SoftScope `like` _ = True
- _ `like` SoftScope = False
- CostCentreScope `like` _ = True
+tickishCounts = \case
+ ProfNote { profNoteCount = counts } -> counts
+ HpcTick {} -> True
+ Breakpoint {} -> True
+ SourceNote {} -> False
+
+-- | Is this a non-scoping tick, for which we don't care about precisely
+-- the extent of code that the tick encompasses?
+--
+-- See Note [Scoped ticks]
+tickishHasNoScope :: GenTickish pass -> Bool
+tickishHasNoScope = \case
+ ProfNote { profNoteScope = scopes } -> not scopes
+ HpcTick {} -> True
+ Breakpoint {} -> False
+ SourceNote {} -> False
+
+-- | A "tick with soft scoping" (for which 'tickishHasSoftScope' is True) is
+-- one that either does not scope at all (for which 'tickishHasNoScope' is True),
+-- or that has a "soft" scope: we allow new code to be floated into to the scope,
+-- as long as all code that was covered remains covered.
+--
+-- See Note [Scoped ticks]
+tickishHasSoftScope :: GenTickish pass -> Bool
+tickishHasSoftScope = \case
+ ProfNote { profNoteScope = scopes } -> not scopes
+ HpcTick {} -> True
+ Breakpoint {} -> False
+ SourceNote {} -> True
+
+{- Note [Scoping ticks and counting ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticks have two independent attributes:
+
+ * Whether the tick /counts/.
+ Counting ticks are used when we want a counter to be bumped, e.g. counting
+ how many times a function is called.
+
+ See Note [Counting ticks]
+
+ * What kind of /scope/ the tick has:
+ * Cost-centre scope: you cannot move a redex into the scope of the tick,
+ nor can you float a redex out.
+ * Soft scope: you can move a redex /into/ the scope of a tick,
+ but you cannot float a redex /out/
+ * No scope: there are no restrictions on floating in or out.
+
+ See Note [Scoped ticks]
+
+Note [Counting ticks]
+~~~~~~~~~~~~~~~~~~~~
+The following ticks count:
+ - ProfNote ticks with profNoteCounts = True
+ - HPC ticks
+ - Breakpoints
+
+Going past a counting tick implies bumping a counter.
+Generally, the simplifier attempts to preserve counts when transforming
+programs and moving ticks, for example by transforming:
+
+ case <tick> e of
+ alt1 -> rhs1
+ alt2 -> rhs2
+
+to
+
+ case e of
+ alt1 -> <tick> rhs1
+ alt2 -> <tick> rhs2
+
+which preserves the total count (as exactly one branch of the case
+will be taken).
+
+However, we still allow the simplifier to increase or decrease
+sharing, so in practice the actual number of ticks may vary, except
+that we never change the value from zero to non-zero or vice-versa.
+
+Note [Scoped ticks]
+~~~~~~~~~~~~~~~~~~~~
+The following ticks are scoped:
+ - ProfNote ticks with profNoteScope = True
+ - Breakpoints
+ - Source notes
+
+A scoped tick is one that scopes over a portion of code. For example,
+an SCC anotation sets the cost centre for the code within; any allocations
+within that piece of code should get attributed to that cost centre.
+
+When the simplifier deals with a scoping tick, it ensures that all code that
+was covered remains covered. For example
+
+ let x = tick<...> (let y = foo in bar) in baz
+ ===>
+ let x = tick<...> bar; y = tick<...> foo in baz
+
+is a valid transformation as far as "bar" and "foo" are concerned, because
+both still are scoped over by the tick. One might object to the "let" not
+being covered by the tick any more. However, we are generally lax with this;
+constant costs don't matter too much, and given that the "let" was effectively
+merged we can view it as having lost its identity anyway.
+
+Perhaps surprisingly, breakpoints are considered to be scoped, because we
+don't want the simplifier to move them around, changing their result type (see #1531).
+
+We specifically forbid floating code outside of a scoping tick, as cost
+associated with the floated-out code would no longer be attributed to the
+appropriate scope.
+
+Whether we are allowed to float in additional cost depends on the tick:
+
+ Cost-centre scope ticks
+ - ProfNote with profNoteScope = True
+ - Breakpoints
+
+ A tick with cost-centre scope is one for which we can neither move
+ redexes into or move redexes outside of the tick. For example, we don't
+ want profiling costs to move to other cost-centre stacks.
+ Morever, we also object to changing the order in which such ticks
+ are applied.
+
+ A rule of thumb is that we don't want any code to gain new
+ lexically-enclosing ticks. For example, we should not transform:
+
+ f (scctick<foo> a) ==> scctick<foo> (f a)
+
+ as this would attribute the cost of evaluating the application 'f a'
+ to the cost centre 'foo'.
+
+ However, there are notable exceptions, for example:
+
+ let f = \y -> foo in tick<...> ... (f x) ...
+ ==>
+ tick<...> ... foo[x/y] ...
+
+ Inlining lambdas like this is always legal, because inlining a function
+ does not change the cost-centre stack when the function is called.
+
+ Soft scope ticks
+ - Source notes
+
+ A tick with soft scope is one for which we can move redexes inside the
+ tick, but cannot float redexes outside the tick. This is a slightly more
+ lenient notion of scoping than cost-centres, and is used only for source
+ note ticks (they are used to provide DWARF debug symbols, and for those
+ it matters less if code from outside gets moved under the tick).
+
+ Examples:
+
+ - FloatIn (GHC.Core.Opt.FloatIn.fiExpr)
+
+ let x = rhs in <tick> body
+ ==>
+ <tick> (let x = rhs in body)
+
+ - Moving a tick outside of a case or of an application
+ (GHC.Core.Opt.Simplify.Iteration.simplTick)
+
+ case <tick> e of alts ==> <tick> case e of alts
+
+ (<tick> e1) e2 ==> <tick> (e1 e2)
+
+ While these transformations are legal, we want to make a best effort to
+ only make use of them where it exposes transformation opportunities.
+-}
-- | Returns @True@ for ticks that can be floated upwards easily even
-- where it might change execution counts, such as:
@@ -311,12 +384,11 @@ tickishScopesLike t scope = tickishScoped t `like` scope
-- ==>
-- tick<...> (Just foo)
--
--- This is a combination of @tickishSoftScope@ and
--- @tickishCounts@. Note that in principle splittable ticks can become
--- floatable using @mkNoTick@ -- even though there's currently no
--- tickish for which that is the case.
+-- This is a combination of @tickishHasSoftScope@ and @tickishCounts@.
+-- Note that in principle splittable ticks can become floatable using @mkNoTick@,
+-- even though there's currently no tickish for which that is the case.
tickishFloatable :: GenTickish pass -> Bool
-tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)
+tickishFloatable t = tickishHasSoftScope t && not (tickishCounts t)
-- | Returns @True@ for a tick that is both counting /and/ scoping and
-- can be split into its (tick, scope) parts using 'mkNoScope' and
@@ -334,7 +406,7 @@ mkNoCount n@ProfNote{} = let n' = n {profNoteCount = False}
mkNoCount _ = panic "mkNoCount: Undefined split!"
mkNoScope :: GenTickish pass -> GenTickish pass
-mkNoScope n | tickishScoped n == NoScope = n
+mkNoScope n | tickishHasNoScope n = n
| not (tickishCanSplit n) = panic "mkNoScope: Cannot split!"
mkNoScope n@ProfNote{} = let n' = n {profNoteScope = False}
in assert (profNoteCount n) n'
@@ -357,7 +429,9 @@ mkNoScope _ = panic "mkNoScope: Undefined split!"
-- translate the code as if it found the latter.
tickishIsCode :: GenTickish pass -> Bool
tickishIsCode SourceNote{} = False
-tickishIsCode _tickish = True -- all the rest for now
+tickishIsCode ProfNote{} = True
+tickishIsCode Breakpoint{} = True
+tickishIsCode HpcTick{} = True
isProfTick :: GenTickish pass -> Bool
isProfTick ProfNote{} = True
=====================================
testsuite/tests/codeGen/should_compile/debug.stdout
=====================================
@@ -18,7 +18,6 @@ src<debug.hs:4:9>
src<debug.hs:5:21-29>
src<debug.hs:5:9-29>
src<debug.hs:6:1-21>
-src<debug.hs:6:16-21>
== CBE ==
src<debug.hs:4:9>
89
=====================================
testsuite/tests/simplCore/should_compile/T26642.hs
=====================================
@@ -0,0 +1,46 @@
+module T26642 ( saveClobberedTemps ) where
+
+import Prelude ( IO, Bool(..), Int, (>>=), (==), return )
+import Data.Word ( Word64 )
+
+-------------------------------------------------------------------------------
+
+data Word64Map a
+ = Bin (Word64Map a) (Word64Map a)
+ | Tip a
+ | Nil
+
+{-# NOINLINE myFoldr #-}
+myFoldr :: (a -> b -> b) -> b -> Word64Map a -> b
+myFoldr f = go
+ where
+ {-# NOINLINE go #-}
+ go z' Nil = z'
+ go z' (Tip x) = f x z'
+ go z' (Bin l r) = go (go z' r) l
+
+{-# NOINLINE nonDetFold #-}
+nonDetFold :: (b -> elt -> IO b) -> b -> Word64Map elt -> IO b
+nonDetFold f z0 xs = myFoldr c return xs z0
+ where
+ {-# NOINLINE c #-}
+ c x k z = f z x >>= k
+
+{-# NOINLINE myFalse #-}
+myFalse :: Bool
+myFalse = False
+
+type RealReg = Int
+data Loc = InReg RealReg | InMem
+
+saveClobberedTemps :: forall instr. [RealReg] -> IO [instr]
+saveClobberedTemps clobbered = nonDetFold maybe_spill [] Nil
+ where
+ {-# NOINLINE maybe_spill #-}
+ maybe_spill :: [instr] -> Loc -> IO [instr]
+ maybe_spill instrs !loc =
+ case loc of
+ InReg reg
+ | myFalse
+ -> return []
+ _ -> return instrs
=====================================
testsuite/tests/simplCore/should_compile/TrickyJoins.hs
=====================================
@@ -0,0 +1,154 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module TrickyJoinPoints where
+
+import Data.Coerce
+ ( coerce )
+import Data.Kind
+ ( Type )
+
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+-----------------------------------
+-- Join points and profiling ticks
+
+data ModGuts2 = MkModGuts2
+
+runCorePasses3 :: Bool -> ModGuts2 -> IO ModGuts2
+runCorePasses3 pass guts = doCorePass3 pass guts
+
+doCorePass3 :: Bool -> ModGuts2 -> IO ModGuts2
+doCorePass3 pass guts = do
+ _ <- putStrLn "hi"
+
+ let
+ updateBinds _ = return guts
+
+ case pass of
+ True -> {-# SCC "XXX3" #-} updateBinds False
+ _ -> {-# SCC "YYY3" #-} updateBinds True
+
+--------------------------
+-- Join points & casts
+
+newtype AdjacencyMap a = AM {
+ adjacencyMap :: Map a (Set.Set a) }
+
+overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a
+overlays = AM . Map.unionsWith Set.union . map adjacencyMap
+
+
+type SBool :: Bool -> Type
+data SBool b where
+ SFalse :: SBool False
+ STrue :: SBool True
+
+type N :: Bool -> Type
+data family N b
+newtype instance N False = NF ( Int -> Int )
+newtype instance N True = NT ( Int -> Int )
+
+testCast :: forall b. SBool b -> Int -> Int
+testCast b n =
+ case
+ ( let
+ {-# NOINLINE juliet #-}
+ juliet :: Int -> Int -> Int
+ juliet x = \ y -> x + y + n
+ in
+ case b of
+ SFalse -> NF (juliet 1)
+ STrue -> NT (juliet 2)
+ ) :: N b of
+ n | SFalse <- b
+ , NF f <- n
+ -> f 100
+ | STrue <- b
+ , NT g <- n
+ -> g 200
+
+
+------------------------------------------
+-- Join points, profiling ticks and casts
+
+newtype M = M ( Int -> Int -> Int )
+
+testCastTick :: forall b. SBool b -> Int -> Int
+testCastTick b n =
+ case
+ ( let
+ {-# NOINLINE j #-}
+ j :: Int -> Int -> Int
+ j x = \ y -> x + y + n
+ {-# NOINLINE k #-}
+ k :: M
+ k = coerce j
+ in
+ case b of
+ SFalse -> {-# SCC "ticked" #-} NF ( coerce @M @( Int -> Int -> Int ) k 1 )
+ STrue -> NT ( coerce @M @( Int -> Int -> Int ) k 2 )
+ ) :: N b of
+ n | SFalse <- b
+ , NF f <- n
+ -> f 100
+ | STrue <- b
+ , NT g <- n
+ -> g 200
+
+------------------------------------------
+
+{-# NOINLINE testJoinTransitivity #-}
+testJoinTransitivity :: Bool -> Int -> Int
+testJoinTransitivity b n =
+ let
+ f x = x ^ ( 99 :: Int ) + 7 * ( x - 19 )
+ {-# NOINLINE f #-}
+ in
+ f (
+ let
+ j1 :: Int -> Int
+ j1 x = x + n
+ {-# NOINLINE j1 #-}
+
+ j2 :: Int -> Int
+ j2 y = j1 (y * 2)
+ {-# NOINLINE j2 #-}
+
+ j3 :: Int -> Int
+ j3 z = j2 (z * 3)
+ {-# NOINLINE j3 #-}
+
+ in case b of
+ True -> {-# SCC "ticked" #-} j3 10
+ False -> j3 20
+ )
+
+--------------------------------------------------------------------------------
+-- Test relating to Note [JoinId vs TailCallInfo]
+
+expt :: Int -> Int
+expt _ = 3
+{-# NOINLINE expt #-}
+
+repro :: (Int, Int) -> (Int, Int)
+repro (f0,e0) =
+ let
+ (f,e) =
+ let n = e0
+ in
+ case n > 0 of
+ True -> (f0, e0 + n)
+ False -> (f0, e0)
+ r = let be = expt e in f * be
+ in
+ (r, 7)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -470,6 +470,9 @@ test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings
# go should become a join point
test('T22428', [grep_errmsg(r'jump go') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds -dsuppress-unfoldings'])
+test('TrickyJoins', normal, compile, [''])
+test('T26642', [unless(have_profiling(), skip)], compile, ['-O -prof -fprof-auto-calls'])
+
test('T22459', normal, compile, [''])
test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
test('T22662', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77b48b37fa767a00d747419c0483afa…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77b48b37fa767a00d747419c0483afa…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
01 Mar '26
Simon Peyton Jones pushed to branch wip/T26868 at Glasgow Haskell Compiler / GHC
Commits:
7c714caf by Simon Peyton Jones at 2026-02-28T23:47:11+00:00
Wibble error messages
- - - - -
15 changed files:
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Tc/Errors.hs
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/cpranal/should_compile/T18401.stderr
- testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/partial-sigs/should_compile/T10403.stderr
- testsuite/tests/partial-sigs/should_compile/T12844.stderr
- testsuite/tests/partial-sigs/should_compile/T15039a.stderr
- testsuite/tests/partial-sigs/should_compile/T15039b.stderr
- testsuite/tests/partial-sigs/should_compile/T15039c.stderr
- testsuite/tests/partial-sigs/should_compile/T15039d.stderr
- testsuite/tests/partial-sigs/should_fail/T10999.stderr
- testsuite/tests/partial-sigs/should_fail/T12634.stderr
Changes:
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -749,7 +749,12 @@ tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList
-- | Get the free vars of types in scoped order
tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
-tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList
+tyCoVarsOfTypesWellScoped tys
+-- = pprTrace "tyCoVarsOfTypesWellScoped"
+-- (vcat [ ppr tys
+-- , ppr (tyCoVarsOfTypesList tys)
+-- , ppr (scopedSort (tyCoVarsOfTypesList tys)) ]) $
+ = scopedSort (tyCoVarsOfTypesList tys)
{- *********************************************************************
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -2024,6 +2024,12 @@ mkTyVarEqErr' ctxt item tv1 ty2
{ mismatchMsg = headline_msg
, cannotUnifyReason = occurs_err }
+-- pprTrace "mkTyVarEqErr" (vcat
+-- [ text "interesting" <+> pprTyVars interesting_tyvars
+-- , text "tv1" <+> ppr tv1
+-- , text "free tvs1" <+> pprTyVars (tyCoVarsOfTypeList ty1)
+-- , text "ty2" <+> ppr ty2
+-- , text "free tvs2" <+> pprTyVars (tyCoVarsOfTypeList ty2) ]) $
return main_msg
-- If the immediately-enclosing implication has 'tv' a skolem, and
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -192,6 +192,7 @@ GHC.Types.Unique.Set
GHC.Types.Unique.Supply
GHC.Types.Var
GHC.Types.Var.Env
+GHC.Types.Var.FV
GHC.Types.Var.Set
GHC.Unit
GHC.Unit.Home
@@ -218,7 +219,6 @@ GHC.Utils.Containers.Internal.StrictPair
GHC.Utils.EndoOS
GHC.Utils.Error
GHC.Utils.Exception
-GHC.Utils.FV
GHC.Utils.Fingerprint
GHC.Utils.GlobalVars
GHC.Utils.IO.Unsafe
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -217,6 +217,7 @@ GHC.Types.Unique.Set
GHC.Types.Unique.Supply
GHC.Types.Var
GHC.Types.Var.Env
+GHC.Types.Var.FV
GHC.Types.Var.Set
GHC.Unit
GHC.Unit.Home
@@ -247,7 +248,6 @@ GHC.Utils.Containers.Internal.StrictPair
GHC.Utils.EndoOS
GHC.Utils.Error
GHC.Utils.Exception
-GHC.Utils.FV
GHC.Utils.Fingerprint
GHC.Utils.GlobalVars
GHC.Utils.IO.Unsafe
=====================================
testsuite/tests/cpranal/should_compile/T18401.stderr
=====================================
@@ -1,37 +1,34 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 58, types: 93, coercions: 0, joins: 1/1}
+Result size of Tidy Core = {terms: 52, types: 86, coercions: 0, joins: 0/0}
Rec {
-- RHS size: {terms: 18, types: 24, coercions: 0, joins: 0/0}
-T18401.$w$spoly_$wgo1 :: forall a. a -> [a] -> (# [a] #)
+T18401.$w$spoly_$wgo1 :: forall a. [a] -> a -> (# [a] #)
T18401.$w$spoly_$wgo1
- = \ (@a_s1eu) (sc_s1ev :: a_s1eu) (sc1_s1ew :: [a_s1eu]) ->
- case sc1_s1ew of {
- [] -> (# GHC.Types.[] @a_s1eu #);
- : y_a1dy ys_a1dz -> (# GHC.Types.: @a_s1eu sc_s1ev (case T18401.$w$spoly_$wgo1 @a_s1eu y_a1dy ys_a1dz of { (# ww_s1eA #) -> ww_s1eA }) #)
+ = \ (@a_s1fk) (sc_s1fl :: [a_s1fk]) (sc1_s1fm :: a_s1fk) ->
+ case sc_s1fl of {
+ [] -> (# GHC.Internal.Types.[] @a_s1fk #);
+ : y_a1eg ys_a1eh -> (# GHC.Internal.Types.: @a_s1fk sc1_s1fm (case T18401.$w$spoly_$wgo1 @a_s1fk ys_a1eh y_a1eg of { (# ww_s1fr #) -> ww_s1fr }) #)
}
end Rec }
--- RHS size: {terms: 23, types: 29, coercions: 0, joins: 1/1}
+-- RHS size: {terms: 17, types: 22, coercions: 0, joins: 0/0}
si :: forall a. [a] -> (Bool, [a])
si
- = \ (@a_s1dI) (xs0_s1dJ :: [a_s1dI]) ->
- join {
- $j_s1eq :: Bool %1 -> [a_s1dI] %1 -> (Bool, [a_s1dI])
- $j_s1eq (ww_s1dX :: Bool) (ww1_s1dY :: [a_s1dI]) = (ww_s1dX, ww1_s1dY) } in
- case xs0_s1dJ of {
- [] -> jump $j_s1eq GHC.Types.False (GHC.Types.[] @a_s1dI);
- : y_a1dy ys_a1dz -> jump $j_s1eq GHC.Types.True (case T18401.$w$spoly_$wgo1 @a_s1dI y_a1dy ys_a1dz of { (# ww_s1eA #) -> ww_s1eA })
+ = \ (@a_s1er) (xs0_s1es :: [a_s1er]) ->
+ case xs0_s1es of {
+ [] -> (GHC.Internal.Types.False, GHC.Internal.Types.[] @a_s1er);
+ : y_a1eg ys_a1eh -> (GHC.Internal.Types.True, case T18401.$w$spoly_$wgo1 @a_s1er ys_a1eh y_a1eg of { (# ww_s1fr #) -> ww_s1fr })
}
-- RHS size: {terms: 14, types: 19, coercions: 0, joins: 0/0}
safeInit :: forall a. [a] -> Maybe [a]
safeInit
- = \ (@a_aQY) (xs_awU :: [a_aQY]) ->
- case xs_awU of {
- [] -> GHC.Internal.Maybe.Nothing @[a_aQY];
- : y_a1dy ys_a1dz -> GHC.Internal.Maybe.Just @[a_aQY] (case T18401.$w$spoly_$wgo1 @a_aQY y_a1dy ys_a1dz of { (# ww_s1eA #) -> ww_s1eA })
+ = \ (@a_aUv) (xs_ax5 :: [a_aUv]) ->
+ case xs_ax5 of {
+ [] -> GHC.Internal.Maybe.Nothing @[a_aUv];
+ : y_a1eg ys_a1eh -> GHC.Internal.Maybe.Just @[a_aUv] (case T18401.$w$spoly_$wgo1 @a_aUv ys_a1eh y_a1eg of { (# ww_s1fr #) -> ww_s1fr })
}
=====================================
testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr
=====================================
@@ -5,13 +5,13 @@ deriving-via-fail4.hs:15:12: error: [GHC-18872]
• When deriving the instance for (Eq F1)
deriving-via-fail4.hs:18:13: error: [GHC-25897]
- • Couldn't match representation of type ‘a2’ with that of ‘a1’
+ • Couldn't match representation of type ‘a1’ with that of ‘a2’
arising from the coercion of the method ‘c’
from type ‘a -> a -> Bool’ to type ‘a -> F2 a1 -> Bool’
- ‘a2’ is a rigid type variable bound by
+ ‘a1’ is a rigid type variable bound by
the deriving clause for ‘C a (F2 a1)’
at deriving-via-fail4.hs:18:13-15
- ‘a1’ is a rigid type variable bound by
+ ‘a2’ is a rigid type variable bound by
the deriving clause for ‘C a (F2 a1)’
at deriving-via-fail4.hs:18:13-15
• When deriving the instance for (C a (F2 a1))
=====================================
testsuite/tests/indexed-types/should_fail/T2693.stderr
=====================================
@@ -1,38 +1,38 @@
T2693.hs:12:15: error: [GHC-83865]
- • Couldn't match expected type: (a8, b1)
+ • Couldn't match expected type: (a7, b1)
with actual type: TFn a6
The type variable ‘a6’ is ambiguous
• In the first argument of ‘fst’, namely ‘x’
In the first argument of ‘(+)’, namely ‘fst x’
In the expression: fst x + fst x
- • Relevant bindings include n :: a8 (bound at T2693.hs:12:7)
+ • Relevant bindings include n :: a7 (bound at T2693.hs:12:7)
T2693.hs:12:23: error: [GHC-83865]
- • Couldn't match expected type: (a8, b2)
- with actual type: TFn a7
- The type variable ‘a7’ is ambiguous
+ • Couldn't match expected type: (a7, b2)
+ with actual type: TFn a8
+ The type variable ‘a8’ is ambiguous
• In the first argument of ‘fst’, namely ‘x’
In the second argument of ‘(+)’, namely ‘fst x’
In the expression: fst x + fst x
- • Relevant bindings include n :: a8 (bound at T2693.hs:12:7)
+ • Relevant bindings include n :: a7 (bound at T2693.hs:12:7)
T2693.hs:19:15: error: [GHC-83865]
- • Couldn't match expected type: (a5, b0)
+ • Couldn't match expected type: (a3, b0)
with actual type: TFn a2
The type variable ‘a2’ is ambiguous
• In the first argument of ‘fst’, namely ‘x’
In the first argument of ‘(+)’, namely ‘fst x’
In the expression: fst x + snd x
- • Relevant bindings include n :: a5 (bound at T2693.hs:19:7)
+ • Relevant bindings include n :: a3 (bound at T2693.hs:19:7)
T2693.hs:19:23: error: [GHC-83865]
- • Couldn't match expected type: (a4, a5)
- with actual type: TFn a3
- The type variable ‘a3’ is ambiguous
+ • Couldn't match expected type: (a5, a3)
+ with actual type: TFn a4
+ The type variable ‘a4’ is ambiguous
• In the first argument of ‘snd’, namely ‘x’
In the second argument of ‘(+)’, namely ‘snd x’
In the expression: fst x + snd x
- • Relevant bindings include n :: a5 (bound at T2693.hs:19:7)
+ • Relevant bindings include n :: a3 (bound at T2693.hs:19:7)
T2693.hs:29:20: error: [GHC-83865]
• Couldn't match type: TFn a0
=====================================
testsuite/tests/partial-sigs/should_compile/T10403.stderr
=====================================
@@ -7,14 +7,14 @@ T10403.hs:16:7: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
T10403.hs:16:12: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’ standing for ‘(t -> b) -> f t -> H f’
- Where: ‘b’, ‘t’, ‘f’ are rigid type variables bound by
+ Where: ‘t’, ‘b’, ‘f’ are rigid type variables bound by
the inferred type of h1 :: Functor f => (t -> b) -> f t -> H f
at T10403.hs:18:1-41
• In the type signature: h1 :: _ => _
T10403.hs:20:7: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’ standing for ‘(t -> b) -> f t -> H f’
- Where: ‘b’, ‘t’, ‘f’ are rigid type variables bound by
+ Where: ‘t’, ‘b’, ‘f’ are rigid type variables bound by
the inferred type of h2 :: (t -> b) -> f t -> H f
at T10403.hs:23:1-41
• In the type signature: h2 :: _
=====================================
testsuite/tests/partial-sigs/should_compile/T12844.stderr
=====================================
@@ -1,10 +1,10 @@
-
T12844.hs:12:9: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found extra-constraints wildcard standing for
‘(Head rngs ~ '(r, r'), Foo rngs)’
- Where: ‘r’, ‘r'’, ‘k1’, ‘k2’, ‘rngs’
+ Where: ‘k1’, ‘k2’, ‘rngs’, ‘r’, ‘r'’
are rigid type variables bound by
the inferred type of
bar :: (Head rngs ~ '(r, r'), Foo rngs) => FooData rngs
at T12844.hs:(12,1)-(13,9)
• In the type signature: bar :: _ => FooData rngs
+
=====================================
testsuite/tests/partial-sigs/should_compile/T15039a.stderr
=====================================
@@ -1,4 +1,3 @@
-
T15039a.hs:19:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’ standing for ‘Dict (a ~ b)’
Where: ‘a’, ‘b’ are rigid type variables bound by
@@ -25,7 +24,7 @@ T15039a.hs:22:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)
T15039a.hs:25:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’ standing for ‘Dict (a ~~ b)’
- Where: ‘a’, ‘k’, ‘b’ are rigid type variables bound by
+ Where: ‘k’, ‘a’, ‘b’ are rigid type variables bound by
the type signature for:
ex3 :: forall a k (b :: k). Dict (a ~~ b) -> ()
at T15039a.hs:24:1-43
@@ -54,3 +53,4 @@ T15039a.hs:35:8: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
at T15039a.hs:35:1-44
• In the type signature:
ex7 :: _ => Coercion (a :: Type) (b :: Type)
+
=====================================
testsuite/tests/partial-sigs/should_compile/T15039b.stderr
=====================================
@@ -1,4 +1,3 @@
-
T15039b.hs:19:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’ standing for ‘Dict ((a :: *) ~ (b :: *))’
Where: ‘a’, ‘b’ are rigid type variables bound by
@@ -26,7 +25,7 @@ T15039b.hs:22:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)
T15039b.hs:25:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’
standing for ‘Dict ((a :: *) ~~ (b :: k))’
- Where: ‘a’, ‘k’, ‘b’ are rigid type variables bound by
+ Where: ‘k’, ‘a’, ‘b’ are rigid type variables bound by
the type signature for:
ex3 :: forall a k (b :: k). Dict ((a :: *) ~~ (b :: k)) -> ()
at T15039b.hs:24:1-43
@@ -56,3 +55,4 @@ T15039b.hs:35:8: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
at T15039b.hs:35:1-44
• In the type signature:
ex7 :: _ => Coercion (a :: Type) (b :: Type)
+
=====================================
testsuite/tests/partial-sigs/should_compile/T15039c.stderr
=====================================
@@ -1,4 +1,3 @@
-
T15039c.hs:19:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’ standing for ‘Dict (a ~ b)’
Where: ‘a’, ‘b’ are rigid type variables bound by
@@ -25,7 +24,7 @@ T15039c.hs:22:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)
T15039c.hs:25:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’ standing for ‘Dict (a ~~ b)’
- Where: ‘a’, ‘k’, ‘b’ are rigid type variables bound by
+ Where: ‘k’, ‘a’, ‘b’ are rigid type variables bound by
the type signature for:
ex3 :: forall a k (b :: k). Dict (a ~~ b) -> ()
at T15039c.hs:24:1-43
@@ -54,3 +53,4 @@ T15039c.hs:35:8: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
at T15039c.hs:35:1-44
• In the type signature:
ex7 :: _ => Coercion (a :: Type) (b :: Type)
+
=====================================
testsuite/tests/partial-sigs/should_compile/T15039d.stderr
=====================================
@@ -1,4 +1,3 @@
-
T15039d.hs:19:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’ standing for ‘Dict ((a :: *) ~ (b :: *))’
Where: ‘a’, ‘b’ are rigid type variables bound by
@@ -27,7 +26,7 @@ T15039d.hs:22:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)
T15039d.hs:25:14: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
• Found type wildcard ‘_’
standing for ‘Dict ((a :: *) ~~ (b :: k))’
- Where: ‘a’, ‘k’, ‘b’ are rigid type variables bound by
+ Where: ‘k’, ‘a’, ‘b’ are rigid type variables bound by
the type signature for:
ex3 :: forall a k (b :: k). Dict ((a :: *) ~~ (b :: k)) -> ()
at T15039d.hs:24:1-43
@@ -57,3 +56,4 @@ T15039d.hs:35:8: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
at T15039d.hs:35:1-44
• In the type signature:
ex7 :: _ => Coercion (a :: Type) (b :: Type)
+
=====================================
testsuite/tests/partial-sigs/should_fail/T10999.stderr
=====================================
@@ -15,10 +15,10 @@ T10999.hs:5:17: error: [GHC-88464]
• In the type signature: f :: _ => () -> _
T10999.hs:8:28: error: [GHC-39999]
- • Ambiguous type variable ‘b1’ arising from a use of ‘f’
- prevents the constraint ‘(Ord b1)’ from being solved.
- Relevant bindings include g :: [b1] (bound at T10999.hs:8:1)
- Probable fix: use a type annotation to specify what ‘b1’ should be.
+ • Ambiguous type variable ‘b0’ arising from a use of ‘f’
+ prevents the constraint ‘(Ord b0)’ from being solved.
+ Relevant bindings include g :: [b0] (bound at T10999.hs:8:1)
+ Probable fix: use a type annotation to specify what ‘b0’ should be.
Potentially matching instances:
instance Ord a => Ord (Set.Intersection a)
-- Defined in ‘Data.Set.Internal’
=====================================
testsuite/tests/partial-sigs/should_fail/T12634.stderr
=====================================
@@ -1,9 +1,9 @@
-
T12634.hs:15:58: error: [GHC-83865]
• Expected a type,
but ‘'(t, m, m', r)’ has kind
- ‘(k1 -> k2 -> *, k0, k1, k2)’
+ ‘(k0 -> k1 -> *, k2, k0, k1)’
• In the first argument of ‘Bench’, namely ‘'(t, m, m', r)’
In the type signature:
bench_twacePow :: forall t m m' r. _ =>
t m' r -> Bench '(t, m, m', r)
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c714cafd41c42f19debb2fca76667b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c714cafd41c42f19debb2fca76667b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/int-index/star-exp] Extend HsExpr with the StarIsType syntax (#26587, #26967)
by Vladislav Zavialov (＠int-index) 01 Mar '26
by Vladislav Zavialov (＠int-index) 01 Mar '26
01 Mar '26
Vladislav Zavialov pushed to branch wip/int-index/star-exp at Glasgow Haskell Compiler / GHC
Commits:
11243c8d by Vladislav Zavialov at 2026-03-01T01:58:10+03:00
Extend HsExpr with the StarIsType syntax (#26587, #26967)
This patch allows kinds of the form `k -> *` and `* -> k` to occur in
expression syntax, i.e. to be used as required type arguments.
For example:
{-# LANGUAGE RequiredTypeArguments, StarIsType #-}
x1 = f (* -> * -> *)
x2 = f (forall k. k -> *)
x3 = f ((* -> *) -> Constraint)
Summary of the changes:
* Introduce the HsStar constructor of HsExpr and its extension field XStar.
It is analogous to HsStarTy in HsType.
* Refactor HsStarTy to store the unicode flag as TokStar, defined as
type TokStar = EpUniToken "*" "★" -- similar to TokForall, TokRArrow, etc.
The token is stored in the extension field and replaces the Bool field.
* Extend the `infixexp2` nonterminal to parse `*` as a direct argument of `->`.
This is more limited than the full StarIsType syntax, but has the nice
property of not conflicting with the multiplication operator `a * b`.
Test case: T26967
- - - - -
35 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Type.hs
- docs/users_guide/exts/required_type_arguments.rst
- + testsuite/tests/vdq-rta/should_compile/T26967.hs
- + testsuite/tests/vdq-rta/should_compile/T26967.stderr
- testsuite/tests/vdq-rta/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11243c8de7e2d2dd7d79cd1431277c8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11243c8de7e2d2dd7d79cd1431277c8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/int-index/star-exp
by Vladislav Zavialov (＠int-index) 28 Feb '26
by Vladislav Zavialov (＠int-index) 28 Feb '26
28 Feb '26
Vladislav Zavialov pushed new branch wip/int-index/star-exp at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/star-exp
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/system-io-uncovering] Remove in-package dependencies on `GHC.Internal.System.IO`
by Wolfgang Jeltsch (＠jeltsch) 28 Feb '26
by Wolfgang Jeltsch (＠jeltsch) 28 Feb '26
28 Feb '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/system-io-uncovering at Glasgow Haskell Compiler / GHC
Commits:
d5fe2582 by Wolfgang Jeltsch at 2026-02-28T17:04:55+02:00
Remove in-package dependencies on `GHC.Internal.System.IO`
This contribution eliminates all dependencies on
`GHC.Internal.System.IO` from within `ghc-internal`. It comprises the
following changes:
* Make `GHC.Internal.Fingerprint` independent of I/O support
* Tighten the dependencies of `GHC.Internal.Data.Version`
* Tighten the dependencies of `GHC.Internal.TH.Monad`
* Tighten the dependencies of `GHCi.Helpers`
* Move the `* -> *` `Heap.Closure` instances into `ghc-heap`
* Move some code that needs `System.IO` to `template-haskell`
* Move the `GHC.ResponseFile` implementation into `base`
* Move the `System.Exit` implementation into `base`
* Move the `System.IO.OS` implementation into `base`
Metric Decrease:
size_hello_artifact
size_hello_artifact_gzip
size_hello_unicode
size_hello_unicode_gzip
- - - - -
15 changed files:
- libraries/base/src/GHC/Fingerprint.hs
- libraries/base/src/GHC/ResponseFile.hs
- libraries/base/src/System/Exit.hs
- libraries/base/src/System/IO/OS.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs
- libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs
- libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- − libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs
- − libraries/ghc-internal/src/GHC/Internal/System/Exit.hs
- − libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
Changes:
=====================================
libraries/base/src/GHC/Fingerprint.hs
=====================================
@@ -9,3 +9,45 @@ module GHC.Fingerprint (
) where
import GHC.Internal.Fingerprint
+
+import Data.Function (($))
+import Control.Monad (return, when)
+import Data.Bool (not, (&&))
+import Data.List ((++))
+import Data.Maybe (Maybe (Nothing, Just))
+import Data.Int (Int)
+import Data.Word (Word8)
+import Data.Eq ((/=))
+import Text.Show (show)
+import System.IO
+ (
+ IO,
+ FilePath,
+ IOMode (ReadMode),
+ withBinaryFile,
+ hGetBuf,
+ hIsEOF
+ )
+import Foreign.Ptr (Ptr)
+import GHC.Err (errorWithoutStackTrace)
+
+-- | Computes the hash of a given file.
+-- This function runs in constant memory.
+--
+-- @since base-4.7.0.0
+getFileHash :: FilePath -> IO Fingerprint
+getFileHash path = withBinaryFile path ReadMode $ \ hdl ->
+ let
+ readChunk :: Ptr Word8 -> Int -> IO (Maybe Int)
+ readChunk bufferPtr bufferSize = do
+ chunkSize <- hGetBuf hdl bufferPtr bufferSize
+ isFinished <- hIsEOF hdl
+ when (chunkSize /= bufferSize && not isFinished)
+ (
+ errorWithoutStackTrace $
+ "GHC.Fingerprint.getFileHash: could only read " ++
+ show chunkSize ++
+ " bytes, but more are available"
+ )
+ return (if isFinished then Just chunkSize else Nothing)
+ in fingerprintBufferedStream readChunk
=====================================
libraries/base/src/GHC/ResponseFile.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Safe #-}
-- |
@@ -19,4 +20,145 @@ module GHC.ResponseFile (
expandResponse
) where
-import GHC.Internal.ResponseFile
+import Control.Monad (return, (>>=), mapM)
+import Control.Exception (IOException, catch)
+import Data.Function (($), (.))
+import Data.Bool (Bool (False, True), otherwise, not, (||))
+import Data.Char (Char, isSpace)
+import Data.List ((++), map, filter, concat, reverse)
+import Data.String (String, unlines)
+import Data.Functor (fmap)
+import Data.Foldable (null, foldl')
+import Data.Eq ((==))
+import Text.Show (show)
+import System.Environment (getArgs)
+import System.IO (IO, hPutStrLn, readFile, stderr)
+import System.Exit (exitFailure)
+
+{-|
+Like 'getArgs', but can also read arguments supplied via response files.
+
+
+For example, consider a program @foo@:
+
+@
+main :: IO ()
+main = do
+ args <- getArgsWithResponseFiles
+ putStrLn (show args)
+@
+
+
+And a response file @args.txt@:
+
+@
+--one 1
+--\'two\' 2
+--"three" 3
+@
+
+Then the result of invoking @foo@ with @args.txt@ is:
+
+> > ./foo @args.txt
+> ["--one","1","--two","2","--three","3"]
+
+-}
+getArgsWithResponseFiles :: IO [String]
+getArgsWithResponseFiles = getArgs >>= expandResponse
+
+-- | Given a string of concatenated strings, separate each by removing
+-- a layer of /quoting/ and\/or /escaping/ of certain characters.
+--
+-- These characters are: any whitespace, single quote, double quote,
+-- and the backslash character. The backslash character always
+-- escapes (i.e., passes through without further consideration) the
+-- character which follows. Characters can also be escaped in blocks
+-- by quoting (i.e., surrounding the blocks with matching pairs of
+-- either single- or double-quotes which are not themselves escaped).
+--
+-- Any whitespace which appears outside of either of the quoting and
+-- escaping mechanisms, is interpreted as having been added by this
+-- special concatenation process to designate where the boundaries
+-- are between the original, un-concatenated list of strings. These
+-- added whitespace characters are removed from the output.
+--
+-- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""]
+unescapeArgs :: String -> [String]
+unescapeArgs = filter (not . null) . unescape
+
+-- | Given a list of strings, concatenate them into a single string
+-- with escaping of certain characters, and the addition of a newline
+-- between each string. The escaping is done by adding a single
+-- backslash character before any whitespace, single quote, double
+-- quote, or backslash character, so this escaping character must be
+-- removed. Unescaped whitespace (in this case, newline) is part
+-- of this "transport" format to indicate the end of the previous
+-- string and the start of a new string.
+--
+-- While 'unescapeArgs' allows using quoting (i.e., convenient
+-- escaping of many characters) by having matching sets of single- or
+-- double-quotes,'escapeArgs' does not use the quoting mechanism,
+-- and thus will always escape any whitespace, quotes, and
+-- backslashes.
+--
+-- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n"
+escapeArgs :: [String] -> String
+escapeArgs = unlines . map escapeArg
+
+-- | Arguments which look like @\@foo@ will be replaced with the
+-- contents of file @foo@. A gcc-like syntax for response files arguments
+-- is expected. This must re-constitute the argument list by doing an
+-- inverse of the escaping mechanism done by the calling-program side.
+--
+-- We quit if the file is not found or reading somehow fails.
+-- (A convenience routine for haddock or possibly other clients)
+expandResponse :: [String] -> IO [String]
+expandResponse = fmap concat . mapM expand
+ where
+ expand :: String -> IO [String]
+ expand ('@':f) = readFileExc f >>= return . unescapeArgs
+ expand x = return [x]
+
+ readFileExc f =
+ readFile f `catch` \(e :: IOException) -> do
+ hPutStrLn stderr $ "Error while expanding response file: " ++ show e
+ exitFailure
+
+data Quoting = NoneQ | SngQ | DblQ
+
+unescape :: String -> [String]
+unescape args = reverse . map reverse $ go args NoneQ False [] []
+ where
+ -- n.b., the order of these cases matters; these are cribbed from gcc
+ -- case 1: end of input
+ go [] _q _bs a as = a:as
+ -- case 2: back-slash escape in progress
+ go (c:cs) q True a as = go cs q False (c:a) as
+ -- case 3: no back-slash escape in progress, but got a back-slash
+ go (c:cs) q False a as
+ | '\\' == c = go cs q True a as
+ -- case 4: single-quote escaping in progress
+ go (c:cs) SngQ False a as
+ | '\'' == c = go cs NoneQ False a as
+ | otherwise = go cs SngQ False (c:a) as
+ -- case 5: double-quote escaping in progress
+ go (c:cs) DblQ False a as
+ | '"' == c = go cs NoneQ False a as
+ | otherwise = go cs DblQ False (c:a) as
+ -- case 6: no escaping is in progress
+ go (c:cs) NoneQ False a as
+ | isSpace c = go cs NoneQ False [] (a:as)
+ | '\'' == c = go cs SngQ False a as
+ | '"' == c = go cs DblQ False a as
+ | otherwise = go cs NoneQ False (c:a) as
+
+escapeArg :: String -> String
+escapeArg = reverse . foldl' escape []
+
+escape :: String -> Char -> String
+escape cs c
+ | isSpace c
+ || '\\' == c
+ || '\'' == c
+ || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result
+ | otherwise = c:cs
=====================================
libraries/base/src/System/Exit.hs
=====================================
@@ -21,4 +21,67 @@ module System.Exit
die
) where
-import GHC.Internal.System.Exit
\ No newline at end of file
+import GHC.IO.Exception
+ (
+ IOErrorType (InvalidArgument),
+ IOException (IOError),
+ ExitCode (ExitSuccess, ExitFailure)
+ )
+import Control.Monad ((>>))
+import Control.Exception (throwIO, ioError)
+import Data.Bool (otherwise)
+import Data.Maybe (Maybe (Nothing))
+import Data.String (String)
+import Data.Eq ((/=))
+import System.IO (IO, hPutStrLn, stderr)
+
+-- ---------------------------------------------------------------------------
+-- exitWith
+
+-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@.
+-- Normally this terminates the program, returning @code@ to the
+-- program's caller.
+--
+-- On program termination, the standard 'Handle's 'stdout' and
+-- 'stderr' are flushed automatically; any other buffered 'Handle's
+-- need to be flushed manually, otherwise the buffered data will be
+-- discarded.
+--
+-- A program that fails in any other way is treated as if it had
+-- called 'exitFailure'.
+-- A program that terminates successfully without calling 'exitWith'
+-- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'.
+--
+-- As an 'ExitCode' is an 'Control.Exception.Exception', it can be
+-- caught using the functions of "Control.Exception". This means that
+-- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from
+-- "Control.Exception") are also executed properly on 'exitWith'.
+--
+-- Note: in GHC, 'exitWith' should be called from the main program
+-- thread in order to exit the process. When called from another
+-- thread, 'exitWith' will throw an 'ExitCode' as normal, but the
+-- exception will not cause the process itself to exit.
+--
+exitWith :: ExitCode -> IO a
+exitWith ExitSuccess = throwIO ExitSuccess
+exitWith code@(ExitFailure n)
+ | n /= 0 = throwIO code
+ | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing)
+
+-- | The computation 'exitFailure' is equivalent to
+-- 'exitWith' @(@'ExitFailure' /exitfail/@)@,
+-- where /exitfail/ is implementation-dependent.
+exitFailure :: IO a
+exitFailure = exitWith (ExitFailure 1)
+
+-- | The computation 'exitSuccess' is equivalent to
+-- 'exitWith' 'ExitSuccess', It terminates the program
+-- successfully.
+exitSuccess :: IO a
+exitSuccess = exitWith ExitSuccess
+
+-- | Write given error message to `stderr` and terminate with `exitFailure`.
+--
+-- @since base-4.8.0.0
+die :: String -> IO a
+die err = hPutStrLn stderr err >> exitFailure
=====================================
libraries/base/src/System/IO/OS.hs
=====================================
@@ -1,4 +1,6 @@
{-# LANGUAGE Safe #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
{-|
This module bridges between Haskell handles and underlying operating-system
@@ -21,17 +23,293 @@ module System.IO.OS
)
where
-import GHC.Internal.System.IO.OS
+import Control.Monad (return)
+import Control.Concurrent.MVar (MVar)
+import Control.Exception (mask)
+import Data.Function (const, (.), ($))
+import Data.Functor (fmap)
+import Data.Maybe (Maybe (Nothing), maybe)
+#if defined(mingw32_HOST_OS)
+import Data.Bool (otherwise)
+import Data.Maybe (Maybe (Just))
+#endif
+import Data.List ((++))
+import Data.String (String)
+import Data.Typeable (Typeable, cast)
+import System.IO (IO)
+import GHC.IO.FD (fdFD)
+#if defined(mingw32_HOST_OS)
+import GHC.IO.Windows.Handle
(
- withFileDescriptorReadingBiased,
- withFileDescriptorWritingBiased,
- withWindowsHandleReadingBiased,
- withWindowsHandleWritingBiased,
- withFileDescriptorReadingBiasedRaw,
- withFileDescriptorWritingBiasedRaw,
- withWindowsHandleReadingBiasedRaw,
- withWindowsHandleWritingBiasedRaw
+ NativeHandle,
+ ConsoleHandle,
+ IoHandle,
+ toHANDLE
)
+#endif
+import GHC.IO.Handle.Types
+ (
+ Handle (FileHandle, DuplexHandle),
+ Handle__ (Handle__, haDevice)
+ )
+import GHC.IO.Handle.Internals (withHandle_', flushBuffer)
+import GHC.IO.Exception
+ (
+ IOErrorType (InappropriateType),
+ IOException (IOError),
+ ioException
+ )
+import Foreign.Ptr (Ptr)
+import Foreign.C.Types (CInt)
+
+-- * Obtaining POSIX file descriptors and Windows handles
+
+{-|
+ Executes a user-provided action on an operating-system handle that underlies
+ a Haskell handle. Before the user-provided action is run, user-defined
+ preparation based on the handle state that contains the operating-system
+ handle is performed. While the user-provided action is executed, further
+ operations on the Haskell handle are blocked to a degree that interference
+ with this action is prevented.
+
+ See [below](#with-ref-caveats) for caveats regarding this operation.
+-}
+withOSHandle :: String
+ -- ^ The name of the overall operation
+ -> (Handle -> MVar Handle__)
+ {-^
+ Obtaining of the handle state variable that holds the
+ operating-system handle
+ -}
+ -> (forall d. Typeable d => d -> IO a)
+ -- ^ Conversion of a device into an operating-system handle
+ -> (Handle__ -> IO ())
+ -- ^ The preparation
+ -> Handle
+ -- ^ The Haskell handle to use
+ -> (a -> IO r)
+ -- ^ The action to execute on the operating-system handle
+ -> IO r
+withOSHandle opName handleStateVar getOSHandle prepare handle act
+ = mask $ \ withOriginalMaskingState ->
+ withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do
+ osHandle <- getOSHandle dev
+ prepare handleState
+ withOriginalMaskingState $ act osHandle
+ where
+
+ withHandleState = withHandle_' opName handle (handleStateVar handle)
+{-
+ The 'withHandle_'' operation, which we use here, already performs masking.
+ Still, we have to employ 'mask', in order do obtain the operation that
+ restores the original masking state. The user-provided action should be
+ executed with this original masking state, as there is no inherent reason to
+ generally perform it with masking in place. The masking that 'withHandle_''
+ performs is only for safely accessing handle state and thus constitutes an
+ implementation detail; it has nothing to do with the user-provided action.
+-}
+{-
+ The order of actions in 'withOSHandle' is such that any exception from
+ 'getOSHandle' is thrown before the user-defined preparation is performed.
+-}
+
+{-|
+ Obtains the handle state variable that underlies a handle or specifically
+ the handle state variable for reading if the handle uses different state
+ variables for reading and writing.
+-}
+handleStateVarReadingBiased :: Handle -> MVar Handle__
+handleStateVarReadingBiased (FileHandle _ var) = var
+handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar
+
+{-|
+ Obtains the handle state variable that underlies a handle or specifically
+ the handle state variable for writing if the handle uses different state
+ variables for reading and writing.
+-}
+handleStateVarWritingBiased :: Handle -> MVar Handle__
+handleStateVarWritingBiased (FileHandle _ var) = var
+handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar
+
+{-|
+ Yields the result of another operation if that operation succeeded, and
+ otherwise throws an exception that signals that the other operation failed
+ because some Haskell handle does not use an operating-system handle of a
+ required type.
+-}
+requiringOSHandleOfType :: String
+ -- ^ The name of the operating-system handle type
+ -> Maybe a
+ {-^
+ The result of the other operation if it succeeded
+ -}
+ -> IO a
+requiringOSHandleOfType osHandleTypeName
+ = maybe (ioException osHandleOfTypeRequired) return
+ where
+
+ osHandleOfTypeRequired :: IOException
+ osHandleOfTypeRequired
+ = IOError Nothing
+ InappropriateType
+ ""
+ ("handle does not use " ++ osHandleTypeName ++ "s")
+ Nothing
+ Nothing
+
+{-|
+ Obtains the POSIX file descriptor of a device if the device contains one,
+ and throws an exception otherwise.
+-}
+getFileDescriptor :: Typeable d => d -> IO CInt
+getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" .
+ fmap fdFD . cast
+
+{-|
+ Obtains the Windows handle of a device if the device contains one, and
+ throws an exception otherwise.
+-}
+getWindowsHandle :: Typeable d => d -> IO (Ptr ())
+getWindowsHandle = requiringOSHandleOfType "Windows handle" .
+ toMaybeWindowsHandle
+ where
+
+ toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ())
+#if defined(mingw32_HOST_OS)
+ toMaybeWindowsHandle dev
+ | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle)
+ = Just (toHANDLE nativeHandle)
+ | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle)
+ = Just (toHANDLE consoleHandle)
+ | otherwise
+ = Nothing
+ {-
+ This is inspired by the implementation of
+ 'System.Win32.Types.withHandleToHANDLENative'.
+ -}
+#else
+ toMaybeWindowsHandle _ = Nothing
+#endif
+
+{-|
+ Executes a user-provided action on the POSIX file descriptor that underlies
+ a handle or specifically on the POSIX file descriptor for reading if the
+ handle uses different file descriptors for reading and writing. The
+ Haskell-managed buffers related to the file descriptor are flushed before
+ the user-provided action is run. While this action is executed, further
+ operations on the handle are blocked to a degree that interference with this
+ action is prevented.
+
+ If the handle does not use POSIX file descriptors, an exception is thrown.
+
+ See [below](#with-ref-caveats) for caveats regarding this operation.
+-}
+withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r
+withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased"
+ handleStateVarReadingBiased
+ getFileDescriptor
+ flushBuffer
+
+{-|
+ Executes a user-provided action on the POSIX file descriptor that underlies
+ a handle or specifically on the POSIX file descriptor for writing if the
+ handle uses different file descriptors for reading and writing. The
+ Haskell-managed buffers related to the file descriptor are flushed before
+ the user-provided action is run. While this action is executed, further
+ operations on the handle are blocked to a degree that interference with this
+ action is prevented.
+
+ If the handle does not use POSIX file descriptors, an exception is thrown.
+
+ See [below](#with-ref-caveats) for caveats regarding this operation.
+-}
+withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r
+withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased"
+ handleStateVarWritingBiased
+ getFileDescriptor
+ flushBuffer
+
+{-|
+ Executes a user-provided action on the Windows handle that underlies a
+ Haskell handle or specifically on the Windows handle for reading if the
+ Haskell handle uses different Windows handles for reading and writing. The
+ Haskell-managed buffers related to the Windows handle are flushed before the
+ user-provided action is run. While this action is executed, further
+ operations on the Haskell handle are blocked to a degree that interference
+ with this action is prevented.
+
+ If the Haskell handle does not use Windows handles, an exception is thrown.
+
+ See [below](#with-ref-caveats) for caveats regarding this operation.
+-}
+withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r
+withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased"
+ handleStateVarReadingBiased
+ getWindowsHandle
+ flushBuffer
+
+{-|
+ Executes a user-provided action on the Windows handle that underlies a
+ Haskell handle or specifically on the Windows handle for writing if the
+ Haskell handle uses different Windows handles for reading and writing. The
+ Haskell-managed buffers related to the Windows handle are flushed before the
+ user-provided action is run. While this action is executed, further
+ operations on the Haskell handle are blocked to a degree that interference
+ with this action is prevented.
+
+ If the Haskell handle does not use Windows handles, an exception is thrown.
+
+ See [below](#with-ref-caveats) for caveats regarding this operation.
+-}
+withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r
+withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased"
+ handleStateVarWritingBiased
+ getWindowsHandle
+ flushBuffer
+
+{-|
+ Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers
+ are not flushed.
+-}
+withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r
+withFileDescriptorReadingBiasedRaw
+ = withOSHandle "withFileDescriptorReadingBiasedRaw"
+ handleStateVarReadingBiased
+ getFileDescriptor
+ (const $ return ())
+
+{-|
+ Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers
+ are not flushed.
+-}
+withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r
+withFileDescriptorWritingBiasedRaw
+ = withOSHandle "withFileDescriptorWritingBiasedRaw"
+ handleStateVarWritingBiased
+ getFileDescriptor
+ (const $ return ())
+
+{-|
+ Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers
+ are not flushed.
+-}
+withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r
+withWindowsHandleReadingBiasedRaw
+ = withOSHandle "withWindowsHandleReadingBiasedRaw"
+ handleStateVarReadingBiased
+ getWindowsHandle
+ (const $ return ())
+
+{-|
+ Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers
+ are not flushed.
+-}
+withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r
+withWindowsHandleWritingBiasedRaw
+ = withOSHandle "withWindowsHandleWritingBiasedRaw"
+ handleStateVarWritingBiased
+ getWindowsHandle
+ (const $ return ())
-- ** Caveats
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -1,10 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE GHCForeignImportPrim #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE UnliftedFFITypes #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
-- Late cost centres introduce a thunk in the asBox function, which leads to
-- an additional wrapper being added to any value placed inside a box.
@@ -42,3 +37,23 @@ module GHC.Exts.Heap.Closures (
) where
import GHC.Internal.Heap.Closures
+
+import GHC.Internal.Data.Functor
+import GHC.Internal.Data.Foldable
+import GHC.Internal.Data.Traversable
+
+deriving instance Functor GenClosure
+deriving instance Foldable GenClosure
+deriving instance Traversable GenClosure
+
+deriving instance Functor GenStgStackClosure
+deriving instance Foldable GenStgStackClosure
+deriving instance Traversable GenStgStackClosure
+
+deriving instance Functor GenStackField
+deriving instance Foldable GenStackField
+deriving instance Traversable GenStackField
+
+deriving instance Functor GenStackFrame
+deriving instance Foldable GenStackFrame
+deriving instance Traversable GenStackFrame
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -284,7 +284,6 @@ Library
GHC.Internal.Read
GHC.Internal.Real
GHC.Internal.Records
- GHC.Internal.ResponseFile
GHC.Internal.RTS.Flags
GHC.Internal.RTS.Flags.Test
GHC.Internal.ST
@@ -323,10 +322,8 @@ Library
GHC.Internal.Numeric.Natural
GHC.Internal.System.Environment
GHC.Internal.System.Environment.Blank
- GHC.Internal.System.Exit
GHC.Internal.System.IO
GHC.Internal.System.IO.Error
- GHC.Internal.System.IO.OS
GHC.Internal.System.Mem
GHC.Internal.System.Mem.StableName
GHC.Internal.System.Posix.Internals
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
=====================================
@@ -41,8 +41,7 @@ import GHC.Internal.Data.Eq
import GHC.Internal.Int ( Int )
import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) )
import GHC.Internal.Data.Ord
-import GHC.Internal.Data.String ( String )
-import GHC.Internal.Base ( Applicative(..), (&&) )
+import GHC.Internal.Base ( Applicative(..), (&&), String )
import GHC.Internal.Generics
import GHC.Internal.Unicode ( isDigit, isAlphaNum )
import GHC.Internal.Read
=====================================
libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs
=====================================
@@ -16,23 +16,22 @@ module GHC.Internal.Fingerprint (
fingerprintData,
fingerprintString,
fingerprintFingerprints,
- getFileHash
+ fingerprintBufferedStream
) where
import GHC.Internal.IO
import GHC.Internal.Base
import GHC.Internal.Bits
import GHC.Internal.Num
+import GHC.Internal.Data.Maybe
import GHC.Internal.List
import GHC.Internal.Real
import GHC.Internal.Word
-import GHC.Internal.Show
import GHC.Internal.Ptr
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.Marshal.Alloc
import GHC.Internal.Foreign.Marshal.Array
import GHC.Internal.Foreign.Storable
-import GHC.Internal.System.IO
import GHC.Internal.Fingerprint.Type
@@ -71,41 +70,27 @@ fingerprintString str = unsafeDupablePerformIO $
fromIntegral (w32 `shiftR` 8),
fromIntegral w32]
--- | Computes the hash of a given file.
--- This function loops over the handle, running in constant memory.
---
--- @since base-4.7.0.0
-getFileHash :: FilePath -> IO Fingerprint
-getFileHash path = withBinaryFile path ReadMode $ \h ->
+-- | Reads data in chunks and computes its hash.
+-- This function runs in constant memory.
+fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int))
+ -> IO Fingerprint
+fingerprintBufferedStream readChunk =
allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
c_MD5Init pctxt
-
- processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size))
-
+ allocaBytes _BUFSIZE $ \arrPtr ->
+ let loop = do
+ maybeRemainderSize <- readChunk arrPtr _BUFSIZE
+ c_MD5Update pctxt
+ arrPtr
+ (fromIntegral (fromMaybe _BUFSIZE maybeRemainderSize))
+ when (isNothing maybeRemainderSize) loop
+ in loop
allocaBytes 16 $ \pdigest -> do
c_MD5Final pdigest pctxt
peek (castPtr pdigest :: Ptr Fingerprint)
-
where
_BUFSIZE = 4096
- -- Loop over _BUFSIZE sized chunks read from the handle,
- -- passing the callback a block of bytes and its size.
- processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO ()
- processChunks h f = allocaBytes _BUFSIZE $ \arrPtr ->
-
- let loop = do
- count <- hGetBuf h arrPtr _BUFSIZE
- eof <- hIsEOF h
- when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $
- "GHC.Internal.Fingerprint.getFileHash: only read " ++ show count ++ " bytes"
-
- f arrPtr count
-
- when (not eof) loop
-
- in loop
-
data MD5Context
foreign import ccall unsafe "__hsbase_MD5Init"
=====================================
libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs
=====================================
@@ -24,9 +24,10 @@ module GHC.Internal.GHCi.Helpers
, evalWrapper
) where
-import GHC.Internal.Base
-import GHC.Internal.System.IO
-import GHC.Internal.System.Environment
+import GHC.Internal.Base (String, IO)
+import GHC.Internal.IO.Handle (BufferMode (NoBuffering), hSetBuffering, hFlush)
+import GHC.Internal.IO.StdHandles (stdin, stdout, stderr)
+import GHC.Internal.System.Environment (withProgName, withArgs)
disableBuffering :: IO ()
disableBuffering = do
=====================================
libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
=====================================
@@ -5,7 +5,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveTraversable #-}
-- Late cost centres introduce a thunk in the asBox function, which leads to
-- an additional wrapper being added to any value placed inside a box.
-- This can be removed once our boot compiler is no longer affected by #25212
@@ -69,8 +68,7 @@ in the profiling way. (#15197)
import GHC.Internal.Heap.ProfInfo.Types
import GHC.Internal.Data.Bits
-import GHC.Internal.Data.Foldable (Foldable, toList)
-import GHC.Internal.Data.Traversable (Traversable)
+import GHC.Internal.Data.Foldable (toList)
import GHC.Internal.Int
import GHC.Internal.Num
import GHC.Internal.Real
@@ -383,7 +381,7 @@ data GenClosure b
-- or an Int#).
| UnknownTypeWordSizedPrimitive
{ wordVal :: !Word }
- deriving (Show, Generic, Functor, Foldable, Traversable)
+ deriving (Show, Generic)
-- | Get the info table for a heap closure, or Nothing for a prim value
--
@@ -500,7 +498,7 @@ data GenStgStackClosure b = GenStgStackClosure
, ssc_stack_size :: !Word32 -- ^ stack size in *words*
, ssc_stack :: ![GenStackFrame b]
}
- deriving (Foldable, Functor, Generic, Show, Traversable)
+ deriving (Generic, Show)
type StackField = GenStackField Box
@@ -510,7 +508,7 @@ data GenStackField b
= StackWord !Word
-- | A pointer field
| StackBox !b
- deriving (Foldable, Functor, Generic, Show, Traversable)
+ deriving (Generic, Show)
type StackFrame = GenStackFrame Box
@@ -579,7 +577,7 @@ data GenStackFrame b =
{ info_tbl :: !StgInfoTable
, annotation :: !b
}
- deriving (Foldable, Functor, Generic, Show, Traversable)
+ deriving (Generic, Show)
data PrimType
= PInt
=====================================
libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs deleted
=====================================
@@ -1,163 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Trustworthy #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.Internal.ResponseFile
--- License : BSD-style (see the file LICENSE)
---
--- Maintainer : libraries(a)haskell.org
--- Stability : internal
--- Portability : portable
---
--- GCC style response files.
---
--- @since base-4.12.0.0
-----------------------------------------------------------------------------
-
--- Migrated from Haddock.
-
-module GHC.Internal.ResponseFile (
- getArgsWithResponseFiles,
- unescapeArgs,
- escapeArgs, escapeArg,
- expandResponse
- ) where
-
-import GHC.Internal.Control.Exception
-import GHC.Internal.Data.Foldable (Foldable(..))
-import GHC.Internal.Base
-import GHC.Internal.Unicode (isSpace)
-import GHC.Internal.Data.List (filter, unlines, concat, reverse)
-import GHC.Internal.Text.Show (show)
-import GHC.Internal.System.Environment (getArgs)
-import GHC.Internal.System.Exit (exitFailure)
-import GHC.Internal.System.IO
-
-{-|
-Like 'getArgs', but can also read arguments supplied via response files.
-
-
-For example, consider a program @foo@:
-
-@
-main :: IO ()
-main = do
- args <- getArgsWithResponseFiles
- putStrLn (show args)
-@
-
-
-And a response file @args.txt@:
-
-@
---one 1
---\'two\' 2
---"three" 3
-@
-
-Then the result of invoking @foo@ with @args.txt@ is:
-
-> > ./foo @args.txt
-> ["--one","1","--two","2","--three","3"]
-
--}
-getArgsWithResponseFiles :: IO [String]
-getArgsWithResponseFiles = getArgs >>= expandResponse
-
--- | Given a string of concatenated strings, separate each by removing
--- a layer of /quoting/ and\/or /escaping/ of certain characters.
---
--- These characters are: any whitespace, single quote, double quote,
--- and the backslash character. The backslash character always
--- escapes (i.e., passes through without further consideration) the
--- character which follows. Characters can also be escaped in blocks
--- by quoting (i.e., surrounding the blocks with matching pairs of
--- either single- or double-quotes which are not themselves escaped).
---
--- Any whitespace which appears outside of either of the quoting and
--- escaping mechanisms, is interpreted as having been added by this
--- special concatenation process to designate where the boundaries
--- are between the original, un-concatenated list of strings. These
--- added whitespace characters are removed from the output.
---
--- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""]
-unescapeArgs :: String -> [String]
-unescapeArgs = filter (not . null) . unescape
-
--- | Given a list of strings, concatenate them into a single string
--- with escaping of certain characters, and the addition of a newline
--- between each string. The escaping is done by adding a single
--- backslash character before any whitespace, single quote, double
--- quote, or backslash character, so this escaping character must be
--- removed. Unescaped whitespace (in this case, newline) is part
--- of this "transport" format to indicate the end of the previous
--- string and the start of a new string.
---
--- While 'unescapeArgs' allows using quoting (i.e., convenient
--- escaping of many characters) by having matching sets of single- or
--- double-quotes,'escapeArgs' does not use the quoting mechanism,
--- and thus will always escape any whitespace, quotes, and
--- backslashes.
---
--- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n"
-escapeArgs :: [String] -> String
-escapeArgs = unlines . map escapeArg
-
--- | Arguments which look like @\@foo@ will be replaced with the
--- contents of file @foo@. A gcc-like syntax for response files arguments
--- is expected. This must re-constitute the argument list by doing an
--- inverse of the escaping mechanism done by the calling-program side.
---
--- We quit if the file is not found or reading somehow fails.
--- (A convenience routine for haddock or possibly other clients)
-expandResponse :: [String] -> IO [String]
-expandResponse = fmap concat . mapM expand
- where
- expand :: String -> IO [String]
- expand ('@':f) = readFileExc f >>= return . unescapeArgs
- expand x = return [x]
-
- readFileExc f =
- readFile f `catch` \(e :: IOException) -> do
- hPutStrLn stderr $ "Error while expanding response file: " ++ show e
- exitFailure
-
-data Quoting = NoneQ | SngQ | DblQ
-
-unescape :: String -> [String]
-unescape args = reverse . map reverse $ go args NoneQ False [] []
- where
- -- n.b., the order of these cases matters; these are cribbed from gcc
- -- case 1: end of input
- go [] _q _bs a as = a:as
- -- case 2: back-slash escape in progress
- go (c:cs) q True a as = go cs q False (c:a) as
- -- case 3: no back-slash escape in progress, but got a back-slash
- go (c:cs) q False a as
- | '\\' == c = go cs q True a as
- -- case 4: single-quote escaping in progress
- go (c:cs) SngQ False a as
- | '\'' == c = go cs NoneQ False a as
- | otherwise = go cs SngQ False (c:a) as
- -- case 5: double-quote escaping in progress
- go (c:cs) DblQ False a as
- | '"' == c = go cs NoneQ False a as
- | otherwise = go cs DblQ False (c:a) as
- -- case 6: no escaping is in progress
- go (c:cs) NoneQ False a as
- | isSpace c = go cs NoneQ False [] (a:as)
- | '\'' == c = go cs SngQ False a as
- | '"' == c = go cs DblQ False a as
- | otherwise = go cs NoneQ False (c:a) as
-
-escapeArg :: String -> String
-escapeArg = reverse . foldl' escape []
-
-escape :: String -> Char -> String
-escape cs c
- | isSpace c
- || '\\' == c
- || '\'' == c
- || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result
- | otherwise = c:cs
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Exit.hs deleted
=====================================
@@ -1,81 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.Internal.System.Exit
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries(a)haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Exiting the program.
---
------------------------------------------------------------------------------
-
-module GHC.Internal.System.Exit
- (
- ExitCode(ExitSuccess,ExitFailure)
- , exitWith
- , exitFailure
- , exitSuccess
- , die
- ) where
-
-import GHC.Internal.System.IO
-
-import GHC.Internal.Base
-import GHC.Internal.IO
-import GHC.Internal.IO.Exception
-
--- ---------------------------------------------------------------------------
--- exitWith
-
--- | Computation 'exitWith' @code@ throws 'ExitCode' @code@.
--- Normally this terminates the program, returning @code@ to the
--- program's caller.
---
--- On program termination, the standard 'Handle's 'stdout' and
--- 'stderr' are flushed automatically; any other buffered 'Handle's
--- need to be flushed manually, otherwise the buffered data will be
--- discarded.
---
--- A program that fails in any other way is treated as if it had
--- called 'exitFailure'.
--- A program that terminates successfully without calling 'exitWith'
--- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'.
---
--- As an 'ExitCode' is an 'Control.Exception.Exception', it can be
--- caught using the functions of "Control.Exception". This means that
--- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from
--- "Control.Exception") are also executed properly on 'exitWith'.
---
--- Note: in GHC, 'exitWith' should be called from the main program
--- thread in order to exit the process. When called from another
--- thread, 'exitWith' will throw an 'ExitCode' as normal, but the
--- exception will not cause the process itself to exit.
---
-exitWith :: ExitCode -> IO a
-exitWith ExitSuccess = throwIO ExitSuccess
-exitWith code@(ExitFailure n)
- | n /= 0 = throwIO code
- | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing)
-
--- | The computation 'exitFailure' is equivalent to
--- 'exitWith' @(@'ExitFailure' /exitfail/@)@,
--- where /exitfail/ is implementation-dependent.
-exitFailure :: IO a
-exitFailure = exitWith (ExitFailure 1)
-
--- | The computation 'exitSuccess' is equivalent to
--- 'exitWith' 'ExitSuccess', It terminates the program
--- successfully.
-exitSuccess :: IO a
-exitSuccess = exitWith ExitSuccess
-
--- | Write given error message to `stderr` and terminate with `exitFailure`.
---
--- @since base-4.8.0.0
-die :: String -> IO a
-die err = hPutStrLn stderr err >> exitFailure
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs deleted
=====================================
@@ -1,323 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE RankNTypes #-}
-
-{-|
- This module bridges between Haskell handles and underlying operating-system
- features.
--}
-module GHC.Internal.System.IO.OS
-(
- -- * Obtaining file descriptors and Windows handles
- withFileDescriptorReadingBiased,
- withFileDescriptorWritingBiased,
- withWindowsHandleReadingBiased,
- withWindowsHandleWritingBiased,
- withFileDescriptorReadingBiasedRaw,
- withFileDescriptorWritingBiasedRaw,
- withWindowsHandleReadingBiasedRaw,
- withWindowsHandleWritingBiasedRaw
-
- -- ** Caveats
- -- $with-ref-caveats
-)
-where
-
-#if defined(mingw32_HOST_OS)
-import GHC.Internal.Base (otherwise)
-#endif
-import GHC.Internal.Control.Monad (return)
-import GHC.Internal.Control.Concurrent.MVar (MVar)
-import GHC.Internal.Control.Exception (mask)
-import GHC.Internal.Data.Function (const, (.), ($))
-import GHC.Internal.Data.Functor (fmap)
-import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe)
-#if defined(mingw32_HOST_OS)
-import GHC.Internal.Data.Maybe (Maybe (Just))
-#endif
-import GHC.Internal.Data.List ((++))
-import GHC.Internal.Data.String (String)
-import GHC.Internal.Data.Typeable (Typeable, cast)
-import GHC.Internal.System.IO (IO)
-import GHC.Internal.IO.FD (fdFD)
-#if defined(mingw32_HOST_OS)
-import GHC.Internal.IO.Windows.Handle
- (
- NativeHandle,
- ConsoleHandle,
- IoHandle,
- toHANDLE
- )
-#endif
-import GHC.Internal.IO.Handle.Types
- (
- Handle (FileHandle, DuplexHandle),
- Handle__ (Handle__, haDevice)
- )
-import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer)
-import GHC.Internal.IO.Exception
- (
- IOErrorType (InappropriateType),
- IOException (IOError),
- ioException
- )
-import GHC.Internal.Foreign.Ptr (Ptr)
-import GHC.Internal.Foreign.C.Types (CInt)
-
--- * Obtaining POSIX file descriptors and Windows handles
-
-{-|
- Executes a user-provided action on an operating-system handle that underlies
- a Haskell handle. Before the user-provided action is run, user-defined
- preparation based on the handle state that contains the operating-system
- handle is performed. While the user-provided action is executed, further
- operations on the Haskell handle are blocked to a degree that interference
- with this action is prevented.
-
- See [below](#with-ref-caveats) for caveats regarding this operation.
--}
-withOSHandle :: String
- -- ^ The name of the overall operation
- -> (Handle -> MVar Handle__)
- {-^
- Obtaining of the handle state variable that holds the
- operating-system handle
- -}
- -> (forall d. Typeable d => d -> IO a)
- -- ^ Conversion of a device into an operating-system handle
- -> (Handle__ -> IO ())
- -- ^ The preparation
- -> Handle
- -- ^ The Haskell handle to use
- -> (a -> IO r)
- -- ^ The action to execute on the operating-system handle
- -> IO r
-withOSHandle opName handleStateVar getOSHandle prepare handle act
- = mask $ \ withOriginalMaskingState ->
- withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do
- osHandle <- getOSHandle dev
- prepare handleState
- withOriginalMaskingState $ act osHandle
- where
-
- withHandleState = withHandle_' opName handle (handleStateVar handle)
-{-
- The 'withHandle_'' operation, which we use here, already performs masking.
- Still, we have to employ 'mask', in order do obtain the operation that
- restores the original masking state. The user-provided action should be
- executed with this original masking state, as there is no inherent reason to
- generally perform it with masking in place. The masking that 'withHandle_''
- performs is only for safely accessing handle state and thus constitutes an
- implementation detail; it has nothing to do with the user-provided action.
--}
-{-
- The order of actions in 'withOSHandle' is such that any exception from
- 'getOSHandle' is thrown before the user-defined preparation is performed.
--}
-
-{-|
- Obtains the handle state variable that underlies a handle or specifically
- the handle state variable for reading if the handle uses different state
- variables for reading and writing.
--}
-handleStateVarReadingBiased :: Handle -> MVar Handle__
-handleStateVarReadingBiased (FileHandle _ var) = var
-handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar
-
-{-|
- Obtains the handle state variable that underlies a handle or specifically
- the handle state variable for writing if the handle uses different state
- variables for reading and writing.
--}
-handleStateVarWritingBiased :: Handle -> MVar Handle__
-handleStateVarWritingBiased (FileHandle _ var) = var
-handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar
-
-{-|
- Yields the result of another operation if that operation succeeded, and
- otherwise throws an exception that signals that the other operation failed
- because some Haskell handle does not use an operating-system handle of a
- required type.
--}
-requiringOSHandleOfType :: String
- -- ^ The name of the operating-system handle type
- -> Maybe a
- {-^
- The result of the other operation if it succeeded
- -}
- -> IO a
-requiringOSHandleOfType osHandleTypeName
- = maybe (ioException osHandleOfTypeRequired) return
- where
-
- osHandleOfTypeRequired :: IOException
- osHandleOfTypeRequired
- = IOError Nothing
- InappropriateType
- ""
- ("handle does not use " ++ osHandleTypeName ++ "s")
- Nothing
- Nothing
-
-{-|
- Obtains the POSIX file descriptor of a device if the device contains one,
- and throws an exception otherwise.
--}
-getFileDescriptor :: Typeable d => d -> IO CInt
-getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" .
- fmap fdFD . cast
-
-{-|
- Obtains the Windows handle of a device if the device contains one, and
- throws an exception otherwise.
--}
-getWindowsHandle :: Typeable d => d -> IO (Ptr ())
-getWindowsHandle = requiringOSHandleOfType "Windows handle" .
- toMaybeWindowsHandle
- where
-
- toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ())
-#if defined(mingw32_HOST_OS)
- toMaybeWindowsHandle dev
- | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle)
- = Just (toHANDLE nativeHandle)
- | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle)
- = Just (toHANDLE consoleHandle)
- | otherwise
- = Nothing
- {-
- This is inspired by the implementation of
- 'System.Win32.Types.withHandleToHANDLENative'.
- -}
-#else
- toMaybeWindowsHandle _ = Nothing
-#endif
-
-{-|
- Executes a user-provided action on the POSIX file descriptor that underlies
- a handle or specifically on the POSIX file descriptor for reading if the
- handle uses different file descriptors for reading and writing. The
- Haskell-managed buffers related to the file descriptor are flushed before
- the user-provided action is run. While this action is executed, further
- operations on the handle are blocked to a degree that interference with this
- action is prevented.
-
- If the handle does not use POSIX file descriptors, an exception is thrown.
-
- See [below](#with-ref-caveats) for caveats regarding this operation.
--}
-withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r
-withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased"
- handleStateVarReadingBiased
- getFileDescriptor
- flushBuffer
-
-{-|
- Executes a user-provided action on the POSIX file descriptor that underlies
- a handle or specifically on the POSIX file descriptor for writing if the
- handle uses different file descriptors for reading and writing. The
- Haskell-managed buffers related to the file descriptor are flushed before
- the user-provided action is run. While this action is executed, further
- operations on the handle are blocked to a degree that interference with this
- action is prevented.
-
- If the handle does not use POSIX file descriptors, an exception is thrown.
-
- See [below](#with-ref-caveats) for caveats regarding this operation.
--}
-withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r
-withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased"
- handleStateVarWritingBiased
- getFileDescriptor
- flushBuffer
-
-{-|
- Executes a user-provided action on the Windows handle that underlies a
- Haskell handle or specifically on the Windows handle for reading if the
- Haskell handle uses different Windows handles for reading and writing. The
- Haskell-managed buffers related to the Windows handle are flushed before the
- user-provided action is run. While this action is executed, further
- operations on the Haskell handle are blocked to a degree that interference
- with this action is prevented.
-
- If the Haskell handle does not use Windows handles, an exception is thrown.
-
- See [below](#with-ref-caveats) for caveats regarding this operation.
--}
-withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r
-withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased"
- handleStateVarReadingBiased
- getWindowsHandle
- flushBuffer
-
-{-|
- Executes a user-provided action on the Windows handle that underlies a
- Haskell handle or specifically on the Windows handle for writing if the
- Haskell handle uses different Windows handles for reading and writing. The
- Haskell-managed buffers related to the Windows handle are flushed before the
- user-provided action is run. While this action is executed, further
- operations on the Haskell handle are blocked to a degree that interference
- with this action is prevented.
-
- If the Haskell handle does not use Windows handles, an exception is thrown.
-
- See [below](#with-ref-caveats) for caveats regarding this operation.
--}
-withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r
-withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased"
- handleStateVarWritingBiased
- getWindowsHandle
- flushBuffer
-
-{-|
- Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers
- are not flushed.
--}
-withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r
-withFileDescriptorReadingBiasedRaw
- = withOSHandle "withFileDescriptorReadingBiasedRaw"
- handleStateVarReadingBiased
- getFileDescriptor
- (const $ return ())
-
-{-|
- Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers
- are not flushed.
--}
-withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r
-withFileDescriptorWritingBiasedRaw
- = withOSHandle "withFileDescriptorWritingBiasedRaw"
- handleStateVarWritingBiased
- getFileDescriptor
- (const $ return ())
-
-{-|
- Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers
- are not flushed.
--}
-withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r
-withWindowsHandleReadingBiasedRaw
- = withOSHandle "withWindowsHandleReadingBiasedRaw"
- handleStateVarReadingBiased
- getWindowsHandle
- (const $ return ())
-
-{-|
- Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers
- are not flushed.
--}
-withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r
-withWindowsHandleWritingBiasedRaw
- = withOSHandle "withWindowsHandleWritingBiasedRaw"
- handleStateVarWritingBiased
- getWindowsHandle
- (const $ return ())
-
--- ** Caveats
-
-{-$with-ref-caveats
- #with-ref-caveats#This subsection is just a dummy, whose purpose is to serve
- as the target of the hyperlinks above. The real documentation of the caveats
- is in the /Caveats/ subsection in the @base@ module @System.IO.OS@, which
- re-exports the above operations.
--}
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
=====================================
@@ -26,17 +26,19 @@ module GHC.Internal.TH.Monad
import Prelude
import Data.Data hiding (Fixity(..))
import Data.IORef
-import System.IO.Unsafe ( unsafePerformIO )
+import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.IO.Class (MonadIO (..))
-import System.IO ( hPutStrLn, stderr )
+import System.IO (FilePath, hPutStrLn, stderr)
import qualified Data.Kind as Kind (Type)
-import GHC.Types (TYPE, RuntimeRep(..))
+import GHC.Types (TYPE, RuntimeRep(..))
#else
import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.Traversable
import GHC.Internal.IORef
-import GHC.Internal.System.IO
+import GHC.Internal.IO (FilePath)
+import GHC.Internal.IO.Handle.Text (hPutStrLn)
+import GHC.Internal.IO.StdHandles (stderr)
import GHC.Internal.Data.Foldable
import GHC.Internal.Data.Typeable
import GHC.Internal.Control.Monad.IO.Class
@@ -819,38 +821,6 @@ addTempFile suffix = Q (qAddTempFile suffix)
addTopDecls :: [Dec] -> Q ()
addTopDecls ds = Q (qAddTopDecls ds)
-
--- | Emit a foreign file which will be compiled and linked to the object for
--- the current module. Currently only languages that can be compiled with
--- the C compiler are supported, and the flags passed as part of -optc will
--- be also applied to the C compiler invocation that will compile them.
---
--- Note that for non-C languages (for example C++) @extern "C"@ directives
--- must be used to get symbols that we can access from Haskell.
---
--- To get better errors, it is recommended to use #line pragmas when
--- emitting C files, e.g.
---
--- > {-# LANGUAGE CPP #-}
--- > ...
--- > addForeignSource LangC $ unlines
--- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
--- > , ...
--- > ]
-addForeignSource :: ForeignSrcLang -> String -> Q ()
-addForeignSource lang src = do
- let suffix = case lang of
- LangC -> "c"
- LangCxx -> "cpp"
- LangObjc -> "m"
- LangObjcxx -> "mm"
- LangAsm -> "s"
- LangJs -> "js"
- RawObject -> "a"
- path <- addTempFile suffix
- runIO $ writeFile path src
- addForeignFilePath lang path
-
-- | Same as 'addForeignSource', but expects to receive a path pointing to the
-- foreign file instead of a 'String' of its contents. Consider using this in
-- conjunction with 'addTempFile'.
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -209,7 +209,7 @@ import Data.List.NonEmpty (NonEmpty(..))
import GHC.Lexeme ( startsVarSym, startsVarId )
-- This module completely re-exports 'GHC.Boot.TH.Syntax',
--- and exports additionally functions that depend on filepath.
+-- and exports additionally functions that depend on @filepath@ or @System.IO@.
-- |
addForeignFile :: ForeignSrcLang -> String -> Q ()
@@ -218,6 +218,37 @@ addForeignFile = addForeignSource
"Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"
#-} -- deprecated in 8.6
+-- | Emit a foreign file which will be compiled and linked to the object for
+-- the current module. Currently only languages that can be compiled with
+-- the C compiler are supported, and the flags passed as part of -optc will
+-- be also applied to the C compiler invocation that will compile them.
+--
+-- Note that for non-C languages (for example C++) @extern "C"@ directives
+-- must be used to get symbols that we can access from Haskell.
+--
+-- To get better errors, it is recommended to use #line pragmas when
+-- emitting C files, e.g.
+--
+-- > {-# LANGUAGE CPP #-}
+-- > ...
+-- > addForeignSource LangC $ unlines
+-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
+-- > , ...
+-- > ]
+addForeignSource :: ForeignSrcLang -> String -> Q ()
+addForeignSource lang src = do
+ let suffix = case lang of
+ LangC -> "c"
+ LangCxx -> "cpp"
+ LangObjc -> "m"
+ LangObjcxx -> "mm"
+ LangAsm -> "s"
+ LangJs -> "js"
+ RawObject -> "a"
+ path <- addTempFile suffix
+ runIO $ writeFile path src
+ addForeignFilePath lang path
+
-- | The input is a filepath, which if relative is offset by the package root.
makeRelativeToProject :: FilePath -> Q FilePath
makeRelativeToProject fp | isRelative fp = do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5fe25821cac5dcb542e4fd2a045480…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5fe25821cac5dcb542e4fd2a045480…
You're receiving this email because of your account on gitlab.haskell.org.
1
0