[Git][ghc/ghc][wip/andreask/revert-generics] 7 commits: Migrate `ghc-pkg` to use `OsPath` and `file-io`
by Andreas Klebinger (＠AndreasK) 21 Apr '26
by Andreas Klebinger (＠AndreasK) 21 Apr '26
21 Apr '26
Andreas Klebinger pushed to branch wip/andreask/revert-generics at Glasgow Haskell Compiler / GHC
Commits:
7666f4a9 by Fendor at 2026-04-17T22:29:51-04:00
Migrate `ghc-pkg` to use `OsPath` and `file-io`
`ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH
issues on windows.
`file-io` uses UNC Paths by default on windows, ensuring we use the
correct APIs and that we finally are no longer plagued by MAX_PATH
issues in CI and private machines.
On top of it, the higher correctness of `OsPath` is appreciated in this
small codebase. Also, we improve memory usage very slightly, due to the
more efficient memory representation of `OsPath` over `FilePath`
Adds `ghc-pkg` regression test for MAX_PATH on windows
Make sure `ghc-pkg` behaves as expected when long paths (> 255) are
involved on windows.
Let's generate a testcase where we can actually observe that `ghc-pkg`
behaves as epxected.
See the documentation for windows on Maximum Path Length Limitation:
* `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation`
Adds changelog entry for long path support in ghc-pkg.
- - - - -
78434e8c by Simon Peyton Jones at 2026-04-17T22:30:38-04:00
Kill off the substitution in Lint
Now that we have invariant (NoTypeShadowing) we no longer
need Lint to carry an ambient substitution. This makes it
simpler and faster. A really worthwhile refactor.
There are some knock-on effects
* Linting join points after worker/wrapper. See
Note [Join points and beta redexes]
* Running a type substitution after the desugarer.
See Note [Substituting type-lets] in
the new module GHC.Core.SubstTypeLets
Implements #27078
Most perf tests don't use Lint so we won't see a perf incresae.
But T1969, which uses -O0 and Lint, gets 1.3% worse because it has
to run the SubstTypeLets pass which is a somewhat expensive no-op
Overall though compile-time allocations are down 0.1%.
Metric Increase:
T1969
- - - - -
86ca6c2c by mangoiv at 2026-04-17T22:31:22-04:00
testsuite: inline elemCoreTest
Some weird (probably python scoping) rule caused elemCoreTest, a regex
being out of scope on ubuntu, presumably because of a newer python version.
This patch just inlines the regex, which fixes the issue.
Fixes #27193
- - - - -
72d6dc74 by aparker at 2026-04-20T20:15:44-04:00
NCG: Implement constant folding for vector simd ops (Issue #25030)
- - - - -
b9cab907 by sheaf at 2026-04-20T20:15:44-04:00
Mark some SIMD tests as broken on i386 optllvm
As seen in #25498, several SIMD tests are broken on i386 in the optllvm
way. This commit marks them as "expect_broken".
- - - - -
76528cc3 by Wolfgang Jeltsch at 2026-04-20T20:16:25-04:00
Move most of the `System.IO` implementation into `base`
This involves a rewrite of the `combine` helper function to avoid the
use of `last`, which would now be flagged as an error.
Metric Decrease:
LinkableUsage01
T3294
Metric Increase:
T12227
T12707
T5642
- - - - -
288a6698 by Andreas Klebinger at 2026-04-21T14:31:21+02:00
Revert use of generic instances for compiler time perf reasons.
Revert "Derive Semigroup/Monoid for instances believed could be derived in #25871"
This reverts commit 11a04cbb221cc404fe00d65d7c951558ede4caa9.
Revert "add Ghc.Data.Pair deriving"
This reverts commit 15d9ce449e1be8c01b89fd39bdf1e700ea7d1dce.
- - - - -
63 changed files:
- + changelog.d/ghc-pkg-long-path-support
- + changelog.d/simd_constant_folding
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core/Lint.hs
- + compiler/GHC/Core/Lint/SubstTypeLets.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Data/Pair.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Types/Unique/DSet.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Utils/Misc.hs
- compiler/GHC/Utils/Ppr/Colour.hs
- compiler/ghc.cabal.in
- libraries/base/src/Control/Concurrent.hs
- libraries/base/src/GHC/IO/Handle.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/Text/Printf.hs
- libraries/base/tests/perf/all.T
- libraries/ghc-boot/GHC/Unit/Database.hs
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- testsuite/tests/cabal/Makefile
- testsuite/tests/cabal/all.T
- + testsuite/tests/cabal/ghcpkg10.stdout
- testsuite/tests/corelint/LintEtaExpand.stderr
- testsuite/tests/corelint/T21115b.stderr
- 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/simd/should_run/Makefile
- + testsuite/tests/simd/should_run/T25030.hs
- + testsuite/tests/simd/should_run/T25030.stdout
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/typecheck/should_compile/T9497a.stderr
- testsuite/tests/typecheck/should_compile/holes.stderr
- testsuite/tests/typecheck/should_compile/holes3.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T9497d.stderr
- testsuite/tests/typecheck/should_run/T9497a-run.stderr
- testsuite/tests/typecheck/should_run/T9497b-run.stderr
- testsuite/tests/typecheck/should_run/T9497c-run.stderr
- utils/ghc-pkg/Main.hs
- utils/ghc-pkg/ghc-pkg.cabal.in
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug973.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/DefaultSignatures.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/PatternSyns.html
- utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/QuasiExpr.html
- utils/haddock/html-test/ref/Test.html
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e989ad19482ffab5f51d67fccfc6f7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e989ad19482ffab5f51d67fccfc6f7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/reduce-type-in-stg] Remove kind from StgOpApp
by Jaro Reinders (＠jaro) 21 Apr '26
by Jaro Reinders (＠jaro) 21 Apr '26
21 Apr '26
Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC
Commits:
74459809 by Jaro Reinders at 2026-04-21T14:20:35+02:00
Remove kind from StgOpApp
- - - - -
19 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/CSE.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/Stg/EnforceEpt.hs
- compiler/GHC/Stg/EnforceEpt/Rewrite.hs
- compiler/GHC/Stg/FVs.hs
- compiler/GHC/Stg/Lift.hs
- compiler/GHC/Stg/Lift/Analysis.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Stats.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Sinker/Collect.hs
- compiler/GHC/StgToJS/Sinker/StringsUnfloat.hs
- compiler/GHC/StgToJS/Utils.hs
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -552,24 +552,24 @@ mkStgApp f how_bound core_args stg_args res_ty
-- stores the type constructor information. See Note [tagToEnum# in STG]
-- in GHC.Stg.Syntax.
PrimOpId TagToEnumOp _ ->
- StgOpApp (StgTagToEnumOp (tcTyConAppTyCon res_ty)) stg_args res_kind
+ StgOpApp (StgTagToEnumOp (tcTyConAppTyCon res_ty)) stg_args
-- Some primitive operator that might be implemented as a library call.
-- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
-- we require that primop applications be saturated.
PrimOpId op _ -> -- assertPpr saturated (ppr f <+> ppr stg_args) $
- StgOpApp (StgPrimOp op) stg_args res_kind
+ StgOpApp (StgPrimOp op) stg_args
-- A call to some primitive Cmm function.
FCallId (CCall (CCallSpec
(StaticTarget ext lbl ForeignFunction) PrimCallConv _))
| TargetIsInThat unit <- staticTargetUnit ext
-> assert exactly_saturated $
- StgOpApp (StgPrimCallOp (PrimCall lbl unit)) stg_args res_kind
+ StgOpApp (StgPrimCallOp (PrimCall lbl unit) res_kind) stg_args
-- A regular foreign call.
FCallId call -> assert exactly_saturated $
- StgOpApp (StgFCallOp call (collectStgFArgTypes (idType f))) stg_args res_kind
+ StgOpApp (StgFCallOp call (collectStgFArgTypes (idType f)) res_kind) stg_args
TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,stg_args)
=====================================
compiler/GHC/Stg/CSE.hs
=====================================
@@ -349,8 +349,8 @@ stgCseExpr env (StgApp fun args)
args' = substArgs env args
stgCseExpr _ (StgLit lit)
= StgLit lit
-stgCseExpr env (StgOpApp op args tys)
- = StgOpApp op args' tys
+stgCseExpr env (StgOpApp op args)
+ = StgOpApp op args'
where args' = substArgs env args
stgCseExpr env (StgTick tick body)
= let body' = stgCseExpr env body
=====================================
compiler/GHC/Stg/Debug.hs
=====================================
@@ -103,7 +103,7 @@ collectExpr = go
go (StgConApp dc _mn as tys) = do
n' <- numberDataCon dc []
return (StgConApp dc n' as tys)
- go (StgOpApp op as ty) = return (StgOpApp op as ty)
+ go (StgOpApp op as) = return (StgOpApp op as)
go (StgCase scrut bndr ty alts) =
StgCase <$> collectExpr scrut <*> pure bndr <*> pure ty <*> mapM collectAlt alts
go (StgLet ext bind body) = do
=====================================
compiler/GHC/Stg/EnforceEpt.hs
=====================================
@@ -419,11 +419,11 @@ inferTagExpr env (StgTick tick body)
where
(info, body') = inferTagExpr env body
-inferTagExpr _ (StgOpApp op args ty)
+inferTagExpr _ (StgOpApp op args)
-- Which primops guarantee to return a properly tagged value?
-- Probably none, and that is the conservative assumption anyway.
-- (And foreign calls definitely need not make promises.)
- = (TagDunno, StgOpApp op args ty)
+ = (TagDunno, StgOpApp op args)
inferTagExpr env (StgLet ext bind body)
= (info, StgLet ext bind' body')
=====================================
compiler/GHC/Stg/EnforceEpt/Rewrite.hs
=====================================
@@ -396,7 +396,7 @@ rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e
rewriteExpr e@(StgConApp {}) = rewriteConApp e
rewriteExpr e@(StgApp {}) = rewriteApp e
rewriteExpr (StgLit lit) = return $! (StgLit lit)
-rewriteExpr (StgOpApp op args res_ty) = (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
+rewriteExpr (StgOpApp op args) = StgOpApp op <$!> rewriteArgs args
rewriteCase :: InferStgExpr -> RM TgStgExpr
@@ -496,12 +496,12 @@ So for these we should call `rewriteArgs`.
-}
rewriteOpApp :: InferStgExpr -> RM TgStgExpr
-rewriteOpApp (StgOpApp op args res_ty) = case op of
+rewriteOpApp (StgOpApp op args) = case op of
op@(StgPrimOp primOp)
| primOp == DataToTagSmallOp || primOp == DataToTagLargeOp
-- see Note [Rewriting primop arguments]
- -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
- _ -> pure $! StgOpApp op args res_ty
+ -> StgOpApp op <$!> rewriteArgs args
+ _ -> pure $! StgOpApp op args
rewriteOpApp _ = panic "Impossible"
-- `mkSeq` x x' e generates `case x of x' -> e`
=====================================
compiler/GHC/Stg/FVs.hs
=====================================
@@ -234,9 +234,9 @@ exprFVs env = go
| (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env as
= (StgConApp dc n as tys, imp_fvs, top_fvs, lcl_fvs)
- go (StgOpApp op as ty)
+ go (StgOpApp op as)
| (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env as
- = (StgOpApp op as ty, imp_fvs, top_fvs, lcl_fvs)
+ = (StgOpApp op as, imp_fvs, top_fvs, lcl_fvs)
go (StgCase scrut bndr ty alts)
| (scrut',scrut_imp_fvs,scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut
=====================================
compiler/GHC/Stg/Lift.hs
=====================================
@@ -229,7 +229,7 @@ liftExpr (StgApp f args) = do
let top_lvl_args = map StgVarArg fvs' ++ args'
pure (StgApp f' top_lvl_args)
liftExpr (StgConApp con mn args tys) = StgConApp con mn <$> traverse liftArgs args <*> pure tys
-liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty
+liftExpr (StgOpApp op args) = StgOpApp op <$> traverse liftArgs args
liftExpr (StgCase scrut info ty alts) = do
scrut' <- liftExpr scrut
withSubstBndr (binderInfoBndr info) $ \bndr' -> do
=====================================
compiler/GHC/Stg/Lift/Analysis.hs
=====================================
@@ -138,8 +138,8 @@ tagSkeletonExpr (StgLit lit)
= (NilSk, emptyVarSet, StgLit lit)
tagSkeletonExpr (StgConApp con mn args tys)
= (NilSk, mkArgOccs args, StgConApp con mn args tys)
-tagSkeletonExpr (StgOpApp op args ty)
- = (NilSk, mkArgOccs args, StgOpApp op args ty)
+tagSkeletonExpr (StgOpApp op args)
+ = (NilSk, mkArgOccs args, StgOpApp op args)
tagSkeletonExpr (StgApp f args)
= (NilSk, arg_occs, StgApp f args)
where
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -295,7 +295,7 @@ lintStgExpr app@(StgConApp con _n args _arg_tys) = do
opts <- getStgPprOpts
lintConApp con args (pprStgExpr opts app)
-lintStgExpr (StgOpApp _ args _) =
+lintStgExpr (StgOpApp _ args) =
mapM_ lintStgFunArg args
lintStgExpr (StgLet _ binds body) = do
=====================================
compiler/GHC/Stg/Stats.hs
=====================================
@@ -150,7 +150,7 @@ statExpr :: StgExpr -> StatEnv
statExpr (StgApp _ _) = countOne Applications
statExpr (StgLit _) = countOne Literals
statExpr (StgConApp {}) = countOne ConstructorApps
-statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
+statExpr (StgOpApp _ _) = countOne PrimitiveApps
statExpr (StgTick _ e) = statExpr e
statExpr (StgLetNoEscape _ binds body)
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -282,9 +282,6 @@ for the details of this transformation.
| StgOpApp StgOp -- Primitive op or foreign call
[StgArg] -- Saturated.
- StgKind -- Result kind
- -- We need to know this so that we can
- -- assign result registers
{-
************************************************************************
@@ -795,9 +792,9 @@ last moment that we still have access to the type information.
data StgOp
= StgPrimOp PrimOp
- | StgPrimCallOp PrimCall
+ | StgPrimCallOp PrimCall StgKind
- | StgFCallOp ForeignCall [StgFArgType]
+ | StgFCallOp ForeignCall [StgFArgType] StgKind
-- The foreign argument types, which are obtained from the foreign
-- import declaration itself, areneeded by the stg-to-cmm pass to
-- determine the offset to apply to unlifted boxed arguments in
@@ -907,7 +904,7 @@ pprStgExpr opts e = case e of
-> ppr func <> ppr sig
| otherwise -> hang (ppr func) 4 (interppSP args) -- TODO: Print taggedness
StgConApp con n args _ -> hsep [ ppr con, ppr n, brackets (interppSP args) ]
- StgOpApp op args _ -> hsep [ pprStgOp op, brackets (interppSP args)]
+ StgOpApp op args -> hsep [ pprStgOp op, brackets (interppSP args)]
-- special case: let v = <very specific thing>
-- in
@@ -994,8 +991,8 @@ pprStgAlt opts indent GenStgAlt{alt_con, alt_bndrs, alt_rhs}
pprStgOp :: StgOp -> SDoc
pprStgOp (StgPrimOp op) = ppr op
-pprStgOp (StgPrimCallOp op)= ppr op
-pprStgOp (StgFCallOp op _) = ppr op
+pprStgOp (StgPrimCallOp op _)= ppr op
+pprStgOp (StgFCallOp op _ _) = ppr op
-- TODO: how do we want to pretty print this?
pprStgOp (StgTagToEnumOp tyc) = text "TagToEnumOp" <+> ppr tyc
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -574,8 +574,8 @@ unariseExpr rho (StgConApp dc n args ty_args)
let args' = unariseConArgs rho args in
return $ (StgConApp dc n args' [])
-unariseExpr rho (StgOpApp op args ty)
- = return (StgOpApp op (unariseFunArgs rho args) ty)
+unariseExpr rho (StgOpApp op args)
+ = return (StgOpApp op (unariseFunArgs rho args))
unariseExpr rho (StgCase scrut bndr alt_ty alts)
-- tuple/sum binders in the scrutinee can always be eliminated
@@ -902,7 +902,7 @@ stgKindPrimRep1 (MkStgKind k) = case kindPrimRep_maybe k of
mkCast :: StgArg -> PrimOp -> OutId -> StgKind -> StgExpr -> StgExpr
mkCast arg_in cast_op out_id out_kind in_rhs =
- let scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_kind
+ let scrut = StgOpApp (StgPrimOp cast_op) [arg_in]
alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs}
alt_ty = PrimAlt (stgKindPrimRep1 out_kind)
in (StgCase scrut out_id alt_ty [alt])
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -659,12 +659,12 @@ schemeT d s p app
= implement_tagToId d s p arg constr_names
-- Case 1
-schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args kind)
+schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _argtys kind) args)
= if isSupportedCConv ccall_spec
then generateCCall d s p ccall_spec kind args
else unsupportedCConvException
-schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do
+schemeT d s p (StgOpApp (StgPrimOp op) args) = do
profile <- getProfile
let platform = profilePlatform profile
case doPrimOp platform op d s p args of
@@ -673,7 +673,7 @@ schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do
-- Otherwise we have to do a call to the primop wrapper instead :(
_ -> doTailCall d s p (primOpId op) (reverse args)
-schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label _)) args _reps)
+schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label _) _) args)
= generatePrimCall d s p label args
schemeT d s p (StgConApp con _cn args _tys)
@@ -2170,7 +2170,7 @@ mkDummyLiteral platform pr
maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name])
-- Detect and extract relevant info for the tagToEnum kludge.
-maybe_is_tagToEnum_call (StgOpApp (StgTagToEnumOp tyc) args _)
+maybe_is_tagToEnum_call (StgOpApp (StgTagToEnumOp tyc) args)
| [v] <- args
= Just (v, extract_constr_Names tyc)
| otherwise
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -69,7 +69,7 @@ cgExpr (StgApp fun args) = cgIdApp fun args
-- dataToTagSmall# :: a_levpoly -> Int#
-- See Note [DataToTag overview] in GHC.Tc.Instance.Class,
-- particularly wrinkles H3 and DTW4
-cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do
+cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a]) = do
platform <- getPlatform
emitComment (mkFastString "dataToTagSmall#")
@@ -84,7 +84,7 @@ cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do
-- dataToTagLarge# :: a_levpoly -> Int#
-- See Note [DataToTag overview] in GHC.Tc.Instance.Class,
-- particularly wrinkles H3 and DTW4
-cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do
+cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a]) = do
platform <- getPlatform
emitComment (mkFastString "dataToTagLarge#")
@@ -114,7 +114,7 @@ cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do
emitReturn [CmmReg $ CmmLocal result_reg]
-cgExpr (StgOpApp op args kind) = cgOpApp op args kind
+cgExpr (StgOpApp op args) = cgOpApp op args
cgExpr (StgConApp con mn args _) = cgConApp con mn args
cgExpr (StgTick t e) = cgTick t >> cgExpr e
cgExpr (StgLit lit) = do cmm_expr <- cgLit lit
@@ -621,7 +621,7 @@ cgCase scrut bndr alt_type alts
; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts
}
where
- is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op
+ is_cmp_op (StgOpApp (StgPrimOp op) _) = isComparisonPrimOp op
is_cmp_op _ = False
@@ -663,7 +663,7 @@ isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool
-- heap usage from alternatives into the stuff before the case
-- NB: if you get this wrong, and claim that the expression doesn't allocate
-- when it does, you'll deeply mess up allocation
-isSimpleScrut (StgOpApp op args _) _ = isSimpleOp op args
+isSimpleScrut (StgOpApp op args) _ = isSimpleOp op args
isSimpleScrut (StgLit _) _ = return True -- case 1# of { 0# -> ..; ... }
isSimpleScrut (StgApp _ []) (PrimAlt _) = return True -- case x# of { 0# -> ..; ... }
isSimpleScrut (StgApp f []) _
@@ -677,7 +677,7 @@ isSimpleScrut _ _ = return False
isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
-- True iff the op cannot block or allocate
-isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _ _) _ = return $! not (playSafe safe)
-- dataToTagSmall#/dataToTagLarge# evaluate an argument;
-- see Note [DataToTag overview] in GHC.Tc.Instance.Class
isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False
@@ -687,7 +687,7 @@ isSimpleOp (StgPrimOp op) stg_args = do
cfg <- getStgToCmmConfig
-- See Note [Inlining out-of-line primops and heap checks]
return $! shouldInlinePrimOp cfg op arg_exprs
-isSimpleOp (StgPrimCallOp _) _ = return False
+isSimpleOp (StgPrimCallOp _ _) _ = return False
isSimpleOp (StgTagToEnumOp _) _ = return True
-----------------
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -68,27 +68,26 @@ might be a Haskell closure pointer, we don't want to evaluate it. -}
----------------------------------
cgOpApp :: StgOp -- The op
-> [StgArg] -- Arguments
- -> StgKind -- Kind (always unboxed tuple)
-> FCode ReturnKind
-- Foreign calls
-cgOpApp (StgFCallOp fcall ty) stg_args res_kind
+cgOpApp (StgFCallOp fcall ty res_kind) stg_args
= cgForeignCall fcall ty stg_args res_kind
-- See Note [Foreign call results]
-cgOpApp (StgPrimOp primop) args kind = do
+cgOpApp (StgPrimOp primop) args = do
cfg <- getStgToCmmConfig
cmm_args <- getNonVoidArgAmodes args
- cmmPrimOpApp cfg primop cmm_args (Just kind)
+ cmmPrimOpApp cfg primop cmm_args
-cgOpApp (StgPrimCallOp primcall) args _res_ty
+cgOpApp (StgPrimCallOp primcall _) args
= do { cmm_args <- getNonVoidArgAmodes args
; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
-- tagToEnum# is special: we need to pull the constructor
-- out of the table, and perform an appropriate return.
-cgOpApp (StgTagToEnumOp tyc) args _ = do
+cgOpApp (StgTagToEnumOp tyc) args = do
amodes <- getNonVoidArgAmodes args
case amodes of
[amode] -> do
@@ -102,14 +101,12 @@ cgOpApp (StgTagToEnumOp tyc) args _ = do
emitReturn [tagToClosure platform tyc amode]
_ -> pprPanic "cgOpApp: tagToEnum# should be applied to exactly one argument" (ppr args)
-cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe StgKind -> FCode ReturnKind
-cmmPrimOpApp cfg primop cmm_args mres_ty =
+cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> FCode ReturnKind
+cmmPrimOpApp cfg primop cmm_args =
case emitPrimOp cfg primop cmm_args of
PrimopCmmEmit_Internal f ->
let
- -- if the result kind isn't explicitly given, we directly use the
- -- result kind of the primop.
- res_ty = fromMaybe (MkStgKind (typeKind (primOpResultType primop))) mres_ty
+ res_ty = MkStgKind (typeKind (primOpResultType primop))
in emitReturn =<< f res_ty
PrimopCmmEmit_External -> do
let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
@@ -2322,7 +2319,7 @@ genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]
p <- newTemp t
-- 1) compute the multiplication as if numbers were unsigned
_ <- withSequel (AssignTo [p, res_l] False) $
- cmmPrimOpApp cfg WordMul2Op both_args Nothing
+ cmmPrimOpApp cfg WordMul2Op both_args
-- 2) correct the high bits of the unsigned result
let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]
sub x y = CmmMachOp (MO_Sub ww) [x, y]
@@ -3676,7 +3673,7 @@ emitRangeBoundsCheck idx len arrSizeExpr = do
rangeTooLargeReg <- newTemp (bWord platform)
lastSafeIndexReg <- newTemp (bWord platform)
_ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $
- cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing
+ cmmPrimOpApp config WordSubCOp [arrSize, len]
boundsCheckFailed <- getCode $
emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []
let
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -107,14 +107,14 @@ genExpr ctx stg = case stg of
as <- concatMapM genArg args
c <- genCon ctx con as
return (c, ExprInline)
- StgOpApp (StgFCallOp f _) args k
+ StgOpApp (StgFCallOp f _ k) args
-> genForeignCall ctx f k (concatMap typex_expr $ ctxTarget ctx) args
- StgOpApp (StgPrimOp op) args _k
+ StgOpApp (StgPrimOp op) args
-> genPrimOp ctx op args
- StgOpApp (StgPrimCallOp c) args k
+ StgOpApp (StgPrimCallOp c k) args
-> genPrimCall ctx c args k
- StgOpApp (StgTagToEnumOp tyc) [arg] _k -> genTagToEnumOp ctx tyc arg
- StgOpApp op@(StgTagToEnumOp _) args k -> pprPanic "genExpr: StgTagToEnumOp not applied to exactly one argument" (ppr op <+> ppr args <+> ppr (getStgKind k))
+ StgOpApp (StgTagToEnumOp tyc) [arg] -> genTagToEnumOp ctx tyc arg
+ StgOpApp op@(StgTagToEnumOp _) args -> pprPanic "genExpr: StgTagToEnumOp not applied to exactly one argument" (ppr op <+> ppr args)
StgCase e b at alts
-> genCase ctx b e at alts (liveVars $ stgExprLive False stg)
StgLet _ b e -> do
=====================================
compiler/GHC/StgToJS/Sinker/Collect.hs
=====================================
@@ -42,7 +42,7 @@ collectArgs = \case
-> x : concatMap collectArgsA args
StgConApp _con _mn args _ts
-> concatMap collectArgsA args
- StgOpApp _x args _t
+ StgOpApp _x args
-> concatMap collectArgsA args
StgCase e _b _a alts
-> collectArgsE e ++ concatMap collectArgsAlt alts
=====================================
compiler/GHC/StgToJS/Sinker/StringsUnfloat.hs
=====================================
@@ -103,7 +103,7 @@ unfloatStringLits' stringLits allBindings = (binderWithoutChanges ++ binderWithU
-- No args
processStgExpr (StgApp _ []) = Nothing
processStgExpr (StgConApp _ _ [] _) = Nothing
- processStgExpr (StgOpApp _ [] _) = Nothing
+ processStgExpr (StgOpApp _ []) = Nothing
-- Main targets. Preserving the order of args is important
processStgExpr (StgApp fn args@(_:_))
@@ -116,9 +116,9 @@ unfloatStringLits' stringLits allBindings = (binderWithoutChanges ++ binderWithU
| otherwise = Just (StgConApp dc n unified tys, names)
where
(unified, names) = substituteArgWithNames args
- processStgExpr (StgOpApp op args@(_:_) tys)
+ processStgExpr (StgOpApp op args@(_:_))
| isEmptyUniqSet names = Nothing
- | otherwise = Just (StgOpApp op unified tys, names)
+ | otherwise = Just (StgOpApp op unified, names)
where
(unified, names) = substituteArgWithNames args
=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -312,7 +312,7 @@ exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs u = \case
StgApp f args -> s f <> l (argRefs u) args
StgConApp d _n args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args
- StgOpApp _ args _ -> l (argRefs u) args
+ StgOpApp _ args -> l (argRefs u) args
StgLit {} -> mempty
StgCase expr _ _ alts -> exprRefs u expr <> mconcat (fmap (altRefs u) alts)
StgLet _ bnd expr -> bindingRefs u bnd <> exprRefs u expr
@@ -400,7 +400,7 @@ stgExprLive includeLHS = \case
StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args)
StgLit {} -> emptyDVarSet
StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args)
- StgOpApp _op args _ty -> unionDVarSets (map stgArgLive args)
+ StgOpApp _op args -> unionDVarSets (map stgArgLive args)
StgCase e b _at alts
| includeLHS -> el `unionDVarSet` delDVarSet al b
| otherwise -> delDVarSet al b
@@ -445,11 +445,13 @@ isInlineExpr = \case
-> True
StgConApp{}
-> True
- StgOpApp (StgFCallOp f _) _ _
+ StgOpApp (StgFCallOp f _ _) _
-> isInlineForeignCall f
- StgOpApp (StgPrimOp op) _ _
+ StgOpApp (StgPrimOp op) _
-> primOpIsReallyInline op
- StgOpApp (StgPrimCallOp _c) _ _
+ StgOpApp (StgPrimCallOp _c _) _
+ -> True
+ StgOpApp (StgTagToEnumOp _) _c
-> True
StgCase e _ _ alts
->let ie = isInlineExpr e
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/74459809e757ea513bb4efcfe01d5d2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/74459809e757ea513bb4efcfe01d5d2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ani/T27156] split tcExpand into two functions. Call Expansion in HsToCore.Quote
by Apoorv Ingle (＠ani) 21 Apr '26
by Apoorv Ingle (＠ani) 21 Apr '26
21 Apr '26
Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC
Commits:
0ceec1e3 by Apoorv Ingle at 2026-04-20T23:42:56-05:00
split tcExpand into two functions. Call Expansion in HsToCore.Quote
- - - - -
7 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Expand.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -279,7 +279,7 @@ type instance XCase GhcRn = HsMatchContextRn
type instance XCase GhcTc = HsMatchContextRn
type instance XIf GhcPs = AnnsIf
-type instance XIf GhcRn = Maybe RebindableSyntaxTable -- Nothing <=> RebindableSyntax is off
+type instance XIf GhcRn = RebindableSyntaxTable -- NoRebindable <=> RebindableSyntax is off
type instance XIf GhcTc = NoExtField
type instance XMultiIf GhcPs = (EpToken "if", EpToken "{", EpToken "}")
@@ -295,7 +295,7 @@ type instance XDo GhcRn = NoExtField
type instance XDo GhcTc = Type
type instance XExplicitList GhcPs = AnnList ()
-type instance XExplicitList GhcRn = Maybe RebindableSyntaxTable -- Nothing <=> RebindableSyntax is off
+type instance XExplicitList GhcRn = RebindableSyntaxTable -- NoRebindable <=> RebindableSyntax is off
type instance XExplicitList GhcTc = Type
-- GhcPs: ExplicitList includes all source-level
-- list literals, including overloaded ones
@@ -310,7 +310,7 @@ type instance XRecordCon GhcRn = NoExtField
type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function
type instance XRecordUpd GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}"))
-type instance XRecordUpd GhcRn = Maybe RebindableSyntaxTable -- Nothing <=> RebindableSyntaxTable is off
+type instance XRecordUpd GhcRn = RebindableSyntaxTable -- NoRebindable <=> RebindableSyntaxTable is off
type instance XRecordUpd GhcTc = DataConCantHappen
-- We desugar record updates in the typechecker.
-- See [Handling overloaded and rebindable constructs],
@@ -1485,11 +1485,15 @@ type instance XXCmd GhcTc = HsWrap HsCmd
type CmdSyntaxTable p = [(Name, HsExpr p)]
-- See Note [CmdSyntaxTable]
-type RebindableSyntaxTable = [(String, Name)]
+data RebindableSyntaxTable = NoRebindable | Rebindable [(OccName, Name)]
-- Stores the names of the operators for rebindable syntax
-- eg. getField, setField etc.
-- GHC.Tc.Expand will use these names to build the expansions
+isNoRebindable :: RebindableSyntaxTable -> Bool
+isNoRebindable NoRebindable = True
+isNoRebindable Rebindable{} = False
+
{-
Note [CmdSyntaxTable]
~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -340,6 +340,8 @@ deriving instance Data (RoleAnnotDecl GhcTc)
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs.Expr -----------------------------------
+deriving instance Data RebindableSyntaxTable -- maybe don't traverse?
+
deriving instance Data (FieldLabelStrings GhcPs)
deriving instance Data (FieldLabelStrings GhcRn)
deriving instance Data (FieldLabelStrings GhcTc)
@@ -684,7 +686,6 @@ deriving instance Data (HsExpansion GhcTc)
deriving instance Data a => Data (WithUserRdr a)
-- -------------------------------
---------------------------------------
deriving instance Data XXExprGhcTc
deriving instance Data XXPatGhcTc
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -44,6 +44,8 @@ import GHC.Tc.Types.Evidence
import GHC.Tc.Types.ErrCtxt
import GHC.Tc.TyCl ( IsPrefixConGADT(..), unannotatedMultIsLinear )
+import GHC.Tc.Gen.Expand ( tcExpandNoTcM )
+
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.TyCon
@@ -1618,11 +1620,13 @@ repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
; ms2 <- mapM repMatchTup ms
; core_ms2 <- coreListM matchTyConName ms2
; repCaseE arg core_ms2 }
-repE (HsIf _ x y z) = do
- a <- repLE x
- b <- repLE y
- c <- repLE z
- repCond a b c
+repE e@(HsIf _ x y z) = case (tcExpandNoTcM e) of
+ Nothing -> do { a <- repLE x
+ ; b <- repLE y
+ ; c <- repLE z
+ ; repCond a b c }
+ Just (HSE _ (L _ e')) -> repE e'
+
repE (HsMultiIf _ alts)
= do { (binds, alts') <- NE.unzip <$> mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList' alts')
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -344,7 +344,7 @@ rnExpr (HsHole h)
-- HsOverLabel: see Note [Handling overloaded and rebindable constructs]
rnExpr (HsOverLabel src v)
= do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName
- ; let rs_table = [("fromLabel", from_label)]
+ ; let rs_table = Rebindable [(nameOccName fromLabelClassOpName, from_label)]
; return (HsOverLabel (src, rs_table) v, fvs)
}
@@ -416,14 +416,14 @@ rnExpr (HsGetField _ e f)
= do { (getField, fv_getField) <- lookupSyntaxName getFieldName
; (e, fv_e) <- rnLExpr e
; let f' = rnDotFieldOcc <$> f
- rs_table = [("getField", getField)]
+ rs_table = Rebindable [(nameOccName getFieldName, getField)]
; return (HsGetField rs_table e f', fv_e `plusFN` fv_getField) }
rnExpr (HsProjection _ fs)
= do { (getFieldName, fv_getField) <- lookupSyntaxName getFieldName
; circName <- lookupOccRn WL_TermVariable compose_RDR
; let fs' = NE.map rnDotFieldOcc fs
- rs_table = [("getField" , getFieldName), ("circ", circName)]
+ rs_table = Rebindable [(nameOccName getFieldName , getFieldName), (rdrNameOcc compose_RDR, circName)]
; return (HsProjection rs_table fs', unitFN circName `plusFN` fv_getField) }
------------------------------------------
@@ -487,10 +487,10 @@ rnExpr (ExplicitList _ exps)
= do { (exps', fvs) <- rnExprs exps
; opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; if not opt_OverloadedLists
- then return (ExplicitList Nothing exps', fvs)
+ then return (ExplicitList NoRebindable exps', fvs)
else
do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
- ; let rs_table = Just [("fromListN", from_list_n_name)]
+ ; let rs_table = Rebindable [(nameOccName fromListNName, from_list_n_name)]
rn_list = ExplicitList rs_table exps'
; return ( rn_list
, fvs `plusFN` fvs') } }
@@ -536,7 +536,7 @@ rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds })
RegularRecUpdFields
{ xRecUpdFields = parents
, recUpdFields = flds }
- ; return ( RecordUpd Nothing (L l e) upd_flds
+ ; return ( RecordUpd NoRebindable (L l e) upd_flds
, fv_e `plusFN` fv_flds ) }
-- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.
@@ -554,7 +554,7 @@ rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds })
; let upd_flds = OverloadedRecUpdFields
{ xOLRecUpdFields = noExtField
, olRecUpdFields = us }
- rs_table = Just [("getFieldName", getField) , ("setFieldName", setField)]
+ rs_table = Rebindable [(nameOccName getField, getField) , (nameOccName getField, setField)]
; return (RecordUpd rs_table (L l e) upd_flds
, plusFNs [fv_getField, fv_setField, fv_e, fv_us] )
}
@@ -2698,11 +2698,11 @@ rnHsIf p b1 b2
; mb_ite <- lookupIfThenElse
; case mb_ite of
Nothing -- Non rebindable-syntax case
- -> return (HsIf Nothing p' b1' b2', fvs_if)
+ -> return (HsIf NoRebindable p' b1' b2', fvs_if)
Just ite_name -- Rebindable-syntax case
-> do { let fvs = plusFNs [fvs_if, unitFN ite_name]
- ; return (HsIf (Just [("ifThenElse" , ite_name)]) p' b1' b2', fvs) } }
+ ; return (HsIf (Rebindable [(rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse"), ite_name)]) p' b1' b2', fvs) } }
rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeNames)
=====================================
compiler/GHC/Tc/Gen/Expand.hs
=====================================
@@ -5,30 +5,34 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
-module GHC.Tc.Gen.Expand( tcExpand ) where
+module GHC.Tc.Gen.Expand( tcExpand, tcExpandNoTcM ) where
import GHC.Prelude hiding (last, init, tail)
-
-import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
+import GHC.Data.FastString
import GHC.Hs
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.ErrCtxt
import GHC.Tc.Gen.Do
+import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
import GHC.Types.Name
+import GHC.Types.Name.Reader
import GHC.Types.Id.Make
import GHC.Types.SrcLoc
import GHC.Types.SourceText ( mkIntegralLit , SourceText(..) )
+import GHC.Builtin.Names
+
import GHC.Rename.Utils
-import qualified Data.List.NonEmpty as NE ( map, head, (<|) )
-import Data.List.NonEmpty ( NonEmpty(..), init, last, tail )
import GHC.Utils.Panic
import GHC.Utils.Outputable
+import qualified Data.List.NonEmpty as NE ( map, head, (<|) )
+import Data.List.NonEmpty ( NonEmpty(..), init, last, tail )
+
import qualified GHC.LanguageExtensions as LangExt
{- Note [Typechecking by expansion: overview]
@@ -116,14 +120,15 @@ Wrinkle (TBE1)
-- See Note [Typechecking by expansion: overview]
tcExpand :: HsExpr GhcRn -> TcM (Maybe (HsExpansion GhcRn))
+tcExpandNoTcM :: HsExpr GhcRn -> Maybe (HsExpansion GhcRn)
------------------------------------------
-- Overloaded labels
-tcExpand e@(HsOverLabel (_, rs_table) v)
- | Just fromLabelName <- lookup "fromLabel" rs_table
+tcExpandNoTcM e@(HsOverLabel (_, Rebindable rs_table) v)
+ | Just fromLabelName <- lookup (nameOccName fromLabelClassOpName) rs_table
, let hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
HsTyLit noExtField (HsString NoSourceText v)
- = return $ Just $
+ = Just $
HSE { hse_ctxt = ExprCtxt e
, hse_exp = wrapGenSpan $ HsAppType noExtField (genLHsVar fromLabelName) hs_ty_arg
}
@@ -134,26 +139,92 @@ tcExpand e@(HsOverLabel (_, rs_table) v)
------------------------------------------
-- Qualified Literals
-tcExpand e@(HsQualLit _ QualLit{ql_val = ql_val, ql_ext = (L _ fromStringName)})
+tcExpandNoTcM e@(HsQualLit _ QualLit{ql_val = ql_val, ql_ext = (L _ fromStringName)})
= do { let hsLit = case ql_val of
-- See Note [Implementation of QualifiedStrings]
HsQualString st s -> HsString st s
- ; return $ Just $
- HSE { hse_ctxt = ExprCtxt e
- , hse_exp = wrapGenSpan $ genHsApps fromStringName [genLHsLit hsLit]
- }
+ ; Just $
+ HSE { hse_ctxt = ExprCtxt e
+ , hse_exp = wrapGenSpan $ genHsApps fromStringName [genLHsLit hsLit]
+ }
}
------------------------------------------
-- Operator Applications
-tcExpand e@(OpApp _ arg1 op arg2)
- = return $ Just $
+tcExpandNoTcM e@(OpApp _ arg1 op arg2)
+ = Just $
HSE { hse_ctxt = ExprCtxt e
, hse_exp = foldl ap op [arg1,arg2] }
where
ap f a = wrapGenSpan (HsApp noExtField f a)
+------------------------------------------
+-- If
+
+-- NoRebindable <=> rebindable is turned off
+-- so we typecheck the HsIf in tcExprNoExpand
+tcExpandNoTcM (HsIf NoRebindable _ _ _ )
+ = Nothing
+tcExpandNoTcM e@(HsIf (Rebindable rs_table) p b1 b2)
+ | Just ifThenElseName <- lookup (rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse")) rs_table
+ = Just $
+ HSE { hse_ctxt = ExprCtxt e
+ , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2]
+ }
+ | otherwise
+ = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find ifThenElse in rs_table"
+ , ppr e ])
+
+------------------------------------------
+-- Record dot syntax
+
+tcExpandNoTcM e@(HsGetField (Rebindable rs_table) expr f)
+ | Just getField <- lookup (nameOccName getFieldName) rs_table
+ = Just $
+ HSE { hse_ctxt = ExprCtxt e
+ , hse_exp = wrapGenSpan $ (mkGetField getField expr (fmap (unLoc . dfoLabel) f)) }
+ | otherwise
+ = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField in rs_table"
+ , ppr e ])
+
+tcExpandNoTcM e@(HsProjection (Rebindable rs_table) fs)
+ | Just getField <- lookup (nameOccName getFieldName) rs_table
+ , Just circ <- lookup (rdrNameOcc compose_RDR) rs_table
+ = Just $
+ HSE { hse_ctxt = ExprCtxt e
+ , hse_exp = wrapGenSpan $ (mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs) }
+ | otherwise
+ = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or circ in rs_table"
+ , ppr e])
+
+
+tcExpandNoTcM (RecordUpd NoRebindable _ _ ) = Nothing -- until #27160 is fixed
+
+tcExpandNoTcM e@(RecordUpd (Rebindable rs_table) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us}))
+ | Just getField <- lookup (nameOccName getFieldName) rs_table
+ , Just setField <- lookup (nameOccName setFieldName) rs_table
+ = Just $
+ HSE { hse_ctxt = ExprCtxt e
+ , hse_exp = wrapGenSpan $ mkRecordDotUpd getField setField (L l expr) us }
+ | otherwise
+ = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or setfield in rs_table"
+ , ppr e ])
+
+
+
+------------------------
+-- XExpr
+-- Expansions are idempotent, XExprs do not expand again
+tcExpandNoTcM (XExpr (ExpandedThingRn hse))
+ = Just hse
+
+
+tcExpandNoTcM _
+ = Nothing
+
+
+
------------------------------------------
-- Left and Right Sections
@@ -174,15 +245,20 @@ tcExpand e@(SectionL _ expr op)
HSE { hse_ctxt = ExprCtxt e
, hse_exp = wrapGenSpan ds_section } }
-tcExpand (ExplicitList Nothing _ )
+------------------------------------------
+-- Explicit Lists
+
+tcExpand (ExplicitList NoRebindable _ )
= return Nothing -- rebindable syntax is off
-tcExpand e@(ExplicitList (Just rs_table) exps)
- | Just from_list_n_name <- lookup "fromListN" rs_table
+tcExpand e@(ExplicitList (Rebindable rs_table) exps)
+ | Just from_list_n_name <- lookup (nameOccName fromListNName) rs_table
= do { loc <- getSrcSpanM -- See Note [Source locations for implicit function calls]
; let lit_n = mkIntegralLit (length exps)
hs_lit = genHsIntegralLit lit_n
exp_list = genHsApps' (wrapGenSpan' loc from_list_n_name)
- [hs_lit, wrapGenSpan (ExplicitList Nothing exps)]
+ [hs_lit, wrapGenSpan (ExplicitList NoRebindable exps)]
+ -- important to make it NoRebindable
+ -- Or we will go into an infinite loop
; return $ Just $
HSE { hse_ctxt = ExprCtxt e
, hse_exp = wrapGenSpan $ exp_list }
@@ -193,7 +269,7 @@ tcExpand e@(ExplicitList (Just rs_table) exps)
------------------------------------------
--- Do expression statements
+-- Do statements
tcExpand (HsDo _ do_or_lc stmts)
| DoExpr{} <- do_or_lc
@@ -214,66 +290,6 @@ tcExpand (HsDo _ do_or_lc stmts)
-- GHCiStmts are handled completely separate
= return Nothing
-------------------------------------------
--- If
-
--- Nothing <=> rebindable is turned off
--- so we typecheck the HsIf in tcExprNoExpand
-tcExpand (HsIf Nothing _ _ _ )
- = return Nothing
-tcExpand e@(HsIf (Just rs_table) p b1 b2)
- | Just ifThenElseName <- lookup "ifThenElse" rs_table
- = return $ Just $
- HSE { hse_ctxt = ExprCtxt e
- , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2]
- }
- | otherwise
- = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find ifThenElse in rs_table"
- , ppr e ])
-
-------------------------------------------
--- Record dot syntax
-
-tcExpand e@(HsGetField rs_table expr f)
- | Just getFieldName <- lookup "getField" rs_table
- = return $ Just $
- HSE { hse_ctxt = ExprCtxt e
- , hse_exp = wrapGenSpan $ (mkGetField getFieldName expr (fmap (unLoc . dfoLabel) f)) }
- | otherwise
- = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField in rs_table"
- , ppr e ])
-
-tcExpand e@(HsProjection rs_table fs)
- | Just getFieldName <- lookup "getField" rs_table
- , Just circName <- lookup "circ" rs_table
- = return $ Just $
- HSE { hse_ctxt = ExprCtxt e
- , hse_exp = wrapGenSpan $ (mkProjection getFieldName circName $ NE.map (unLoc . dfoLabel) fs) }
- | otherwise
- = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or circ in rs_table"
- , ppr e])
-
-
-tcExpand (RecordUpd Nothing _ _ ) = return Nothing -- until #27160 is fixed
-
-tcExpand e@(RecordUpd (Just rs_table) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us}))
- | Just getFieldName <- lookup "getFieldName" rs_table
- , Just setFieldName <- lookup "setFieldName" rs_table
- = return $ Just $
- HSE { hse_ctxt = ExprCtxt e
- , hse_exp = wrapGenSpan $ mkRecordDotUpd getFieldName setFieldName (L l expr) us }
- | otherwise
- = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or setfield in rs_table"
- , ppr e ])
-
-
-
-------------------------
--- XExpr
--- Expansions are idempotent, XExprs do not expand again
-tcExpand (XExpr (ExpandedThingRn hse))
- = return (Just hse)
-
------------------------------------------
-- Template Haskell Splices
@@ -281,10 +297,11 @@ tcExpand e@(HsUntypedSplice splice_res _)
-- See Note [Looking through Template Haskell splices in splitHsApps]
= do { fun <- getUntypedSpliceBody splice_res
; return $ Just $
- HSE { hse_ctxt = ExprCtxt e
- , hse_exp = wrapGenSpan fun } }
+ HSE { hse_ctxt = ExprCtxt e
+ , hse_exp = wrapGenSpan fun }
+ }
-tcExpand _ = return Nothing
+tcExpand e = return $ tcExpandNoTcM e
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -445,7 +445,7 @@ tcExprNoExpand e@HsQualLit{} _ = pprPanic "tcExpr: HsQualLit" (ppr e)
-- list type, so that's all we need concern ourselves with here. See
-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs]
tcExprNoExpand (ExplicitList x exprs) res_ty
- = assert (isNothing x) $
+ = assert (isNoRebindable x) $
do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedListTy res_ty
; let tc_elt expr = tcCheckPolyExpr expr elt_ty
@@ -540,7 +540,7 @@ tcExprNoExpand (HsCase ctxt scrut matches) res_ty
tcExprNoExpand (HsIf x pred b1 b2) res_ty
-- HsIf in rebindable case would be expanded out so we would not
-- have a Just RebindableSyntaxTable here, only Nothing
- = assert (isNothing x) $
+ = assert (isNoRebindable x) $
do { pred' <- tcCheckMonoExpr pred boolTy
; let res_ty' = adjustExpTypeForCaseBranches res_ty [b1,b2]
; (u1,b1') <- tcCollectingUsage $ tcMonoLExpr b1 res_ty'
@@ -680,7 +680,7 @@ tcExprNoExpand expr@(RecordCon { rcon_con = L loc qcon@(WithUserRdr _ con_name)
orig = OccurrenceOf con_name
-- Record updates via dot syntax are replaced by expanded expressions
--- in the renamer. See Note [Overview of record dot syntax] in
+-- in GHC.Tc.Expand. See Note [Overview of record dot syntax] in
-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
-- and panic otherwise.
-- WIP: To be fixed soon (#27160) expandRecordUpd needs to return HsExpansion and not a separate ds_res_ty
@@ -1644,7 +1644,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
RegularRecUpdFields
{ xRecUpdFields = parents
, recUpdFields = rbnds }
- , rupd_ext = Nothing }
+ , rupd_ext = NoRebindable }
loc = getLocA (head rbnds)
{-
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -1087,7 +1087,7 @@ tcPatToExpr args pat = go pat
go1 (ParPat _ pat) = fmap (HsPar noExtField) (go pat)
go1 (ListPat _ pats)
= do { exprs <- mapM go pats
- ; return $ ExplicitList Nothing exprs }
+ ; return $ ExplicitList NoRebindable exprs }
go1 (TuplePat _ pats box) = do { exprs <- mapM go pats
; return $ ExplicitTuple noExtField
(map (Present noExtField) exprs) box }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ceec1e334fa838664b974883fbb314…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ceec1e334fa838664b974883fbb314…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Move most of the `System.IO` implementation into `base`
by Marge Bot (＠marge-bot) 21 Apr '26
by Marge Bot (＠marge-bot) 21 Apr '26
21 Apr '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
76528cc3 by Wolfgang Jeltsch at 2026-04-20T20:16:25-04:00
Move most of the `System.IO` implementation into `base`
This involves a rewrite of the `combine` helper function to avoid the
use of `last`, which would now be flagged as an error.
Metric Decrease:
LinkableUsage01
T3294
Metric Increase:
T12227
T12707
T5642
- - - - -
27 changed files:
- libraries/base/src/Control/Concurrent.hs
- libraries/base/src/GHC/IO/Handle.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/Text/Printf.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/typecheck/should_compile/T9497a.stderr
- testsuite/tests/typecheck/should_compile/holes.stderr
- testsuite/tests/typecheck/should_compile/holes3.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T9497d.stderr
- testsuite/tests/typecheck/should_run/T9497a-run.stderr
- testsuite/tests/typecheck/should_run/T9497b-run.stderr
- testsuite/tests/typecheck/should_run/T9497c-run.stderr
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug973.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/DefaultSignatures.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/PatternSyns.html
- utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/QuasiExpr.html
- utils/haddock/html-test/ref/Test.html
Changes:
=====================================
libraries/base/src/Control/Concurrent.hs
=====================================
@@ -120,7 +120,7 @@ import GHC.Internal.System.Posix.Types ( Fd )
#if defined(mingw32_HOST_OS)
import GHC.Internal.Foreign.C.Error
import GHC.Internal.Foreign.C.Types
-import GHC.Internal.System.IO
+import System.IO
import GHC.Internal.Data.Functor ( void )
import GHC.Internal.Int ( Int64 )
#else
=====================================
libraries/base/src/GHC/IO/Handle.hs
=====================================
@@ -53,6 +53,7 @@ module GHC.IO.Handle
hGetEcho,
hIsTerminalDevice,
hSetNewlineMode,
+ hGetNewlineMode,
Newline(..),
NewlineMode(..),
nativeNewline,
=====================================
libraries/base/src/Prelude.hs
=====================================
@@ -165,7 +165,7 @@ module Prelude (
) where
import GHC.Internal.Control.Monad
-import GHC.Internal.System.IO
+import System.IO
import GHC.Internal.System.IO.Error
import qualified GHC.Internal.Data.List as List
import GHC.Internal.Data.Either
=====================================
libraries/base/src/System/IO.hs
=====================================
@@ -1,4 +1,5 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP #-}
-- |
--
@@ -184,8 +185,683 @@ module System.IO
nativeNewlineMode
) where
-import GHC.Internal.System.IO
+import GHC.Internal.System.IO (putStrLn, print)
+
+import GHC.Base (Bool (False, True), otherwise, failIO)
+import GHC.Err (errorWithoutStackTrace)
+import GHC.List ((++), reverse, break)
+import GHC.IO (IO, FilePath)
+import GHC.IO.IOMode (IOMode (ReadMode, WriteMode, ReadWriteMode, AppendMode))
+import qualified GHC.Internal.IO.FD as FD
+import GHC.IO.Encoding
+ (
+ TextEncoding,
+ mkTextEncoding,
+ getLocaleEncoding,
+ initLocaleEncoding,
+ utf8,
+ utf8_bom,
+ utf16,
+ utf16be,
+ utf16le,
+ utf32,
+ utf32be,
+ utf32le,
+ latin1,
+ char8
+ )
+import GHC.IO.Handle
+ (
+ Handle,
+ hLookAhead,
+ hFlush,
+ hClose,
+ hSetBinaryMode,
+ hSetEncoding,
+ hSetNewlineMode,
+ hSetEcho,
+ hSetFileSize,
+ hGetEncoding,
+ hGetNewlineMode,
+ hGetEcho,
+ hFileSize,
+ hIsOpen,
+ hIsReadable,
+ hIsSeekable,
+ hIsWritable,
+ hIsTerminalDevice,
+ hIsEOF,
+ hIsClosed,
+ hShow,
+ BufferMode (NoBuffering, LineBuffering, BlockBuffering),
+ hSetBuffering,
+ hGetBuffering,
+ HandlePosn,
+ hSetPosn,
+ hGetPosn,
+ hSeek,
+ hTell,
+ Newline (LF, CRLF),
+ nativeNewline,
+ NewlineMode (NewlineMode, inputNL, outputNL),
+ noNewlineTranslation,
+ nativeNewlineMode,
+ universalNewlineMode,
+ isEOF
+ )
+import GHC.IO.Handle.Text
+ (
+ hPutChar,
+ hPutStr,
+ hPutStrLn,
+ hPutBuf,
+ hPutBufNonBlocking,
+ hGetChar,
+ hGetContents,
+ hGetContents',
+ hGetLine,
+ hGetBuf,
+ hGetBufNonBlocking,
+ hGetBufSome,
+ hWaitForInput
+ )
+import qualified GHC.Internal.IO.Handle.FD as POSIX
+import GHC.IO.StdHandles
+ (
+ openBinaryFile,
+ withBinaryFile,
+ openFile,
+ withFile,
+ stdin,
+ stdout,
+ stderr
+ )
import GHC.Internal.Control.Monad.Fix (fixIO)
+import Control.Monad (return, (>>=))
+import Control.Exception (ioError)
+import Data.Eq ((==))
+import Data.Ord ((<))
+import Data.Bits ((.|.))
+import Data.Function (($), (.))
+import Data.Maybe (Maybe (Nothing, Just))
+import Data.Char (Char)
+import Data.String (String)
+import System.IO.Error (userError)
+import System.Posix.Internals
+ (
+ c_open,
+ o_EXCL,
+ o_BINARY,
+ o_NONBLOCK,
+ o_RDWR,
+ o_NOCTTY,
+ withFilePath
+ )
+import System.Posix.Types (CMode)
+import Text.Read (lex, Read, reads)
+import Text.Show (Show, show)
+import Foreign.C.Types (CInt)
+import Foreign.C.Error (getErrno, errnoToIOError)
+
+#if defined(mingw32_HOST_OS)
+import GHC.Base (undefined, not, (||), fmap)
+import GHC.List (null, any)
+import GHC.Num ((*))
+import GHC.IO (onException)
+import GHC.IO.SubSystem
+import GHC.IO.Windows.Handle (openFileAsTemp)
+import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
+import GHC.IO.Device as IODevice
+import GHC.Internal.Real (fromIntegral)
+import Data.Bits ((.&.))
+import Foreign.C.Types (CUInt (CUInt), CWchar)
+import Foreign.C.String
+import Foreign.Ptr
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils (with)
+import Foreign.Storable
+#else
+import GHC.List (elem, unsnoc)
+import GHC.Num ((+))
+import GHC.IO.Handle (SeekMode (AbsoluteSeek, RelativeSeek, SeekFromEnd))
+import GHC.IORef (atomicModifyIORef'_)
+import Data.Int (Int)
+import Data.IORef (IORef, newIORef)
+import System.IO.Unsafe (unsafePerformIO)
+import System.Posix.Internals (c_getpid, o_CREAT)
+import Foreign.C.Error (Errno, eEXIST)
+#endif
+
+-----------------------------------------------------------------------------
+-- Standard IO
+
+-- | Write a character to the standard output device
+--
+-- 'putChar' is implemented as @'hPutChar' 'stdout'@.
+--
+-- This operation may fail with the same errors as 'hPutChar'.
+--
+-- ==== __Examples__
+--
+-- Note that the following do not put a newline.
+--
+-- >>> putChar 'x'
+-- x
+--
+-- >>> putChar '\0042'
+-- *
+putChar :: Char -> IO ()
+putChar c = hPutChar stdout c
+
+-- | Write a string to the standard output device
+--
+-- 'putStr' is implemented as @'hPutStr' 'stdout'@.
+--
+-- This operation may fail with the same errors, and has the same issues with concurrency, as 'hPutStr'!
+--
+-- ==== __Examples__
+--
+-- Note that the following do not put a newline.
+--
+-- >>> putStr "Hello, World!"
+-- Hello, World!
+--
+-- >>> putStr "\0052\0042\0050"
+-- 4*2
+--
+putStr :: String -> IO ()
+putStr s = hPutStr stdout s
+
+-- | Read a single character from the standard input device.
+--
+-- 'getChar' is implemented as @'hGetChar' 'stdin'@.
+--
+-- This operation may fail with the same errors as 'hGetChar'.
+--
+-- ==== __Examples__
+--
+-- >>> getChar
+-- a'a'
+--
+-- >>> getChar
+-- >
+-- '\n'
+getChar :: IO Char
+getChar = hGetChar stdin
+
+-- | Read a line from the standard input device.
+--
+-- 'getLine' is implemented as @'hGetLine' 'stdin'@.
+--
+-- This operation may fail with the same errors as 'hGetLine'.
+--
+-- ==== __Examples__
+--
+-- >>> getLine
+-- > Hello World!
+-- "Hello World!"
+--
+-- >>> getLine
+-- >
+-- ""
+getLine :: IO String
+getLine = hGetLine stdin
+
+-- | The 'getContents' operation returns all user input as a single string,
+-- which is read lazily as it is needed.
+--
+-- 'getContents' is implemented as @'hGetContents' 'stdin'@.
+--
+-- This operation may fail with the same errors as 'hGetContents'.
+--
+-- ==== __Examples__
+--
+-- >>> getContents >>= putStr
+-- > aaabbbccc :D
+-- aaabbbccc :D
+-- > I hope you have a great day
+-- I hope you have a great day
+-- > ^D
+--
+-- >>> getContents >>= print . length
+-- > abc
+-- > <3
+-- > def ^D
+-- 11
+getContents :: IO String
+getContents = hGetContents stdin
+
+-- | The 'getContents'' operation returns all user input as a single string,
+-- which is fully read before being returned
+--
+-- 'getContents'' is implemented as @'hGetContents'' 'stdin'@.
+--
+-- This operation may fail with the same errors as 'hGetContents''.
+--
+-- ==== __Examples__
+--
+-- >>> getContents' >>= putStr
+-- > aaabbbccc :D
+-- > I hope you have a great day
+-- aaabbbccc :D
+-- I hope you have a great day
+--
+-- >>> getContents' >>= print . length
+-- > abc
+-- > <3
+-- > def ^D
+-- 11
+--
+-- @since base-4.15.0.0
+getContents' :: IO String
+getContents' = hGetContents' stdin
+
+-- | @'interact' f@ takes the entire input from 'stdin' and applies @f@ to it.
+-- The resulting string is written to the 'stdout' device.
+--
+-- Note that this operation is lazy, which allows to produce output
+-- even before all input has been consumed.
+--
+-- This operation may fail with the same errors as 'getContents' and 'putStr'.
+--
+-- If it doesn't produce output the buffering settings may not be
+-- correct, use ^D (ctrl+D) to close stdin which forces
+-- the buffer to be consumed.
+--
+-- You may wish to set the buffering style appropriate to your program's
+-- needs before using this function, for example:
+--
+-- @
+-- main :: IO ()
+-- main = do
+-- hSetBuffering stdin LineBuffering
+-- hSetBuffering stdout NoBuffering
+-- interact (concatMap (\str -> str ++ str) . L.lines)
+-- @
+--
+-- ==== __Examples__
+--
+-- >>> interact (\str -> str ++ str)
+-- > hi :)
+-- hi :)
+-- > ^D
+-- hi :)
+--
+-- >>> interact (const ":D")
+-- :D
+--
+-- >>> interact (show . words)
+-- > hello world!
+-- > I hope you have a great day
+-- > ^D
+-- ["hello","world!","I","hope","you","have","a","great","day"]
+interact :: (String -> String) -> IO ()
+interact f = do s <- getContents
+ putStr (f s)
+
+-- | The 'readFile' function reads a file and
+-- returns the contents of the file as a string.
+--
+-- The file is read lazily, on demand, as with 'getContents'.
+--
+-- This operation may fail with the same errors as 'hGetContents' and 'openFile'.
+--
+-- ==== __Examples__
+--
+-- >>> readFile "~/hello_world"
+-- "Greetings!"
+--
+-- >>> take 5 <$> readFile "/dev/zero"
+-- "\NUL\NUL\NUL\NUL\NUL"
+readFile :: FilePath -> IO String
+readFile name = openFile name ReadMode >>= hGetContents
+
+-- | The 'readFile'' function reads a file and
+-- returns the contents of the file as a string.
+--
+-- This is identical to 'readFile', but the file is fully read before being returned,
+-- as with 'getContents''.
+--
+-- @since base-4.15.0.0
+readFile' :: FilePath -> IO String
+-- There's a bit of overkill here—both withFile and
+-- hGetContents' will close the file in the end.
+readFile' name = withFile name ReadMode hGetContents'
+
+-- | The computation @'writeFile' file str@ function writes the string @str@,
+-- to the file @file@.
+--
+-- This operation may fail with the same errors as 'hPutStr' and 'withFile'.
+--
+-- ==== __Examples__
+--
+-- >>> writeFile "hello" "world" >> readFile "hello"
+-- "world"
+--
+-- >>> writeFile "~/" "D:"
+-- *** Exception: ~/: withFile: inappropriate type (Is a directory)
+writeFile :: FilePath -> String -> IO ()
+writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt)
+
+-- | The computation @'appendFile' file str@ function appends the string @str@,
+-- to the file @file@.
+--
+-- Note that 'writeFile' and 'appendFile' write a literal string
+-- to a file. To write a value of any printable type, as with 'print',
+-- use the 'show' function to convert the value to a string first.
+--
+-- This operation may fail with the same errors as 'hPutStr' and 'withFile'.
+--
+-- ==== __Examples__
+--
+-- The following example could be more efficently written by acquiring a handle
+-- instead with 'openFile' and using the computations capable of writing to handles
+-- such as 'hPutStr'.
+--
+-- >>> let fn = "hello_world"
+-- >>> in writeFile fn "hello" >> appendFile fn " world!" >> (readFile fn >>= putStrLn)
+-- "hello world!"
+--
+-- >>> let fn = "foo"; output = readFile' fn >>= putStrLn
+-- >>> in output >> appendFile fn (show [1,2,3]) >> output
+-- this is what's in the file
+-- this is what's in the file[1,2,3]
+appendFile :: FilePath -> String -> IO ()
+appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt)
+
+-- | The 'readLn' function combines 'getLine' and 'readIO'.
+--
+-- This operation may fail with the same errors as 'getLine' and 'readIO'.
+--
+-- ==== __Examples__
+--
+-- >>> fmap (+ 5) readLn
+-- > 25
+-- 30
+--
+-- >>> readLn :: IO String
+-- > this is not a string literal
+-- *** Exception: user error (Prelude.readIO: no parse)
+readLn :: Read a => IO a
+readLn = getLine >>= readIO
+
+-- | The 'readIO' function is similar to 'read' except that it signals
+-- parse failure to the 'IO' monad instead of terminating the program.
+--
+-- This operation may fail with:
+--
+-- * 'GHC.Internal.System.IO.Error.isUserError' if there is no unambiguous parse.
+--
+-- ==== __Examples__
+--
+-- >>> fmap (+ 1) (readIO "1")
+-- 2
+--
+-- >>> readIO "not quite ()" :: IO ()
+-- *** Exception: user error (Prelude.readIO: no parse)
+readIO :: Read a => String -> IO a
+readIO s = case (do { (x,t) <- reads s ;
+ ("","") <- lex t ;
+ return x }) of
+ [x] -> return x
+ [] -> ioError (userError "Prelude.readIO: no parse")
+ _ -> ioError (userError "Prelude.readIO: ambiguous parse")
+
+-- | The encoding of the current locale.
+--
+-- This is the initial locale encoding: if it has been subsequently changed by
+-- 'GHC.Internal.IO.Encoding.setLocaleEncoding' this value will not reflect that change.
+localeEncoding :: TextEncoding
+localeEncoding = initLocaleEncoding
+
+-- | Computation 'hReady' @hdl@ indicates whether at least one item is
+-- available for input from handle @hdl@.
+--
+-- This operation may fail with:
+--
+-- * 'GHC.Internal.System.IO.Error.isEOFError' if the end of file has been reached.
+hReady :: Handle -> IO Bool
+hReady h = hWaitForInput h 0
+
+-- | Computation 'hPrint' @hdl t@ writes the string representation of @t@
+-- given by the 'show' function to the file or channel managed by @hdl@
+-- and appends a newline.
+--
+-- This operation may fail with the same errors as 'hPutStrLn'
+--
+-- ==== __Examples__
+--
+-- >>> hPrint stdout [1,2,3]
+-- [1,2,3]
+--
+-- >>> hPrint stdin [4,5,6]
+-- *** Exception: <stdin>: hPutStr: illegal operation (handle is not open for writing)
+hPrint :: Show a => Handle -> a -> IO ()
+hPrint hdl = hPutStrLn hdl . show
+
+-- | The function creates a temporary file in ReadWrite mode.
+-- The created file isn\'t deleted automatically, so you need to delete it manually.
+--
+-- The file is created with permissions such that only the current
+-- user can read\/write it.
+--
+-- With some exceptions (see below), the file will be created securely
+-- in the sense that an attacker should not be able to cause
+-- openTempFile to overwrite another file on the filesystem using your
+-- credentials, by putting symbolic links (on Unix) in the place where
+-- the temporary file is to be created. On Unix the @O_CREAT@ and
+-- @O_EXCL@ flags are used to prevent this attack, but note that
+-- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you
+-- rely on this behaviour it is best to use local filesystems only.
+openTempFile :: FilePath -- ^ Directory in which to create the file
+ -> String -- ^ File name template. If the template is \"foo.ext\" then
+ -- the created file will be \"fooXXX.ext\" where XXX is some
+ -- random number. Note that this should not contain any path
+ -- separator characters. On Windows, the template prefix may
+ -- be truncated to 3 chars, e.g. \"foobar.ext\" will be
+ -- \"fooXXX.ext\".
+ -> IO (FilePath, Handle)
+openTempFile tmp_dir template
+ = openTempFile' "openTempFile" tmp_dir template False 0o600
+
+-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
+openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openBinaryTempFile tmp_dir template
+ = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600
+
+-- | Like 'openTempFile', but uses the default file permissions
+openTempFileWithDefaultPermissions :: FilePath -> String
+ -> IO (FilePath, Handle)
+openTempFileWithDefaultPermissions tmp_dir template
+ = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666
+
+-- | Like 'openBinaryTempFile', but uses the default file permissions
+openBinaryTempFileWithDefaultPermissions :: FilePath -> String
+ -> IO (FilePath, Handle)
+openBinaryTempFileWithDefaultPermissions tmp_dir template
+ = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666
+
+openTempFile' :: String -> FilePath -> String -> Bool -> CMode
+ -> IO (FilePath, Handle)
+openTempFile' loc tmp_dir template binary mode
+ | pathSeparator template
+ = failIO $ "openTempFile': Template string must not contain path separator characters: "++template
+ | otherwise = findTempName
+ where
+ -- We split off the last extension, so we can use .foo.ext files
+ -- for temporary files (hidden on Unix OSes). Unfortunately we're
+ -- below filepath in the hierarchy here.
+ (prefix, suffix) =
+ case break (== '.') $ reverse template of
+ -- First case: template contains no '.'s. Just re-reverse it.
+ (rev_suffix, "") -> (reverse rev_suffix, "")
+ -- Second case: template contains at least one '.'. Strip the
+ -- dot from the prefix and prepend it to the suffix (if we don't
+ -- do this, the unique number will get added after the '.' and
+ -- thus be part of the extension, which is wrong.)
+ (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
+ -- Otherwise, something is wrong, because (break (== '.')) should
+ -- always return a pair with either the empty string or a string
+ -- beginning with '.' as the second component.
+ _ -> errorWithoutStackTrace "bug in GHC.Internal.System.IO.openTempFile"
+#if defined(mingw32_HOST_OS)
+ findTempName = findTempNamePosix <!> findTempNameWinIO
+
+ findTempNameWinIO = do
+ let label = if null prefix then "ghc" else prefix
+ withCWString tmp_dir $ \c_tmp_dir ->
+ withCWString label $ \c_template ->
+ withCWString suffix $ \c_suffix ->
+ with nullPtr $ \c_ptr -> do
+ res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix c_ptr
+ if not res
+ then do errno <- getErrno
+ ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
+ else do c_p <- peek c_ptr
+ filename <- peekCWString c_p
+ free c_p
+ let flags = fromIntegral mode .&. o_EXCL
+ handleResultsWinIO filename (flags == o_EXCL)
+
+ findTempNamePosix = do
+ let label = if null prefix then "ghc" else prefix
+ withCWString tmp_dir $ \c_tmp_dir ->
+ withCWString label $ \c_template ->
+ withCWString suffix $ \c_suffix ->
+ allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do
+ res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0
+ c_str
+ if not res
+ then do errno <- getErrno
+ ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
+ else do filename <- peekCWString c_str
+ handleResultsPosix filename
+
+ handleResultsPosix filename = do
+ let oflags1 = rw_flags .|. o_EXCL
+ binary_flags
+ | binary = o_BINARY
+ | otherwise = 0
+ oflags = oflags1 .|. binary_flags
+ fd <- withFilePath filename $ \ f -> c_open f oflags mode
+ case fd < 0 of
+ True -> do errno <- getErrno
+ ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
+ False ->
+ do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}
+ False{-is_socket-}
+ True{-is_nonblock-}
+
+ enc <- getLocaleEncoding
+ h <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode
+ False{-set non-block-} (Just enc)
+
+ return (filename, h)
+
+ handleResultsWinIO filename excl = do
+ (hwnd, hwnd_type) <- openFileAsTemp filename True excl
+ mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding
+
+ -- then use it to make a Handle
+ h <- mkHandleFromHANDLE hwnd hwnd_type filename ReadWriteMode mb_codec
+ `onException` IODevice.close hwnd
+ return (filename, h)
+
+foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo
+ :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool
+
+foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo
+ :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool
+
+pathSeparator :: String -> Bool
+pathSeparator template = any (\x-> x == '/' || x == '\\') template
+
+output_flags = std_flags
+#else /* else mingw32_HOST_OS */
+ findTempName = do
+ rs <- rand_string
+ let filename = prefix ++ rs ++ suffix
+ filepath = tmp_dir `combine` filename
+ r <- openNewFile filepath binary mode
+ case r of
+ FileExists -> findTempName
+ OpenNewError errno -> ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
+ NewFileCreated fd -> do
+ (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}
+ False{-is_socket-}
+ True{-is_nonblock-}
+
+ enc <- getLocaleEncoding
+ h <- POSIX.mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc)
+
+ return (filepath, h)
+
+ where
+ {-
+ The following code is inspired by code from 'System.FilePath', since
+ that code is not available here.
+ -}
+ combine path1 []
+ = path1
+ combine path1 path2
+ = case unsnoc path1 of
+ Nothing
+ -> path2
+ Just (_, path1Last)
+ | pathSeparator [path1Last]
+ -> path1 ++ path2
+ | otherwise
+ -> path1 ++ [pathSeparatorChar] ++ path2
+
+tempCounter :: IORef Int
+tempCounter = unsafePerformIO $ newIORef 0
+{-# NOINLINE tempCounter #-}
+
+-- build large digit-alike number
+rand_string :: IO String
+rand_string = do
+ r1 <- c_getpid
+ (r2, _) <- atomicModifyIORef'_ tempCounter (+1)
+ return $ show r1 ++ "-" ++ show r2
+
+data OpenNewFileResult
+ = NewFileCreated CInt
+ | FileExists
+ | OpenNewError Errno
+
+openNewFile :: FilePath -> Bool -> CMode -> IO OpenNewFileResult
+openNewFile filepath binary mode = do
+ let oflags1 = rw_flags .|. o_EXCL
+
+ binary_flags
+ | binary = o_BINARY
+ | otherwise = 0
+
+ oflags = oflags1 .|. binary_flags
+ fd <- withFilePath filepath $ \ f ->
+ c_open f oflags mode
+ if fd < 0
+ then do
+ errno <- getErrno
+ case errno of
+ _ | errno == eEXIST -> return FileExists
+ _ -> return (OpenNewError errno)
+ else return (NewFileCreated fd)
+
+-- XXX Should use filepath library
+pathSeparatorChar :: Char
+pathSeparatorChar = '/'
+
+pathSeparator :: String -> Bool
+pathSeparator template = pathSeparatorChar `elem` template
+
+output_flags = std_flags .|. o_CREAT
+#endif /* mingw32_HOST_OS */
+
+-- XXX Copied from GHC.Handle
+std_flags, output_flags, rw_flags :: CInt
+std_flags = o_NONBLOCK .|. o_NOCTTY
+rw_flags = output_flags .|. o_RDWR
-- $locking
-- Implementations should enforce as far as possible, at least locally to the
=====================================
libraries/base/src/Text/Printf.hs
=====================================
@@ -99,7 +99,7 @@ import GHC.Internal.Data.List (stripPrefix)
import GHC.Internal.Word
import GHC.Internal.Numeric
import GHC.Internal.Numeric.Natural
-import GHC.Internal.System.IO
+import System.IO
-- $setup
-- >>> import Prelude
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO.hs
=====================================
@@ -1,6 +1,4 @@
{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-}
-{-# OPTIONS_GHC -Wno-x-partial #-}
-----------------------------------------------------------------------------
-- |
@@ -16,293 +14,13 @@
--
-----------------------------------------------------------------------------
-module GHC.Internal.System.IO (
- -- * The IO monad
+module GHC.Internal.System.IO (putStrLn, print) where
- IO,
-
- -- * Files and handles
-
- FilePath,
-
- Handle, -- abstract, instance of: Eq, Show.
-
- -- | GHC note: a 'Handle' will be automatically closed when the garbage
- -- collector detects that it has become unreferenced by the program.
- -- However, relying on this behaviour is not generally recommended:
- -- the garbage collector is unpredictable. If possible, use
- -- an explicit 'hClose' to close 'Handle's when they are no longer
- -- required. GHC does not currently attempt to free up file
- -- descriptors when they have run out, it is your responsibility to
- -- ensure that this doesn't happen.
-
- -- ** Standard handles
-
- -- | Three handles are allocated during program initialisation,
- -- and are initially open.
-
- stdin, stdout, stderr,
-
- -- * Opening and closing files
-
- -- ** Opening files
-
- withFile,
- openFile,
- IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
-
- -- ** Closing files
-
- hClose,
-
- -- ** Special cases
-
- -- | These functions are also exported by the "Prelude".
-
- readFile,
- readFile',
- writeFile,
- appendFile,
-
- -- * Operations on handles
-
- -- ** Determining and changing the size of a file
-
- hFileSize,
- hSetFileSize,
-
- -- ** Detecting the end of input
-
- hIsEOF,
- isEOF,
-
- -- ** Buffering operations
-
- BufferMode(NoBuffering,LineBuffering,BlockBuffering),
- hSetBuffering,
- hGetBuffering,
- hFlush,
-
- -- ** Repositioning handles
-
- hGetPosn,
- hSetPosn,
- HandlePosn, -- abstract, instance of: Eq, Show.
-
- hSeek,
- SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
- hTell,
-
- -- ** Handle properties
-
- hIsOpen, hIsClosed,
- hIsReadable, hIsWritable,
- hIsSeekable,
-
- -- ** Terminal operations (not portable: GHC only)
-
- hIsTerminalDevice,
-
- hSetEcho,
- hGetEcho,
-
- -- ** Showing handle state (not portable: GHC only)
-
- hShow,
-
- -- * Text input and output
-
- -- ** Text input
-
- hWaitForInput,
- hReady,
- hGetChar,
- hGetLine,
- hLookAhead,
- hGetContents,
- hGetContents',
-
- -- ** Text output
-
- hPutChar,
- hPutStr,
- hPutStrLn,
- hPrint,
-
- -- ** Special cases for standard input and output
-
- -- | These functions are also exported by the "Prelude".
-
- interact,
- putChar,
- putStr,
- putStrLn,
- print,
- getChar,
- getLine,
- getContents,
- getContents',
- readIO,
- readLn,
-
- -- * Binary input and output
-
- withBinaryFile,
- openBinaryFile,
- hSetBinaryMode,
- hPutBuf,
- hGetBuf,
- hGetBufSome,
- hPutBufNonBlocking,
- hGetBufNonBlocking,
-
- -- * Temporary files
-
- openTempFile,
- openBinaryTempFile,
- openTempFileWithDefaultPermissions,
- openBinaryTempFileWithDefaultPermissions,
-
- -- * Unicode encoding\/decoding
-
- -- | A text-mode 'Handle' has an associated 'TextEncoding', which
- -- is used to decode bytes into Unicode characters when reading,
- -- and encode Unicode characters into bytes when writing.
- --
- -- The default 'TextEncoding' is the same as the default encoding
- -- on your system, which is also available as 'localeEncoding'.
- -- (GHC note: on Windows, we currently do not support double-byte
- -- encodings; if the console\'s code page is unsupported, then
- -- 'localeEncoding' will be 'latin1'.)
- --
- -- Encoding and decoding errors are always detected and reported,
- -- except during lazy I/O ('hGetContents', 'getContents', and
- -- 'readFile'), where a decoding error merely results in
- -- termination of the character stream, as with other I/O errors.
-
- hSetEncoding,
- hGetEncoding,
-
- -- ** Unicode encodings
- TextEncoding,
- latin1,
- utf8, utf8_bom,
- utf16, utf16le, utf16be,
- utf32, utf32le, utf32be,
- localeEncoding,
- char8,
- mkTextEncoding,
-
- -- * Newline conversion
-
- -- | In Haskell, a newline is always represented by the character
- -- @\'\\n\'@. However, in files and external character streams, a
- -- newline may be represented by another character sequence, such
- -- as @\'\\r\\n\'@.
- --
- -- A text-mode 'Handle' has an associated 'NewlineMode' that
- -- specifies how to translate newline characters. The
- -- 'NewlineMode' specifies the input and output translation
- -- separately, so that for instance you can translate @\'\\r\\n\'@
- -- to @\'\\n\'@ on input, but leave newlines as @\'\\n\'@ on output.
- --
- -- The default 'NewlineMode' for a 'Handle' is
- -- 'nativeNewlineMode', which does no translation on Unix systems,
- -- but translates @\'\\r\\n\'@ to @\'\\n\'@ and back on Windows.
- --
- -- Binary-mode 'Handle's do no newline translation at all.
- --
- hSetNewlineMode,
- hGetNewlineMode,
- Newline(..), nativeNewline,
- NewlineMode(..),
- noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
- ) where
-
-import GHC.Internal.Control.Exception.Base
-
-import GHC.Internal.Classes (Eq(..), Ord(..))
-import GHC.Internal.Data.Bits
-import GHC.Internal.Data.Maybe
-import GHC.Internal.Err (errorWithoutStackTrace)
-import GHC.Internal.Foreign.C.Error
-#if defined(mingw32_HOST_OS)
-import GHC.Internal.Base (fmap)
-import GHC.Internal.Classes (not, (||))
-import GHC.Internal.Err (undefined)
-import GHC.Internal.Foreign.C.String
-import GHC.Internal.Foreign.Ptr
-import GHC.Internal.Foreign.Marshal.Alloc
-import GHC.Internal.Foreign.Marshal.Utils (with)
-import GHC.Internal.Foreign.Storable
-import GHC.Internal.IO.SubSystem
-import GHC.Internal.IO.Windows.Handle (openFileAsTemp)
-import GHC.Internal.IO.Handle.Windows (mkHandleFromHANDLE)
-import GHC.Internal.IO.Device as IODevice
-import GHC.Internal.Real (fromIntegral)
-#endif
-import GHC.Internal.Foreign.C.Types
-import GHC.Internal.System.Posix.Internals
-import GHC.Internal.System.Posix.Types
-
-import GHC.Internal.Base (String, failIO, otherwise, return, ($), (.), (>>=))
-import GHC.Internal.List
-#if !defined(mingw32_HOST_OS)
-import GHC.Internal.IORef
-import GHC.Internal.Types (Int)
-#endif
-import GHC.Internal.Num
-import GHC.Internal.IO hiding ( bracket, onException )
-import GHC.Internal.IO.IOMode
-import qualified GHC.Internal.IO.FD as FD
-import GHC.Internal.IO.Handle
-import qualified GHC.Internal.IO.Handle.FD as POSIX
-import GHC.Internal.IO.Handle.Text ( hGetBufSome, hPutStrLn )
-import GHC.Internal.IO.Exception ( userError )
-import GHC.Internal.IO.Encoding
-import GHC.Internal.Text.Read
-import GHC.Internal.IO.StdHandles
-import GHC.Internal.Show
-import GHC.Internal.Types (Bool(..), Char)
------------------------------------------------------------------------------
--- Standard IO
-
--- | Write a character to the standard output device
---
--- 'putChar' is implemented as @'hPutChar' 'stdout'@.
---
--- This operation may fail with the same errors as 'hPutChar'.
---
--- ==== __Examples__
---
--- Note that the following do not put a newline.
---
--- >>> putChar 'x'
--- x
---
--- >>> putChar '\0042'
--- *
-putChar :: Char -> IO ()
-putChar c = hPutChar stdout c
-
--- | Write a string to the standard output device
---
--- 'putStr' is implemented as @'hPutStr' 'stdout'@.
---
--- This operation may fail with the same errors, and has the same issues with concurrency, as 'hPutStr'!
---
--- ==== __Examples__
---
--- Note that the following do not put a newline.
---
--- >>> putStr "Hello, World!"
--- Hello, World!
---
--- >>> putStr "\0052\0042\0050"
--- 4*2
---
-putStr :: String -> IO ()
-putStr s = hPutStr stdout s
+import GHC.Internal.Base (String)
+import GHC.Internal.IO (IO)
+import GHC.Internal.IO.Handle.Text (hPutStrLn)
+import GHC.Internal.IO.StdHandles (stdout)
+import GHC.Internal.Show (Show, show)
-- | The same as 'putStr', but adds a newline character.
--
@@ -339,485 +57,3 @@ putStrLn s = hPutStrLn stdout s
-- [(0,1),(1,2),(2,4),(3,8),(4,16),(5,32),(6,64),(7,128),(8,256)]
print :: Show a => a -> IO ()
print x = putStrLn (show x)
-
--- | Read a single character from the standard input device.
---
--- 'getChar' is implemented as @'hGetChar' 'stdin'@.
---
--- This operation may fail with the same errors as 'hGetChar'.
---
--- ==== __Examples__
---
--- >>> getChar
--- a'a'
---
--- >>> getChar
--- >
--- '\n'
-getChar :: IO Char
-getChar = hGetChar stdin
-
--- | Read a line from the standard input device.
---
--- 'getLine' is implemented as @'hGetLine' 'stdin'@.
---
--- This operation may fail with the same errors as 'hGetLine'.
---
--- ==== __Examples__
---
--- >>> getLine
--- > Hello World!
--- "Hello World!"
---
--- >>> getLine
--- >
--- ""
-getLine :: IO String
-getLine = hGetLine stdin
-
--- | The 'getContents' operation returns all user input as a single string,
--- which is read lazily as it is needed.
---
--- 'getContents' is implemented as @'hGetContents' 'stdin'@.
---
--- This operation may fail with the same errors as 'hGetContents'.
---
--- ==== __Examples__
---
--- >>> getContents >>= putStr
--- > aaabbbccc :D
--- aaabbbccc :D
--- > I hope you have a great day
--- I hope you have a great day
--- > ^D
---
--- >>> getContents >>= print . length
--- > abc
--- > <3
--- > def ^D
--- 11
-getContents :: IO String
-getContents = hGetContents stdin
-
--- | The 'getContents'' operation returns all user input as a single string,
--- which is fully read before being returned
---
--- 'getContents'' is implemented as @'hGetContents'' 'stdin'@.
---
--- This operation may fail with the same errors as 'hGetContents''.
---
--- ==== __Examples__
---
--- >>> getContents' >>= putStr
--- > aaabbbccc :D
--- > I hope you have a great day
--- aaabbbccc :D
--- I hope you have a great day
---
--- >>> getContents' >>= print . length
--- > abc
--- > <3
--- > def ^D
--- 11
---
--- @since base-4.15.0.0
-getContents' :: IO String
-getContents' = hGetContents' stdin
-
--- | @'interact' f@ takes the entire input from 'stdin' and applies @f@ to it.
--- The resulting string is written to the 'stdout' device.
---
--- Note that this operation is lazy, which allows to produce output
--- even before all input has been consumed.
---
--- This operation may fail with the same errors as 'getContents' and 'putStr'.
---
--- If it doesn't produce output the buffering settings may not be
--- correct, use ^D (ctrl+D) to close stdin which forces
--- the buffer to be consumed.
---
--- You may wish to set the buffering style appropriate to your program's
--- needs before using this function, for example:
---
--- @
--- main :: IO ()
--- main = do
--- hSetBuffering stdin LineBuffering
--- hSetBuffering stdout NoBuffering
--- interact (concatMap (\str -> str ++ str) . L.lines)
--- @
---
--- ==== __Examples__
---
--- >>> interact (\str -> str ++ str)
--- > hi :)
--- hi :)
--- > ^D
--- hi :)
---
--- >>> interact (const ":D")
--- :D
---
--- >>> interact (show . words)
--- > hello world!
--- > I hope you have a great day
--- > ^D
--- ["hello","world!","I","hope","you","have","a","great","day"]
-interact :: (String -> String) -> IO ()
-interact f = do s <- getContents
- putStr (f s)
-
--- | The 'readFile' function reads a file and
--- returns the contents of the file as a string.
---
--- The file is read lazily, on demand, as with 'getContents'.
---
--- This operation may fail with the same errors as 'hGetContents' and 'openFile'.
---
--- ==== __Examples__
---
--- >>> readFile "~/hello_world"
--- "Greetings!"
---
--- >>> take 5 <$> readFile "/dev/zero"
--- "\NUL\NUL\NUL\NUL\NUL"
-readFile :: FilePath -> IO String
-readFile name = openFile name ReadMode >>= hGetContents
-
--- | The 'readFile'' function reads a file and
--- returns the contents of the file as a string.
---
--- This is identical to 'readFile', but the file is fully read before being returned,
--- as with 'getContents''.
---
--- @since base-4.15.0.0
-readFile' :: FilePath -> IO String
--- There's a bit of overkill here—both withFile and
--- hGetContents' will close the file in the end.
-readFile' name = withFile name ReadMode hGetContents'
-
--- | The computation @'writeFile' file str@ function writes the string @str@,
--- to the file @file@.
---
--- This operation may fail with the same errors as 'hPutStr' and 'withFile'.
---
--- ==== __Examples__
---
--- >>> writeFile "hello" "world" >> readFile "hello"
--- "world"
---
--- >>> writeFile "~/" "D:"
--- *** Exception: ~/: withFile: inappropriate type (Is a directory)
-writeFile :: FilePath -> String -> IO ()
-writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt)
-
--- | The computation @'appendFile' file str@ function appends the string @str@,
--- to the file @file@.
---
--- Note that 'writeFile' and 'appendFile' write a literal string
--- to a file. To write a value of any printable type, as with 'print',
--- use the 'show' function to convert the value to a string first.
---
--- This operation may fail with the same errors as 'hPutStr' and 'withFile'.
---
--- ==== __Examples__
---
--- The following example could be more efficently written by acquiring a handle
--- instead with 'openFile' and using the computations capable of writing to handles
--- such as 'hPutStr'.
---
--- >>> let fn = "hello_world"
--- >>> in writeFile fn "hello" >> appendFile fn " world!" >> (readFile fn >>= putStrLn)
--- "hello world!"
---
--- >>> let fn = "foo"; output = readFile' fn >>= putStrLn
--- >>> in output >> appendFile fn (show [1,2,3]) >> output
--- this is what's in the file
--- this is what's in the file[1,2,3]
-appendFile :: FilePath -> String -> IO ()
-appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt)
-
--- | The 'readLn' function combines 'getLine' and 'readIO'.
---
--- This operation may fail with the same errors as 'getLine' and 'readIO'.
---
--- ==== __Examples__
---
--- >>> fmap (+ 5) readLn
--- > 25
--- 30
---
--- >>> readLn :: IO String
--- > this is not a string literal
--- *** Exception: user error (Prelude.readIO: no parse)
-readLn :: Read a => IO a
-readLn = getLine >>= readIO
-
--- | The 'readIO' function is similar to 'read' except that it signals
--- parse failure to the 'IO' monad instead of terminating the program.
---
--- This operation may fail with:
---
--- * 'GHC.Internal.System.IO.Error.isUserError' if there is no unambiguous parse.
---
--- ==== __Examples__
---
--- >>> fmap (+ 1) (readIO "1")
--- 2
---
--- >>> readIO "not quite ()" :: IO ()
--- *** Exception: user error (Prelude.readIO: no parse)
-readIO :: Read a => String -> IO a
-readIO s = case (do { (x,t) <- reads s ;
- ("","") <- lex t ;
- return x }) of
- [x] -> return x
- [] -> ioError (userError "Prelude.readIO: no parse")
- _ -> ioError (userError "Prelude.readIO: ambiguous parse")
-
--- | The encoding of the current locale.
---
--- This is the initial locale encoding: if it has been subsequently changed by
--- 'GHC.Internal.IO.Encoding.setLocaleEncoding' this value will not reflect that change.
-localeEncoding :: TextEncoding
-localeEncoding = initLocaleEncoding
-
--- | Computation 'hReady' @hdl@ indicates whether at least one item is
--- available for input from handle @hdl@.
---
--- This operation may fail with:
---
--- * 'GHC.Internal.System.IO.Error.isEOFError' if the end of file has been reached.
-hReady :: Handle -> IO Bool
-hReady h = hWaitForInput h 0
-
--- | Computation 'hPrint' @hdl t@ writes the string representation of @t@
--- given by the 'show' function to the file or channel managed by @hdl@
--- and appends a newline.
---
--- This operation may fail with the same errors as 'hPutStrLn'
---
--- ==== __Examples__
---
--- >>> hPrint stdout [1,2,3]
--- [1,2,3]
---
--- >>> hPrint stdin [4,5,6]
--- *** Exception: <stdin>: hPutStr: illegal operation (handle is not open for writing)
-hPrint :: Show a => Handle -> a -> IO ()
-hPrint hdl = hPutStrLn hdl . show
-
--- | The function creates a temporary file in ReadWrite mode.
--- The created file isn\'t deleted automatically, so you need to delete it manually.
---
--- The file is created with permissions such that only the current
--- user can read\/write it.
---
--- With some exceptions (see below), the file will be created securely
--- in the sense that an attacker should not be able to cause
--- openTempFile to overwrite another file on the filesystem using your
--- credentials, by putting symbolic links (on Unix) in the place where
--- the temporary file is to be created. On Unix the @O_CREAT@ and
--- @O_EXCL@ flags are used to prevent this attack, but note that
--- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you
--- rely on this behaviour it is best to use local filesystems only.
-openTempFile :: FilePath -- ^ Directory in which to create the file
- -> String -- ^ File name template. If the template is \"foo.ext\" then
- -- the created file will be \"fooXXX.ext\" where XXX is some
- -- random number. Note that this should not contain any path
- -- separator characters. On Windows, the template prefix may
- -- be truncated to 3 chars, e.g. \"foobar.ext\" will be
- -- \"fooXXX.ext\".
- -> IO (FilePath, Handle)
-openTempFile tmp_dir template
- = openTempFile' "openTempFile" tmp_dir template False 0o600
-
--- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
-openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openBinaryTempFile tmp_dir template
- = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600
-
--- | Like 'openTempFile', but uses the default file permissions
-openTempFileWithDefaultPermissions :: FilePath -> String
- -> IO (FilePath, Handle)
-openTempFileWithDefaultPermissions tmp_dir template
- = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666
-
--- | Like 'openBinaryTempFile', but uses the default file permissions
-openBinaryTempFileWithDefaultPermissions :: FilePath -> String
- -> IO (FilePath, Handle)
-openBinaryTempFileWithDefaultPermissions tmp_dir template
- = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666
-
-openTempFile' :: String -> FilePath -> String -> Bool -> CMode
- -> IO (FilePath, Handle)
-openTempFile' loc tmp_dir template binary mode
- | pathSeparator template
- = failIO $ "openTempFile': Template string must not contain path separator characters: "++template
- | otherwise = findTempName
- where
- -- We split off the last extension, so we can use .foo.ext files
- -- for temporary files (hidden on Unix OSes). Unfortunately we're
- -- below filepath in the hierarchy here.
- (prefix, suffix) =
- case break (== '.') $ reverse template of
- -- First case: template contains no '.'s. Just re-reverse it.
- (rev_suffix, "") -> (reverse rev_suffix, "")
- -- Second case: template contains at least one '.'. Strip the
- -- dot from the prefix and prepend it to the suffix (if we don't
- -- do this, the unique number will get added after the '.' and
- -- thus be part of the extension, which is wrong.)
- (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
- -- Otherwise, something is wrong, because (break (== '.')) should
- -- always return a pair with either the empty string or a string
- -- beginning with '.' as the second component.
- _ -> errorWithoutStackTrace "bug in GHC.Internal.System.IO.openTempFile"
-#if defined(mingw32_HOST_OS)
- findTempName = findTempNamePosix <!> findTempNameWinIO
-
- findTempNameWinIO = do
- let label = if null prefix then "ghc" else prefix
- withCWString tmp_dir $ \c_tmp_dir ->
- withCWString label $ \c_template ->
- withCWString suffix $ \c_suffix ->
- with nullPtr $ \c_ptr -> do
- res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix c_ptr
- if not res
- then do errno <- getErrno
- ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
- else do c_p <- peek c_ptr
- filename <- peekCWString c_p
- free c_p
- let flags = fromIntegral mode .&. o_EXCL
- handleResultsWinIO filename (flags == o_EXCL)
-
- findTempNamePosix = do
- let label = if null prefix then "ghc" else prefix
- withCWString tmp_dir $ \c_tmp_dir ->
- withCWString label $ \c_template ->
- withCWString suffix $ \c_suffix ->
- allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do
- res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0
- c_str
- if not res
- then do errno <- getErrno
- ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
- else do filename <- peekCWString c_str
- handleResultsPosix filename
-
- handleResultsPosix filename = do
- let oflags1 = rw_flags .|. o_EXCL
- binary_flags
- | binary = o_BINARY
- | otherwise = 0
- oflags = oflags1 .|. binary_flags
- fd <- withFilePath filename $ \ f -> c_open f oflags mode
- case fd < 0 of
- True -> do errno <- getErrno
- ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
- False ->
- do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}
- False{-is_socket-}
- True{-is_nonblock-}
-
- enc <- getLocaleEncoding
- h <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode
- False{-set non-block-} (Just enc)
-
- return (filename, h)
-
- handleResultsWinIO filename excl = do
- (hwnd, hwnd_type) <- openFileAsTemp filename True excl
- mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding
-
- -- then use it to make a Handle
- h <- mkHandleFromHANDLE hwnd hwnd_type filename ReadWriteMode mb_codec
- `onException` IODevice.close hwnd
- return (filename, h)
-
-foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo
- :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool
-
-foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo
- :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool
-
-pathSeparator :: String -> Bool
-pathSeparator template = any (\x-> x == '/' || x == '\\') template
-
-output_flags = std_flags
-#else /* else mingw32_HOST_OS */
- findTempName = do
- rs <- rand_string
- let filename = prefix ++ rs ++ suffix
- filepath = tmp_dir `combine` filename
- r <- openNewFile filepath binary mode
- case r of
- FileExists -> findTempName
- OpenNewError errno -> ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
- NewFileCreated fd -> do
- (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}
- False{-is_socket-}
- True{-is_nonblock-}
-
- enc <- getLocaleEncoding
- h <- POSIX.mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc)
-
- return (filepath, h)
-
- where
- -- XXX bits copied from System.FilePath, since that's not available here
- combine a b
- | null b = a
- | null a = b
- | pathSeparator [last a] = a ++ b
- | otherwise = a ++ [pathSeparatorChar] ++ b
-
-tempCounter :: IORef Int
-tempCounter = unsafePerformIO $ newIORef 0
-{-# NOINLINE tempCounter #-}
-
--- build large digit-alike number
-rand_string :: IO String
-rand_string = do
- r1 <- c_getpid
- (r2, _) <- atomicModifyIORef'_ tempCounter (+1)
- return $ show r1 ++ "-" ++ show r2
-
-data OpenNewFileResult
- = NewFileCreated CInt
- | FileExists
- | OpenNewError Errno
-
-openNewFile :: FilePath -> Bool -> CMode -> IO OpenNewFileResult
-openNewFile filepath binary mode = do
- let oflags1 = rw_flags .|. o_EXCL
-
- binary_flags
- | binary = o_BINARY
- | otherwise = 0
-
- oflags = oflags1 .|. binary_flags
- fd <- withFilePath filepath $ \ f ->
- c_open f oflags mode
- if fd < 0
- then do
- errno <- getErrno
- case errno of
- _ | errno == eEXIST -> return FileExists
- _ -> return (OpenNewError errno)
- else return (NewFileCreated fd)
-
--- XXX Should use filepath library
-pathSeparatorChar :: Char
-pathSeparatorChar = '/'
-
-pathSeparator :: String -> Bool
-pathSeparator template = pathSeparatorChar `elem` template
-
-output_flags = std_flags .|. o_CREAT
-#endif /* mingw32_HOST_OS */
-
--- XXX Copied from GHC.Handle
-std_flags, output_flags, rw_flags :: CInt
-std_flags = o_NONBLOCK .|. o_NOCTTY
-rw_flags = output_flags .|. o_RDWR
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -7850,6 +7850,7 @@ module GHC.IO.Handle where
hGetEcho :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
hGetEncoding :: Handle -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Encoding.Types.TextEncoding)
hGetLine :: Handle -> GHC.Internal.Types.IO GHC.Internal.Base.String
+ hGetNewlineMode :: Handle -> GHC.Internal.Types.IO NewlineMode
hGetPosn :: Handle -> GHC.Internal.Types.IO HandlePosn
hIsClosed :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
hIsEOF :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
@@ -9885,7 +9886,7 @@ module System.Exit where
exitWith :: forall a. ExitCode -> GHC.Internal.Types.IO a
module System.IO where
- -- Safety: Safe
+ -- Safety: Trustworthy
type BufferMode :: *
data BufferMode = NoBuffering | LineBuffering | BlockBuffering (GHC.Internal.Maybe.Maybe GHC.Internal.Types.Int)
type FilePath :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -7822,6 +7822,7 @@ module GHC.IO.Handle where
hGetEcho :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
hGetEncoding :: Handle -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Encoding.Types.TextEncoding)
hGetLine :: Handle -> GHC.Internal.Types.IO GHC.Internal.Base.String
+ hGetNewlineMode :: Handle -> GHC.Internal.Types.IO NewlineMode
hGetPosn :: Handle -> GHC.Internal.Types.IO HandlePosn
hIsClosed :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
hIsEOF :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
@@ -9923,7 +9924,7 @@ module System.Exit where
exitWith :: forall a. ExitCode -> GHC.Internal.Types.IO a
module System.IO where
- -- Safety: Safe
+ -- Safety: Trustworthy
type BufferMode :: *
data BufferMode = NoBuffering | LineBuffering | BlockBuffering (GHC.Internal.Maybe.Maybe GHC.Internal.Types.Int)
type FilePath :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -8014,6 +8014,7 @@ module GHC.IO.Handle where
hGetEcho :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
hGetEncoding :: Handle -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Encoding.Types.TextEncoding)
hGetLine :: Handle -> GHC.Internal.Types.IO GHC.Internal.Base.String
+ hGetNewlineMode :: Handle -> GHC.Internal.Types.IO NewlineMode
hGetPosn :: Handle -> GHC.Internal.Types.IO HandlePosn
hIsClosed :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
hIsEOF :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
@@ -10165,7 +10166,7 @@ module System.Exit where
exitWith :: forall a. ExitCode -> GHC.Internal.Types.IO a
module System.IO where
- -- Safety: Safe
+ -- Safety: Trustworthy
type BufferMode :: *
data BufferMode = NoBuffering | LineBuffering | BlockBuffering (GHC.Internal.Maybe.Maybe GHC.Internal.Types.Int)
type FilePath :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -7850,6 +7850,7 @@ module GHC.IO.Handle where
hGetEcho :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
hGetEncoding :: Handle -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.IO.Encoding.Types.TextEncoding)
hGetLine :: Handle -> GHC.Internal.Types.IO GHC.Internal.Base.String
+ hGetNewlineMode :: Handle -> GHC.Internal.Types.IO NewlineMode
hGetPosn :: Handle -> GHC.Internal.Types.IO HandlePosn
hIsClosed :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
hIsEOF :: Handle -> GHC.Internal.Types.IO GHC.Internal.Types.Bool
@@ -9885,7 +9886,7 @@ module System.Exit where
exitWith :: forall a. ExitCode -> GHC.Internal.Types.IO a
module System.IO where
- -- Safety: Safe
+ -- Safety: Trustworthy
type BufferMode :: *
data BufferMode = NoBuffering | LineBuffering | BlockBuffering (GHC.Internal.Maybe.Maybe GHC.Internal.Types.Int)
type FilePath :: *
=====================================
testsuite/tests/typecheck/should_compile/T9497a.stderr
=====================================
@@ -1,4 +1,3 @@
-
T9497a.hs:2:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
• Found hole: _main :: IO ()
Or perhaps ‘_main’ is mis-spelled, or not in scope
@@ -8,8 +7,7 @@ T9497a.hs:2:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
main :: IO () (bound at T9497a.hs:2:1)
readLn :: forall a. Read a => IO a
with readLn @()
- (imported from ‘Prelude’
- (and originally defined in ‘GHC.Internal.System.IO’))
+ (imported from ‘Prelude’ (and originally defined in ‘System.IO’))
mempty :: forall a. Monoid a => a
with mempty @(IO ())
(imported from ‘Prelude’
=====================================
testsuite/tests/typecheck/should_compile/holes.stderr
=====================================
@@ -45,6 +45,15 @@ holes.hs:11:15: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
y :: [a]
z :: [a] -> [a]
f :: forall {p}. p
+ appendFile :: FilePath -> String -> IO ()
+ getChar :: IO Char
+ getContents :: IO String
+ getLine :: IO String
+ interact :: (String -> String) -> IO ()
+ putChar :: Char -> IO ()
+ putStr :: String -> IO ()
+ readFile :: FilePath -> IO String
+ writeFile :: FilePath -> String -> IO ()
otherwise :: Bool
(&&) :: Bool -> Bool -> Bool
not :: Bool -> Bool
@@ -58,16 +67,7 @@ holes.hs:11:15: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
showChar :: Char -> ShowS
showParen :: Bool -> ShowS -> ShowS
showString :: String -> ShowS
- appendFile :: FilePath -> String -> IO ()
- getChar :: IO Char
- getContents :: IO String
- getLine :: IO String
- interact :: (String -> String) -> IO ()
- putChar :: Char -> IO ()
- putStr :: String -> IO ()
putStrLn :: String -> IO ()
- readFile :: FilePath -> IO String
- writeFile :: FilePath -> String -> IO ()
EQ :: Ordering
GT :: Ordering
LT :: Ordering
=====================================
testsuite/tests/typecheck/should_compile/holes3.stderr
=====================================
@@ -48,6 +48,15 @@ holes3.hs:11:15: error: [GHC-88464]
y :: [a]
z :: [a] -> [a]
f :: forall {p}. p
+ appendFile :: FilePath -> String -> IO ()
+ getChar :: IO Char
+ getContents :: IO String
+ getLine :: IO String
+ interact :: (String -> String) -> IO ()
+ putChar :: Char -> IO ()
+ putStr :: String -> IO ()
+ readFile :: FilePath -> IO String
+ writeFile :: FilePath -> String -> IO ()
otherwise :: Bool
(&&) :: Bool -> Bool -> Bool
not :: Bool -> Bool
@@ -61,16 +70,7 @@ holes3.hs:11:15: error: [GHC-88464]
showChar :: Char -> ShowS
showParen :: Bool -> ShowS -> ShowS
showString :: String -> ShowS
- appendFile :: FilePath -> String -> IO ()
- getChar :: IO Char
- getContents :: IO String
- getLine :: IO String
- interact :: (String -> String) -> IO ()
- putChar :: Char -> IO ()
- putStr :: String -> IO ()
putStrLn :: String -> IO ()
- readFile :: FilePath -> IO String
- writeFile :: FilePath -> String -> IO ()
EQ :: Ordering
GT :: Ordering
LT :: Ordering
=====================================
testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
=====================================
@@ -230,15 +230,14 @@ valid_hole_fits.hs:41:8: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
Valid hole fits include
ps :: String -> IO () (defined at valid_hole_fits.hs:9:1)
System.IO.putStr :: String -> IO ()
- (imported qualified from ‘System.IO’ at valid_hole_fits.hs:4:29-34
- (and originally defined in ‘GHC.Internal.System.IO’))
+ (imported qualified from ‘System.IO’ at valid_hole_fits.hs:4:29-34)
System.IO.putStrLn :: String -> IO ()
(imported qualified from ‘System.IO’ at valid_hole_fits.hs:4:37-44
(and originally defined in ‘GHC.Internal.System.IO’))
readIO :: forall a. Read a => String -> IO a
with readIO @()
(imported from ‘Prelude’ at valid_hole_fits.hs:3:1-40
- (and originally defined in ‘GHC.Internal.System.IO’))
+ (and originally defined in ‘System.IO’))
fail :: forall (m :: * -> *) a.
(MonadFail m, GHC.Internal.Stack.Types.HasCallStack) =>
String -> m a
=====================================
testsuite/tests/typecheck/should_fail/T9497d.stderr
=====================================
@@ -8,8 +8,7 @@ T9497d.hs:2:8: error: [GHC-88464]
main :: IO () (bound at T9497d.hs:2:1)
readLn :: forall a. Read a => IO a
with readLn @()
- (imported from ‘Prelude’
- (and originally defined in ‘GHC.Internal.System.IO’))
+ (imported from ‘Prelude’ (and originally defined in ‘System.IO’))
mempty :: forall a. Monoid a => a
with mempty @(IO ())
(imported from ‘Prelude’
=====================================
testsuite/tests/typecheck/should_run/T9497a-run.stderr
=====================================
@@ -10,8 +10,7 @@ T9497a-run.hs:2:8: error: [GHC-88464]
main :: IO () (bound at T9497a-run.hs:2:1)
readLn :: forall a. Read a => IO a
with readLn @()
- (imported from ‘Prelude’
- (and originally defined in ‘GHC.Internal.System.IO’))
+ (imported from ‘Prelude’ (and originally defined in ‘System.IO’))
mempty :: forall a. Monoid a => a
with mempty @(IO ())
(imported from ‘Prelude’
=====================================
testsuite/tests/typecheck/should_run/T9497b-run.stderr
=====================================
@@ -10,8 +10,7 @@ T9497b-run.hs:2:8: error: [GHC-88464]
main :: IO () (bound at T9497b-run.hs:2:1)
readLn :: forall a. Read a => IO a
with readLn @()
- (imported from ‘Prelude’
- (and originally defined in ‘GHC.Internal.System.IO’))
+ (imported from ‘Prelude’ (and originally defined in ‘System.IO’))
mempty :: forall a. Monoid a => a
with mempty @(IO ())
(imported from ‘Prelude’
=====================================
testsuite/tests/typecheck/should_run/T9497c-run.stderr
=====================================
@@ -10,8 +10,7 @@ T9497c-run.hs:2:8: error: [GHC-88464]
main :: IO () (bound at T9497c-run.hs:2:1)
readLn :: forall a. Read a => IO a
with readLn @()
- (imported from ‘Prelude’
- (and originally defined in ‘GHC.Internal.System.IO’))
+ (imported from ‘Prelude’ (and originally defined in ‘System.IO’))
mempty :: forall a. Monoid a => a
with mempty @(IO ())
(imported from ‘Prelude’
=====================================
utils/haddock/html-test/ref/Bug1004.html
=====================================
@@ -627,13 +627,13 @@
>liftReadsPrec</a
> :: (<a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="Text.ParserCombinators.ReadP"
>ReadS</a
- > a) -> <a href="#" title="Prelude"
+ > a) -> <a href="#" title="Text.ParserCombinators.ReadP"
>ReadS</a
> [a] -> <a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="Text.ParserCombinators.ReadP"
>ReadS</a
> (<a href="#" title="Bug1004"
>Product</a
@@ -645,11 +645,11 @@
>liftReadList</a
> :: (<a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="Text.ParserCombinators.ReadP"
>ReadS</a
- > a) -> <a href="#" title="Prelude"
+ > a) -> <a href="#" title="Text.ParserCombinators.ReadP"
>ReadS</a
- > [a] -> <a href="#" title="Prelude"
+ > [a] -> <a href="#" title="Text.ParserCombinators.ReadP"
>ReadS</a
> [<a href="#" title="Bug1004"
>Product</a
@@ -735,15 +735,15 @@
>liftShowsPrec</a
> :: (<a href="#" title="Data.Int"
>Int</a
- > -> a -> <a href="#" title="Prelude"
+ > -> a -> <a href="#" title="Text.Show"
>ShowS</a
- >) -> ([a] -> <a href="#" title="Prelude"
+ >) -> ([a] -> <a href="#" title="Text.Show"
>ShowS</a
>) -> <a href="#" title="Data.Int"
>Int</a
> -> <a href="#" title="Bug1004"
>Product</a
- > f g a -> <a href="#" title="Prelude"
+ > f g a -> <a href="#" title="Text.Show"
>ShowS</a
> <a href="#" class="selflink"
>#</a
@@ -753,13 +753,13 @@
>liftShowList</a
> :: (<a href="#" title="Data.Int"
>Int</a
- > -> a -> <a href="#" title="Prelude"
+ > -> a -> <a href="#" title="Text.Show"
>ShowS</a
- >) -> ([a] -> <a href="#" title="Prelude"
+ >) -> ([a] -> <a href="#" title="Text.Show"
>ShowS</a
>) -> [<a href="#" title="Bug1004"
>Product</a
- > f g a] -> <a href="#" title="Prelude"
+ > f g a] -> <a href="#" title="Text.Show"
>ShowS</a
> <a href="#" class="selflink"
>#</a
@@ -2563,15 +2563,15 @@
></span
> <span class="breakable"
>(<span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Read"
>Read</a
> (f a)</span
>, <span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Read"
>Read</a
> (g a)</span
>)</span
- > => <a href="#" title="Prelude"
+ > => <a href="#" title="Text.Read"
>Read</a
> (<a href="#" title="Bug1004"
>Product</a
@@ -2603,7 +2603,7 @@
>readsPrec</a
> :: <a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="Text.ParserCombinators.ReadP"
>ReadS</a
> (<a href="#" title="Bug1004"
>Product</a
@@ -2613,7 +2613,7 @@
><p class="src"
><a href="#"
>readList</a
- > :: <a href="#" title="Prelude"
+ > :: <a href="#" title="Text.ParserCombinators.ReadP"
>ReadS</a
> [<a href="#" title="Bug1004"
>Product</a
@@ -2651,15 +2651,15 @@
></span
> <span class="breakable"
>(<span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Show"
>Show</a
> (f a)</span
>, <span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Show"
>Show</a
> (g a)</span
>)</span
- > => <a href="#" title="Prelude"
+ > => <a href="#" title="Text.Show"
>Show</a
> (<a href="#" title="Bug1004"
>Product</a
@@ -2693,7 +2693,7 @@
>Int</a
> -> <a href="#" title="Bug1004"
>Product</a
- > f g a -> <a href="#" title="Prelude"
+ > f g a -> <a href="#" title="Text.Show"
>ShowS</a
> <a href="#" class="selflink"
>#</a
@@ -2713,7 +2713,7 @@
>showList</a
> :: [<a href="#" title="Bug1004"
>Product</a
- > f g a] -> <a href="#" title="Prelude"
+ > f g a] -> <a href="#" title="Text.Show"
>ShowS</a
> <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/Bug973.html
=====================================
@@ -58,11 +58,11 @@
>showRead</a
> :: <span class="breakable"
>(<span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Show"
>Show</a
> a</span
>, <span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Read"
>Read</a
> b</span
>)</span
@@ -74,11 +74,11 @@
>forall</span
> b a. <span class="breakable"
>(<span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Show"
>Show</a
> a</span
>, <span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Read"
>Read</a
> b</span
>)</span
@@ -104,11 +104,11 @@
><td class="src"
>:: <span class="breakable"
>(<span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Show"
>Show</a
> a</span
>, <span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Read"
>Read</a
> b</span
>)</span
@@ -152,11 +152,11 @@
>forall</span
> b a. <span class="breakable"
>(<span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Show"
>Show</a
> a</span
>, <span class="unbreakable"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Read"
>Read</a
> b</span
>)</span
=====================================
utils/haddock/html-test/ref/ConstructorPatternExport.html
=====================================
@@ -95,7 +95,7 @@
>pattern</span
> <a id="v:BlubCons" class="def"
>BlubCons</a
- > :: () => <a href="#" title="Prelude"
+ > :: () => <a href="#" title="Text.Show"
>Show</a
> b => b -> Blub <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/DefaultSignatures.html
=====================================
@@ -133,7 +133,7 @@
>default</span
> <a id="v:bar" class="def"
>bar</a
- > :: <a href="#" title="Prelude"
+ > :: <a href="#" title="Text.Show"
>Show</a
> a => a -> <a href="#" title="Data.String"
>String</a
@@ -177,7 +177,7 @@
>default</span
> <a id="v:baz-39-" class="def"
>baz'</a
- > :: <a href="#" title="Prelude"
+ > :: <a href="#" title="Text.Read"
>Read</a
> a => <a href="#" title="Data.String"
>String</a
=====================================
utils/haddock/html-test/ref/Hash.html
=====================================
@@ -111,7 +111,7 @@
>)</span
> => <a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="System.IO"
>IO</a
> (<a href="#" title="Hash"
>HashTable</a
@@ -129,7 +129,7 @@
>Hash</a
> key</span
>)</span
- > => key -> val -> <a href="#" title="Prelude"
+ > => key -> val -> <a href="#" title="System.IO"
>IO</a
> ()</li
><li class="src short"
@@ -137,7 +137,7 @@
>lookup</a
> :: <a href="#" title="Hash"
>Hash</a
- > key => key -> <a href="#" title="Prelude"
+ > key => key -> <a href="#" title="System.IO"
>IO</a
> (<a href="#" title="Data.Maybe"
>Maybe</a
@@ -215,7 +215,7 @@
>)</span
> => <a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="System.IO"
>IO</a
> (<a href="#" title="Hash"
>HashTable</a
@@ -241,7 +241,7 @@
>Hash</a
> key</span
>)</span
- > => key -> val -> <a href="#" title="Prelude"
+ > => key -> val -> <a href="#" title="System.IO"
>IO</a
> () <a href="#" class="selflink"
>#</a
@@ -257,7 +257,7 @@
>lookup</a
> :: <a href="#" title="Hash"
>Hash</a
- > key => key -> <a href="#" title="Prelude"
+ > key => key -> <a href="#" title="System.IO"
>IO</a
> (<a href="#" title="Data.Maybe"
>Maybe</a
=====================================
utils/haddock/html-test/ref/PatternSyns.html
=====================================
@@ -104,7 +104,7 @@
>data</span
> <a href="#"
>BlubType</a
- > = <a href="#" title="Prelude"
+ > = <a href="#" title="Text.Show"
>Show</a
> x => <a href="#"
>BlubCtor</a
@@ -114,7 +114,7 @@
>pattern</span
> <a href="#"
>Blub</a
- > :: () => <a href="#" title="Prelude"
+ > :: () => <a href="#" title="Text.Show"
>Show</a
> x => x -> <a href="#" title="PatternSyns"
>BlubType</a
@@ -266,7 +266,7 @@
><table
><tr
><td class="src"
- ><a href="#" title="Prelude"
+ ><a href="#" title="Text.Show"
>Show</a
> x => <a id="v:BlubCtor" class="def"
>BlubCtor</a
@@ -283,7 +283,7 @@
>pattern</span
> <a id="v:Blub" class="def"
>Blub</a
- > :: () => <a href="#" title="Prelude"
+ > :: () => <a href="#" title="Text.Show"
>Show</a
> x => x -> <a href="#" title="PatternSyns"
>BlubType</a
=====================================
utils/haddock/html-test/ref/PatternSyns2.html
=====================================
@@ -145,7 +145,7 @@
>P</a
> :: () => <span class="keyword"
>forall</span
- > k (a :: k) b. <a href="#" title="Prelude"
+ > k (a :: k) b. <a href="#" title="Text.Show"
>Show</a
> b => <a href="#" title="Data.Proxy"
>Proxy</a
=====================================
utils/haddock/html-test/ref/QuasiExpr.html
=====================================
@@ -122,7 +122,7 @@
><span class="inst-left"
><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Expr:Show:1"
></span
- > <a href="#" title="Prelude"
+ > <a href="#" title="Text.Show"
>Show</a
> <a href="#" title="QuasiExpr"
>Expr</a
@@ -152,7 +152,7 @@
>Int</a
> -> <a href="#" title="QuasiExpr"
>Expr</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="Text.Show"
>ShowS</a
> <a href="#" class="selflink"
>#</a
@@ -172,7 +172,7 @@
>showList</a
> :: [<a href="#" title="QuasiExpr"
>Expr</a
- >] -> <a href="#" title="Prelude"
+ >] -> <a href="#" title="Text.Show"
>ShowS</a
> <a href="#" class="selflink"
>#</a
@@ -244,7 +244,7 @@
><span class="inst-left"
><span class="instance details-toggle-control details-toggle" data-details-id="i:id:BinOp:Show:1"
></span
- > <a href="#" title="Prelude"
+ > <a href="#" title="Text.Show"
>Show</a
> <a href="#" title="QuasiExpr"
>BinOp</a
@@ -274,7 +274,7 @@
>Int</a
> -> <a href="#" title="QuasiExpr"
>BinOp</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="Text.Show"
>ShowS</a
> <a href="#" class="selflink"
>#</a
@@ -294,7 +294,7 @@
>showList</a
> :: [<a href="#" title="QuasiExpr"
>BinOp</a
- >] -> <a href="#" title="Prelude"
+ >] -> <a href="#" title="Text.Show"
>ShowS</a
> <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/Test.html
=====================================
@@ -521,7 +521,7 @@
><li
><a href="#"
>a</a
- > :: <a href="#" title="Prelude"
+ > :: <a href="#" title="System.IO"
>IO</a
> a</li
><li
@@ -575,7 +575,7 @@
>a</a
> :: <a href="#" title="Test"
>C</a
- > a => <a href="#" title="Prelude"
+ > a => <a href="#" title="System.IO"
>IO</a
> a</li
><li class="src short"
@@ -591,7 +591,7 @@
>g</a
> :: <a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="System.IO"
>IO</a
> CInt</li
><li class="src short"
@@ -661,7 +661,7 @@
>Float</a
>) -> <a href="#" title="Test"
>T5</a
- > () () -> <a href="#" title="Prelude"
+ > () () -> <a href="#" title="System.IO"
>IO</a
> ()</li
><li class="src short"
@@ -683,7 +683,7 @@
>R</a
> -> <a href="#" title="Test"
>N1</a
- > () -> <a href="#" title="Prelude"
+ > () -> <a href="#" title="System.IO"
>IO</a
> <a href="#" title="Data.Int"
>Int</a
@@ -693,7 +693,7 @@
>o</a
> :: <a href="#" title="Prelude"
>Float</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="System.IO"
>IO</a
> <a href="#" title="Prelude"
>Float</a
@@ -1674,7 +1674,7 @@
><p class="src"
><a id="v:a" class="def"
>a</a
- > :: <a href="#" title="Prelude"
+ > :: <a href="#" title="System.IO"
>IO</a
> a <a href="#" class="selflink"
>#</a
@@ -1903,7 +1903,7 @@
>a</a
> :: <a href="#" title="Test"
>C</a
- > a => <a href="#" title="Prelude"
+ > a => <a href="#" title="System.IO"
>IO</a
> a <a href="#" class="selflink"
>#</a
@@ -1991,7 +1991,7 @@ using double quotes: <a href="#"
>g</a
> :: <a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="Prelude"
+ > -> <a href="#" title="System.IO"
>IO</a
> CInt <a href="#" class="selflink"
>#</a
@@ -2267,7 +2267,7 @@ is at the beginning of the line).</pre
></tr
><tr
><td class="src"
- >-> <a href="#" title="Prelude"
+ >-> <a href="#" title="System.IO"
>IO</a
> ()</td
><td class="doc"
@@ -2355,7 +2355,7 @@ is at the beginning of the line).</pre
></tr
><tr
><td class="src"
- >-> <a href="#" title="Prelude"
+ >-> <a href="#" title="System.IO"
>IO</a
> <a href="#" title="Data.Int"
>Int</a
@@ -2395,7 +2395,7 @@ is at the beginning of the line).</pre
></tr
><tr
><td class="src"
- >-> <a href="#" title="Prelude"
+ >-> <a href="#" title="System.IO"
>IO</a
> <a href="#" title="Prelude"
>Float</a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76528cc323b6338a873fa68ef8c9a76…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76528cc323b6338a873fa68ef8c9a76…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: NCG: Implement constant folding for vector simd ops (Issue #25030)
by Marge Bot (＠marge-bot) 21 Apr '26
by Marge Bot (＠marge-bot) 21 Apr '26
21 Apr '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
72d6dc74 by aparker at 2026-04-20T20:15:44-04:00
NCG: Implement constant folding for vector simd ops (Issue #25030)
- - - - -
b9cab907 by sheaf at 2026-04-20T20:15:44-04:00
Mark some SIMD tests as broken on i386 optllvm
As seen in #25498, several SIMD tests are broken on i386 in the optllvm
way. This commit marks them as "expect_broken".
- - - - -
7 changed files:
- + changelog.d/simd_constant_folding
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Utils/Misc.hs
- + testsuite/tests/simd/should_run/Makefile
- + testsuite/tests/simd/should_run/T25030.hs
- + testsuite/tests/simd/should_run/T25030.stdout
- testsuite/tests/simd/should_run/all.T
Changes:
=====================================
changelog.d/simd_constant_folding
=====================================
@@ -0,0 +1,14 @@
+section: codegen
+synopsis: Implement Cmm constant folding for some SIMD vector instructions
+issues: #25030 #26915
+mrs: !15512
+
+description: {
+The Cmm constant folding pass now handles the following vector operations:
+
+- insert and extract (broadcast was already supported)
+- integer arithmetic operations: negation, addition, subtraction, multiplication,
+ minimum, maximum
+- logical operations: and, or, xor
+}
+
=====================================
compiler/GHC/Cmm/Opt.hs
=====================================
@@ -24,6 +24,7 @@ import GHC.Platform
import GHC.Types.Literal.Floating
import Data.Maybe
+import Control.Monad (zipWithM, guard)
import GHC.Float
@@ -47,7 +48,6 @@ cmmMachOpFold
-> MachOp -- The operation from an CmmMachOp
-> [CmmExpr] -- The optimized arguments
-> CmmExpr
-
cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args)
-- Returns Nothing if no changes, useful for Hoopl, also reduces
@@ -65,6 +65,30 @@ cmmMachOpFoldM _ (MO_VF_Broadcast lg _w) exprs =
case exprs of
[CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l)
_ -> Nothing
+
+cmmMachOpFoldM plat (MO_V_Extract l _) [v, (CmmLit (CmmInt idx W32))]
+ | idx >= 0, idx < fromIntegral l
+ = do
+ es <- vectorElements_maybe plat v
+ es !! fromInteger idx
+
+cmmMachOpFoldM plat (MO_VF_Extract l _) [v, (CmmLit (CmmInt idx W32))]
+ | idx >= 0, idx < fromIntegral l
+ = do
+ es <- vectorElements_maybe plat v
+ es !! fromInteger idx
+
+cmmMachOpFoldM plat op [v, newval@(CmmLit _), CmmLit (CmmInt idx W32)]
+ | MO_V_Insert l _ <- op = foldToVecLit l
+ | MO_VF_Insert l _ <- op = foldToVecLit l
+ where foldToVecLit l = do
+ guard (idx >= 0 && idx < fromIntegral l)
+ ls <- vectorElements_maybe plat v
+ lits <- sequence $ map toLit_maybe (replaceAt (fromIntegral idx) (Just newval) ls)
+ Just $! CmmLit (CmmVec lits)
+ toLit_maybe (Just (CmmLit l)) = Just l
+ toLit_maybe _ = Nothing
+
cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
| MO_WF_Bitcast width <- op = case width of
W32 | res <- castWord32ToFloat (fromInteger x)
@@ -457,6 +481,64 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _w))]
x2 = if p == 1 then x1 else
CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
+-- Many vector MachOps are simply element-wise scalar MachOps. For these, we reduce
+-- to the scalar case using 'vectorMachOpScalarMachOp_maybe' and 'vectorElements_maybe'.
+
+-- Unary vector MachOps.
+cmmMachOpFoldM plat op [v]
+ | Just scalar_op <- vectorMachOpToScalarMachOp_maybe op
+ = do es <- vectorElements_maybe plat v
+ ls <- mapM (foldToLit plat scalar_op) es
+ Just $! CmmLit $ CmmVec ls
+
+ where foldToLit plat mop (Just a) = do
+ CmmLit l <- cmmMachOpFoldM plat mop [a]
+ return l
+ foldToLit _ _ _ = Nothing
+
+-- Binary vector MachOps.
+cmmMachOpFoldM plat op [v1, v2]
+ | Just scalar_op <- vectorMachOpToScalarMachOp_maybe op
+ = do
+ es1 <- vectorElements_maybe plat v1
+ es2 <- vectorElements_maybe plat v2
+ ls <- zipWithM (foldToLit plat scalar_op) es1 es2
+ Just $! CmmLit $ CmmVec ls
+ -- MIN/MAX don't have scalar equivalents, so handle them manually.
+ | MO_VS_Max _ w <- op = do
+ es1 <- vectorElements_maybe plat v1
+ es2 <- vectorElements_maybe plat v2
+ ls <- zipWithM (foldOp (narrowS w) max) es1 es2
+ Just $! CmmLit $ CmmVec ls
+ | MO_VU_Max _ w <- op = do
+ es1 <- vectorElements_maybe plat v1
+ es2 <- vectorElements_maybe plat v2
+ ls <- zipWithM (foldOp (narrowU w) max) es1 es2
+ Just $! CmmLit $ CmmVec ls
+ | MO_VS_Min _ w <- op = do
+ es1 <- vectorElements_maybe plat v1
+ es2 <- vectorElements_maybe plat v2
+ ls <- zipWithM (foldOp (narrowS w) min) es1 es2
+ Just $! CmmLit $ CmmVec ls
+ | MO_VU_Min _ w <- op = do
+ es1 <- vectorElements_maybe plat v1
+ es2 <- vectorElements_maybe plat v2
+ ls <- zipWithM (foldOp (narrowU w) min) es1 es2
+ Just $! CmmLit $ CmmVec ls
+
+ where
+ foldToLit plat mop (Just a1) (Just a2) = do
+ CmmLit l <- cmmMachOpFoldM plat mop [a1, a2]
+ return l
+ foldToLit _ _ _ _ = Nothing
+
+ foldOp do_narrow op
+ (Just (CmmLit (CmmInt x rep)))
+ (Just (CmmLit (CmmInt y _)))
+ = Just $! CmmInt (do_narrow x `op` do_narrow y) rep
+ foldOp _ _ _ _ = Nothing
+
+
-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
-- Unfortunately this needs a unique supply because x might not be a
-- register. See #2253 (program 6) for an example.
@@ -473,6 +555,59 @@ validOffsetRep :: Width -> Bool
validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int)
+-- Is this a vector 'MachOp' that is an element-wise lift of
+-- a scalar 'MachOp'? If so, returns the corresponding scalar 'MachOp'.
+vectorMachOpToScalarMachOp_maybe :: MachOp -> Maybe MachOp
+vectorMachOpToScalarMachOp_maybe m = case m of
+ MO_VS_Neg _ w -> Just $ MO_S_Neg w
+ MO_VF_Neg _ w -> Just $ MO_F_Neg w
+ MO_V_Add _ w -> Just $ MO_Add w
+ MO_V_Sub _ w -> Just $ MO_Sub w
+ MO_V_Mul _ w -> Just $ MO_Mul w
+ MO_VF_Add _ w -> Just $ MO_F_Add w
+ MO_VF_Sub _ w -> Just $ MO_F_Sub w
+ MO_VF_Mul _ w -> Just $ MO_F_Mul w
+ MO_VF_Min _ w -> Just $ MO_F_Min w
+ MO_VF_Max _ w -> Just $ MO_F_Max w
+ MO_V_And _ w -> Just $ MO_And w
+ MO_V_Or _ w -> Just $ MO_Or w
+ MO_V_Xor _ w -> Just $ MO_Xor w
+ _ -> Nothing
+
+
+-- | Helper function that tells us what we know about the elements of a vector.
+--
+-- Returns 'Nothing' for non-vectors, and @[Nothing, Nothing, ...]@ for vectors
+-- with unknown elements.
+vectorElements_maybe :: Platform -> CmmExpr -> Maybe [Maybe CmmExpr]
+vectorElements_maybe _plat (CmmLit (CmmVec es)) = Just $! map (Just . CmmLit) es
+
+vectorElements_maybe _plat (CmmMachOp (MO_V_Broadcast l _) args)
+ | [CmmLit v] <- args = Just $! replicate l (Just $! CmmLit v)
+vectorElements_maybe _plat (CmmMachOp (MO_VF_Broadcast l _) args)
+ | [CmmLit v] <- args = Just $! replicate l (Just $! CmmLit v)
+
+vectorElements_maybe plat (CmmMachOp (MO_V_Insert _ _) args)
+ | [v, e, (CmmLit (CmmInt i _w))] <- args
+ , Just es <- vectorElements_maybe plat v
+ = Just $! (replaceAt (fromInteger i) (Just $! e) es)
+
+vectorElements_maybe plat (CmmMachOp (MO_VF_Insert _ _) args)
+ | [v, e, (CmmLit (CmmInt i _w))] <- args
+ , Just es <- vectorElements_maybe plat v
+ = Just $! (replaceAt (fromInteger i) (Just $! e) es)
+
+vectorElements_maybe plat (CmmMachOp mop _)
+ | isVecType result_type = Just $! replicate (vecLength result_type) Nothing
+ where result_type = machOpResultType plat mop []
+
+vectorElements_maybe _plat (CmmReg reg)
+ | isVecType reg_type = Just $! replicate (vecLength reg_type) Nothing
+ where reg_type = cmmRegType reg
+
+vectorElements_maybe _ _ = Nothing
+
+
{- Note [Comparison operators]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have
=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -56,7 +56,7 @@ module GHC.Utils.Misc (
-- * List operations controlled by another list
takeList, dropList, splitAtList, split,
- dropTail, capitalise,
+ replaceAt, dropTail, capitalise,
-- * Sorting
sortWith, minWith, nubSort, ordNub, ordNubOn,
@@ -718,6 +718,14 @@ splitAtList xs ys = go 0# xs ys
go n [] bs = (take (I# n) ys, bs) -- = splitAt n ys
go n (_:as) (_:bs) = go (n +# 1#) as bs
+-- | given an index n and element y, replace the nth element of list xs with y
+replaceAt :: Int -> a -> [a] -> [a]
+replaceAt n y xs
+ | n >= length xs = xs
+ | n < 0 = xs
+ | otherwise = before ++ (y : drop 1 after)
+ where (before, after) = splitAt n xs
+
-- | drop from the end of a list
dropTail :: Int -> [a] -> [a]
-- Specification: dropTail n = reverse . drop n . reverse
=====================================
testsuite/tests/simd/should_run/Makefile
=====================================
@@ -0,0 +1,42 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T25030:
+ '$(TEST_HC)' $(TEST_HC_OPTS) T25030.hs -v0 -O1 -fforce-recomp -ddump-cmm > T25030.cmm 2>&1
+
+ # testFoldPlus: 111111+121212=232323, 121212+131313=252525 should be folded
+ grep -m 1 -o "232323" T25030.cmm
+ grep -m 1 -o "252525" T25030.cmm
+ # operands should not appear in the output
+ grep -o "111111" T25030.cmm || echo "Does not appear: 111111"
+ grep -o "121212" T25030.cmm || echo "Does not appear: 121212"
+ grep -o "131313" T25030.cmm || echo "Does not appear: 131313"
+
+ # testFoldMax: max(333333,333332)=333333 should be folded
+ grep -m 1 -o "333333" T25030.cmm
+ # lesser operand should not appear
+ grep -o "333332" T25030.cmm || echo "Does not appear: 333332"
+
+ # testNeg: negate(343434)=-343434 should be folded
+ grep -m 1 -o -- "-343434" T25030.cmm
+
+ # testInserts: insert 363636 into broadcast(353535) and extract it;
+ # should fold to constant 363636
+ grep -m 1 -o "363636" T25030.cmm
+ # broadcast operand should not appear
+ grep -o "353535" T25030.cmm || echo "Does not appear: 353535"
+
+ # testInserts2: 383838+393939=777777 should be folded
+ grep -m 1 -o "777777" T25030.cmm
+ # addends should not appear
+ grep -o "383838" T25030.cmm || echo "Does not appear: 383838"
+
+ # testOverwrite: inserting 404040,404041 into broadcast(414141) should fold to <404040,404041>
+ grep -m 1 -o "404040" T25030.cmm
+ grep -m 1 -o "404041" T25030.cmm
+ # original broadcast value should not appear
+ grep -o "414141" T25030.cmm || echo "Does not appear: 414141"
+
+ # testExtractFromInsert: extract(insert(unknown_v, 454545, 3), 3) should fold to 454545
+ grep -m 1 -o "454545" T25030.cmm
=====================================
testsuite/tests/simd/should_run/T25030.hs
=====================================
@@ -0,0 +1,79 @@
+{-# LANGUAGE MagicHash, UnboxedTuples, LexicalNegation, ExtendedLiterals #-}
+
+import GHC.Prim
+import GHC.Int
+
+-- Cmm constant folding tests for vector operations
+
+data IntX2 = IX2# Int64X2#
+data IntX4 = IX4# Int32X4#
+
+instance Show IntX2 where
+ show (IX2# d) = case (unpackInt64X2# d) of
+ (# a, b #) -> show ((I64# a), (I64# b))
+
+instance Show IntX4 where
+ show (IX4# v) = case (unpackInt32X4# v) of
+ (# a, b, c, d #) -> show ((I32# a), (I32# b), (I32# c), (I32# d))
+
+testFoldPlus = do
+ let v1 = packInt64X2# (# 111111#Int64, 121212#Int64 #)
+ let v2 = packInt64X2# (# 121212#Int64, 131313#Int64 #)
+ print $ IX2# $ plusInt64X2# v1 v2 -- expect to see 232323 and 252525 here,
+ -- and not 111111, 121212, or 131313
+
+testFoldMax = do
+ let v1 = broadcastInt32X4# 333333#Int32
+ let v2 = broadcastInt32X4# 333332#Int32
+ print $ IX4# $ maxInt32X4# v1 v2 -- expect to see 333333 here and not 333332
+
+testFoldMin = do
+ let v1 = broadcastInt32X4# 474747#Int32
+ let v2 = broadcastInt32X4# 474748#Int32
+ print $ IX4# $ minInt32X4# v1 v2 -- expect to see 474747 here and not 474748
+
+testNeg = do
+ let v1 = broadcastInt32X4# 343434#Int32
+ print $ IX4# $ negateInt32X4# v1 -- expect to see -343434 here, not positive 343434
+
+
+testInserts = do
+ let v1 = broadcastInt32X4# 353535#Int32
+ let v2 = insertInt32X4# v1 363636#Int32 0#
+ let (# a, _, _, _ #) = unpackInt32X4# v2
+ print $ (I32# a) -- expect to see 363636 here, not 353535
+
+
+testInserts2 = do
+ let v1 = broadcastInt32X4# 373737#Int32
+ let v2 = insertInt32X4# v1 383838#Int32 0#
+ let v3 = plusInt32X4# v2 (broadcastInt32X4# 393939#Int32)
+ let (# a, _, _, _ #) = unpackInt32X4# v3
+ print $ (I32# a) -- expect to see 777777 == 383838+393939 here, and not 373737, 383838, or 393939
+
+{-# INLINE testOverwrite #-}
+testOverwrite :: Int64X2# -> IO ()
+testOverwrite v = do
+ let v1 = insertInt64X2# v 404040#Int64 0#
+ let v2 = insertInt64X2# v1 404041#Int64 1#
+ print $ IX2# v2 -- expect <404040, 404041> to appear in the cmm as a single assignment,
+ -- rather than a series of inserts
+
+{-# NOINLINE testExtractFromInsert #-}
+testExtractFromInsert :: Int32X4# -> IO ()
+testExtractFromInsert v = do
+ let v2 = insertInt32X4# v 454545#Int32 3#
+ let (# _, _, _, d #) = unpackInt32X4# v2
+ print (I32# d) -- 454545 should fold as a constant even though v is a runtime value
+
+
+main = do
+ testFoldPlus
+ testFoldMax
+ testFoldMin
+ testNeg
+ testInserts
+ testInserts2
+ testOverwrite (broadcastInt64X2# 414141#Int64)
+ testExtractFromInsert (broadcastInt32X4# 464646#Int32)
+
=====================================
testsuite/tests/simd/should_run/T25030.stdout
=====================================
@@ -0,0 +1,20 @@
+232323
+252525
+Does not appear: 111111
+Does not appear: 121212
+Does not appear: 131313
+333333
+333333
+333333
+Does not appear: 333332
+-343434
+-343434
+-343434
+363636
+Does not appear: 353535
+777777
+Does not appear: 383838
+404040
+404041
+Does not appear: 414141
+454545
=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -49,6 +49,8 @@ test('int16x8_shuffle_baseline', [], compile_and_run, [''])
test('int32x4_shuffle_baseline', [], compile_and_run, [''])
test('int64x2_shuffle_baseline', [], compile_and_run, [''])
+test('T25030', [when(arch('i386'), expect_broken_for(25498, ['optllvm']))], makefile_test, [])
+
test('T25658', [], compile_and_run, ['']) # #25658 is a bug with SSE2 code generation
test('T25659', [], compile_and_run, [''])
@@ -83,6 +85,7 @@ test('simd007', [], compile_and_run, [''])
test('simd008', [], compile_and_run, [''])
test('simd009', [ req_th
, extra_files(['Simd009b.hs', 'Simd009c.hs'])
+ , when(arch('i386'), expect_broken_for(25498, ['optllvm']))
]
, multimod_compile_and_run, ['simd009', ''])
test('simd010', [], compile_and_run, [''])
@@ -174,7 +177,7 @@ test('T25062_V64'
, compile_and_run if have_cpu_feature('avx512f') else compile
, [''])
-test('T25169', [], compile_and_run, [''])
+test('T25169', [when(arch('i386'), expect_broken_for(25498, ['optllvm']))], compile_and_run, [''])
test('T25455', [], compile_and_run, [''])
test('T25486', [], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86ca6c2cf93147ed67a39be1112911…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86ca6c2cf93147ed67a39be1112911…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/build-opt] 4 commits: SOURCE-import HsInstances inside ghc.
by Andreas Klebinger (＠AndreasK) 20 Apr '26
by Andreas Klebinger (＠AndreasK) 20 Apr '26
20 Apr '26
Andreas Klebinger pushed to branch wip/andreask/build-opt at Glasgow Haskell Compiler / GHC
Commits:
74e4e745 by Andreas Klebinger at 2026-04-20T20:04:26+00:00
SOURCE-import HsInstances inside ghc.
Fixes #27198 by SOURCE importing HsInstances unlocking
more build paralleism.
- - - - -
2bfb4ced by Andreas Klebinger at 2026-04-20T20:04:48+00:00
SOURCE import GHC.Types.Error in some places for build parallelism.
Performance for these interfaces is not very relevant since it's only used for error handling.
This means we can use SOURCE imports to shorten the critical build path
by a non trivial amount.
- - - - -
0be2e78a by Andreas Klebinger at 2026-04-20T20:04:48+00:00
Split GHC.Driver.Main.hs up into multiple components.
This module was getting far too large to reason about, it split it
into components that all are re-exported from GHC.Driver.Main
I mostly did this for clarity but it also helps (slightly) with build
times.
- - - - -
b4b25892 by Andreas Klebinger at 2026-04-20T20:04:48+00:00
Add a few boot files and SOURCE import them to improve build parallelism.
See the Note [hs-boot files as "header" files] for details.
Modules with new SOURCE exports:
* GHC.HsToCore (deSugar)
* GHC.Tc.Deriv.hs-boot
* GHC.Driver.Main.Compile/Passes
- - - - -
24 changed files:
- compiler/GHC/Core/Opt/Stats.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Main.hs
- + compiler/GHC/Driver/Main/Compile.hs
- compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot
- + compiler/GHC/Driver/Main/Hsc.hs
- + compiler/GHC/Driver/Main/Interactive.hs
- + compiler/GHC/Driver/Main/Passes.hs
- + compiler/GHC/Driver/Main/Passes.hs-boot
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Instances.hs
- + compiler/GHC/Hs/Instances.hs-boot
- + compiler/GHC/HsToCore.hs-boot
- compiler/GHC/Iface/Load.hs
- + compiler/GHC/Tc/Deriv.hs-boot
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/Instance.hs-boot
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Error.hs-boot
- compiler/ghc.cabal.in
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/613871fdec67e432a70bf148f57907…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/613871fdec67e432a70bf148f57907…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: NCG: Implement constant folding for vector simd ops (Issue #25030)
by Marge Bot (＠marge-bot) 20 Apr '26
by Marge Bot (＠marge-bot) 20 Apr '26
20 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
c32aacb0 by aparker at 2026-04-20T16:05:03-04:00
NCG: Implement constant folding for vector simd ops (Issue #25030)
- - - - -
8ed41a6c by sheaf at 2026-04-20T16:05:04-04:00
Mark some SIMD tests as broken on i386 optllvm
As seen in #25498, several SIMD tests are broken on i386 in the optllvm
way. This commit marks them as "expect_broken".
- - - - -
d52b3d45 by Wolfgang Jeltsch at 2026-04-20T16:05:05-04:00
Move most of the `System.IO` implementation into `base`
This involves a rewrite of the `combine` helper function to avoid the
use of `last`, which would now be flagged as an error.
Metric Decrease:
LinkableUsage01
T3294
Metric Increase:
T12227
T12707
T5642
- - - - -
34 changed files:
- + changelog.d/simd_constant_folding
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Utils/Misc.hs
- libraries/base/src/Control/Concurrent.hs
- libraries/base/src/GHC/IO/Handle.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/Text/Printf.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/simd/should_run/Makefile
- + testsuite/tests/simd/should_run/T25030.hs
- + testsuite/tests/simd/should_run/T25030.stdout
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/typecheck/should_compile/T9497a.stderr
- testsuite/tests/typecheck/should_compile/holes.stderr
- testsuite/tests/typecheck/should_compile/holes3.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T9497d.stderr
- testsuite/tests/typecheck/should_run/T9497a-run.stderr
- testsuite/tests/typecheck/should_run/T9497b-run.stderr
- testsuite/tests/typecheck/should_run/T9497c-run.stderr
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug973.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/DefaultSignatures.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/PatternSyns.html
- utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/QuasiExpr.html
- utils/haddock/html-test/ref/Test.html
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82d2f00ecbe315c01a922ad8d63c37…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82d2f00ecbe315c01a922ad8d63c37…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/build-opt] 2 commits: Clean up Instances.hs-boot a bit
by Andreas Klebinger (＠AndreasK) 20 Apr '26
by Andreas Klebinger (＠AndreasK) 20 Apr '26
20 Apr '26
Andreas Klebinger pushed to branch wip/andreask/build-opt at Glasgow Haskell Compiler / GHC
Commits:
6aa2e67e by Andreas Klebinger at 2026-04-20T19:45:21+00:00
Clean up Instances.hs-boot a bit
- - - - -
613871fd by Andreas Klebinger at 2026-04-20T19:48:08+00:00
Even better note
- - - - -
1 changed file:
- compiler/GHC/Hs/Instances.hs-boot
Changes:
=====================================
compiler/GHC/Hs/Instances.hs-boot
=====================================
@@ -2,35 +2,8 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--- This module contains exclusively Data instances, which are going to be slow
--- no matter what we do. Furthermore, they are incredibly slow to compile with
--- optimisation (see #9557). Consequently we compile this with -O0.
--- See #18254.
-
module GHC.Hs.Instances where
--- This module defines the Data instances for the hsSyn AST.
-
--- It happens here to avoid massive constraint types on the AST with concomitant
--- slow GHC bootstrap times.
-
--- UndecidableInstances ?
-
-{- Note [Data.Data instances for GHC AST Types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We give all of the frontend types and their instantiations (HsSyn) and
-some other types Data.Data instances. There are two main motivations to
-do so:
-
-* For users of the GHC API it allows to write Generic code over the GHC AST.
-* GHC itself has a few uses of these as well:
- * In the showAstData, showAstDataFull helpers to print a representation of
- the actual AST using it's constructors rather than just user facing pretty printing.
- * It's used to some degree for HIE file generation in the ToHIE instances.
- * TH serialization uses it for serialization of Annotations (GHC.Serialized)
- * Some of the dump flags use showAstData to produce the actual dump output.
--}
-
{- Note [hs-boot files as "header" files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can use hs-boot files like C header files to unlock parallel
@@ -64,8 +37,10 @@ inlining things from TakesForever.hs or needs to know the exact representation o
types for unboxing or similar this trick will do more harm than good.
For GHC itself we can figure out where it makes sense to insert such "header" boot
-files by looking at a build profile and look for places where the build sequentializes
-to one or two concurrent GHC invocations.
+files by looking at a build profile generated by shake.
+They can be generated via `--profile=report.trace` and looking for places where
+the build sequentializes to one or two concurrent GHC invocations is visually
+pretty obvious in those cases.
-}
import Data.Data hiding ( Fixity )
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c930572d0e0d369147ba23f99f8e3a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c930572d0e0d369147ba23f99f8e3a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/build-opt] 2 commits: Update note
by Andreas Klebinger (＠AndreasK) 20 Apr '26
by Andreas Klebinger (＠AndreasK) 20 Apr '26
20 Apr '26
Andreas Klebinger pushed to branch wip/andreask/build-opt at Glasgow Haskell Compiler / GHC
Commits:
2b309962 by Andreas Klebinger at 2026-04-20T19:42:42+00:00
Update note
- - - - -
c930572d by Andreas Klebinger at 2026-04-20T19:43:41+00:00
Reference Note more places
- - - - -
2 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Instances.hs-boot
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -280,6 +280,7 @@ import GHC.Utils.Error (emptyDiagOpts, logInfo)
import GHC.Settings
import GHC.CmmToAsm.CFG.Weight
import GHC.Core.Opt.CallerCC
+-- See Note [hs-boot files as "header" files]
import {-# SOURCE #-} GHC.Parser (parseIdentifier) -- build time optimization
import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..))
import GHC.Stg.Debug.Types
=====================================
compiler/GHC/Hs/Instances.hs-boot
=====================================
@@ -49,10 +49,10 @@ TakesForver.hs -> Depends.hs -> Step2-1.hs
If inlining thinks from `TakesForever` isn't performance critical we can
change it using SOURCE imports such that we have:
-TakesForver.hs -> Depends.hs -> Step2-1.hs
- | -> Step2-2.hs
- | -> Step2-3.hs
- | -> Step2-4.hs
+TakesForver.hs-boot -> Depends.hs -> Step2-1.hs
+ | -> Step2-2.hs
+ | -> Step2-3.hs
+ | -> Step2-4.hs
This replaces TakesForever.hs with TakesForever.hs-boot which will compile
in no time at all reducing the compile time along the critical path significantly.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee3550f91f54aa9e783edca1292f52…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee3550f91f54aa9e783edca1292f52…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/build-opt] 17 commits: Migrate `ghc-pkg` to use `OsPath` and `file-io`
by Andreas Klebinger (＠AndreasK) 20 Apr '26
by Andreas Klebinger (＠AndreasK) 20 Apr '26
20 Apr '26
Andreas Klebinger pushed to branch wip/andreask/build-opt at Glasgow Haskell Compiler / GHC
Commits:
7666f4a9 by Fendor at 2026-04-17T22:29:51-04:00
Migrate `ghc-pkg` to use `OsPath` and `file-io`
`ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH
issues on windows.
`file-io` uses UNC Paths by default on windows, ensuring we use the
correct APIs and that we finally are no longer plagued by MAX_PATH
issues in CI and private machines.
On top of it, the higher correctness of `OsPath` is appreciated in this
small codebase. Also, we improve memory usage very slightly, due to the
more efficient memory representation of `OsPath` over `FilePath`
Adds `ghc-pkg` regression test for MAX_PATH on windows
Make sure `ghc-pkg` behaves as expected when long paths (> 255) are
involved on windows.
Let's generate a testcase where we can actually observe that `ghc-pkg`
behaves as epxected.
See the documentation for windows on Maximum Path Length Limitation:
* `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation`
Adds changelog entry for long path support in ghc-pkg.
- - - - -
78434e8c by Simon Peyton Jones at 2026-04-17T22:30:38-04:00
Kill off the substitution in Lint
Now that we have invariant (NoTypeShadowing) we no longer
need Lint to carry an ambient substitution. This makes it
simpler and faster. A really worthwhile refactor.
There are some knock-on effects
* Linting join points after worker/wrapper. See
Note [Join points and beta redexes]
* Running a type substitution after the desugarer.
See Note [Substituting type-lets] in
the new module GHC.Core.SubstTypeLets
Implements #27078
Most perf tests don't use Lint so we won't see a perf incresae.
But T1969, which uses -O0 and Lint, gets 1.3% worse because it has
to run the SubstTypeLets pass which is a somewhat expensive no-op
Overall though compile-time allocations are down 0.1%.
Metric Increase:
T1969
- - - - -
86ca6c2c by mangoiv at 2026-04-17T22:31:22-04:00
testsuite: inline elemCoreTest
Some weird (probably python scoping) rule caused elemCoreTest, a regex
being out of scope on ubuntu, presumably because of a newer python version.
This patch just inlines the regex, which fixes the issue.
Fixes #27193
- - - - -
1f30005b by Andreas Klebinger at 2026-04-19T21:48:05+00:00
SOURCE import parseIdentifer to improve parallelism.
- - - - -
e96b8d63 by Andreas Klebinger at 2026-04-19T21:48:05+00:00
CallerCC: Remove CoreM dependency
Pass DynFlags directly, making the dependency graph more parallel.
- - - - -
26090197 by Andreas Klebinger at 2026-04-19T21:58:28+00:00
SOURCE-import HsInstances inside ghc.
Fixes #27198 by SOURCE importing HsInstances unlocking
more build paralleism.
(cherry picked from commit 7e53835977538e3c37e5d78502ff422ad87d4f9d)
- - - - -
cb679710 by Andreas Klebinger at 2026-04-19T22:06:08+00:00
HsInstances - fix a warning
- - - - -
f5722894 by Andreas Klebinger at 2026-04-20T15:11:06+00:00
SOURCE import GHC.Types.Error in some places for build parallelism.
Performance for these interfaces is not very relevant since it's only used for error handling.
This means we can use SOURCE imports to shorten the critical build path
by a non trivial amount.
- - - - -
a64cd962 by Andreas Klebinger at 2026-04-20T15:11:26+00:00
Split GHC.Driver.Main.hs up into multiple components.
This module was getting far too large to reason about, it split it
into components that all are re-exported from GHC.Driver.Main
- - - - -
cf62c053 by Andreas Klebinger at 2026-04-20T15:42:58+00:00
Fix hs-boot import
- - - - -
e6550ad1 by Andreas Klebinger at 2026-04-20T15:45:33+00:00
Fix hs-boot import2
- - - - -
900317b2 by Andreas Klebinger at 2026-04-20T15:54:23+00:00
Use SOURCE header for Driver.Main.Compiler import
- - - - -
8de7314b by Andreas Klebinger at 2026-04-20T16:23:24+00:00
more hs-boot workarounds
- - - - -
c6ce86ca by Andreas Klebinger at 2026-04-20T17:15:07+00:00
Driver interactive boot import
- - - - -
19fd9f7e by Andreas Klebinger at 2026-04-20T17:18:27+00:00
deSugar SOURCE header
- - - - -
eff8fd32 by Andreas Klebinger at 2026-04-20T17:27:00+00:00
Add GHC.Tc.Deriv.hs-boot
- - - - -
ee3550f9 by Andreas Klebinger at 2026-04-20T18:56:35+00:00
Remove a potentially pointless import
- - - - -
44 changed files:
- + changelog.d/ghc-pkg-long-path-support
- compiler/GHC/Core/Lint.hs
- + compiler/GHC/Core/Lint/SubstTypeLets.hs
- compiler/GHC/Core/Opt/CallerCC.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Stats.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Main.hs
- + compiler/GHC/Driver/Main/Compile.hs
- compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot
- + compiler/GHC/Driver/Main/Hsc.hs
- + compiler/GHC/Driver/Main/Interactive.hs
- + compiler/GHC/Driver/Main/Passes.hs
- + compiler/GHC/Driver/Main/Passes.hs-boot
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Instances.hs
- + compiler/GHC/Hs/Instances.hs-boot
- + compiler/GHC/HsToCore.hs-boot
- compiler/GHC/Iface/Load.hs
- + compiler/GHC/Tc/Deriv.hs-boot
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/Instance.hs-boot
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Error.hs-boot
- compiler/GHC/Unit/State.hs
- compiler/ghc.cabal.in
- libraries/base/tests/perf/all.T
- libraries/ghc-boot/GHC/Unit/Database.hs
- libraries/ghc-boot/ghc-boot.cabal.in
- testsuite/tests/cabal/Makefile
- testsuite/tests/cabal/all.T
- + testsuite/tests/cabal/ghcpkg10.stdout
- testsuite/tests/corelint/LintEtaExpand.stderr
- testsuite/tests/corelint/T21115b.stderr
- utils/ghc-pkg/Main.hs
- utils/ghc-pkg/ghc-pkg.cabal.in
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c622f0df932d3d0e0a36ec171499a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c622f0df932d3d0e0a36ec171499a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0