27 Jan '26
sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC
Commits:
77386709 by sheaf at 2026-01-27T18:46:12+01:00
deal with exitification
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Types/Id.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -45,12 +45,14 @@ import GHC.Core.Type
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin )
+
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Types.Basic( JoinPointHood(..) )
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Misc( mapSnd )
+import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -93,23 +95,23 @@ exitifyProgram binds = map goTopLvl binds
where
in_scope' = in_scope `extendInScopeSet` bndr
- go in_scope (Let (Rec pairs) body)
- | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'
- | otherwise = Let (Rec pairs') body'
+ go in_scope (Let (Rec pairs) body) =
+ case joinPointType_maybe (joinId_maybe . fst) pairs of
+ Just join_ty -> mkLets (exitifyRec join_ty in_scope' pairs') body'
+ Nothing -> Let (Rec pairs') body'
where
- is_join_rec = any (isJoinId . fst) pairs
in_scope' = in_scope `extendInScopeSetBind` (Rec pairs)
pairs' = mapSnd (go in_scope') pairs
body' = go in_scope' body
-- | State Monad used inside `exitify`
-type ExitifyM = State [(JoinId, CoreExpr)]
+type ExitifyM = State [(JoinId, CoreExpr)]
-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
-- join-points outside the joinrec.
-exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
-exitifyRec in_scope pairs
+exitifyRec :: JoinPointType -> InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
+exitifyRec joinrec_join_ty in_scope pairs
= [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']
where
-- We need the set of free variables of many subexpressions here, so
@@ -124,7 +126,7 @@ exitifyRec in_scope pairs
forM ann_pairs $ \(x,rhs) -> do
-- go past the lambdas of the join point
let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
- body' <- go args body
+ body' <- go joinrec_join_ty args body -- (ExitJoin2): start with JoinPointType of parent joinrec
let rhs' = mkLams args body'
return (x, rhs')
@@ -135,40 +137,41 @@ exitifyRec in_scope pairs
-- variables bound on the way and lifts it out as a join point.
--
-- ExitifyM is a state monad to keep track of floated binds
- go :: [Var] -- Variables that are in-scope here, but
- -- not in scope at the joinrec; that is,
- -- we must potentially abstract over them.
- -- Invariant: they are kept in dependency order
+ go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables that are in-scope here, but
+ -- not in scope at the joinrec; that is,
+ -- we must potentially abstract over them.
+ -- Invariant: they are kept in dependency order
-> CoreExprWithFVs -- Current expression in tail position
-> ExitifyM CoreExpr
-- We first look at the expression (no matter what it shape is)
-- and determine if we can turn it into a exit join point
- go captured ann_e
+ go exit_join_ty captured ann_e
| -- An exit expression has no recursive calls
let fvs = dVarSetToVarSet (freeVarsOf ann_e)
, disjointVarSet fvs recursive_calls
- = go_exit captured (deAnnotate ann_e) fvs
+ = go_exit exit_join_ty captured (deAnnotate ann_e) fvs
-- We could not turn it into a exit join point. So now recurse
-- into all expression where eligible exit join points might sit,
-- i.e. into all tail-call positions:
-- Case right hand sides are in tail-call position
- go captured (_, AnnCase scrut bndr ty alts) = do
+ go exit_join_ty captured (_, AnnCase scrut bndr ty alts) = do
alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do
- rhs' <- go (captured ++ [bndr] ++ pats) rhs
+ rhs' <- go exit_join_ty (captured ++ [bndr] ++ pats) rhs
return (Alt dc pats rhs')
return $ Case (deAnnotate scrut) bndr ty alts'
- go captured (_, AnnLet ann_bind body)
+ go exit_join_ty captured (_, AnnLet ann_bind body)
-- join point, RHS and body are in tail-call position
| AnnNonRec j rhs <- ann_bind
, JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j
= do let (params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ params) join_body
+ join_body' <- go exit_join_ty (captured ++ params) join_body
let rhs' = mkLams params join_body'
- body' <- go (captured ++ [j]) body
+ body' <- go exit_join_ty (captured ++ [j]) body
return $ Let (NonRec j rhs') body'
-- rec join point, RHSs and body are in tail-call position
@@ -178,30 +181,41 @@ exitifyRec in_scope pairs
pairs' <- forM pairs $ \(j,rhs) -> do
let join_arity = idJoinArity j
(params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ js ++ params) join_body
+ join_body' <- go exit_join_ty (captured ++ js ++ params) join_body
let rhs' = mkLams params join_body'
return (j, rhs')
- body' <- go (captured ++ js) body
+ body' <- go exit_join_ty (captured ++ js) body
return $ Let (Rec pairs') body'
-- normal Let, only the body is in tail-call position
| otherwise
- = do body' <- go (captured ++ bindersOf bind ) body
+ = do body' <- go exit_join_ty (captured ++ bindersOf bind ) body
return $ Let bind body'
where bind = deAnnBind ann_bind
+ -- (ExitJoin1) from Note [Exitification and quasi join points]
+ go _ captured (_, AnnCast ann_e (_, co)) = do
+ e' <- go QuasiJoinPoint captured ann_e
+ return (Cast e' co)
+ go exit_join_ty captured (_, AnnTick tickish ann_e)
+ | tickishCanScopeJoin tickish
+ = Tick tickish <$> go exit_join_ty captured ann_e
+ | ProfNote {} <- tickish
+ = Tick tickish <$> go QuasiJoinPoint captured ann_e
+
-- Cannot be turned into an exit join point, but also has no
-- tail-call subexpression. Nothing to do here.
- go _ ann_e = return (deAnnotate ann_e)
+ go _ _ ann_e = return (deAnnotate ann_e)
---------------------
- go_exit :: [Var] -- Variables captured locally
+ go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables captured locally
-> CoreExpr -- An exit expression
-> VarSet -- Free vars of the expression
-> ExitifyM CoreExpr
-- go_exit deals with a tail expression that is floatable
-- out as an exit point; that is, it mentions no recursive calls
- go_exit captured e fvs
+ go_exit exit_join_ty captured e fvs
-- Do not touch an expression that is already a join jump where all arguments
-- are captured variables. See Note [Idempotency]
-- But _do_ float join jumps with interesting arguments.
@@ -226,7 +240,7 @@ exitifyRec in_scope pairs
let rhs = mkLams abs_vars e
avoid = in_scope `extendInScopeSetList` captured
-- Remember this binding under a suitable name
- ; v <- addExit avoid (length abs_vars) rhs
+ ; v <- addExit avoid exit_join_ty (length abs_vars) rhs
-- And jump to it from here
; return $ mkVarApps (Var v) abs_vars }
@@ -263,7 +277,7 @@ exitifyRec in_scope pairs
-- * any bound variables (captured)
-- * any exit join points created so far.
mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId
-mkExitJoinId in_scope ty join_ty join_arity = do
+mkExitJoinId in_scope ty exit_join_ty join_arity = do
fs <- get
let avoid = in_scope `extendInScopeSetList` (map fst fs)
`extendInScopeSet` exit_id_tmpl -- just cosmetics
@@ -271,17 +285,65 @@ mkExitJoinId in_scope ty join_ty join_arity = do
where
exit_id_tmpl =
asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty)
- join_ty join_arity
+ exit_join_ty join_arity
-addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
-addExit in_scope join_arity rhs = do
+addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope exit_join_ty join_arity rhs = do
-- Pick a suitable name
let ty = exprType rhs
- v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity
+ v <- mkExitJoinId in_scope ty exit_join_ty join_arity
fs <- get
put ((v,rhs):fs)
return v
+{- Note [Exitification and quasi join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we float an exit path, we must determine if the new exit join point
+should be a true join point or a quasi join point, in the sense of
+Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration.
+
+The new exit join point must be a quasi join point if either of the following
+conditions apply:
+
+ (ExitJoin1) The exit path occurs under a cast or a profiling tick.
+
+ (ExitJoin2) The original joinrec was a quasi join point.
+
+Rationale for (ExitJoin1):
+
+ Suppose we have:
+
+ joinrec j x = ... case ... of alts -> e |> co ... in ...
+
+ After exitifying 'e' to 'exit':
+
+ join exit y = e in
+ joinrec j x = ... case ... of alts -> (exit y) |> co ... in ...
+
+ Because the jump to 'exit' occurs under a cast, 'exit' must be classified
+ as a quasi join point.
+
+Rationale for (ExitJoin2):
+
+ Suppose we have:
+
+ quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co
+
+ If we float an exit out of 'j', we end up with
+
+ join exit = 100 in
+ quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co
+
+ Now suppose we inline j and simplify; we end up with:
+
+ join exit = 100 in exit |> co
+
+ We see now that 'exit' must be a quasi join point, due to the cast.
+
+ Hence: exit join points for a parent quasi join point must themselves be
+ quasi join points.
+-}
+
{-
Note [Interesting expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -68,7 +68,6 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
import Data.List (mapAccumL)
-import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semi
{-
@@ -4118,10 +4117,7 @@ setBinderOcc occ_info bndr
-- See Note [Invariants on join points] in "GHC.Core".
decideRecJoinPointHood :: TopLevelFlag -> UsageDetails
-> [CoreBndr] -> Maybe JoinPointType
-decideRecJoinPointHood lvl usage bndrs = do
- bndrsNE <- NE.nonEmpty bndrs
- -- Invariant 3: Either all are join points or none are
- Semi.sconcat <$> traverse ok bndrsNE
+decideRecJoinPointHood lvl usage = joinPointType_maybe ok
where
ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont
of a SpecConstr-generated RULE for a join point.
-}
--- SLD TODO horrible logic that must be removed
-peelJoinResTy :: Int -> Type -> Type
-peelJoinResTy 0 ty = ty
-peelJoinResTy n ty
- | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty
- = peelJoinResTy n inner_ty
- | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty
- = peelJoinResTy (n-1) res_ty
- | otherwise
- = ty
+joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type
+joinResTy n0 ty0 = go n0 ty0
+ where
+ go 0 ty = ty
+ go n ty
+ | Just (_bndr, res_ty) <- splitPiTy_maybe ty
+ = go (n-1) res_ty
+ | otherwise
+ = pprPanic "joinResTy" $
+ vcat [ text "join arity:" <+> ppr n0
+ , text "join ty:" <+> ppr ty0
+ , text "n:" <+> ppr n
+ , text "ty:" <+> ppr ty
+ ]
simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplNonRecJoinPoint env bndr rhs body cont
+simplNonRecJoinPoint env0 bndr rhs body cont0
= assert (isJoinId bndr) $
- wrapJoinCont do_case_case env cont $ \ env cont ->
+ wrapJoinCont do_case_case env0 bndr cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
do { -- We push join_cont into the join RHS and the body;
-- and wrap wrap_cont around the whole thing
- ; let (mult, res_ty)
- -- SLD TODO
- | Just QuasiJoinPoint <- joinId_maybe bndr
- = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+ let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
- ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)
- ; (floats2, body') <- simplExprF env3 body cont
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont)
+ ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env)
+ ; (floats2, body') <- simplExprF env3 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
do_case_case
| Just TrueJoinPoint <- joinId_maybe bndr
- = seCaseCase env
+ = seCaseCase env0
| otherwise
= False
simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplRecJoinPoint env pairs body cont
- = wrapJoinCont do_case_case env cont $ \ env cont ->
- do { let bndrs = map fst pairs
- (mult, res_ty)
- -- SLD TODO
- | [b] <- bndrs
- , Just QuasiJoinPoint <- joinId_maybe b
- = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+simplRecJoinPoint env0 pairs body cont0
+ = wrapJoinCont do_case_case env0 (head bndrs) cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
+ do { let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; env1 <- simplRecJoinBndrs env bndrs mult res_ty
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
- ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs
- ; (floats2, body') <- simplExprF env2 body cont
+ ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs
+ ; (floats2, body') <- simplExprF env2 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
+ bndrs = map fst pairs
+
do_case_case =
- if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs
- then seCaseCase env
+ if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs
+ then seCaseCase env0
else False
--------------------
+
+-- | Information computed by 'wrapJoinCont'.
+data WrapJoinCont
+ = WJC
+ { wjc_bind_env :: !SimplEnv
+ , wjc_bind_cont :: !SimplCont
+ , wjc_body_cont :: !SimplCont
+ }
+
wrapJoinCont :: Bool
- -> SimplEnv -> SimplCont
- -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
+ -> SimplEnv -> InId -> SimplCont
+ -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr))
-> SimplM (SimplFloats, OutExpr)
-- Deal with making the continuation duplicable if necessary,
-- and with the no-case-of-case situation.
-wrapJoinCont do_case_case env cont thing_inside
+wrapJoinCont do_case_case env join_bndr cont thing_inside
| contIsStop cont -- Common case; no need for fancy footwork
- = thing_inside env cont
+ = thing_inside $
+ WJC { wjc_bind_env = env
+ , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont
+ , wjc_body_cont = cont
+ }
| do_case_case
-- Normal situation: do the "case-of-case" transformation.
-- See Note [Join points and case-of-case].
= do { (floats1, cont') <- mkDupableCont env cont
- ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
+ ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1
+ , wjc_bind_cont = cont'
+ , wjc_body_cont = cont'
+ }
+ ; (floats2, result) <- thing_inside wjc
; return (floats1 `addFloats` floats2, result) }
| otherwise
-- No "case-of-case" transformation.
-- See Note [Join points with -fno-case-of-case].
- = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))
+ = do { let
+ wjc = WJC { wjc_bind_env = env
+ , wjc_bind_cont = no_case_case_bind_cont
+ , wjc_body_cont = mkBoringStop (contHoleType cont)
+ }
+ ; (floats1, expr1) <- thing_inside wjc
; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
; return (floats2 `addFloats` floats3, expr3) }
+ where
+ -- See Wrinkle [Casts and join point result types]
+ join_res_ty = joinResTy (idJoinArity join_bndr)
+ $ substTy env (idType join_bndr)
+ no_case_case_bind_cont = mkBoringStop join_res_ty
--------------------
trimJoinCont :: Id -- Used only in error message
@@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the
argument to both the join point RHS and the case alternatives:
join { j :: Bool -> IO (); j _ = guts arg ] }
- in case b of
- False -> (scctick<foo> jump j True) arg
- True -> jump j False arg
+ in case b of
+ False -> (scctick<foo> jump j True) arg
+ True -> jump j False arg
Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails
for the first branch, because 'trimJoinCont' doesn't look through profiling
@@ -2293,9 +2318,9 @@ 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
+ 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).
@@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'.
Similarly for casts:
join { j = blah }
- in case e of
- False -> j True |> co1
- True -> j False |> co2
+ in case e of
+ False -> j True |> co1
+ True -> j False |> co2
if we want to apply this to an argument 'arg', we would need to perform the
following transformation:
join { j co = ( blah |> co ) arg }
- in case e of
- False -> j co1 True
- True -> j co2 False
+ in case e of
+ False -> j co1 True
+ True -> j co2 False
in which we add a coercion argument to the join point. Again, this is not a
transformation we currently implement, so we instead prevent case-of-case for
@@ -2339,6 +2364,33 @@ we proceed as follows:
If we are dealing with a quasi join point, we switch off the case-of-case
transformation.
+Wrinkle [Casts and join point result types]
+
+ When dealing with a quasi joint-point, we must preserve the original type of
+ the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType).
+ This is because we don't trim the continuation like we do in
+ Note [Join points and case-of-case].
+
+ For example, suppose we have:
+
+ type family F a
+
+ join
+ j :: forall a. a -> F a
+ j @a x = ...
+ in case e of
+ False -> j @T1 x1 |> ( co1 :: F T1 ~ Int )
+ True -> j @T2 x2 |> ( co2 :: F T2 ~ Int )
+
+ If we used 'contHoleType cont' to compute the result type of 'j', we would
+ change the result type of 'j' to 'Int', when it needs to remain 'F a'.
+
+ Instead, we avoid doing that and re-compute the result type of 'j' using
+ 'joinResTy' to get 'F a', as required.
+
+See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify
+for another wrinkle.
+
************************************************************************
* *
Variables
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -79,7 +79,8 @@ module GHC.Types.Id (
-- ** Join variables
JoinId, JoinPointHood,
- isJoinId, joinId_maybe, idJoinPointHood, idJoinArity,
+ isJoinId, joinId_maybe, joinPointType_maybe,
+ idJoinPointHood, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
-- ** Inline pragma stuff
@@ -172,6 +173,8 @@ import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Semigroup as Semi
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
@@ -584,6 +587,13 @@ joinId_maybe id
_ -> Nothing
| otherwise = Nothing
+joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType
+joinPointType_maybe f xs = do
+ xsNE <- NE.nonEmpty xs
+ Semi.sconcat <$> traverse f xsNE
+ -- traverse: either all are join points or none are
+ -- sconcat: only a 'TrueJoinPoint' if all are
+
-- | Doesn't return strictness marks
idJoinPointHood :: Var -> JoinPointHood
idJoinPointHood id
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77386709e6160e7a7283f4f0ba20aa4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77386709e6160e7a7283f4f0ba20aa4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
27 Jan '26
sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC
Commits:
678d8950 by sheaf at 2026-01-27T18:45:58+01:00
deal with exitification
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Types/Id.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -45,12 +45,14 @@ import GHC.Core.Type
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin )
+
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Types.Basic( JoinPointHood(..) )
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Misc( mapSnd )
+import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -93,23 +95,23 @@ exitifyProgram binds = map goTopLvl binds
where
in_scope' = in_scope `extendInScopeSet` bndr
- go in_scope (Let (Rec pairs) body)
- | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'
- | otherwise = Let (Rec pairs') body'
+ go in_scope (Let (Rec pairs) body) =
+ case joinPointType_maybe (joinId_maybe . fst) pairs of
+ Just join_ty -> mkLets (exitifyRec join_ty in_scope' pairs') body'
+ Nothing -> Let (Rec pairs') body'
where
- is_join_rec = any (isJoinId . fst) pairs
in_scope' = in_scope `extendInScopeSetBind` (Rec pairs)
pairs' = mapSnd (go in_scope') pairs
body' = go in_scope' body
-- | State Monad used inside `exitify`
-type ExitifyM = State [(JoinId, CoreExpr)]
+type ExitifyM = State [(JoinId, CoreExpr)]
-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
-- join-points outside the joinrec.
-exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
-exitifyRec in_scope pairs
+exitifyRec :: JoinPointType -> InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
+exitifyRec joinrec_join_ty in_scope pairs
= [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']
where
-- We need the set of free variables of many subexpressions here, so
@@ -124,7 +126,7 @@ exitifyRec in_scope pairs
forM ann_pairs $ \(x,rhs) -> do
-- go past the lambdas of the join point
let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
- body' <- go args body
+ body' <- go joinrec_join_ty args body -- (ExitJoin2): start with JoinPointType of parent joinrec
let rhs' = mkLams args body'
return (x, rhs')
@@ -135,40 +137,41 @@ exitifyRec in_scope pairs
-- variables bound on the way and lifts it out as a join point.
--
-- ExitifyM is a state monad to keep track of floated binds
- go :: [Var] -- Variables that are in-scope here, but
- -- not in scope at the joinrec; that is,
- -- we must potentially abstract over them.
- -- Invariant: they are kept in dependency order
+ go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables that are in-scope here, but
+ -- not in scope at the joinrec; that is,
+ -- we must potentially abstract over them.
+ -- Invariant: they are kept in dependency order
-> CoreExprWithFVs -- Current expression in tail position
-> ExitifyM CoreExpr
-- We first look at the expression (no matter what it shape is)
-- and determine if we can turn it into a exit join point
- go captured ann_e
+ go exit_join_ty captured ann_e
| -- An exit expression has no recursive calls
let fvs = dVarSetToVarSet (freeVarsOf ann_e)
, disjointVarSet fvs recursive_calls
- = go_exit captured (deAnnotate ann_e) fvs
+ = go_exit exit_join_ty captured (deAnnotate ann_e) fvs
-- We could not turn it into a exit join point. So now recurse
-- into all expression where eligible exit join points might sit,
-- i.e. into all tail-call positions:
-- Case right hand sides are in tail-call position
- go captured (_, AnnCase scrut bndr ty alts) = do
+ go exit_join_ty captured (_, AnnCase scrut bndr ty alts) = do
alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do
- rhs' <- go (captured ++ [bndr] ++ pats) rhs
+ rhs' <- go exit_join_ty (captured ++ [bndr] ++ pats) rhs
return (Alt dc pats rhs')
return $ Case (deAnnotate scrut) bndr ty alts'
- go captured (_, AnnLet ann_bind body)
+ go exit_join_ty captured (_, AnnLet ann_bind body)
-- join point, RHS and body are in tail-call position
| AnnNonRec j rhs <- ann_bind
, JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j
= do let (params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ params) join_body
+ join_body' <- go exit_join_ty (captured ++ params) join_body
let rhs' = mkLams params join_body'
- body' <- go (captured ++ [j]) body
+ body' <- go exit_join_ty (captured ++ [j]) body
return $ Let (NonRec j rhs') body'
-- rec join point, RHSs and body are in tail-call position
@@ -178,30 +181,41 @@ exitifyRec in_scope pairs
pairs' <- forM pairs $ \(j,rhs) -> do
let join_arity = idJoinArity j
(params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ js ++ params) join_body
+ join_body' <- go exit_join_ty (captured ++ js ++ params) join_body
let rhs' = mkLams params join_body'
return (j, rhs')
- body' <- go (captured ++ js) body
+ body' <- go exit_join_ty (captured ++ js) body
return $ Let (Rec pairs') body'
-- normal Let, only the body is in tail-call position
| otherwise
- = do body' <- go (captured ++ bindersOf bind ) body
+ = do body' <- go exit_join_ty (captured ++ bindersOf bind ) body
return $ Let bind body'
where bind = deAnnBind ann_bind
+ -- (ExitJoin1) from Note [Exitification and quasi join points]
+ go _ captured (_, AnnCast ann_e (_, co)) = do
+ e' <- go QuasiJoinPoint captured ann_e
+ return (Cast e' co)
+ go exit_join_ty captured (_, AnnTick tickish ann_e)
+ | tickishCanScopeJoin tickish
+ = Tick tickish <$> go exit_join_ty captured ann_e
+ | ProfNote {} <- tickish
+ = Tick tickish <$> go QuasiJoinPoint captured ann_e
+
-- Cannot be turned into an exit join point, but also has no
-- tail-call subexpression. Nothing to do here.
- go _ ann_e = return (deAnnotate ann_e)
+ go _ _ ann_e = return (deAnnotate ann_e)
---------------------
- go_exit :: [Var] -- Variables captured locally
+ go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables captured locally
-> CoreExpr -- An exit expression
-> VarSet -- Free vars of the expression
-> ExitifyM CoreExpr
-- go_exit deals with a tail expression that is floatable
-- out as an exit point; that is, it mentions no recursive calls
- go_exit captured e fvs
+ go_exit exit_join_ty captured e fvs
-- Do not touch an expression that is already a join jump where all arguments
-- are captured variables. See Note [Idempotency]
-- But _do_ float join jumps with interesting arguments.
@@ -226,7 +240,7 @@ exitifyRec in_scope pairs
let rhs = mkLams abs_vars e
avoid = in_scope `extendInScopeSetList` captured
-- Remember this binding under a suitable name
- ; v <- addExit avoid (length abs_vars) rhs
+ ; v <- addExit avoid exit_join_ty (length abs_vars) rhs
-- And jump to it from here
; return $ mkVarApps (Var v) abs_vars }
@@ -263,7 +277,7 @@ exitifyRec in_scope pairs
-- * any bound variables (captured)
-- * any exit join points created so far.
mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId
-mkExitJoinId in_scope ty join_ty join_arity = do
+mkExitJoinId in_scope ty exit_join_ty join_arity = do
fs <- get
let avoid = in_scope `extendInScopeSetList` (map fst fs)
`extendInScopeSet` exit_id_tmpl -- just cosmetics
@@ -271,17 +285,65 @@ mkExitJoinId in_scope ty join_ty join_arity = do
where
exit_id_tmpl =
asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty)
- join_ty join_arity
+ exit_join_ty join_arity
-addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
-addExit in_scope join_arity rhs = do
+addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope exit_join_ty join_arity rhs = do
-- Pick a suitable name
let ty = exprType rhs
- v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity
+ v <- mkExitJoinId in_scope ty exit_join_ty join_arity
fs <- get
put ((v,rhs):fs)
return v
+{- Note [Exitification and quasi join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we float an exit path, we must determine if the new exit join point
+should be a true join point or a quasi join point, in the sense of
+Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration).
+
+The new exit join point must be a quasi join point if either of the following
+conditions apply:
+
+ (ExitJoin1) The exit path occurs under a cast or a profiling tick.
+
+ (ExitJoin2) The original joinrec was a quasi join point.
+
+Rationale for (ExitJoin1):
+
+ Suppose we have:
+
+ joinrec j x = ... case ... of alts -> e |> co ... in ...
+
+ After exitifying 'e' to 'exit':
+
+ join exit y = e in
+ joinrec j x = ... case ... of alts -> (exit y) |> co ... in ...
+
+ Because the jump to 'exit' occurs under a cast, 'exit' must be classified
+ as a quasi join point.
+
+Rationale for (ExitJoin2):
+
+ Suppose we have:
+
+ quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co
+
+ If we float an exit out of 'j', we end up with
+
+ join exit = 100 in
+ quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co
+
+ Now suppose we inline j and simplify; we end up with:
+
+ join exit = 100 in exit |> co
+
+ We see now that 'exit' must be a quasi join point, due to the cast.
+
+ Hence: exit join points for a parent quasi join point must themselves be
+ quasi join points.
+-}
+
{-
Note [Interesting expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -68,7 +68,6 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
import Data.List (mapAccumL)
-import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semi
{-
@@ -4118,10 +4117,7 @@ setBinderOcc occ_info bndr
-- See Note [Invariants on join points] in "GHC.Core".
decideRecJoinPointHood :: TopLevelFlag -> UsageDetails
-> [CoreBndr] -> Maybe JoinPointType
-decideRecJoinPointHood lvl usage bndrs = do
- bndrsNE <- NE.nonEmpty bndrs
- -- Invariant 3: Either all are join points or none are
- Semi.sconcat <$> traverse ok bndrsNE
+decideRecJoinPointHood lvl usage = joinPointType_maybe ok
where
ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont
of a SpecConstr-generated RULE for a join point.
-}
--- SLD TODO horrible logic that must be removed
-peelJoinResTy :: Int -> Type -> Type
-peelJoinResTy 0 ty = ty
-peelJoinResTy n ty
- | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty
- = peelJoinResTy n inner_ty
- | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty
- = peelJoinResTy (n-1) res_ty
- | otherwise
- = ty
+joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type
+joinResTy n0 ty0 = go n0 ty0
+ where
+ go 0 ty = ty
+ go n ty
+ | Just (_bndr, res_ty) <- splitPiTy_maybe ty
+ = go (n-1) res_ty
+ | otherwise
+ = pprPanic "joinResTy" $
+ vcat [ text "join arity:" <+> ppr n0
+ , text "join ty:" <+> ppr ty0
+ , text "n:" <+> ppr n
+ , text "ty:" <+> ppr ty
+ ]
simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplNonRecJoinPoint env bndr rhs body cont
+simplNonRecJoinPoint env0 bndr rhs body cont0
= assert (isJoinId bndr) $
- wrapJoinCont do_case_case env cont $ \ env cont ->
+ wrapJoinCont do_case_case env0 bndr cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
do { -- We push join_cont into the join RHS and the body;
-- and wrap wrap_cont around the whole thing
- ; let (mult, res_ty)
- -- SLD TODO
- | Just QuasiJoinPoint <- joinId_maybe bndr
- = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+ let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
- ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)
- ; (floats2, body') <- simplExprF env3 body cont
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont)
+ ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env)
+ ; (floats2, body') <- simplExprF env3 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
do_case_case
| Just TrueJoinPoint <- joinId_maybe bndr
- = seCaseCase env
+ = seCaseCase env0
| otherwise
= False
simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplRecJoinPoint env pairs body cont
- = wrapJoinCont do_case_case env cont $ \ env cont ->
- do { let bndrs = map fst pairs
- (mult, res_ty)
- -- SLD TODO
- | [b] <- bndrs
- , Just QuasiJoinPoint <- joinId_maybe b
- = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+simplRecJoinPoint env0 pairs body cont0
+ = wrapJoinCont do_case_case env0 (head bndrs) cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
+ do { let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; env1 <- simplRecJoinBndrs env bndrs mult res_ty
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
- ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs
- ; (floats2, body') <- simplExprF env2 body cont
+ ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs
+ ; (floats2, body') <- simplExprF env2 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
+ bndrs = map fst pairs
+
do_case_case =
- if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs
- then seCaseCase env
+ if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs
+ then seCaseCase env0
else False
--------------------
+
+-- | Information computed by 'wrapJoinCont'.
+data WrapJoinCont
+ = WJC
+ { wjc_bind_env :: !SimplEnv
+ , wjc_bind_cont :: !SimplCont
+ , wjc_body_cont :: !SimplCont
+ }
+
wrapJoinCont :: Bool
- -> SimplEnv -> SimplCont
- -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
+ -> SimplEnv -> InId -> SimplCont
+ -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr))
-> SimplM (SimplFloats, OutExpr)
-- Deal with making the continuation duplicable if necessary,
-- and with the no-case-of-case situation.
-wrapJoinCont do_case_case env cont thing_inside
+wrapJoinCont do_case_case env join_bndr cont thing_inside
| contIsStop cont -- Common case; no need for fancy footwork
- = thing_inside env cont
+ = thing_inside $
+ WJC { wjc_bind_env = env
+ , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont
+ , wjc_body_cont = cont
+ }
| do_case_case
-- Normal situation: do the "case-of-case" transformation.
-- See Note [Join points and case-of-case].
= do { (floats1, cont') <- mkDupableCont env cont
- ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
+ ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1
+ , wjc_bind_cont = cont'
+ , wjc_body_cont = cont'
+ }
+ ; (floats2, result) <- thing_inside wjc
; return (floats1 `addFloats` floats2, result) }
| otherwise
-- No "case-of-case" transformation.
-- See Note [Join points with -fno-case-of-case].
- = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))
+ = do { let
+ wjc = WJC { wjc_bind_env = env
+ , wjc_bind_cont = no_case_case_bind_cont
+ , wjc_body_cont = mkBoringStop (contHoleType cont)
+ }
+ ; (floats1, expr1) <- thing_inside wjc
; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
; return (floats2 `addFloats` floats3, expr3) }
+ where
+ -- See Wrinkle [Casts and join point result types]
+ join_res_ty = joinResTy (idJoinArity join_bndr)
+ $ substTy env (idType join_bndr)
+ no_case_case_bind_cont = mkBoringStop join_res_ty
--------------------
trimJoinCont :: Id -- Used only in error message
@@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the
argument to both the join point RHS and the case alternatives:
join { j :: Bool -> IO (); j _ = guts arg ] }
- in case b of
- False -> (scctick<foo> jump j True) arg
- True -> jump j False arg
+ in case b of
+ False -> (scctick<foo> jump j True) arg
+ True -> jump j False arg
Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails
for the first branch, because 'trimJoinCont' doesn't look through profiling
@@ -2293,9 +2318,9 @@ 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
+ 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).
@@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'.
Similarly for casts:
join { j = blah }
- in case e of
- False -> j True |> co1
- True -> j False |> co2
+ in case e of
+ False -> j True |> co1
+ True -> j False |> co2
if we want to apply this to an argument 'arg', we would need to perform the
following transformation:
join { j co = ( blah |> co ) arg }
- in case e of
- False -> j co1 True
- True -> j co2 False
+ in case e of
+ False -> j co1 True
+ True -> j co2 False
in which we add a coercion argument to the join point. Again, this is not a
transformation we currently implement, so we instead prevent case-of-case for
@@ -2339,6 +2364,33 @@ we proceed as follows:
If we are dealing with a quasi join point, we switch off the case-of-case
transformation.
+Wrinkle [Casts and join point result types]
+
+ When dealing with a quasi joint-point, we must preserve the original type of
+ the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType).
+ This is because we don't trim the continuation like we do in
+ Note [Join points and case-of-case].
+
+ For example, suppose we have:
+
+ type family F a
+
+ join
+ j :: forall a. a -> F a
+ j @a x = ...
+ in case e of
+ False -> j @T1 x1 |> ( co1 :: F T1 ~ Int )
+ True -> j @T2 x2 |> ( co2 :: F T2 ~ Int )
+
+ If we used 'contHoleType cont' to compute the result type of 'j', we would
+ change the result type of 'j' to 'Int', when it needs to remain 'F a'.
+
+ Instead, we avoid doing that and re-compute the result type of 'j' using
+ 'joinResTy' to get 'F a', as required.
+
+See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify
+for another wrinkle.
+
************************************************************************
* *
Variables
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -79,7 +79,8 @@ module GHC.Types.Id (
-- ** Join variables
JoinId, JoinPointHood,
- isJoinId, joinId_maybe, idJoinPointHood, idJoinArity,
+ isJoinId, joinId_maybe, joinPointType_maybe,
+ idJoinPointHood, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
-- ** Inline pragma stuff
@@ -172,6 +173,8 @@ import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Semigroup as Semi
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
@@ -584,6 +587,13 @@ joinId_maybe id
_ -> Nothing
| otherwise = Nothing
+joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType
+joinPointType_maybe f xs = do
+ xsNE <- NE.nonEmpty xs
+ Semi.sconcat <$> traverse f xsNE
+ -- traverse: either all are join points or none are
+ -- sconcat: only a 'TrueJoinPoint' if all are
+
-- | Doesn't return strictness marks
idJoinPointHood :: Var -> JoinPointHood
idJoinPointHood id
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/678d8950191d2669134d4f126b96649…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/678d8950191d2669134d4f126b96649…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
27 Jan '26
sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC
Commits:
593b8b96 by sheaf at 2026-01-27T18:44:58+01:00
deal with exitification
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Types/Id.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -45,12 +45,14 @@ import GHC.Core.Type
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin )
+
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Types.Basic( JoinPointHood(..) )
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Misc( mapSnd )
+import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -93,23 +95,23 @@ exitifyProgram binds = map goTopLvl binds
where
in_scope' = in_scope `extendInScopeSet` bndr
- go in_scope (Let (Rec pairs) body)
- | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'
- | otherwise = Let (Rec pairs') body'
+ go in_scope (Let (Rec pairs) body) =
+ case joinPointType_maybe (joinId_maybe . fst) pairs of
+ Just join_ty -> mkLets (exitifyRec join_ty in_scope' pairs') body'
+ Nothing -> Let (Rec pairs') body'
where
- is_join_rec = any (isJoinId . fst) pairs
in_scope' = in_scope `extendInScopeSetBind` (Rec pairs)
pairs' = mapSnd (go in_scope') pairs
body' = go in_scope' body
-- | State Monad used inside `exitify`
-type ExitifyM = State [(JoinId, CoreExpr)]
+type ExitifyM = State [(JoinId, CoreExpr)]
-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
-- join-points outside the joinrec.
-exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
-exitifyRec in_scope pairs
+exitifyRec :: JoinPointType -> InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
+exitifyRec joinrec_join_ty in_scope pairs
= [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']
where
-- We need the set of free variables of many subexpressions here, so
@@ -124,7 +126,7 @@ exitifyRec in_scope pairs
forM ann_pairs $ \(x,rhs) -> do
-- go past the lambdas of the join point
let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
- body' <- go args body
+ body' <- go joinrec_join_ty args body -- (ExitJoin2): start with JoinPointType of parent joinrec
let rhs' = mkLams args body'
return (x, rhs')
@@ -135,40 +137,41 @@ exitifyRec in_scope pairs
-- variables bound on the way and lifts it out as a join point.
--
-- ExitifyM is a state monad to keep track of floated binds
- go :: [Var] -- Variables that are in-scope here, but
- -- not in scope at the joinrec; that is,
- -- we must potentially abstract over them.
- -- Invariant: they are kept in dependency order
+ go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables that are in-scope here, but
+ -- not in scope at the joinrec; that is,
+ -- we must potentially abstract over them.
+ -- Invariant: they are kept in dependency order
-> CoreExprWithFVs -- Current expression in tail position
-> ExitifyM CoreExpr
-- We first look at the expression (no matter what it shape is)
-- and determine if we can turn it into a exit join point
- go captured ann_e
+ go exit_join_ty captured ann_e
| -- An exit expression has no recursive calls
let fvs = dVarSetToVarSet (freeVarsOf ann_e)
, disjointVarSet fvs recursive_calls
- = go_exit captured (deAnnotate ann_e) fvs
+ = go_exit exit_join_ty captured (deAnnotate ann_e) fvs
-- We could not turn it into a exit join point. So now recurse
-- into all expression where eligible exit join points might sit,
-- i.e. into all tail-call positions:
-- Case right hand sides are in tail-call position
- go captured (_, AnnCase scrut bndr ty alts) = do
+ go exit_join_ty captured (_, AnnCase scrut bndr ty alts) = do
alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do
- rhs' <- go (captured ++ [bndr] ++ pats) rhs
+ rhs' <- go exit_join_ty (captured ++ [bndr] ++ pats) rhs
return (Alt dc pats rhs')
return $ Case (deAnnotate scrut) bndr ty alts'
- go captured (_, AnnLet ann_bind body)
+ go exit_join_ty captured (_, AnnLet ann_bind body)
-- join point, RHS and body are in tail-call position
| AnnNonRec j rhs <- ann_bind
, JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j
= do let (params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ params) join_body
+ join_body' <- go exit_join_ty (captured ++ params) join_body
let rhs' = mkLams params join_body'
- body' <- go (captured ++ [j]) body
+ body' <- go exit_join_ty (captured ++ [j]) body
return $ Let (NonRec j rhs') body'
-- rec join point, RHSs and body are in tail-call position
@@ -178,30 +181,41 @@ exitifyRec in_scope pairs
pairs' <- forM pairs $ \(j,rhs) -> do
let join_arity = idJoinArity j
(params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ js ++ params) join_body
+ join_body' <- go exit_join_ty (captured ++ js ++ params) join_body
let rhs' = mkLams params join_body'
return (j, rhs')
- body' <- go (captured ++ js) body
+ body' <- go exit_join_ty (captured ++ js) body
return $ Let (Rec pairs') body'
-- normal Let, only the body is in tail-call position
| otherwise
- = do body' <- go (captured ++ bindersOf bind ) body
+ = do body' <- go exit_join_ty (captured ++ bindersOf bind ) body
return $ Let bind body'
where bind = deAnnBind ann_bind
+ -- (ExitJoin1) from Note [Exitification and quasi join points]
+ go _ captured (_, AnnCast ann_e (_, co)) = do
+ e' <- go QuasiJoinPoint captured ann_e
+ return (Cast e' co)
+ go exit_join_ty captured (_, AnnTick tickish ann_e)
+ | tickishCanScopeJoin tickish
+ = Tick tickish <$> go exit_join_ty captured ann_e
+ | ProfNote {} <- tickish
+ = Tick tickish <$> go QuasiJoinPoint captured ann_e
+
-- Cannot be turned into an exit join point, but also has no
-- tail-call subexpression. Nothing to do here.
- go _ ann_e = return (deAnnotate ann_e)
+ go _ _ ann_e = return (deAnnotate ann_e)
---------------------
- go_exit :: [Var] -- Variables captured locally
+ go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables captured locally
-> CoreExpr -- An exit expression
-> VarSet -- Free vars of the expression
-> ExitifyM CoreExpr
-- go_exit deals with a tail expression that is floatable
-- out as an exit point; that is, it mentions no recursive calls
- go_exit captured e fvs
+ go_exit exit_join_ty captured e fvs
-- Do not touch an expression that is already a join jump where all arguments
-- are captured variables. See Note [Idempotency]
-- But _do_ float join jumps with interesting arguments.
@@ -226,7 +240,7 @@ exitifyRec in_scope pairs
let rhs = mkLams abs_vars e
avoid = in_scope `extendInScopeSetList` captured
-- Remember this binding under a suitable name
- ; v <- addExit avoid (length abs_vars) rhs
+ ; v <- addExit avoid exit_join_ty (length abs_vars) rhs
-- And jump to it from here
; return $ mkVarApps (Var v) abs_vars }
@@ -263,7 +277,7 @@ exitifyRec in_scope pairs
-- * any bound variables (captured)
-- * any exit join points created so far.
mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId
-mkExitJoinId in_scope ty join_ty join_arity = do
+mkExitJoinId in_scope ty exit_join_ty join_arity = do
fs <- get
let avoid = in_scope `extendInScopeSetList` (map fst fs)
`extendInScopeSet` exit_id_tmpl -- just cosmetics
@@ -271,17 +285,65 @@ mkExitJoinId in_scope ty join_ty join_arity = do
where
exit_id_tmpl =
asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty)
- join_ty join_arity
+ exit_join_ty join_arity
-addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
-addExit in_scope join_arity rhs = do
+addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope exit_join_ty join_arity rhs = do
-- Pick a suitable name
let ty = exprType rhs
- v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity
+ v <- mkExitJoinId in_scope ty exit_join_ty join_arity
fs <- get
put ((v,rhs):fs)
return v
+{- Note [Exitification and quasi join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we float an exit path, we must determine if the new exit join point
+should be a true join point or a quasi join point, in the sense of
+Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration).
+
+The new exit join point must be a quasi join point if either of the following
+conditions apply.
+
+ (ExitJoin1) The exit path occurs under a cast or a profiling tick.
+
+ (ExitJoin2) The original joinrec was a quasi join point.
+
+Rationale for (ExitJoin1):
+
+ Suppose we have:
+
+ joinrec j x = ... case ... of alts -> e |> co ... in ...
+
+ After exitifying 'e' to 'exit':
+
+ join exit y = e in
+ joinrec j x = ... case ... of alts -> (exit y) |> co ... in ...
+
+ Because the jump to 'exit' occurs under a cast, 'exit' must be classified
+ as a quasi join point.
+
+Rationale for (ExitJoin2):
+
+ Suppose we have:
+
+ quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co
+
+ If we float an exit out of 'j', we end up with
+
+ join exit = 100 in
+ quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co
+
+ Now suppose we inline j and simplify; we end up with:
+
+ join exit = 100 in exit |> co
+
+ We see now that 'exit' must be a quasi join point, due to the cast.
+
+ Hence: exit join points for a parent quasi join point must themselves be
+ quasi join points.
+-}
+
{-
Note [Interesting expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -68,7 +68,6 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
import Data.List (mapAccumL)
-import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semi
{-
@@ -4118,10 +4117,7 @@ setBinderOcc occ_info bndr
-- See Note [Invariants on join points] in "GHC.Core".
decideRecJoinPointHood :: TopLevelFlag -> UsageDetails
-> [CoreBndr] -> Maybe JoinPointType
-decideRecJoinPointHood lvl usage bndrs = do
- bndrsNE <- NE.nonEmpty bndrs
- -- Invariant 3: Either all are join points or none are
- Semi.sconcat <$> traverse ok bndrsNE
+decideRecJoinPointHood lvl usage = joinPointType_maybe ok
where
ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont
of a SpecConstr-generated RULE for a join point.
-}
--- SLD TODO horrible logic that must be removed
-peelJoinResTy :: Int -> Type -> Type
-peelJoinResTy 0 ty = ty
-peelJoinResTy n ty
- | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty
- = peelJoinResTy n inner_ty
- | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty
- = peelJoinResTy (n-1) res_ty
- | otherwise
- = ty
+joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type
+joinResTy n0 ty0 = go n0 ty0
+ where
+ go 0 ty = ty
+ go n ty
+ | Just (_bndr, res_ty) <- splitPiTy_maybe ty
+ = go (n-1) res_ty
+ | otherwise
+ = pprPanic "joinResTy" $
+ vcat [ text "join arity:" <+> ppr n0
+ , text "join ty:" <+> ppr ty0
+ , text "n:" <+> ppr n
+ , text "ty:" <+> ppr ty
+ ]
simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplNonRecJoinPoint env bndr rhs body cont
+simplNonRecJoinPoint env0 bndr rhs body cont0
= assert (isJoinId bndr) $
- wrapJoinCont do_case_case env cont $ \ env cont ->
+ wrapJoinCont do_case_case env0 bndr cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
do { -- We push join_cont into the join RHS and the body;
-- and wrap wrap_cont around the whole thing
- ; let (mult, res_ty)
- -- SLD TODO
- | Just QuasiJoinPoint <- joinId_maybe bndr
- = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+ let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
- ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)
- ; (floats2, body') <- simplExprF env3 body cont
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont)
+ ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env)
+ ; (floats2, body') <- simplExprF env3 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
do_case_case
| Just TrueJoinPoint <- joinId_maybe bndr
- = seCaseCase env
+ = seCaseCase env0
| otherwise
= False
simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplRecJoinPoint env pairs body cont
- = wrapJoinCont do_case_case env cont $ \ env cont ->
- do { let bndrs = map fst pairs
- (mult, res_ty)
- -- SLD TODO
- | [b] <- bndrs
- , Just QuasiJoinPoint <- joinId_maybe b
- = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+simplRecJoinPoint env0 pairs body cont0
+ = wrapJoinCont do_case_case env0 (head bndrs) cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
+ do { let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; env1 <- simplRecJoinBndrs env bndrs mult res_ty
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
- ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs
- ; (floats2, body') <- simplExprF env2 body cont
+ ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs
+ ; (floats2, body') <- simplExprF env2 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
+ bndrs = map fst pairs
+
do_case_case =
- if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs
- then seCaseCase env
+ if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs
+ then seCaseCase env0
else False
--------------------
+
+-- | Information computed by 'wrapJoinCont'.
+data WrapJoinCont
+ = WJC
+ { wjc_bind_env :: !SimplEnv
+ , wjc_bind_cont :: !SimplCont
+ , wjc_body_cont :: !SimplCont
+ }
+
wrapJoinCont :: Bool
- -> SimplEnv -> SimplCont
- -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
+ -> SimplEnv -> InId -> SimplCont
+ -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr))
-> SimplM (SimplFloats, OutExpr)
-- Deal with making the continuation duplicable if necessary,
-- and with the no-case-of-case situation.
-wrapJoinCont do_case_case env cont thing_inside
+wrapJoinCont do_case_case env join_bndr cont thing_inside
| contIsStop cont -- Common case; no need for fancy footwork
- = thing_inside env cont
+ = thing_inside $
+ WJC { wjc_bind_env = env
+ , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont
+ , wjc_body_cont = cont
+ }
| do_case_case
-- Normal situation: do the "case-of-case" transformation.
-- See Note [Join points and case-of-case].
= do { (floats1, cont') <- mkDupableCont env cont
- ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
+ ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1
+ , wjc_bind_cont = cont'
+ , wjc_body_cont = cont'
+ }
+ ; (floats2, result) <- thing_inside wjc
; return (floats1 `addFloats` floats2, result) }
| otherwise
-- No "case-of-case" transformation.
-- See Note [Join points with -fno-case-of-case].
- = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))
+ = do { let
+ wjc = WJC { wjc_bind_env = env
+ , wjc_bind_cont = no_case_case_bind_cont
+ , wjc_body_cont = mkBoringStop (contHoleType cont)
+ }
+ ; (floats1, expr1) <- thing_inside wjc
; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
; return (floats2 `addFloats` floats3, expr3) }
+ where
+ -- See Wrinkle [Casts and join point result types]
+ join_res_ty = joinResTy (idJoinArity join_bndr)
+ $ substTy env (idType join_bndr)
+ no_case_case_bind_cont = mkBoringStop join_res_ty
--------------------
trimJoinCont :: Id -- Used only in error message
@@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the
argument to both the join point RHS and the case alternatives:
join { j :: Bool -> IO (); j _ = guts arg ] }
- in case b of
- False -> (scctick<foo> jump j True) arg
- True -> jump j False arg
+ in case b of
+ False -> (scctick<foo> jump j True) arg
+ True -> jump j False arg
Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails
for the first branch, because 'trimJoinCont' doesn't look through profiling
@@ -2293,9 +2318,9 @@ 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
+ 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).
@@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'.
Similarly for casts:
join { j = blah }
- in case e of
- False -> j True |> co1
- True -> j False |> co2
+ in case e of
+ False -> j True |> co1
+ True -> j False |> co2
if we want to apply this to an argument 'arg', we would need to perform the
following transformation:
join { j co = ( blah |> co ) arg }
- in case e of
- False -> j co1 True
- True -> j co2 False
+ in case e of
+ False -> j co1 True
+ True -> j co2 False
in which we add a coercion argument to the join point. Again, this is not a
transformation we currently implement, so we instead prevent case-of-case for
@@ -2339,6 +2364,33 @@ we proceed as follows:
If we are dealing with a quasi join point, we switch off the case-of-case
transformation.
+Wrinkle [Casts and join point result types]
+
+ When dealing with a quasi joint-point, we must preserve the original type of
+ the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType).
+ This is because we don't trim the continuation like we do in
+ Note [Join points and case-of-case].
+
+ For example, suppose we have:
+
+ type family F a
+
+ join
+ j :: forall a. a -> F a
+ j @a x = ...
+ in case e of
+ False -> j @T1 x1 |> ( co1 :: F T1 ~ Int )
+ True -> j @T2 x2 |> ( co2 :: F T2 ~ Int )
+
+ If we used 'contHoleType cont' to compute the result type of 'j', we would
+ change the result type of 'j' to 'Int', when it needs to remain 'F a'.
+
+ Instead, we avoid doing that and re-compute the result type of 'j' using
+ 'joinResTy' to get 'F a', as required.
+
+See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify
+for another wrinkle.
+
************************************************************************
* *
Variables
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -79,7 +79,8 @@ module GHC.Types.Id (
-- ** Join variables
JoinId, JoinPointHood,
- isJoinId, joinId_maybe, idJoinPointHood, idJoinArity,
+ isJoinId, joinId_maybe, joinPointType_maybe,
+ idJoinPointHood, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
-- ** Inline pragma stuff
@@ -172,6 +173,8 @@ import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Semigroup as Semi
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
@@ -584,6 +587,13 @@ joinId_maybe id
_ -> Nothing
| otherwise = Nothing
+joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType
+joinPointType_maybe f xs = do
+ xsNE <- NE.nonEmpty xs
+ Semi.sconcat <$> traverse f xsNE
+ -- traverse: either all are join points or none are
+ -- sconcat: only a 'TrueJoinPoint' if all are
+
-- | Doesn't return strictness marks
idJoinPointHood :: Var -> JoinPointHood
idJoinPointHood id
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/593b8b964a2783934499bd81d625e4d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/593b8b964a2783934499bd81d625e4d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
27 Jan '26
Cheng Shao pushed new branch wip/submodule-bumps-2026-01 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/submodule-bumps-2026-01
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add operations for obtaining operating-system handles
by Marge Bot (＠marge-bot) 27 Jan '26
by Marge Bot (＠marge-bot) 27 Jan '26
27 Jan '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
5957a8ad by Wolfgang Jeltsch at 2026-01-27T06:11:40-05:00
Add operations for obtaining operating-system handles
This contribution implements CLC proposal #369. It adds operations for
obtaining POSIX file descriptors and Windows handles that underlie
Haskell handles. Those operating system handles can also be obtained
without such additional operations, but this is more involved and, more
importantly, requires using internals.
- - - - -
86a0510c by Greg Steuck at 2026-01-27T06:12:34-05:00
Move flags to precede patterns for grep and read files directly
This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools.
There's no reason to use cat and pipe where direct file argument works.
- - - - -
eeabc098 by Cheng Shao at 2026-01-27T12:20:33-05:00
ci: update darwin boot ghc to 9.10.3
This patch updates darwin boot ghc to 9.10.3, along with other related
updates, and pays off some technical debt here:
- Update `nixpkgs` and use the `nixpkgs-25.05-darwin` channel.
- Update the `niv` template.
- Update LLVM to 21 and update `llvm-targets` to reflect LLVM 21
layout changes for arm64/x86_64 darwin targets.
- Use `stdenvNoCC` to prevent nix packaged apple sdk from being used
by boot ghc, and manually set `DEVELOPER_DIR`/`SDKROOT` to enforce
the usage of system-wide command line sdk for macos.
- When building nix derivation for boot ghc, run `configure` via the
`arch` command so that `configure` and its subprocesses pick up the
manually specified architecture.
- Remove the previous horrible hack that obliterates `configure` to
make autoconf test result in true. `configure` now properly does its
job.
- Remove the now obsolete configure args and post install settings
file patching logic.
- Use `scheme-small` for texlive to avoid build failures in certain
unused texlive packages, especially on x86_64-darwin.
- - - - -
7a6d9d44 by Matthew Pickering at 2026-01-27T12:20:34-05:00
Evaluate backtraces for "error" exceptions at the moment they are thrown
See Note [Capturing the backtrace in throw] and
Note [Hiding precise exception signature in throw] which explain the
implementation.
This commit makes `error` and `throw` behave the same with regard to
backtraces. Previously, exceptions raised by `error` would not contain
useful IPE backtraces.
I did try and implement `error` in terms of `throw` but it started to
involve putting diverging functions into hs-boot files, which seemed to
risky if the compiler wouldn't be able to see if applying a function
would diverge.
CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383
Fixes #26751
- - - - -
1516e93a by Teo Camarasu at 2026-01-27T12:20:35-05:00
ghc-internal: move all Data instances to Data.Data
Most instances of Data are defined in GHC.Internal.Data.Data.
Let's move all remaining instance there.
This moves other modules down in the dependency hierarchy allowing for
more parallelism, and it decreases the likelihood that we would need to
load this heavy .hi file if we don't actually need it.
Resolves #26830
Metric Decrease:
T12227
T16875
- - - - -
41 changed files:
- .gitlab/darwin/nix/sources.json
- .gitlab/darwin/toolchain.nix
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- + libraries/base/src/System/IO/OS.hs
- libraries/base/tests/IO/all.T
- + libraries/base/tests/IO/osHandles001FileDescriptors.hs
- + libraries/base/tests/IO/osHandles001FileDescriptors.stdout
- + libraries/base/tests/IO/osHandles001WindowsHandles.hs
- + libraries/base/tests/IO/osHandles001WindowsHandles.stdout
- + libraries/base/tests/IO/osHandles002FileDescriptors.hs
- + libraries/base/tests/IO/osHandles002FileDescriptors.stderr
- + libraries/base/tests/IO/osHandles002FileDescriptors.stdin
- + libraries/base/tests/IO/osHandles002FileDescriptors.stdout
- + libraries/base/tests/IO/osHandles002WindowsHandles.hs
- + libraries/base/tests/IO/osHandles002WindowsHandles.stderr
- + libraries/base/tests/IO/osHandles002WindowsHandles.stdin
- + libraries/base/tests/IO/osHandles002WindowsHandles.stdout
- libraries/base/tests/perf/Makefile
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/Err.hs
- libraries/ghc-internal/src/GHC/Internal/Exts.hs
- libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs
- + libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- libraries/ghc-internal/tests/stack-annotation/all.T
- + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs
- + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout
- llvm-targets
- testsuite/tests/driver/T16318/Makefile
- testsuite/tests/driver/T18125/Makefile
- testsuite/tests/ghci.debugger/scripts/T8487.stdout
- testsuite/tests/ghci.debugger/scripts/break011.stdout
- testsuite/tests/ghci.debugger/scripts/break017.stdout
- testsuite/tests/ghci.debugger/scripts/break025.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bce2a8faf0531ef6367d783bd316dc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bce2a8faf0531ef6367d783bd316dc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
27 Jan '26
sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC
Commits:
b73a1274 by sheaf at 2026-01-27T18:01:38+01:00
deal with exitification
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Types/Id.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -45,12 +45,14 @@ import GHC.Core.Type
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin )
+
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Types.Basic( JoinPointHood(..) )
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Misc( mapSnd )
+import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -104,7 +106,7 @@ exitifyProgram binds = map goTopLvl binds
-- | State Monad used inside `exitify`
-type ExitifyM = State [(JoinId, CoreExpr)]
+type ExitifyM = State [(JoinId, CoreExpr)]
-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
-- join-points outside the joinrec.
@@ -124,7 +126,7 @@ exitifyRec in_scope pairs
forM ann_pairs $ \(x,rhs) -> do
-- go past the lambdas of the join point
let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
- body' <- go args body
+ body' <- go TrueJoinPoint args body
let rhs' = mkLams args body'
return (x, rhs')
@@ -135,40 +137,41 @@ exitifyRec in_scope pairs
-- variables bound on the way and lifts it out as a join point.
--
-- ExitifyM is a state monad to keep track of floated binds
- go :: [Var] -- Variables that are in-scope here, but
- -- not in scope at the joinrec; that is,
- -- we must potentially abstract over them.
- -- Invariant: they are kept in dependency order
+ go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables that are in-scope here, but
+ -- not in scope at the joinrec; that is,
+ -- we must potentially abstract over them.
+ -- Invariant: they are kept in dependency order
-> CoreExprWithFVs -- Current expression in tail position
-> ExitifyM CoreExpr
-- We first look at the expression (no matter what it shape is)
-- and determine if we can turn it into a exit join point
- go captured ann_e
+ go join_ty captured ann_e
| -- An exit expression has no recursive calls
let fvs = dVarSetToVarSet (freeVarsOf ann_e)
, disjointVarSet fvs recursive_calls
- = go_exit captured (deAnnotate ann_e) fvs
+ = go_exit join_ty captured (deAnnotate ann_e) fvs
-- We could not turn it into a exit join point. So now recurse
-- into all expression where eligible exit join points might sit,
-- i.e. into all tail-call positions:
-- Case right hand sides are in tail-call position
- go captured (_, AnnCase scrut bndr ty alts) = do
+ go join_ty captured (_, AnnCase scrut bndr ty alts) = do
alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do
- rhs' <- go (captured ++ [bndr] ++ pats) rhs
+ rhs' <- go join_ty (captured ++ [bndr] ++ pats) rhs
return (Alt dc pats rhs')
return $ Case (deAnnotate scrut) bndr ty alts'
- go captured (_, AnnLet ann_bind body)
+ go join_ty captured (_, AnnLet ann_bind body)
-- join point, RHS and body are in tail-call position
| AnnNonRec j rhs <- ann_bind
, JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j
= do let (params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ params) join_body
+ join_body' <- go join_ty (captured ++ params) join_body
let rhs' = mkLams params join_body'
- body' <- go (captured ++ [j]) body
+ body' <- go join_ty (captured ++ [j]) body
return $ Let (NonRec j rhs') body'
-- rec join point, RHSs and body are in tail-call position
@@ -178,30 +181,41 @@ exitifyRec in_scope pairs
pairs' <- forM pairs $ \(j,rhs) -> do
let join_arity = idJoinArity j
(params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ js ++ params) join_body
+ join_body' <- go join_ty (captured ++ js ++ params) join_body
let rhs' = mkLams params join_body'
return (j, rhs')
- body' <- go (captured ++ js) body
+ body' <- go join_ty (captured ++ js) body
return $ Let (Rec pairs') body'
-- normal Let, only the body is in tail-call position
| otherwise
- = do body' <- go (captured ++ bindersOf bind ) body
+ = do body' <- go join_ty (captured ++ bindersOf bind ) body
return $ Let bind body'
where bind = deAnnBind ann_bind
+ -- See Note [Exitification and quasi join points]
+ go _ captured (_, AnnCast ann_e (_, co)) = do
+ e' <- go QuasiJoinPoint captured ann_e
+ return (Cast e' co)
+ go join_ty captured (_, AnnTick tickish ann_e)
+ | tickishCanScopeJoin tickish
+ = Tick tickish <$> go join_ty captured ann_e
+ | ProfNote {} <- tickish
+ = Tick tickish <$> go QuasiJoinPoint captured ann_e
+
-- Cannot be turned into an exit join point, but also has no
-- tail-call subexpression. Nothing to do here.
- go _ ann_e = return (deAnnotate ann_e)
+ go _ _ ann_e = return (deAnnotate ann_e)
---------------------
- go_exit :: [Var] -- Variables captured locally
+ go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables captured locally
-> CoreExpr -- An exit expression
-> VarSet -- Free vars of the expression
-> ExitifyM CoreExpr
-- go_exit deals with a tail expression that is floatable
-- out as an exit point; that is, it mentions no recursive calls
- go_exit captured e fvs
+ go_exit join_ty captured e fvs
-- Do not touch an expression that is already a join jump where all arguments
-- are captured variables. See Note [Idempotency]
-- But _do_ float join jumps with interesting arguments.
@@ -226,7 +240,7 @@ exitifyRec in_scope pairs
let rhs = mkLams abs_vars e
avoid = in_scope `extendInScopeSetList` captured
-- Remember this binding under a suitable name
- ; v <- addExit avoid (length abs_vars) rhs
+ ; v <- addExit avoid join_ty (length abs_vars) rhs
-- And jump to it from here
; return $ mkVarApps (Var v) abs_vars }
@@ -273,15 +287,38 @@ mkExitJoinId in_scope ty join_ty join_arity = do
asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty)
join_ty join_arity
-addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
-addExit in_scope join_arity rhs = do
+addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope join_ty join_arity rhs = do
-- Pick a suitable name
let ty = exprType rhs
- v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity
+ v <- mkExitJoinId in_scope ty join_ty join_arity
fs <- get
put ((v,rhs):fs)
return v
+{- Note [Exitification and quasi join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we float an exit path that occurs under a cast (or a profiling tick), we
+must use a quasi join point instead of a true join point, as per
+Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration.
+
+For example, suppose we have:
+
+ joinrec j x = ... case ... of alts -> e |> co ...
+
+We might float 'e' to a new join point 'exit':
+
+ join exit y = e
+ joinrec j x = ... case ... of alts -> (jump exit y) |> co ...
+
+Because the jump to 'exit' occurs under a cast, 'exit' must be classified
+as a quasi join point.
+
+We achieve this by passing a 'JoinPointType' around in 'exitifyRec' which lets
+us know what kind of exit join point to create; we switch it into 'QuasiJoinPoint'
+when we go under a cast (or a profiling tick).
+-}
+
{-
Note [Interesting expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -68,7 +68,6 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
import Data.List (mapAccumL)
-import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semi
{-
@@ -4118,10 +4117,7 @@ setBinderOcc occ_info bndr
-- See Note [Invariants on join points] in "GHC.Core".
decideRecJoinPointHood :: TopLevelFlag -> UsageDetails
-> [CoreBndr] -> Maybe JoinPointType
-decideRecJoinPointHood lvl usage bndrs = do
- bndrsNE <- NE.nonEmpty bndrs
- -- Invariant 3: Either all are join points or none are
- Semi.sconcat <$> traverse ok bndrsNE
+decideRecJoinPointHood lvl usage = joinPointType_maybe ok
where
ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont
of a SpecConstr-generated RULE for a join point.
-}
--- SLD TODO horrible logic that must be removed
-peelJoinResTy :: Int -> Type -> Type
-peelJoinResTy 0 ty = ty
-peelJoinResTy n ty
- | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty
- = peelJoinResTy n inner_ty
- | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty
- = peelJoinResTy (n-1) res_ty
- | otherwise
- = ty
+joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type
+joinResTy n0 ty0 = go n0 ty0
+ where
+ go 0 ty = ty
+ go n ty
+ | Just (_bndr, res_ty) <- splitPiTy_maybe ty
+ = go (n-1) res_ty
+ | otherwise
+ = pprPanic "joinResTy" $
+ vcat [ text "join arity:" <+> ppr n0
+ , text "join ty:" <+> ppr ty0
+ , text "n:" <+> ppr n
+ , text "ty:" <+> ppr ty
+ ]
simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplNonRecJoinPoint env bndr rhs body cont
+simplNonRecJoinPoint env0 bndr rhs body cont0
= assert (isJoinId bndr) $
- wrapJoinCont do_case_case env cont $ \ env cont ->
+ wrapJoinCont do_case_case env0 bndr cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
do { -- We push join_cont into the join RHS and the body;
-- and wrap wrap_cont around the whole thing
- ; let (mult, res_ty)
- -- SLD TODO
- | Just QuasiJoinPoint <- joinId_maybe bndr
- = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+ let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
- ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)
- ; (floats2, body') <- simplExprF env3 body cont
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont)
+ ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env)
+ ; (floats2, body') <- simplExprF env3 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
do_case_case
| Just TrueJoinPoint <- joinId_maybe bndr
- = seCaseCase env
+ = seCaseCase env0
| otherwise
= False
simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplRecJoinPoint env pairs body cont
- = wrapJoinCont do_case_case env cont $ \ env cont ->
- do { let bndrs = map fst pairs
- (mult, res_ty)
- -- SLD TODO
- | [b] <- bndrs
- , Just QuasiJoinPoint <- joinId_maybe b
- = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+simplRecJoinPoint env0 pairs body cont0
+ = wrapJoinCont do_case_case env0 (head bndrs) cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
+ do { let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; env1 <- simplRecJoinBndrs env bndrs mult res_ty
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
- ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs
- ; (floats2, body') <- simplExprF env2 body cont
+ ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs
+ ; (floats2, body') <- simplExprF env2 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
+ bndrs = map fst pairs
+
do_case_case =
- if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs
- then seCaseCase env
+ if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs
+ then seCaseCase env0
else False
--------------------
+
+-- | Information computed by 'wrapJoinCont'.
+data WrapJoinCont
+ = WJC
+ { wjc_bind_env :: !SimplEnv
+ , wjc_bind_cont :: !SimplCont
+ , wjc_body_cont :: !SimplCont
+ }
+
wrapJoinCont :: Bool
- -> SimplEnv -> SimplCont
- -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
+ -> SimplEnv -> InId -> SimplCont
+ -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr))
-> SimplM (SimplFloats, OutExpr)
-- Deal with making the continuation duplicable if necessary,
-- and with the no-case-of-case situation.
-wrapJoinCont do_case_case env cont thing_inside
+wrapJoinCont do_case_case env join_bndr cont thing_inside
| contIsStop cont -- Common case; no need for fancy footwork
- = thing_inside env cont
+ = thing_inside $
+ WJC { wjc_bind_env = env
+ , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont
+ , wjc_body_cont = cont
+ }
| do_case_case
-- Normal situation: do the "case-of-case" transformation.
-- See Note [Join points and case-of-case].
= do { (floats1, cont') <- mkDupableCont env cont
- ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
+ ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1
+ , wjc_bind_cont = cont'
+ , wjc_body_cont = cont'
+ }
+ ; (floats2, result) <- thing_inside wjc
; return (floats1 `addFloats` floats2, result) }
| otherwise
-- No "case-of-case" transformation.
-- See Note [Join points with -fno-case-of-case].
- = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))
+ = do { let
+ wjc = WJC { wjc_bind_env = env
+ , wjc_bind_cont = no_case_case_bind_cont
+ , wjc_body_cont = mkBoringStop (contHoleType cont)
+ }
+ ; (floats1, expr1) <- thing_inside wjc
; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
; return (floats2 `addFloats` floats3, expr3) }
+ where
+ -- See Wrinkle [Casts and join point result types]
+ join_res_ty = joinResTy (idJoinArity join_bndr)
+ $ substTy env (idType join_bndr)
+ no_case_case_bind_cont = mkBoringStop join_res_ty
--------------------
trimJoinCont :: Id -- Used only in error message
@@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the
argument to both the join point RHS and the case alternatives:
join { j :: Bool -> IO (); j _ = guts arg ] }
- in case b of
- False -> (scctick<foo> jump j True) arg
- True -> jump j False arg
+ in case b of
+ False -> (scctick<foo> jump j True) arg
+ True -> jump j False arg
Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails
for the first branch, because 'trimJoinCont' doesn't look through profiling
@@ -2293,9 +2318,9 @@ 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
+ 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).
@@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'.
Similarly for casts:
join { j = blah }
- in case e of
- False -> j True |> co1
- True -> j False |> co2
+ in case e of
+ False -> j True |> co1
+ True -> j False |> co2
if we want to apply this to an argument 'arg', we would need to perform the
following transformation:
join { j co = ( blah |> co ) arg }
- in case e of
- False -> j co1 True
- True -> j co2 False
+ in case e of
+ False -> j co1 True
+ True -> j co2 False
in which we add a coercion argument to the join point. Again, this is not a
transformation we currently implement, so we instead prevent case-of-case for
@@ -2339,6 +2364,33 @@ we proceed as follows:
If we are dealing with a quasi join point, we switch off the case-of-case
transformation.
+Wrinkle [Casts and join point result types]
+
+ When dealing with a quasi joint-point, we must preserve the original type of
+ the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType).
+ This is because we don't trim the continuation like we do in
+ Note [Join points and case-of-case].
+
+ For example, suppose we have:
+
+ type family F a
+
+ join
+ j :: forall a. a -> F a
+ j @a x = ...
+ in case e of
+ False -> j @T1 x1 |> ( co1 :: F T1 ~ Int )
+ True -> j @T2 x2 |> ( co2 :: F T2 ~ Int )
+
+ If we used 'contHoleType cont' to compute the result type of 'j', we would
+ change the result type of 'j' to 'Int', when it needs to remain 'F a'.
+
+ Instead, we avoid doing that and re-compute the result type of 'j' using
+ 'joinResTy' to get 'F a', as required.
+
+See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify
+for another wrinkle.
+
************************************************************************
* *
Variables
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -79,7 +79,8 @@ module GHC.Types.Id (
-- ** Join variables
JoinId, JoinPointHood,
- isJoinId, joinId_maybe, idJoinPointHood, idJoinArity,
+ isJoinId, joinId_maybe, joinPointType_maybe,
+ idJoinPointHood, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
-- ** Inline pragma stuff
@@ -172,6 +173,8 @@ import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Semigroup as Semi
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
@@ -584,6 +587,13 @@ joinId_maybe id
_ -> Nothing
| otherwise = Nothing
+joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType
+joinPointType_maybe f xs = do
+ xsNE <- NE.nonEmpty xs
+ Semi.sconcat <$> traverse f xsNE
+ -- traverse: either all are join points or none are
+ -- sconcat: only a 'TrueJoinPoint' if all are
+
-- | Doesn't return strictness marks
idJoinPointHood :: Var -> JoinPointHood
idJoinPointHood id
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b73a1274f2a56dee874a0ac24ebfbad…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b73a1274f2a56dee874a0ac24ebfbad…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
27 Jan '26
sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC
Commits:
44145574 by sheaf at 2026-01-27T17:58:57+01:00
deal with exitification
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Types/Id.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -45,12 +45,14 @@ import GHC.Core.Type
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Tickish ( GenTickish(..), tickishCanScopeJoin )
+
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Types.Basic( JoinPointHood(..) )
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Misc( mapSnd )
+import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -104,7 +106,7 @@ exitifyProgram binds = map goTopLvl binds
-- | State Monad used inside `exitify`
-type ExitifyM = State [(JoinId, CoreExpr)]
+type ExitifyM = State [(JoinId, CoreExpr)]
-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
-- join-points outside the joinrec.
@@ -124,7 +126,7 @@ exitifyRec in_scope pairs
forM ann_pairs $ \(x,rhs) -> do
-- go past the lambdas of the join point
let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
- body' <- go args body
+ body' <- go TrueJoinPoint args body
let rhs' = mkLams args body'
return (x, rhs')
@@ -135,40 +137,41 @@ exitifyRec in_scope pairs
-- variables bound on the way and lifts it out as a join point.
--
-- ExitifyM is a state monad to keep track of floated binds
- go :: [Var] -- Variables that are in-scope here, but
- -- not in scope at the joinrec; that is,
- -- we must potentially abstract over them.
- -- Invariant: they are kept in dependency order
+ go :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables that are in-scope here, but
+ -- not in scope at the joinrec; that is,
+ -- we must potentially abstract over them.
+ -- Invariant: they are kept in dependency order
-> CoreExprWithFVs -- Current expression in tail position
-> ExitifyM CoreExpr
-- We first look at the expression (no matter what it shape is)
-- and determine if we can turn it into a exit join point
- go captured ann_e
+ go join_ty captured ann_e
| -- An exit expression has no recursive calls
let fvs = dVarSetToVarSet (freeVarsOf ann_e)
, disjointVarSet fvs recursive_calls
- = go_exit captured (deAnnotate ann_e) fvs
+ = go_exit join_ty captured (deAnnotate ann_e) fvs
-- We could not turn it into a exit join point. So now recurse
-- into all expression where eligible exit join points might sit,
-- i.e. into all tail-call positions:
-- Case right hand sides are in tail-call position
- go captured (_, AnnCase scrut bndr ty alts) = do
+ go join_ty captured (_, AnnCase scrut bndr ty alts) = do
alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do
- rhs' <- go (captured ++ [bndr] ++ pats) rhs
+ rhs' <- go join_ty (captured ++ [bndr] ++ pats) rhs
return (Alt dc pats rhs')
return $ Case (deAnnotate scrut) bndr ty alts'
- go captured (_, AnnLet ann_bind body)
+ go join_ty captured (_, AnnLet ann_bind body)
-- join point, RHS and body are in tail-call position
| AnnNonRec j rhs <- ann_bind
, JoinPoint { joinPointArity = join_arity } <- idJoinPointHood j
= do let (params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ params) join_body
+ join_body' <- go join_ty (captured ++ params) join_body
let rhs' = mkLams params join_body'
- body' <- go (captured ++ [j]) body
+ body' <- go join_ty (captured ++ [j]) body
return $ Let (NonRec j rhs') body'
-- rec join point, RHSs and body are in tail-call position
@@ -178,30 +181,41 @@ exitifyRec in_scope pairs
pairs' <- forM pairs $ \(j,rhs) -> do
let join_arity = idJoinArity j
(params, join_body) = collectNAnnBndrs join_arity rhs
- join_body' <- go (captured ++ js ++ params) join_body
+ join_body' <- go join_ty (captured ++ js ++ params) join_body
let rhs' = mkLams params join_body'
return (j, rhs')
- body' <- go (captured ++ js) body
+ body' <- go join_ty (captured ++ js) body
return $ Let (Rec pairs') body'
-- normal Let, only the body is in tail-call position
| otherwise
- = do body' <- go (captured ++ bindersOf bind ) body
+ = do body' <- go join_ty (captured ++ bindersOf bind ) body
return $ Let bind body'
where bind = deAnnBind ann_bind
+ -- See Note [Exitification and quasi join points]
+ go _ captured (_, AnnCast ann_e (_, co)) = do
+ e' <- go QuasiJoinPoint captured ann_e
+ return (Cast e' co)
+ go join_ty captured (_, AnnTick tickish ann_e)
+ | tickishCanScopeJoin tickish
+ = Tick tickish <$> go join_ty captured ann_e
+ | ProfNote {} <- tickish
+ = Tick tickish <$> go QuasiJoinPoint captured ann_e
+
-- Cannot be turned into an exit join point, but also has no
-- tail-call subexpression. Nothing to do here.
- go _ ann_e = return (deAnnotate ann_e)
+ go _ _ ann_e = return (deAnnotate ann_e)
---------------------
- go_exit :: [Var] -- Variables captured locally
+ go_exit :: JoinPointType -- what join point type to create; see Note [Exitification and quasi join points]
+ -> [Var] -- Variables captured locally
-> CoreExpr -- An exit expression
-> VarSet -- Free vars of the expression
-> ExitifyM CoreExpr
-- go_exit deals with a tail expression that is floatable
-- out as an exit point; that is, it mentions no recursive calls
- go_exit captured e fvs
+ go_exit join_ty captured e fvs
-- Do not touch an expression that is already a join jump where all arguments
-- are captured variables. See Note [Idempotency]
-- But _do_ float join jumps with interesting arguments.
@@ -226,7 +240,7 @@ exitifyRec in_scope pairs
let rhs = mkLams abs_vars e
avoid = in_scope `extendInScopeSetList` captured
-- Remember this binding under a suitable name
- ; v <- addExit avoid (length abs_vars) rhs
+ ; v <- addExit avoid join_ty (length abs_vars) rhs
-- And jump to it from here
; return $ mkVarApps (Var v) abs_vars }
@@ -273,15 +287,38 @@ mkExitJoinId in_scope ty join_ty join_arity = do
asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty)
join_ty join_arity
-addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
-addExit in_scope join_arity rhs = do
+addExit :: InScopeSet -> JoinPointType -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope join_ty join_arity rhs = do
-- Pick a suitable name
let ty = exprType rhs
- v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity
+ v <- mkExitJoinId in_scope ty join_ty join_arity
fs <- get
put ((v,rhs):fs)
return v
+{- Note [Exitification and quasi join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we float an exit path that occurs under a cast (or a profiling tick), we
+must use a quasi join point instead of a true join point, as per
+Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration.
+
+For example, suppose we have:
+
+ joinrec j x = ... case ... of alts -> e |> co ...
+
+We might float 'e' to a new join point 'exit':
+
+ join exit y = e
+ joinrec j x = ... case ... of alts -> (jump exit y) |> co ...
+
+Because the jump to 'exit' occurs under a cast, 'exit' must be classified
+as a quasi join point.
+
+We achieve this by passing a 'JoinPointType' around in 'exitifyRec' which lets
+us know what kind of exit join point to create; we switch it into 'QuasiJoinPoint'
+when we go under a cast (or a profiling tick).
+-}
+
{-
Note [Interesting expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -4118,10 +4118,7 @@ setBinderOcc occ_info bndr
-- See Note [Invariants on join points] in "GHC.Core".
decideRecJoinPointHood :: TopLevelFlag -> UsageDetails
-> [CoreBndr] -> Maybe JoinPointType
-decideRecJoinPointHood lvl usage bndrs = do
- bndrsNE <- NE.nonEmpty bndrs
- -- Invariant 3: Either all are join points or none are
- Semi.sconcat <$> traverse ok bndrsNE
+decideRecJoinPointHood lvl usage = joinPointType_maybe ok
where
ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2056,93 +2056,118 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont
of a SpecConstr-generated RULE for a join point.
-}
--- SLD TODO horrible logic that must be removed
-peelJoinResTy :: Int -> Type -> Type
-peelJoinResTy 0 ty = ty
-peelJoinResTy n ty
- | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty
- = peelJoinResTy n inner_ty
- | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty
- = peelJoinResTy (n-1) res_ty
- | otherwise
- = ty
+joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type
+joinResTy n0 ty0 = go n0 ty0
+ where
+ go 0 ty = ty
+ go n ty
+ | Just (_bndr, res_ty) <- splitPiTy_maybe ty
+ = go (n-1) res_ty
+ | otherwise
+ = pprPanic "joinResTy" $
+ vcat [ text "join arity:" <+> ppr n0
+ , text "join ty:" <+> ppr ty0
+ , text "n:" <+> ppr n
+ , text "ty:" <+> ppr ty
+ ]
simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplNonRecJoinPoint env bndr rhs body cont
+simplNonRecJoinPoint env0 bndr rhs body cont0
= assert (isJoinId bndr) $
- wrapJoinCont do_case_case env cont $ \ env cont ->
+ wrapJoinCont do_case_case env0 bndr cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
do { -- We push join_cont into the join RHS and the body;
-- and wrap wrap_cont around the whole thing
- ; let (mult, res_ty)
- -- SLD TODO
- | Just QuasiJoinPoint <- joinId_maybe bndr
- = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+ let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
- ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)
- ; (floats2, body') <- simplExprF env3 body cont
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont)
+ ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env)
+ ; (floats2, body') <- simplExprF env3 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
do_case_case
| Just TrueJoinPoint <- joinId_maybe bndr
- = seCaseCase env
+ = seCaseCase env0
| otherwise
= False
simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
-> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
-simplRecJoinPoint env pairs body cont
- = wrapJoinCont do_case_case env cont $ \ env cont ->
- do { let bndrs = map fst pairs
- (mult, res_ty)
- -- SLD TODO
- | [b] <- bndrs
- , Just QuasiJoinPoint <- joinId_maybe b
- = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b))
- | otherwise
- = (contHoleScaling cont, contResultType cont)
+simplRecJoinPoint env0 pairs body cont0
+ = wrapJoinCont do_case_case env0 (head bndrs) cont0 $
+ \ WJC { wjc_bind_env = env, wjc_bind_cont = bind_cont, wjc_body_cont = body_cont } ->
+ do { let mult = contHoleScaling bind_cont
+ res_ty = contResultType bind_cont
; env1 <- simplRecJoinBndrs env bndrs mult res_ty
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
- ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs
- ; (floats2, body') <- simplExprF env2 body cont
+ ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs
+ ; (floats2, body') <- simplExprF env2 body body_cont
; return (floats1 `addFloats` floats2, body') }
where
+ bndrs = map fst pairs
+
do_case_case =
- if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs
- then seCaseCase env
+ if all ((== Just TrueJoinPoint) . joinId_maybe) bndrs
+ then seCaseCase env0
else False
--------------------
+
+-- | Information computed by 'wrapJoinCont'.
+data WrapJoinCont
+ = WJC
+ { wjc_bind_env :: !SimplEnv
+ , wjc_bind_cont :: !SimplCont
+ , wjc_body_cont :: !SimplCont
+ }
+
wrapJoinCont :: Bool
- -> SimplEnv -> SimplCont
- -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
+ -> SimplEnv -> InId -> SimplCont
+ -> (WrapJoinCont -> SimplM (SimplFloats, OutExpr))
-> SimplM (SimplFloats, OutExpr)
-- Deal with making the continuation duplicable if necessary,
-- and with the no-case-of-case situation.
-wrapJoinCont do_case_case env cont thing_inside
+wrapJoinCont do_case_case env join_bndr cont thing_inside
| contIsStop cont -- Common case; no need for fancy footwork
- = thing_inside env cont
+ = thing_inside $
+ WJC { wjc_bind_env = env
+ , wjc_bind_cont = if do_case_case then cont else no_case_case_bind_cont
+ , wjc_body_cont = cont
+ }
| do_case_case
-- Normal situation: do the "case-of-case" transformation.
-- See Note [Join points and case-of-case].
= do { (floats1, cont') <- mkDupableCont env cont
- ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
+ ; let wjc = WJC { wjc_bind_env = env `setInScopeFromF` floats1
+ , wjc_bind_cont = cont'
+ , wjc_body_cont = cont'
+ }
+ ; (floats2, result) <- thing_inside wjc
; return (floats1 `addFloats` floats2, result) }
| otherwise
-- No "case-of-case" transformation.
-- See Note [Join points with -fno-case-of-case].
- = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))
+ = do { let
+ wjc = WJC { wjc_bind_env = env
+ , wjc_bind_cont = no_case_case_bind_cont
+ , wjc_body_cont = mkBoringStop (contHoleType cont)
+ }
+ ; (floats1, expr1) <- thing_inside wjc
; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
; return (floats2 `addFloats` floats3, expr3) }
+ where
+ -- See Wrinkle [Casts and join point result types]
+ join_res_ty = joinResTy (idJoinArity join_bndr)
+ $ substTy env (idType join_bndr)
+ no_case_case_bind_cont = mkBoringStop join_res_ty
--------------------
trimJoinCont :: Id -- Used only in error message
@@ -2282,9 +2307,9 @@ As per Note [Join points and case-of-case], we proceed by first applying the
argument to both the join point RHS and the case alternatives:
join { j :: Bool -> IO (); j _ = guts arg ] }
- in case b of
- False -> (scctick<foo> jump j True) arg
- True -> jump j False arg
+ in case b of
+ False -> (scctick<foo> jump j True) arg
+ True -> jump j False arg
Then we rely on 'trimJoinCont' to remove the argument. In this case, this fails
for the first branch, because 'trimJoinCont' doesn't look through profiling
@@ -2293,9 +2318,9 @@ 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
+ 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).
@@ -2307,17 +2332,17 @@ So instead, for now, we simply disallow the case-of-case transformation for 'j'.
Similarly for casts:
join { j = blah }
- in case e of
- False -> j True |> co1
- True -> j False |> co2
+ in case e of
+ False -> j True |> co1
+ True -> j False |> co2
if we want to apply this to an argument 'arg', we would need to perform the
following transformation:
join { j co = ( blah |> co ) arg }
- in case e of
- False -> j co1 True
- True -> j co2 False
+ in case e of
+ False -> j co1 True
+ True -> j co2 False
in which we add a coercion argument to the join point. Again, this is not a
transformation we currently implement, so we instead prevent case-of-case for
@@ -2339,6 +2364,44 @@ we proceed as follows:
If we are dealing with a quasi join point, we switch off the case-of-case
transformation.
+Wrinkle [Casts and join point result types]
+
+ When dealing with a quasi joint-point, we must preserve the original type of
+ the join point instead of transforming the type (as in Core.Opt.Simplify.Env.adjustJoinPointType).
+ This is because we don't trim the continuation like we do in
+ Note [Join points and case-of-case].
+
+ For example, suppose we have:
+
+ type family F a
+
+ join
+ j :: forall a. a -> F a
+ j @a x = ...
+ in case e of
+ False -> j @T1 x1 |> ( co1 :: F T1 ~ Int )
+ True -> j @T2 x2 |> ( co2 :: F T2 ~ Int )
+
+ If we used 'contHoleType cont' to compute the result type of 'j', we would
+ change the result type of 'j' to 'Int', when it needs to remain 'F a'.
+
+ Instead, we avoid doing that and re-compute the result type of 'j' using
+ 'joinResTy' to get 'F a', as required.
+
+See also Note [Exitification and quasi join points] in GHC.Core.Opt.Exitify
+for another wrinkle.
+
+ When we float an exit path that occurs under a cast, we must be careful.
+ If we have:
+ joinrec j x = ... case ... of alts -> e |> co ...
+ We might float 'e' to a new join point 'exit':
+ join exit y = e
+ joinrec j x = ... case ... of alts -> (jump exit y) |> co ...
+
+ Because the jump to 'exit' occurs under a cast ('co'), 'exit' must be
+ classified as a quasi join point.
+
+
************************************************************************
* *
Variables
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -79,7 +79,8 @@ module GHC.Types.Id (
-- ** Join variables
JoinId, JoinPointHood,
- isJoinId, joinId_maybe, idJoinPointHood, idJoinArity,
+ isJoinId, joinId_maybe, joinPointType_maybe,
+ idJoinPointHood, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
-- ** Inline pragma stuff
@@ -172,6 +173,8 @@ import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Semigroup as Semi
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
@@ -584,6 +587,13 @@ joinId_maybe id
_ -> Nothing
| otherwise = Nothing
+joinPointType_maybe :: (a -> Maybe JoinPointType) -> [a] -> Maybe JoinPointType
+joinPointType_maybe f xs = do
+ xsNE <- NE.nonEmpty xs
+ Semi.sconcat <$> traverse f xsNE
+ -- traverse: either all are join points or none are
+ -- sconcat: only a 'TrueJoinPoint' if all are
+
-- | Doesn't return strictness marks
idJoinPointHood :: Var -> JoinPointHood
idJoinPointHood id
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44145574f1e491ac8f8c9de0e8d8e6e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44145574f1e491ac8f8c9de0e8d8e6e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26772] 6 commits: PPC NCG: Generate clear right insn at arch width
by Simon Peyton Jones (＠simonpj) 27 Jan '26
by Simon Peyton Jones (＠simonpj) 27 Jan '26
27 Jan '26
Simon Peyton Jones pushed to branch wip/T26772 at Glasgow Haskell Compiler / GHC
Commits:
56db94f7 by Peter Trommler at 2026-01-26T11:26:18+01:00
PPC NCG: Generate clear right insn at arch width
The clear right immediate (clrrxi) is only available in word and
doubleword width. Generate clrrxi instructions at architecture
width for all MachOp widths.
Fixes #24145
- - - - -
5957a8ad by Wolfgang Jeltsch at 2026-01-27T06:11:40-05:00
Add operations for obtaining operating-system handles
This contribution implements CLC proposal #369. It adds operations for
obtaining POSIX file descriptors and Windows handles that underlie
Haskell handles. Those operating system handles can also be obtained
without such additional operations, but this is more involved and, more
importantly, requires using internals.
- - - - -
86a0510c by Greg Steuck at 2026-01-27T06:12:34-05:00
Move flags to precede patterns for grep and read files directly
This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools.
There's no reason to use cat and pipe where direct file argument works.
- - - - -
efa4b101 by Simon Peyton Jones at 2026-01-27T16:56:38+00:00
Fix subtle bug in GHC.Core.Utils.mkTick
..Proper commit message still to come...
- - - - -
a4f9eb90 by Simon Peyton Jones at 2026-01-27T16:56:38+00:00
Modify the debug-trace a little
- - - - -
575a61a9 by Simon Peyton Jones at 2026-01-27T16:56:38+00:00
Fix long-standing interaction between ticks and casts
The code for Note [Eliminate Identity Cases] was simply wrong when
ticks and casts interacted. This patch fixes the interaction.
It was shown up when validating #26772, although it's not the exactly
the bug that's reported by #26772. Nor is it easy to reproduce, hence
no regression test.
- - - - -
31 changed files:
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Types/Evidence.hs
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- + libraries/base/src/System/IO/OS.hs
- libraries/base/tests/IO/all.T
- + libraries/base/tests/IO/osHandles001FileDescriptors.hs
- + libraries/base/tests/IO/osHandles001FileDescriptors.stdout
- + libraries/base/tests/IO/osHandles001WindowsHandles.hs
- + libraries/base/tests/IO/osHandles001WindowsHandles.stdout
- + libraries/base/tests/IO/osHandles002FileDescriptors.hs
- + libraries/base/tests/IO/osHandles002FileDescriptors.stderr
- + libraries/base/tests/IO/osHandles002FileDescriptors.stdin
- + libraries/base/tests/IO/osHandles002FileDescriptors.stdout
- + libraries/base/tests/IO/osHandles002WindowsHandles.hs
- + libraries/base/tests/IO/osHandles002WindowsHandles.stderr
- + libraries/base/tests/IO/osHandles002WindowsHandles.stdin
- + libraries/base/tests/IO/osHandles002WindowsHandles.stdout
- libraries/base/tests/perf/Makefile
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- testsuite/tests/driver/T16318/Makefile
- testsuite/tests/driver/T18125/Makefile
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/89ef3d8b6c7b3854cd449d77021618…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/89ef3d8b6c7b3854cd449d77021618…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
55c4f2b4 by Simon Peyton Jones at 2026-01-27T16:40:20+00:00
Wibbles
- - - - -
3 changed files:
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Monad.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -762,47 +762,73 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
************************************************************************
-}
-{- Note [Overview of Typechecking an XExpr]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Certain constructs undergo expansion right before type checking.
+{- Note [Typechecking by expansion: overview]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For many constructs, rather than typechecking the user-written code
+directly, it's much easier to
+ * Expand (or desugar) the code to something simpler
+ * Typecheck that simpler expression
- tcExpr ue@(RecordUpd{}) rho = do { ee <- expand e; tcExpr ee rho }
+Example: record updates. The typechecker looks like this:
-See Note [Handling overloaded and rebindable constructs] and
-Note [Doing XXExprGhcRn in the Renamer vs Typechecker]
-for details about which constructs are expanded.
+ tcExpr e@(RecordUpd{}) rho = do { ee <- expandExpr e
+ ; tcExpr ee rho }
-The expansion process typically takes a user written thing
- L lspan ue
-and returns
- L lspan (XExpr (ExpandedThingRn { xrn_orig = ue
- , xrn_expanded = ee } ))
+The `expandExpr` replaces the record update (e { x = rhs })
+with something like
+ case e of { MkT a b _ d -> MkT a b rhs d }
+and we then typecheck the latter.
-where `ee` is the expansion of the user written thing `ue`
+See also Note [Handling overloaded and rebindable constructs]
+ and Note [Doing XXExprGhcRn in the Renamer vs Typechecker]
-Now, when a `tcMonoLHsExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)`
-gets a located expression, It does 2 things:
-1. calls `addLExprCtxt` to perform error context management, and;
-2. calls tcExpr to typecheck the expression.
+The Big Question is how to ensure that error messages mention
+only user-written source code, and never talk about the expanded code.
+The rest of this Note explains how that is done.
-The type checker context has 2 key fields:
+* The expansion process typically takes a user written thing
+ L lspan ue
+ and returns
+ L lspan (XExpr (ExpandedThingRn { xrn_orig = ue
+ , xrn_expanded = ee } ))
+ where `ee` is the expansion of the user written thing `ue`
- TcLclCtxt { tcl_loc :: RealSrcSpan
- , tcl_err_ctxt :: [ErrCtxt]
+* The type checker context has 2 key fields that describe the context:
+ TcLclCtxt { tcl_loc :: RealSrcSpan
+ , tcl_err_ctxt :: [ErrCtxt]
, ... }
-
-When called on an XExpr, `addLExprCtxt` updates the location of `tcl_loc` with
-the `lspan` above and adds an ErrCtxt on top of the `tcl_err_ctxt`. If the
-`lspan` is generated, then `addLExprCtxt` is a no-op.
-
-The type checker error stack element `GHC.Tc.Types.ErrCtxt.ErrCtxt` has two fields
-
- ErrCtxt = EC CodeSrcFlag ErrCtxtMsgM
-
-`CodeSrcFlag` says whether we are typechecking an expanded thing, and what that expanded thing is
-`ErrCtxtMsgM` stores the pre-text error message itself. When called on an `XExpr`, `addLExprCtxt`,
-adds the user written thing `ue`, and the error message provided by the caller on the `ErrCtxtStack`
-See Note [ErrCtxtStack Manipulation] for more details.
+ Note `tcl_loc` always points to a real place in the source code,
+ hence `RealSrcSpan`.
+
+ The `tcl_err_ctxt` is a stack of contexts, each saying something
+ like "In the expression: x+y" or "In the record update: r { x=2 }"
+
+* Now, when
+ tcMonoLHsExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+ gets a located expression, it does 2 things:
+ * Calls `addLExprCtxt` to perform error context management
+ * Calls `tcExpr` to typecheck the expression.
+
+* `addLExprCtxt span expr`
+ (1) updates the location of `tcl_loc` with the `span` above,
+ (2) adds an `ErrCtxt` on top of the `tcl_err_ctxt`.
+
+* However, if the `span` is generated (see `isGeneratedSrcSpan`), then
+ `addLExprCtxt` is a no-op. Crucially, when we generate code in `expandExpr`,
+ all the generated AST notes are tagged with a `GeneratedSrcSpan`. This
+ is how we avoid populating the TcLclCtxt with generated code.
+
+* The type checker error-stack element `GHC.Tc.Types.ErrCtxt.ErrCtxt`
+ has two fields
+ data ErrCtxt = EC ErrCtxt
+
+ * `CodeSrcFlag` says whether we are typechecking an expanded thing,
+ and what that expanded thing is
+ * `ErrCtxtMsgM` stores the pre-text error message itself.
+
+ When called on an `XExpr`, `addLExprCtxt`, adds the user written thing
+ `ue`, and the error message provided by the caller on the `ErrCtxtStack` See
+ Note [ErrCtxtStack Manipulation] for more details.
-}
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -19,8 +19,7 @@ module GHC.Tc.Gen.Head
, tyConOf, tyConOfET
, nonBidirectionalErr
- , pprArgInst
- , addLExprCtxt, addFunResCtxt ) where
+ , pprArgInst, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
@@ -1076,39 +1075,3 @@ Notice that tcSplitNestedSigmaTys looks through function arrows too, regardless
of simple/deep subsumption. Here we are concerned only whether there is a
mis-match in the number of value arguments.
-}
-
-
-{- *********************************************************************
-* *
- Misc utility functions
-* *
-********************************************************************* -}
-
--- | !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 (ExprCtxt e) 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 (srcCodeOriginErrCtxMsg o) thing_inside
- -- Flip error ctxt into expansion mode
-
- _ -> addErrCtxt (ExprCtxt e) thing_inside
-
-
-addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
-addLExprCtxt lspan e thing_inside
- | not (isGeneratedSrcSpan lspan)
- = setSrcSpan lspan $ add_expr_ctxt e thing_inside
- | otherwise -- no op in generated code
- = thing_inside
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -88,7 +88,7 @@ module GHC.Tc.Utils.Monad(
-- * Context management for the type checker
getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
- addExpansionErrCtxt, addExpansionErrCtxtM,
+ addLExprCtxt, addExpansionErrCtxt, addExpansionErrCtxtM,
addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv,
-- * Diagnostic message generation (type checker)
@@ -1324,6 +1324,35 @@ relation with pattern-match checks
- See Note [ErrCtxtStack Manipulation] in `GHC.Tc.Types.LclEnv` for info about `ErrCtxtStack`
-}
+addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
+addLExprCtxt lspan e thing_inside
+ | not (isGeneratedSrcSpan lspan)
+ = setSrcSpan lspan $ add_expr_ctxt e thing_inside
+ | otherwise -- no op in generated code
+ = 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 (ExprCtxt e) 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 (srcCodeOriginErrCtxMsg o) thing_inside
+ -- Flip error ctxt into expansion mode
+
+ _ -> addErrCtxt (ExprCtxt e) thing_inside
+
+
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) }
@@ -1335,7 +1364,7 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt)
-- do any tidying.
-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a
-{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
+o{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
-- See Note [ErrCtxtStack Manipulation]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/55c4f2b41a36a96c1166721f906e094…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/55c4f2b41a36a96c1166721f906e094…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/detecting-os-handle-types] Add OS handle type detection to `base`
by Wolfgang Jeltsch (＠jeltsch) 27 Jan '26
by Wolfgang Jeltsch (＠jeltsch) 27 Jan '26
27 Jan '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/detecting-os-handle-types at Glasgow Haskell Compiler / GHC
Commits:
3f8d806e by Wolfgang Jeltsch at 2026-01-27T16:51:12+02:00
Add OS handle type detection to `base`
It is deliberate that this addition to `base` does not simply reflect
the `conditional`/`<!>` operation currently in `GHC.IO.SubSystem` but
simply uses the value of a custom enumeration type to describe the type
of OS handles currently in use. The reason for using this approach is
that it is simpler and at the same type more future-proof: if a new OS
handle type should be introduced in the future, it would only be
necessary to add another value to `OSHandleType`, and user code that
uses fallback branches in case distinctions regarding OS handle types
would continue to be compilable at least; `conditional`, on the other
hand, would have to have its argument count changed and `<!>` could not
even be used as an infix operator anymore. Since Haskell has `case`
expressions, there is no real need to have a case-distinguishing
operation like `conditional`/`<!>`.
- - - - -
20 changed files:
- libraries/base/changelog.md
- libraries/base/src/System/IO/OS.hs
- libraries/base/tests/IO/all.T
- libraries/base/tests/IO/osHandles001FileDescriptors.hs
- libraries/base/tests/IO/osHandles001FileDescriptors.stdout
- libraries/base/tests/IO/osHandles001WindowsHandles.hs
- libraries/base/tests/IO/osHandles001WindowsHandles.stdout
- libraries/base/tests/IO/osHandles002FileDescriptors.hs
- libraries/base/tests/IO/osHandles002FileDescriptors.stdout
- libraries/base/tests/IO/osHandles002WindowsHandles.hs
- libraries/base/tests/IO/osHandles002WindowsHandles.stdout
- + libraries/base/tests/IO/osHandles003FileDescriptors.hs
- libraries/base/tests/IO/osHandles002FileDescriptors.stderr → libraries/base/tests/IO/osHandles003FileDescriptors.stderr
- libraries/base/tests/IO/osHandles002FileDescriptors.stdin → libraries/base/tests/IO/osHandles003FileDescriptors.stdin
- libraries/base/tests/IO/osHandles002WindowsHandles.stdin → libraries/base/tests/IO/osHandles003FileDescriptors.stdout
- + libraries/base/tests/IO/osHandles003WindowsHandles.hs
- libraries/base/tests/IO/osHandles002WindowsHandles.stderr → libraries/base/tests/IO/osHandles003WindowsHandles.stderr
- + libraries/base/tests/IO/osHandles003WindowsHandles.stdin
- + libraries/base/tests/IO/osHandles003WindowsHandles.stdout
- libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
Changes:
=====================================
libraries/base/changelog.md
=====================================
@@ -23,7 +23,7 @@
* `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365))
* Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329)
* Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376))
- * Add a new module `System.IO.OS` with operations for obtaining operating-system handles (file descriptors, Windows handles). ([CLC proposal #369](https://github.com/haskell/core-libraries-committee/issues/369))
+ * Add a new module `System.IO.OS` with operations for detecting the type of operating-system handles in use (file descriptors, Windows handles) and obtaining such handles. (CLC proposals [#395](https://github.com/haskell/core-libraries-committee/issues/395) and [#369](https://github.com/haskell/core-libraries-committee/issues/369))
## 4.22.0.0 *TBA*
* Shipped with GHC 9.14.1
=====================================
libraries/base/src/System/IO/OS.hs
=====================================
@@ -6,6 +6,10 @@
-}
module System.IO.OS
(
+ -- * OS handle type detection
+ OSHandleType (FileDescriptor, WindowsHandle),
+ osHandleType,
+
-- * Obtaining file descriptors and Windows handles
withFileDescriptorReadingBiased,
withFileDescriptorWritingBiased,
@@ -23,6 +27,8 @@ where
import GHC.Internal.System.IO.OS
(
+ OSHandleType (FileDescriptor, WindowsHandle),
+ osHandleType,
withFileDescriptorReadingBiased,
withFileDescriptorWritingBiased,
withWindowsHandleReadingBiased,
=====================================
libraries/base/tests/IO/all.T
=====================================
@@ -189,9 +189,11 @@ test('mkdirExists', [exit_code(1), when(opsys('mingw32'), ignore_stderr)], compi
test('osHandles001FileDescriptors', omit_ways(['winio', 'winio_threaded']), compile_and_run, [''])
test('osHandles001WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, [''])
-test('osHandles002FileDescriptors', [when(opsys('mingw32'), skip), when(arch('javascript'), skip)], compile_and_run, [''])
+test('osHandles002FileDescriptors', omit_ways(['winio', 'winio_threaded']), compile_and_run, [''])
test('osHandles002WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, [''])
-# It would be good to let `osHandles002FileDescriptors` run also on
+test('osHandles003FileDescriptors', [when(opsys('mingw32'), skip), when(arch('javascript'), skip)], compile_and_run, [''])
+test('osHandles003WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, [''])
+# It would be good to let `osHandles003FileDescriptors` run also on
# Windows with the file-descriptor-based I/O manager. However, this
# test, as it is currently implemented, requires the `unix` package.
# That said, `UCRT.DLL`, which is used by GHC-generated Windows
=====================================
libraries/base/tests/IO/osHandles001FileDescriptors.hs
=====================================
@@ -1,23 +1,4 @@
-{-# LANGUAGE TypeApplications #-}
-
-import Control.Monad (mapM_)
-import Control.Exception (SomeException, try)
-import System.IO (stdin, stdout, stderr)
-import System.IO.OS
- (
- withFileDescriptorReadingBiasedRaw,
- withFileDescriptorWritingBiasedRaw,
- withWindowsHandleReadingBiasedRaw,
- withWindowsHandleWritingBiasedRaw
- )
+import System.IO.OS (osHandleType)
main :: IO ()
-main = mapM_ ((>>= print) . try @SomeException) $
- [
- withFileDescriptorReadingBiasedRaw stdin (return . show),
- withFileDescriptorWritingBiasedRaw stdout (return . show),
- withFileDescriptorWritingBiasedRaw stderr (return . show),
- withWindowsHandleReadingBiasedRaw stdin (return . const "_"),
- withWindowsHandleWritingBiasedRaw stdout (return . const "_"),
- withWindowsHandleWritingBiasedRaw stderr (return . const "_")
- ]
+main = print osHandleType
=====================================
libraries/base/tests/IO/osHandles001FileDescriptors.stdout
=====================================
@@ -1,6 +1 @@
-Right "0"
-Right "1"
-Right "2"
-Left <stdin>: withWindowsHandleReadingBiasedRaw: inappropriate type (handle does not use Windows handles)
-Left <stdout>: withWindowsHandleWritingBiasedRaw: inappropriate type (handle does not use Windows handles)
-Left <stderr>: withWindowsHandleWritingBiasedRaw: inappropriate type (handle does not use Windows handles)
+FileDescriptor
=====================================
libraries/base/tests/IO/osHandles001WindowsHandles.hs
=====================================
@@ -1,23 +1,4 @@
-{-# LANGUAGE TypeApplications #-}
-
-import Control.Monad (mapM_)
-import Control.Exception (SomeException, try)
-import System.IO (stdin, stdout, stderr)
-import System.IO.OS
- (
- withFileDescriptorReadingBiasedRaw,
- withFileDescriptorWritingBiasedRaw,
- withWindowsHandleReadingBiasedRaw,
- withWindowsHandleWritingBiasedRaw
- )
+import System.IO.OS (osHandleType)
main :: IO ()
-main = mapM_ ((>>= print) . try @SomeException) $
- [
- withFileDescriptorReadingBiasedRaw stdin (return . show),
- withFileDescriptorWritingBiasedRaw stdout (return . show),
- withFileDescriptorWritingBiasedRaw stderr (return . show),
- withWindowsHandleReadingBiasedRaw stdin (return . const "_"),
- withWindowsHandleWritingBiasedRaw stdout (return . const "_"),
- withWindowsHandleWritingBiasedRaw stderr (return . const "_")
- ]
+main = print osHandleType
=====================================
libraries/base/tests/IO/osHandles001WindowsHandles.stdout
=====================================
@@ -1,6 +1 @@
-Left <stdin>: withFileDescriptorReadingBiasedRaw: inappropriate type (handle does not use file descriptors)
-Left <stdout>: withFileDescriptorWritingBiasedRaw: inappropriate type (handle does not use file descriptors)
-Left <stderr>: withFileDescriptorWritingBiasedRaw: inappropriate type (handle does not use file descriptors)
-Right "_"
-Right "_"
-Right "_"
+WindowsHandle
=====================================
libraries/base/tests/IO/osHandles002FileDescriptors.hs
=====================================
@@ -1,28 +1,23 @@
-import Data.Functor (void)
-import Data.ByteString.Char8 (pack)
-import System.Posix.Types (Fd (Fd), ByteCount)
-import System.Posix.IO.ByteString (fdRead, fdWrite)
+{-# LANGUAGE TypeApplications #-}
+
+import Control.Monad (mapM_)
+import Control.Exception (SomeException, try)
import System.IO (stdin, stdout, stderr)
import System.IO.OS
(
- withFileDescriptorReadingBiased,
- withFileDescriptorWritingBiased
+ withFileDescriptorReadingBiasedRaw,
+ withFileDescriptorWritingBiasedRaw,
+ withWindowsHandleReadingBiasedRaw,
+ withWindowsHandleWritingBiasedRaw
)
main :: IO ()
-main = withFileDescriptorReadingBiased stdin $ \ stdinFD ->
- withFileDescriptorWritingBiased stdout $ \ stdoutFD ->
- withFileDescriptorWritingBiased stderr $ \ stderrFD ->
- do
- regularMsg <- fdRead (Fd stdinFD) inputSizeApproximation
- void $ fdWrite (Fd stdoutFD) regularMsg
- void $ fdWrite (Fd stderrFD) (pack errorMsg)
- where
-
- inputSizeApproximation :: ByteCount
- inputSizeApproximation = 100
-
- errorMsg :: String
- errorMsg = "And every single door\n\
- \That I've walked through\n\
- \Brings me back, back here again\n"
+main = mapM_ ((>>= print) . try @SomeException) $
+ [
+ withFileDescriptorReadingBiasedRaw stdin (return . show),
+ withFileDescriptorWritingBiasedRaw stdout (return . show),
+ withFileDescriptorWritingBiasedRaw stderr (return . show),
+ withWindowsHandleReadingBiasedRaw stdin (return . const "_"),
+ withWindowsHandleWritingBiasedRaw stdout (return . const "_"),
+ withWindowsHandleWritingBiasedRaw stderr (return . const "_")
+ ]
=====================================
libraries/base/tests/IO/osHandles002FileDescriptors.stdout
=====================================
@@ -1 +1,6 @@
-We've got to get in to get out
+Right "0"
+Right "1"
+Right "2"
+Left <stdin>: withWindowsHandleReadingBiasedRaw: inappropriate type (handle does not use Windows handles)
+Left <stdout>: withWindowsHandleWritingBiasedRaw: inappropriate type (handle does not use Windows handles)
+Left <stderr>: withWindowsHandleWritingBiasedRaw: inappropriate type (handle does not use Windows handles)
=====================================
libraries/base/tests/IO/osHandles002WindowsHandles.hs
=====================================
@@ -1,49 +1,23 @@
-import Control.Monad (zipWithM_)
-import Data.Functor (void)
-import Data.Char (ord)
-import Foreign.Marshal.Alloc (allocaBytes)
-import Foreign.Storable (pokeElemOff)
+{-# LANGUAGE TypeApplications #-}
+
+import Control.Monad (mapM_)
+import Control.Exception (SomeException, try)
import System.IO (stdin, stdout, stderr)
import System.IO.OS
(
- withWindowsHandleReadingBiased,
- withWindowsHandleWritingBiased
+ withFileDescriptorReadingBiasedRaw,
+ withFileDescriptorWritingBiasedRaw,
+ withWindowsHandleReadingBiasedRaw,
+ withWindowsHandleWritingBiasedRaw
)
main :: IO ()
-main = withWindowsHandleReadingBiased stdin $ \ windowsStdin ->
- withWindowsHandleWritingBiased stdout $ \ windowsStdout ->
- withWindowsHandleWritingBiased stderr $ \ windowsStderr ->
- do
- withBuffer inputSizeApproximation $ \ bufferPtr -> do
- inputSize <- win32_ReadFile windowsStdin
- bufferPtr
- inputSizeApproximation
- Nothing
- void $ win32_WriteFile windowsStdout
- bufferPtr
- inputSize
- Nothing
- withBuffer errorMsgSize $ \ bufferPtr -> do
- zipWithM_ (pokeElemOff bufferPtr)
- [0 ..]
- (map (fromIntegral . ord) errorMsg)
- void $ win32_WriteFile windowsStderr
- bufferPtr
- errorMsgSize
- Nothing
- where
-
- withBuffer :: DWORD -> (Ptr Word8 -> IO a) -> IO a
- withBuffer = allocaBytes . fromIntegral
-
- inputSizeApproximation :: DWORD
- inputSizeApproximation = 100
-
- errorMsg :: String
- errorMsg = "And every single door\n\
- \That I've walked through\n\
- \Brings me back, back here again\n"
-
- errorMsgSize :: DWORD
- errorMsgSize = fromIntegral (length errorMsg)
+main = mapM_ ((>>= print) . try @SomeException) $
+ [
+ withFileDescriptorReadingBiasedRaw stdin (return . show),
+ withFileDescriptorWritingBiasedRaw stdout (return . show),
+ withFileDescriptorWritingBiasedRaw stderr (return . show),
+ withWindowsHandleReadingBiasedRaw stdin (return . const "_"),
+ withWindowsHandleWritingBiasedRaw stdout (return . const "_"),
+ withWindowsHandleWritingBiasedRaw stderr (return . const "_")
+ ]
=====================================
libraries/base/tests/IO/osHandles002WindowsHandles.stdout
=====================================
@@ -1 +1,6 @@
-We've got to get in to get out
+Left <stdin>: withFileDescriptorReadingBiasedRaw: inappropriate type (handle does not use file descriptors)
+Left <stdout>: withFileDescriptorWritingBiasedRaw: inappropriate type (handle does not use file descriptors)
+Left <stderr>: withFileDescriptorWritingBiasedRaw: inappropriate type (handle does not use file descriptors)
+Right "_"
+Right "_"
+Right "_"
=====================================
libraries/base/tests/IO/osHandles003FileDescriptors.hs
=====================================
@@ -0,0 +1,28 @@
+import Data.Functor (void)
+import Data.ByteString.Char8 (pack)
+import System.Posix.Types (Fd (Fd), ByteCount)
+import System.Posix.IO.ByteString (fdRead, fdWrite)
+import System.IO (stdin, stdout, stderr)
+import System.IO.OS
+ (
+ withFileDescriptorReadingBiased,
+ withFileDescriptorWritingBiased
+ )
+
+main :: IO ()
+main = withFileDescriptorReadingBiased stdin $ \ stdinFD ->
+ withFileDescriptorWritingBiased stdout $ \ stdoutFD ->
+ withFileDescriptorWritingBiased stderr $ \ stderrFD ->
+ do
+ regularMsg <- fdRead (Fd stdinFD) inputSizeApproximation
+ void $ fdWrite (Fd stdoutFD) regularMsg
+ void $ fdWrite (Fd stderrFD) (pack errorMsg)
+ where
+
+ inputSizeApproximation :: ByteCount
+ inputSizeApproximation = 100
+
+ errorMsg :: String
+ errorMsg = "And every single door\n\
+ \That I've walked through\n\
+ \Brings me back, back here again\n"
=====================================
libraries/base/tests/IO/osHandles002FileDescriptors.stderr → libraries/base/tests/IO/osHandles003FileDescriptors.stderr
=====================================
=====================================
libraries/base/tests/IO/osHandles002FileDescriptors.stdin → libraries/base/tests/IO/osHandles003FileDescriptors.stdin
=====================================
=====================================
libraries/base/tests/IO/osHandles002WindowsHandles.stdin → libraries/base/tests/IO/osHandles003FileDescriptors.stdout
=====================================
=====================================
libraries/base/tests/IO/osHandles003WindowsHandles.hs
=====================================
@@ -0,0 +1,49 @@
+import Control.Monad (zipWithM_)
+import Data.Functor (void)
+import Data.Char (ord)
+import Foreign.Marshal.Alloc (allocaBytes)
+import Foreign.Storable (pokeElemOff)
+import System.IO (stdin, stdout, stderr)
+import System.IO.OS
+ (
+ withWindowsHandleReadingBiased,
+ withWindowsHandleWritingBiased
+ )
+
+main :: IO ()
+main = withWindowsHandleReadingBiased stdin $ \ windowsStdin ->
+ withWindowsHandleWritingBiased stdout $ \ windowsStdout ->
+ withWindowsHandleWritingBiased stderr $ \ windowsStderr ->
+ do
+ withBuffer inputSizeApproximation $ \ bufferPtr -> do
+ inputSize <- win32_ReadFile windowsStdin
+ bufferPtr
+ inputSizeApproximation
+ Nothing
+ void $ win32_WriteFile windowsStdout
+ bufferPtr
+ inputSize
+ Nothing
+ withBuffer errorMsgSize $ \ bufferPtr -> do
+ zipWithM_ (pokeElemOff bufferPtr)
+ [0 ..]
+ (map (fromIntegral . ord) errorMsg)
+ void $ win32_WriteFile windowsStderr
+ bufferPtr
+ errorMsgSize
+ Nothing
+ where
+
+ withBuffer :: DWORD -> (Ptr Word8 -> IO a) -> IO a
+ withBuffer = allocaBytes . fromIntegral
+
+ inputSizeApproximation :: DWORD
+ inputSizeApproximation = 100
+
+ errorMsg :: String
+ errorMsg = "And every single door\n\
+ \That I've walked through\n\
+ \Brings me back, back here again\n"
+
+ errorMsgSize :: DWORD
+ errorMsgSize = fromIntegral (length errorMsg)
=====================================
libraries/base/tests/IO/osHandles002WindowsHandles.stderr → libraries/base/tests/IO/osHandles003WindowsHandles.stderr
=====================================
=====================================
libraries/base/tests/IO/osHandles003WindowsHandles.stdin
=====================================
@@ -0,0 +1 @@
+We've got to get in to get out
=====================================
libraries/base/tests/IO/osHandles003WindowsHandles.stdout
=====================================
@@ -0,0 +1 @@
+We've got to get in to get out
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
=====================================
@@ -8,6 +8,10 @@
-}
module GHC.Internal.System.IO.OS
(
+ -- * OS handle type detection
+ OSHandleType (FileDescriptor, WindowsHandle),
+ osHandleType,
+
-- * Obtaining file descriptors and Windows handles
withFileDescriptorReadingBiased,
withFileDescriptorWritingBiased,
@@ -23,6 +27,10 @@ module GHC.Internal.System.IO.OS
)
where
+import GHC.Internal.Classes (Eq, Ord)
+import GHC.Internal.Enum (Bounded, Enum)
+import GHC.Internal.Show (Show)
+import GHC.Internal.Read (Read)
import GHC.Internal.Control.Monad (return)
import GHC.Internal.Control.Concurrent.MVar (MVar)
import GHC.Internal.Control.Exception (mask)
@@ -39,6 +47,7 @@ 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.SubSystem (conditional)
import GHC.Internal.IO.FD (fdFD)
#if defined(mingw32_HOST_OS)
import GHC.Internal.IO.Windows.Handle
@@ -64,6 +73,19 @@ import GHC.Internal.IO.Exception
import GHC.Internal.Foreign.Ptr (Ptr)
import GHC.Internal.Foreign.C.Types (CInt)
+-- * OS handle type detection
+
+-- | The type of operating-system handle types.
+data OSHandleType = FileDescriptor | WindowsHandle
+ deriving (Eq, Ord, Bounded, Enum, Show, Read)
+
+{-|
+ The type of operating-system handles that underlie Haskell handles with the
+ I/O manager currently in use.
+-}
+osHandleType :: OSHandleType
+osHandleType = conditional FileDescriptor WindowsHandle
+
-- * Obtaining POSIX file descriptors and Windows handles
{-|
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f8d806e9421db25e2773b674ac45ab…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f8d806e9421db25e2773b674ac45ab…
You're receiving this email because of your account on gitlab.haskell.org.
1
0