- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/submodule-bumps-2026-01
by Cheng Shao (＠TerrorJack) 28 Jan '26

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

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

[Git][ghc/ghc][wip/andreask/ticked_joins] deal with exitification
by sheaf (＠sheaf) 28 Jan '26

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

[Git][ghc/ghc][wip/andreask/ticked_joins] deal with exitification
by sheaf (＠sheaf) 28 Jan '26

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

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

[Git][ghc/ghc][wip/spj-apporv-Oct24] Wibbles
by Simon Peyton Jones (＠simonpj) 28 Jan '26

28 Jan '26

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

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

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

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

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