28 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) 28 Jan '26
by Marge Bot (@marge-bot) 28 Jan '26
28 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
28 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
28 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) 28 Jan '26
by Simon Peyton Jones (@simonpj) 28 Jan '26
28 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
[Git][ghc/ghc][wip/dcoutts/windows-dlls] Use __attribute__(dllimport)) for external RTS symbol declarations
by Duncan Coutts (@dcoutts) 27 Jan '26
by Duncan Coutts (@dcoutts) 27 Jan '26
27 Jan '26
Duncan Coutts pushed to branch wip/dcoutts/windows-dlls at Glasgow Haskell Compiler / GHC
Commits:
9a1ed49b by Duncan Coutts at 2026-01-27T14:39:37+00:00
Use __attribute__(dllimport)) for external RTS symbol declarations
This is needed to be hygenic about DLL symbol imports and exports.
The attribute is ignored on platforms other than Windows.
Use of the attribute however means that external data symbols do not
have a compile-time constant address (they are loaded using an
indirection). This means we have to adjust the rtsSyms initial linker
table so that it is a local constant in a function, rather than a global
constant. We now define it within a function that pre-populates the
symbol table with the RTS symbols.
- - - - -
3 changed files:
- rts/Linker.c
- rts/RtsSymbols.c
- rts/RtsSymbols.h
Changes:
=====================================
rts/Linker.c
=====================================
@@ -472,16 +472,7 @@ initLinker_ (int retain_cafs)
symhash = allocStrHashTable();
/* populate the symbol table with stuff from the RTS */
- IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n"));
- for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) {
- IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
- if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),
- symhash, sym->lbl, sym->addr,
- sym->strength, sym->type, NULL)) {
- barf("ghciInsertSymbolTable failed");
- }
- }
- IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n"));
+ initLinkerRtsSyms(symhash);
/* Add extra symbols. rtsExtraSyms() is a weakly defined symbol in the rts,
* that can be overrided by linking in an object with a corresponding
=====================================
rts/RtsSymbols.c
=====================================
@@ -9,6 +9,7 @@
#include "ghcplatform.h"
#include "Rts.h"
#include "RtsSymbols.h"
+#include "LinkerInternals.h"
#include "TopHandler.h"
#include "HsFFI.h"
@@ -50,6 +51,18 @@ extern char **environ;
/* -----------------------------------------------------------------------------
* Symbols to be inserted into the RTS symbol table.
+ *
+ * Note [Naming Scheme for Symbol Macros]
+ *
+ * SymI_*: symbol is internal to the RTS. It resides in an object
+ * file/library that is statically.
+ * SymE_*: symbol is external to the RTS library. It might be linked
+ * dynamically.
+ *
+ * Sym*_HasProto : the symbol prototype is imported in an include file
+ * or defined explicitly
+ * Sym*_NeedsProto: the symbol is undefined and we add a dummy
+ * default proto extern void sym(void);
*/
#define Maybe_Stable_Names SymI_HasProto(stg_mkWeakzh) \
@@ -1127,12 +1140,21 @@ extern char **environ;
SymI_HasProto(hs_word2float64)
-/* entirely bogus claims about types of these symbols */
-#define SymI_NeedsProto(vvv) extern void vvv(void);
-#define SymI_NeedsDataProto(vvv) extern StgWord vvv[];
-#define SymE_NeedsProto(vvv) SymI_NeedsProto(vvv);
-#define SymE_NeedsDataProto(vvv) SymI_NeedsDataProto(vvv);
-#define SymE_HasProto(vvv) SymI_HasProto(vvv);
+/* Declare prototypes for the symbols that need it, so we can refer
+ * to them in the rtsSyms table below.
+ *
+ * In particular, for the external ones (SymE_*) we use the dllimport attribute
+ * to indicate that (on Windows) they come from external DLLs. This attribute
+ * is ignored on other platforms.
+ *
+ * The claims about the types of these symbols are entirely bogus.
+ */
+#define SymI_NeedsProto(vvv) extern void vvv(void);
+#define SymI_NeedsDataProto(vvv) extern StgWord vvv[];
+#define SymE_NeedsProto(vvv) extern __attribute__((dllimport)) void vvv(void);
+#define SymE_NeedsDataProto(vvv) extern __attribute__((dllimport)) StgWord vvv[];
+
+#define SymE_HasProto(vvv) /**/
#define SymI_HasProto(vvv) /**/
#define SymI_HasDataProto(vvv) /**/
#define SymI_HasProto_redirect(vvv,xxx,strength,ty) /**/
@@ -1161,6 +1183,8 @@ RTS_SYMBOLS_PRIM
#undef SymE_NeedsProto
#undef SymE_NeedsDataProto
+/* See Note [Naming Scheme for Symbol Macros] */
+
#define SymI_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
(void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_CODE },
#define SymI_HasDataProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
@@ -1181,7 +1205,16 @@ RTS_SYMBOLS_PRIM
{ MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
(void*)(&(xxx)), strength, ty },
-RtsSymbolVal rtsSyms[] = {
+
+/* Populate the symbol table with stuff from the RTS. */
+void initLinkerRtsSyms (StrHashTable *symhash) {
+
+ /* The address of data symbols with the dllimport attribute are not
+ * compile-time constants and so cannot be used in constant initialisers.
+ * For this reason, rtsSyms is a local variable within this function
+ * rather than a global constant (as it was historically).
+ */
+ const RtsSymbolVal rtsSyms[] = {
RTS_SYMBOLS
RTS_RET_SYMBOLS
RTS_POSIX_ONLY_SYMBOLS
@@ -1196,7 +1229,19 @@ RtsSymbolVal rtsSyms[] = {
RTS_SYMBOLS_PRIM
SymI_HasDataProto(nonmoving_write_barrier_enabled)
{ 0, 0, STRENGTH_NORMAL, SYM_TYPE_CODE } /* sentinel */
-};
+ };
+
+ IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n"));
+ for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) {
+ IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
+ if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),
+ symhash, sym->lbl, sym->addr,
+ sym->strength, sym->type, NULL)) {
+ barf("ghciInsertSymbolTable failed");
+ }
+ }
+ IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n"));
+}
// Note [Extra RTS symbols]
=====================================
rts/RtsSymbols.h
=====================================
@@ -9,6 +9,7 @@
#pragma once
#include "ghcautoconf.h"
+#include "Hash.h"
#if defined(LEADING_UNDERSCORE)
#define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
@@ -46,7 +47,7 @@ typedef struct _RtsSymbolVal {
SymType type;
} RtsSymbolVal;
-extern RtsSymbolVal rtsSyms[];
+void initLinkerRtsSyms (StrHashTable *symhash);
extern RtsSymbolVal* __attribute__((weak)) rtsExtraSyms(void);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9a1ed49b90a53e7299294ee4c60d813…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9a1ed49b90a53e7299294ee4c60d813…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/jeltsch/detecting-os-handle-types
by Wolfgang Jeltsch (@jeltsch) 27 Jan '26
by Wolfgang Jeltsch (@jeltsch) 27 Jan '26
27 Jan '26
Wolfgang Jeltsch pushed new branch wip/jeltsch/detecting-os-handle-types at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/detecting-os-handle-t…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26832] 3 commits: ghc-internal: avoid depending on GHC.Internal.Exts
by Teo Camarasu (@teo) 27 Jan '26
by Teo Camarasu (@teo) 27 Jan '26
27 Jan '26
Teo Camarasu pushed to branch wip/T26832 at Glasgow Haskell Compiler / GHC
Commits:
9ba40985 by Teo Camarasu at 2026-01-27T11:03:27+00:00
ghc-internal: avoid depending on GHC.Internal.Exts
This module is mostly just re-exports. It made sense as a user-facing
module, but there's no good reason ghc-internal modules should depend on
it and doing so linearises the module graph
- - - - -
f004fd2d by Teo Camarasu at 2026-01-27T11:03:27+00:00
ghc-internal: move considerAccessible to GHC.Internal.Magic
Previously it lived in GHC.Internal.Exts, but it really deserves to live
along with the other magic function, which are already re-exported from .Exts
- - - - -
bf2c4cae by Teo Camarasu at 2026-01-27T11:03:27+00:00
ghc-internal: move maxTupleSize to GHC.Internal.Tuple
This previously lived in GHC.Internal.Exts but a comment already said it
should be moved to .Tuple
- - - - -
14 changed files:
- compiler/GHC/Builtin/Names.hs
- libraries/ghc-internal/src/GHC/Internal/Exts.hs
- libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- libraries/ghc-internal/src/GHC/Internal/JS/Foreign/Callback.hs
- libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs
- libraries/ghc-internal/src/GHC/Internal/JS/Prim/Internal/Build.hs
- libraries/ghc-internal/src/GHC/Internal/Magic.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-internal/src/GHC/Internal/Tuple.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs
- libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -1063,7 +1063,7 @@ alternativeClassKey = mkPreludeMiscIdUnique 754
-- Functions for GHC extensions
considerAccessibleName :: Name
-considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey
+considerAccessibleName = varQual gHC_MAGIC (fsLit "considerAccessible") considerAccessibleIdKey
-- Random GHC.Internal.Base functions
fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
=====================================
libraries/ghc-internal/src/GHC/Internal/Exts.hs
=====================================
@@ -321,10 +321,7 @@ import GHC.Internal.Data.Data
import GHC.Internal.Data.Ord
import qualified GHC.Internal.Debug.Trace
import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) -- just for re-export
-
--- XXX This should really be in Data.Tuple, where the definitions are
-maxTupleSize :: Int
-maxTupleSize = 64
+import GHC.Internal.Tuple (maxTupleSize)
-- | 'the' ensures that all the elements of the list are identical
-- and then returns that unique element
@@ -444,27 +441,3 @@ resizeSmallMutableArray# arr0 szNew a s0 =
(# s2, arr1 #) -> case copySmallMutableArray# arr0 0# arr1 0# szOld s2 of
s3 -> (# s3, arr1 #)
else (# s1, arr0 #)
-
--- | Semantically, @considerAccessible = True@. But it has special meaning
--- to the pattern-match checker, which will never flag the clause in which
--- 'considerAccessible' occurs as a guard as redundant or inaccessible.
--- Example:
---
--- > case (x, x) of
--- > (True, True) -> 1
--- > (False, False) -> 2
--- > (True, False) -> 3 -- Warning: redundant
---
--- The pattern-match checker will warn here that the third clause is redundant.
--- It will stop doing so if the clause is adorned with 'considerAccessible':
---
--- > case (x, x) of
--- > (True, True) -> 1
--- > (False, False) -> 2
--- > (True, False) | considerAccessible -> 3 -- No warning
---
--- Put 'considerAccessible' as the last statement of the guard to avoid get
--- confusing results from the pattern-match checker, which takes \"consider
--- accessible\" by word.
-considerAccessible :: Bool
-considerAccessible = True
=====================================
libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
=====================================
@@ -75,9 +75,10 @@ import GHC.Internal.Int
import GHC.Internal.Num
import GHC.Internal.Real
import GHC.Internal.Word
-import GHC.Internal.Exts
import GHC.Internal.Generics
import GHC.Internal.Numeric
+import GHC.Internal.Ptr
+import GHC.Internal.Unsafe.Coerce
import GHC.Internal.Stack (HasCallStack)
------------------------------------------------------------------------
=====================================
libraries/ghc-internal/src/GHC/Internal/JS/Foreign/Callback.hs
=====================================
@@ -21,8 +21,6 @@ module GHC.Internal.JS.Foreign.Callback
import GHC.Internal.JS.Prim
-import qualified GHC.Internal.Exts as Exts
-
import GHC.Internal.Unsafe.Coerce
import GHC.Internal.Base
@@ -131,18 +129,18 @@ asyncCallback3 x = js_asyncCallbackApply 3 (unsafeCoerce x)
-- ----------------------------------------------------------------------------
foreign import javascript unsafe "(($1, $2) => { return h$makeCallback(h$runSync, [$1], $2); })"
- js_syncCallback :: Bool -> Exts.Any -> IO (Callback (IO b))
+ js_syncCallback :: Bool -> Any -> IO (Callback (IO b))
foreign import javascript unsafe "(($1) => { return h$makeCallback(h$run, [], $1); })"
- js_asyncCallback :: Exts.Any -> IO (Callback (IO b))
+ js_asyncCallback :: Any -> IO (Callback (IO b))
foreign import javascript unsafe "(($1) => { return h$makeCallback(h$runSyncReturn, [false], $1); })"
- js_syncCallbackReturn :: Exts.Any -> IO (Callback (IO JSVal))
+ js_syncCallbackReturn :: Any -> IO (Callback (IO JSVal))
foreign import javascript unsafe "(($1, $2, $3) => { return h$makeCallbackApply($2, h$runSync, [$1], $3); })"
- js_syncCallbackApply :: Bool -> Int -> Exts.Any -> IO (Callback b)
+ js_syncCallbackApply :: Bool -> Int -> Any -> IO (Callback b)
foreign import javascript unsafe "(($1, $2) => { return h$makeCallbackApply($1, h$run, [], $2); })"
- js_asyncCallbackApply :: Int -> Exts.Any -> IO (Callback b)
+ js_asyncCallbackApply :: Int -> Any -> IO (Callback b)
foreign import javascript unsafe "(($1, $2) => { return h$makeCallbackApply($1, h$runSyncReturn, [false], $2); })"
- js_syncCallbackApplyReturn :: Int -> Exts.Any -> IO (Callback b)
+ js_syncCallbackApplyReturn :: Int -> Any -> IO (Callback b)
foreign import javascript unsafe "h$release"
js_release :: Callback a -> IO ()
=====================================
libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs
=====================================
@@ -42,8 +42,8 @@ module GHC.Internal.JS.Prim ( JSVal(..), JSVal#
import GHC.Internal.Unsafe.Coerce (unsafeCoerce)
import GHC.Internal.Prim
+import GHC.Internal.Types
import qualified GHC.Internal.Exception as Ex
-import qualified GHC.Internal.Exts as Exts
import qualified GHC.Internal.CString as GHC
import GHC.Internal.IO
import GHC.Internal.Data.Bool
@@ -78,15 +78,15 @@ instance Show JSException where
#if defined(javascript_HOST_ARCH)
{-# NOINLINE toIO #-}
-toIO :: Exts.Any -> IO Exts.Any
+toIO :: Any -> IO Any
toIO x = pure x
{-# NOINLINE resolve #-}
-resolve :: JSVal# -> JSVal# -> Exts.Any -> IO ()
+resolve :: JSVal# -> JSVal# -> Any -> IO ()
resolve accept reject x = resolveIO accept reject (pure x)
{-# NOINLINE resolveIO #-} -- used by the rts
-resolveIO :: JSVal# -> JSVal# -> IO Exts.Any -> IO ()
+resolveIO :: JSVal# -> JSVal# -> IO Any -> IO ()
resolveIO accept reject x =
(x >>= evaluate >>= js_callback_any accept) `catch`
(\(e::Ex.SomeException) -> do
@@ -260,16 +260,16 @@ seqList xs = go xs `seq` xs
go [] = ()
foreign import javascript unsafe "h$toHsString"
- js_fromJSString :: JSVal -> Exts.Any
+ js_fromJSString :: JSVal -> Any
foreign import javascript unsafe "h$fromHsString"
- js_toJSString :: Exts.Any -> JSVal
+ js_toJSString :: Any -> JSVal
foreign import javascript unsafe "h$toHsListJSVal"
- js_fromJSArray :: JSVal -> IO Exts.Any
+ js_fromJSArray :: JSVal -> IO Any
foreign import javascript unsafe "h$fromHsListJSVal"
- js_toJSArray :: Exts.Any -> IO JSVal
+ js_toJSArray :: Any -> IO JSVal
foreign import javascript unsafe "(($1) => { return ($1 === null); })"
js_isNull :: JSVal -> Bool
@@ -287,10 +287,10 @@ foreign import javascript unsafe "(() => { return null; })"
js_null :: JSVal
foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })"
- js_getProp :: JSVal -> Exts.Any -> IO JSVal
+ js_getProp :: JSVal -> Any -> IO JSVal
foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })"
- js_unsafeGetProp :: JSVal -> Exts.Any -> JSVal
+ js_unsafeGetProp :: JSVal -> Any -> JSVal
foreign import javascript unsafe "(($1,$2) => { return $1[$2]; })"
js_getProp' :: JSVal -> JSVal -> IO JSVal
@@ -311,7 +311,7 @@ foreign import javascript unsafe "(($1_1, $1_2) => { return h$decodeUtf8z($1_1,$
js_unsafeUnpackJSStringUtf8## :: Addr# -> JSVal#
foreign import javascript unsafe "(($1, $2) => { return $1($2); })"
- js_callback_any :: JSVal# -> Exts.Any -> IO ()
+ js_callback_any :: JSVal# -> Any -> IO ()
foreign import javascript unsafe "(($1, $2) => { return $1($2); })"
js_callback_jsval :: JSVal# -> JSVal -> IO ()
=====================================
libraries/ghc-internal/src/GHC/Internal/JS/Prim/Internal/Build.hs
=====================================
@@ -145,7 +145,6 @@ module GHC.Internal.JS.Prim.Internal.Build
) where
import GHC.Internal.JS.Prim
-import GHC.Internal.Exts
import GHC.Internal.IO
import GHC.Internal.Unsafe.Coerce
import GHC.Internal.Base
=====================================
libraries/ghc-internal/src/GHC/Internal/Magic.hs
=====================================
@@ -24,7 +24,7 @@
--
-----------------------------------------------------------------------------
-module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where
+module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..), considerAccessible ) where
--------------------------------------------------
-- See Note [magicIds] in GHC.Types.Id.Make
@@ -34,7 +34,7 @@ module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(.
-- because TYPE is not exported by the source Haskell module generated by
-- genprimops which Haddock will typecheck (#15935).
import GHC.Internal.Prim (State#, realWorld#, RealWorld, Int#)
-import GHC.Internal.Types (RuntimeRep(BoxedRep), TYPE, Levity, Constraint)
+import GHC.Internal.Types (RuntimeRep(BoxedRep), TYPE, Levity, Constraint, Bool(True))
-- | The call @inline f@ arranges that @f@ is inlined, regardless of
-- its size. More precisely, the call @inline f@ rewrites to the
@@ -137,3 +137,27 @@ type DataToTag :: forall {lev :: Levity}. TYPE (BoxedRep lev) -> Constraint
-- So it does not get its own Unsafe module, unlike WithDict.
class DataToTag a where
dataToTag# :: a -> Int#
+
+-- | Semantically, @considerAccessible = True@. But it has special meaning
+-- to the pattern-match checker, which will never flag the clause in which
+-- 'considerAccessible' occurs as a guard as redundant or inaccessible.
+-- Example:
+--
+-- > case (x, x) of
+-- > (True, True) -> 1
+-- > (False, False) -> 2
+-- > (True, False) -> 3 -- Warning: redundant
+--
+-- The pattern-match checker will warn here that the third clause is redundant.
+-- It will stop doing so if the clause is adorned with 'considerAccessible':
+--
+-- > case (x, x) of
+-- > (True, True) -> 1
+-- > (False, False) -> 2
+-- > (True, False) | considerAccessible -> 3 -- No warning
+--
+-- Put 'considerAccessible' as the last statement of the guard to avoid get
+-- confusing results from the pattern-match checker, which takes \"consider
+-- accessible\" by word.
+considerAccessible :: Bool
+considerAccessible = True
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
=====================================
@@ -40,8 +40,8 @@ import GHC.Internal.Data.List
import GHC.Internal.Data.Tuple
import GHC.Internal.Foreign.Ptr
import GHC.Internal.Foreign.Storable
-import GHC.Internal.Exts
import GHC.Internal.Unsafe.Coerce
+import GHC.Internal.Ptr
import GHC.Internal.ClosureTypes
import GHC.Internal.Heap.Closures
=====================================
libraries/ghc-internal/src/GHC/Internal/Tuple.hs
=====================================
@@ -27,10 +27,11 @@ module GHC.Internal.Tuple (
Tuple40(..), Tuple41(..), Tuple42(..), Tuple43(..), Tuple44(..), Tuple45(..), Tuple46(..), Tuple47(..), Tuple48(..), Tuple49(..),
Tuple50(..), Tuple51(..), Tuple52(..), Tuple53(..), Tuple54(..), Tuple55(..), Tuple56(..), Tuple57(..), Tuple58(..), Tuple59(..),
Tuple60(..), Tuple61(..), Tuple62(..), Tuple63(..), Tuple64(..),
+ maxTupleSize,
) where
-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base
-import GHC.Internal.Types ()
+import GHC.Internal.Types (Int)
default () -- Double and Integer aren't available yet
@@ -598,3 +599,6 @@ data Tuple64 a b c d e f g h i j k l m n o p q r s t u v w x y z a1 b1 c1 d1 e1
r1 s1 t1 u1 v1 w1 x1 y1 z1 a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2
= (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1,
r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)
+
+maxTupleSize :: Int
+maxTupleSize = 64
=====================================
libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs
=====================================
@@ -32,7 +32,6 @@ module GHC.Internal.Wasm.Prim.Exports (
import GHC.Internal.Base
import GHC.Internal.Exception.Type
-import GHC.Internal.Exts
import GHC.Internal.IO
import GHC.Internal.IORef
import GHC.Internal.Int
=====================================
libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs
=====================================
@@ -30,7 +30,6 @@ module GHC.Internal.Wasm.Prim.Imports (
import GHC.Internal.Base
import GHC.Internal.Exception
-import GHC.Internal.Exts
import GHC.Internal.IO.Unsafe
import GHC.Internal.Stable
import GHC.Internal.Wasm.Prim.Types
=====================================
libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs
=====================================
@@ -20,9 +20,9 @@ module GHC.Internal.Wasm.Prim.Types (
import GHC.Internal.Base
import GHC.Internal.Exception.Type
-import GHC.Internal.Exts
import GHC.Internal.Foreign.C.String.Encoding
import GHC.Internal.ForeignPtr
+import GHC.Internal.Ptr
import GHC.Internal.IO
import GHC.Internal.IO.Encoding
import GHC.Internal.Num
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -4453,6 +4453,7 @@ module Data.Tuple.Experimental where
type Unit# :: GHC.Internal.Types.ZeroBitType
data Unit# = ...
getSolo :: forall a. Solo a -> a
+ maxTupleSize :: GHC.Internal.Types.Int
module GHC.Exception.Backtrace.Experimental where
-- Safety: None
@@ -11044,6 +11045,7 @@ module Prelude.Experimental where
type Unit# :: GHC.Internal.Types.ZeroBitType
data Unit# = ...
getSolo :: forall a. Solo a -> a
+ maxTupleSize :: GHC.Internal.Types.Int
module System.Mem.Experimental where
-- Safety: None
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout
=====================================
@@ -1232,6 +1232,7 @@ module GHC.Magic where
class DataToTag a where
dataToTag# :: a -> GHC.Internal.Prim.Int#
{-# MINIMAL dataToTag# #-}
+ considerAccessible :: GHC.Internal.Types.Bool
inline :: forall a. a -> a
lazy :: forall a. a -> a
noinline :: forall a. a -> a
@@ -3891,6 +3892,7 @@ module GHC.Tuple where
type Unit :: *
data Unit = ()
getSolo :: forall a. Solo a -> a
+ maxTupleSize :: GHC.Internal.Types.Int
module GHC.Types where
-- Safety: None
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/836851c8a4650e97e1a7b23a54a802…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/836851c8a4650e97e1a7b23a54a802…
You're receiving this email because of your account on gitlab.haskell.org.
1
0