[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Improve stg lint for unboxed sums.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 25 12:06:09 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8d2dbe2d by Andreas Klebinger at 2022-10-24T15:59:41-04:00
Improve stg lint for unboxed sums.
It now properly lints cases where sums end up distributed
over multiple args after unarise.
Fixes #22026.
- - - - -
d04f94d3 by Sylvain Henry at 2022-10-25T08:05:32-04:00
Enable popcount rewrite rule when cross-compiling
The comment applies only when host's word size < target's word size.
So we can relax the guard.
- - - - -
b6083055 by Sylvain Henry at 2022-10-25T08:05:39-04:00
Add GHC.SysTools.Cpp module
Move doCpp out of the driver to be able to use it in the upcoming JS backend.
- - - - -
e318bfde by Krzysztof Gogolewski at 2022-10-25T08:05:40-04:00
Cleanup String/FastString conversions
Remove unused mkPtrString and isUnderscoreFS.
We no longer use mkPtrString since 1d03d8bef96.
Remove unnecessary conversions between FastString and String and back.
- - - - -
23 changed files:
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/Stats.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Stg/Lint.hs
- + compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Types/CostCentre.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Types/Name/Occurrence.hs-boot
- compiler/GHC/Unit/State.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -2244,7 +2244,7 @@ builtinBignumRules =
-- We use a host Int to compute the popCount. If we compile on a 32-bit
-- host for a 64-bit target, the result may be different than if computed
-- by the target. So we disable this rule if sizes don't match.
- guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word))
+ guard (platformWordSizeInBits platform <= finiteBitSize (0 :: Word))
[a0] <- getArgs
x <- isBignumLiteral a0
pure $ Lit (mk_lit platform (fromIntegral (popCount x)))
=====================================
compiler/GHC/Core/Opt/Stats.hs
=====================================
@@ -213,7 +213,7 @@ pprTickCounts counts
pprTickGroup :: NonEmpty (Tick, Int) -> SDoc
pprTickGroup group@((tick1,_) :| _)
- = hang (int (sum (fmap snd group)) <+> text (tickString tick1))
+ = hang (int (sum (fmap snd group)) <+> pprTickType tick1)
2 (vcat [ int n <+> pprTickCts tick
-- flip as we want largest first
| (tick,n) <- sortOn (Down . snd) (NE.toList group)])
@@ -242,7 +242,7 @@ data Tick -- See Note [Which transformations are innocuous]
| SimplifierDone -- Ticked at each iteration of the simplifier
instance Outputable Tick where
- ppr tick = text (tickString tick) <+> pprTickCts tick
+ ppr tick = pprTickType tick <+> pprTickCts tick
instance Eq Tick where
a == b = case a `cmpTick` b of
@@ -270,23 +270,23 @@ tickToTag (FillInCaseDefault _) = 13
tickToTag SimplifierDone = 16
tickToTag (AltMerge _) = 17
-tickString :: Tick -> String
-tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
-tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
-tickString (UnfoldingDone _) = "UnfoldingDone"
-tickString (RuleFired _) = "RuleFired"
-tickString LetFloatFromLet = "LetFloatFromLet"
-tickString (EtaExpansion _) = "EtaExpansion"
-tickString (EtaReduction _) = "EtaReduction"
-tickString (BetaReduction _) = "BetaReduction"
-tickString (CaseOfCase _) = "CaseOfCase"
-tickString (KnownBranch _) = "KnownBranch"
-tickString (CaseMerge _) = "CaseMerge"
-tickString (AltMerge _) = "AltMerge"
-tickString (CaseElim _) = "CaseElim"
-tickString (CaseIdentity _) = "CaseIdentity"
-tickString (FillInCaseDefault _) = "FillInCaseDefault"
-tickString SimplifierDone = "SimplifierDone"
+pprTickType :: Tick -> SDoc
+pprTickType (PreInlineUnconditionally _) = text "PreInlineUnconditionally"
+pprTickType (PostInlineUnconditionally _)= text "PostInlineUnconditionally"
+pprTickType (UnfoldingDone _) = text "UnfoldingDone"
+pprTickType (RuleFired _) = text "RuleFired"
+pprTickType LetFloatFromLet = text "LetFloatFromLet"
+pprTickType (EtaExpansion _) = text "EtaExpansion"
+pprTickType (EtaReduction _) = text "EtaReduction"
+pprTickType (BetaReduction _) = text "BetaReduction"
+pprTickType (CaseOfCase _) = text "CaseOfCase"
+pprTickType (KnownBranch _) = text "KnownBranch"
+pprTickType (CaseMerge _) = text "CaseMerge"
+pprTickType (AltMerge _) = text "AltMerge"
+pprTickType (CaseElim _) = text "CaseElim"
+pprTickType (CaseIdentity _) = text "CaseIdentity"
+pprTickType (FillInCaseDefault _) = text "FillInCaseDefault"
+pprTickType SimplifierDone = text "SimplifierDone"
pprTickCts :: Tick -> SDoc
pprTickCts (PreInlineUnconditionally v) = ppr v
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -30,8 +30,8 @@
-- * Pointer and size of a Latin-1 encoded string.
-- * Practically no operations.
-- * Outputting them is fast.
--- * Generated by 'mkPtrString'.
--- * Length of string literals (mkPtrString "abc") is computed statically
+-- * Generated by 'mkPtrString#'.
+-- * Length of string literals (mkPtrString# "abc"#) is computed statically
-- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ptext'
-- * Requires manual memory management.
-- Improper use may lead to memory leaks or dangling pointers.
@@ -85,7 +85,6 @@ module GHC.Data.FastString
concatFS,
consFS,
nilFS,
- isUnderscoreFS,
lexicalCompareFS,
uniqCompareFS,
@@ -101,7 +100,6 @@ module GHC.Data.FastString
-- ** Construction
mkPtrString#,
- mkPtrString,
-- ** Deconstruction
unpackPtrString,
@@ -134,7 +132,6 @@ import Foreign.C
import System.IO
import Data.Data
import Data.IORef
-import Data.Char
import Data.Semigroup as Semi
import Foreign
@@ -623,9 +620,6 @@ uniqueOfFS fs = uniq fs
nilFS :: FastString
nilFS = mkFastString ""
-isUnderscoreFS :: FastString -> Bool
-isUnderscoreFS fs = fs == fsLit "_"
-
-- -----------------------------------------------------------------------------
-- Stats
@@ -667,30 +661,6 @@ mkPtrString# :: Addr# -> PtrString
{-# INLINE mkPtrString# #-}
mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#))
--- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1
--- encoding. The original string must not contain non-Latin-1 characters
--- (above codepoint @0xff@).
-{-# NOINLINE[0] mkPtrString #-} -- see rules below
-mkPtrString :: String -> PtrString
-mkPtrString s =
- -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks
- -- and because someone might be using `eqAddr#` to check for string equality.
- unsafePerformIO (do
- let len = length s
- p <- mallocBytes len
- let
- loop :: Int -> String -> IO ()
- loop !_ [] = return ()
- loop n (c:cs) = do
- pokeByteOff p n (fromIntegral (ord c) :: Word8)
- loop (1+n) cs
- loop 0 s
- return (PtrString p len)
- )
-
-{-# RULES "mkPtrString"
- forall x . mkPtrString (unpackCString# x) = mkPtrString# x #-}
-
-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding.
-- This does not free the memory associated with 'PtrString'.
unpackPtrString :: PtrString -> String
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -73,6 +73,7 @@ import GHC.Driver.Hooks
import GHC.Platform.Ways
import GHC.SysTools
+import GHC.SysTools.Cpp
import GHC.Utils.TmpFs
import GHC.Linker.ExtraObj
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -65,9 +65,8 @@ import GHC.Runtime.Loader
import Data.IORef
import GHC.Types.Name.Env
import GHC.Platform.Ways
-import GHC.Platform.ArchOS
import GHC.Driver.LlvmConfigCache (readLlvmConfigCache)
-import GHC.CmmToLlvm.Config (llvmVersionList, LlvmTarget (..), LlvmConfig (..))
+import GHC.CmmToLlvm.Config (LlvmTarget (..), LlvmConfig (..))
import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub)
import GHC.Settings
import System.IO
@@ -79,6 +78,7 @@ import GHC.Unit.Module.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.Config.Finder
import GHC.Rename.Names
+import GHC.SysTools.Cpp
import Language.Haskell.Syntax.Module.Name
import GHC.Unit.Home.ModInfo
@@ -121,7 +121,10 @@ runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do
(hsc_tmpfs hsc_env)
(hsc_dflags hsc_env)
(hsc_unit_env hsc_env)
- False{-not raw-}
+ (CppOpts
+ { cppUseCc = True
+ , cppLinePragmas = True
+ })
input_fn output_fn
return output_fn
runPhase (T_Cmm pipe_env hsc_env input_fn) = do
@@ -620,7 +623,10 @@ runCppPhase hsc_env input_fn output_fn = do
(hsc_tmpfs hsc_env)
(hsc_dflags hsc_env)
(hsc_unit_env hsc_env)
- True{-raw-}
+ (CppOpts
+ { cppUseCc = False
+ , cppLinePragmas = True
+ })
input_fn output_fn
return output_fn
@@ -953,142 +959,6 @@ llvmOptions llvm_config dflags =
ArchRISCV64 -> "lp64d"
_ -> ""
-
--- Note [Filepaths and Multiple Home Units]
-offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
-offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =
- let go = map (augmentByWorkingDirectory dflags)
- in IncludeSpecs (go incs) (go quotes) (go impl)
--- -----------------------------------------------------------------------------
--- Running CPP
-
--- | Run CPP
---
--- UnitEnv is needed to compute MIN_VERSION macros
-doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()
-doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do
- let hscpp_opts = picPOpts dflags
- let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
- let unit_state = ue_units unit_env
- pkg_include_dirs <- mayThrowUnitErr
- (collectIncludeDirs <$> preloadUnitsInfo unit_env)
- -- MP: This is not quite right, the headers which are supposed to be installed in
- -- the package might not be the same as the provided include paths, but it's a close
- -- enough approximation for things to work. A proper solution would be to have to declare which paths should
- -- be propagated to dependent packages.
- let home_pkg_deps =
- [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]
- dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]
-
- let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
- (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
- ++ concatMap includePathsGlobal dep_pkg_extra_inputs)
- let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
- (includePathsQuote cmdline_include_paths ++
- includePathsQuoteImplicit cmdline_include_paths)
- let include_paths = include_paths_quote ++ include_paths_global
-
- let verbFlags = getVerbFlags dflags
-
- let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args
- | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags
- (GHC.SysTools.Option "-E" : args)
-
- let platform = targetPlatform dflags
- targetArch = stringEncodeArch $ platformArch platform
- targetOS = stringEncodeOS $ platformOS platform
- isWindows = platformOS platform == OSMinGW32
- let target_defs =
- [ "-D" ++ HOST_OS ++ "_BUILD_OS",
- "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
- "-D" ++ targetOS ++ "_HOST_OS",
- "-D" ++ targetArch ++ "_HOST_ARCH" ]
- -- remember, in code we *compile*, the HOST is the same our TARGET,
- -- and BUILD is the same as our HOST.
-
- let io_manager_defs =
- [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++
- [ "-D__IO_MANAGER_MIO__=1" ]
-
- let sse_defs =
- [ "-D__SSE__" | isSseEnabled platform ] ++
- [ "-D__SSE2__" | isSse2Enabled platform ] ++
- [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
-
- let avx_defs =
- [ "-D__AVX__" | isAvxEnabled dflags ] ++
- [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
- [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
- [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
- [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
- [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
-
- backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags
-
- let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
- -- Default CPP defines in Haskell source
- ghcVersionH <- getGhcVersionPathName dflags unit_env
- let hsSourceCppOpts = [ "-include", ghcVersionH ]
-
- -- MIN_VERSION macros
- let uids = explicitUnits unit_state
- pkgs = mapMaybe (lookupUnit unit_state . fst) uids
- mb_macro_include <-
- if not (null pkgs) && gopt Opt_VersionMacros dflags
- then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"
- writeFile macro_stub (generatePackageVersionMacros pkgs)
- -- Include version macros for every *exposed* package.
- -- Without -hide-all-packages and with a package database
- -- size of 1000 packages, it takes cpp an estimated 2
- -- milliseconds to process this file. See #10970
- -- comment 8.
- return [GHC.SysTools.FileOption "-include" macro_stub]
- else return []
-
- cpp_prog ( map GHC.SysTools.Option verbFlags
- ++ map GHC.SysTools.Option include_paths
- ++ map GHC.SysTools.Option hsSourceCppOpts
- ++ map GHC.SysTools.Option target_defs
- ++ map GHC.SysTools.Option backend_defs
- ++ map GHC.SysTools.Option th_defs
- ++ map GHC.SysTools.Option hscpp_opts
- ++ map GHC.SysTools.Option sse_defs
- ++ map GHC.SysTools.Option avx_defs
- ++ map GHC.SysTools.Option io_manager_defs
- ++ mb_macro_include
- -- Set the language mode to assembler-with-cpp when preprocessing. This
- -- alleviates some of the C99 macro rules relating to whitespace and the hash
- -- operator, which we tend to abuse. Clang in particular is not very happy
- -- about this.
- ++ [ GHC.SysTools.Option "-x"
- , GHC.SysTools.Option "assembler-with-cpp"
- , GHC.SysTools.Option input_fn
- -- We hackily use Option instead of FileOption here, so that the file
- -- name is not back-slashed on Windows. cpp is capable of
- -- dealing with / in filenames, so it works fine. Furthermore
- -- if we put in backslashes, cpp outputs #line directives
- -- with *double* backslashes. And that in turn means that
- -- our error messages get double backslashes in them.
- -- In due course we should arrange that the lexer deals
- -- with these \\ escapes properly.
- , GHC.SysTools.Option "-o"
- , GHC.SysTools.FileOption "" output_fn
- ])
-
-applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]
-applyCDefs NoCDefs _ _ = return []
-applyCDefs LlvmCDefs logger dflags = do
- llvmVer <- figureLlvmVersion logger dflags
- return $ case fmap llvmVersionList llvmVer of
- Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
- Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
- _ -> []
- where
- format (major, minor)
- | minor >= 100 = error "backendCDefs: Unsupported minor version"
- | otherwise = show (100 * major + minor :: Int) -- Contract is Int
-
-
-- | What phase to run after one of the backend code generators has run
hscPostBackendPhase :: HscSource -> Backend -> Phase
hscPostBackendPhase HsBootFile _ = StopLn
@@ -1279,22 +1149,6 @@ touchObjectFile logger dflags path = do
createDirectoryIfMissing True $ takeDirectory path
GHC.SysTools.touch logger dflags "Touching object file" path
--- | Find out path to @ghcversion.h@ file
-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
-getGhcVersionPathName dflags unit_env = do
- candidates <- case ghcVersionFile dflags of
- Just path -> return [path]
- Nothing -> do
- ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
- return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
-
- found <- filterM doesFileExist candidates
- case found of
- [] -> throwGhcExceptionIO (InstallationError
- ("ghcversion.h missing; tried: "
- ++ intercalate ", " candidates))
- (x:_) -> return x
-
-- Note [-fPIC for assembler]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
-- When compiling .c source file GHC's driver pipeline basically
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -158,7 +158,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
occName n = braces $
text "OccName:"
- <+> text (occNameString n)
+ <+> ftext (occNameFS n)
moduleName :: ModuleName -> SDoc
moduleName m = braces $ text "ModuleName:" <+> ppr m
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -423,7 +423,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
arg_cname n stg_ty
| libffi = char '*' <> parens (stg_ty <> char '*') <>
text "args" <> brackets (int (n-1))
- | otherwise = text ('a':show n)
+ | otherwise = char 'a' <> int n
-- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target
@@ -552,16 +552,16 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
]
mkHObj :: Type -> SDoc
-mkHObj t = text "rts_mk" <> text (showFFIType t)
+mkHObj t = text "rts_mk" <> showFFIType t
unpackHObj :: Type -> SDoc
-unpackHObj t = text "rts_get" <> text (showFFIType t)
+unpackHObj t = text "rts_get" <> showFFIType t
showStgType :: Type -> SDoc
-showStgType t = text "Hs" <> text (showFFIType t)
+showStgType t = text "Hs" <> showFFIType t
-showFFIType :: Type -> String
-showFFIType t = getOccString (getName (typeTyCon t))
+showFFIType :: Type -> SDoc
+showFFIType t = ftext (occNameFS (getOccName (typeTyCon t)))
typeTyCon :: Type -> TyCon
typeTyCon ty
=====================================
compiler/GHC/HsToCore/Pmc/Solver/Types.hs
=====================================
@@ -766,7 +766,7 @@ it's already overloaded.
instance Outputable PmLitValue where
ppr (PmLitInt i) = ppr i
- ppr (PmLitRat r) = ppr (double (fromRat r)) -- good enough
+ ppr (PmLitRat r) = double (fromRat r) -- good enough
ppr (PmLitChar c) = pprHsChar c
ppr (PmLitString s) = pprHsString s
ppr (PmLitOverInt n i) = minuses n (ppr i)
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -744,7 +744,7 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
MkC cc' <- repCCallConv cc
MkC s' <- repSafety s
cis' <- conv_cimportspec cis
- MkC str <- coreStringLit (static ++ chStr ++ cis')
+ MkC str <- coreStringLit (mkFastString (static ++ chStr ++ cis'))
dec <- rep2 forImpDName [cc', s', str, name', typ']
return (locA loc, dec)
where
@@ -818,7 +818,7 @@ repRuleD (L loc (HsRule { rd_name = n
; tm_bndrs' <- repListM ruleBndrTyConName
repRuleBndr
tm_bndrs
- ; n' <- coreStringLit $ unpackFS $ unLoc n
+ ; n' <- coreStringLit $ unLoc n
; act' <- repPhases act
; lhs' <- repLE lhs
; rhs' <- repLE rhs
@@ -1861,7 +1861,7 @@ rep_implicit_param_bind (L loc (IPBind _ (L _ n) (L _ rhs)))
; return (locA loc, ipb) }
rep_implicit_param_name :: HsIPName -> MetaM (Core String)
-rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
+rep_implicit_param_name (HsIPName name) = coreStringLit name
rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-- Assumes: all the binders of the binding are already in the meta-env
@@ -2195,8 +2195,8 @@ globalVar name
; rep2_nwDsM mkNameLName [occ,uni] }
where
mod = assert (isExternalName name) nameModule name
- name_mod = moduleNameString (moduleName mod)
- name_pkg = unitString (moduleUnit mod)
+ name_mod = moduleNameFS (moduleName mod)
+ name_pkg = unitFS (moduleUnit mod)
name_occ = nameOccName name
mk_varg | isDataOcc name_occ = mkNameG_dName
| isVarOcc name_occ = mkNameG_vName
@@ -2235,10 +2235,10 @@ wrapGenSyms binds body@(MkC b)
gensym_app (MkC (Lam id body')) }
nameLit :: Name -> DsM (Core String)
-nameLit n = coreStringLit (occNameString (nameOccName n))
+nameLit n = coreStringLit (occNameFS (nameOccName n))
occNameLit :: OccName -> MetaM (Core String)
-occNameLit name = coreStringLit (occNameString name)
+occNameLit name = coreStringLit (occNameFS name)
-- %*********************************************************************
@@ -2416,7 +2416,7 @@ repDoBlock doName maybeModName (MkC ss) = do
coreModNameM :: MetaM (Core (Maybe TH.ModName))
coreModNameM = case maybeModName of
Just m -> do
- MkC s <- coreStringLit (moduleNameString m)
+ MkC s <- coreStringLit (moduleNameFS m)
mName <- rep2_nw mkModNameName [s]
coreJust modNameTyConName mName
_ -> coreNothing modNameTyConName
@@ -2950,17 +2950,17 @@ repUnboundVar (MkC name) = rep2 unboundVarEName [name]
repOverLabel :: FastString -> MetaM (Core (M TH.Exp))
repOverLabel fs = do
- (MkC s) <- coreStringLit $ unpackFS fs
+ MkC s <- coreStringLit fs
rep2 labelEName [s]
repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp))
repGetField (MkC exp) fs = do
- MkC s <- coreStringLit $ unpackFS fs
+ MkC s <- coreStringLit fs
rep2 getFieldEName [exp,s]
repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp))
repProjection fs = do
- MkC xs <- coreListNonEmpty stringTy <$> mapM (coreStringLit . unpackFS) fs
+ MkC xs <- coreListNonEmpty stringTy <$> mapM coreStringLit fs
rep2 projectionEName [xs]
------------ Lists -------------------
@@ -3004,8 +3004,8 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a]
nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs))
-coreStringLit :: MonadThings m => String -> m (Core String)
-coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
+coreStringLit :: MonadThings m => FastString -> m (Core String)
+coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) }
------------------- Maybe ------------------
=====================================
compiler/GHC/Parser.y
=====================================
@@ -67,7 +67,7 @@ import GHC.Prelude
import qualified GHC.Data.Strict as Strict
import GHC.Types.Name.Reader
-import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString)
+import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS, occNameString)
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Error ( GhcHint(..) )
@@ -3447,7 +3447,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) }
final = last fields
l = comb2 (reLoc $1) $3
isPun = True
- var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOcc . unpackFS . field_label . unLoc . dfoLabel . unLoc $ final))
+ var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final))
fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []
}
@@ -3830,7 +3830,7 @@ special_id
special_sym :: { Located FastString }
special_sym : '.' { sL1 $1 (fsLit ".") }
- | '*' { sL1 $1 (fsLit (starSym (isUnicode $1))) }
+ | '*' { sL1 $1 (starSym (isUnicode $1)) }
-----------------------------------------------------------------------------
-- Data constructors
=====================================
compiler/GHC/Parser/HaddockLex.x
=====================================
@@ -148,7 +148,7 @@ lexStringLiteral identParser (L l sl@(StringLiteral _ fs _))
RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs]
UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs]
- fakeLoc = mkRealSrcLoc (mkFastString "") 0 0
+ fakeLoc = mkRealSrcLoc nilFS 0 0
-- | Lex identifiers from a docstring.
lexHsDoc :: P (LocatedN RdrName) -- ^ A precise identifier parser
@@ -169,7 +169,7 @@ lexHsDoc identParser doc =
plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s))
= [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason
- fakeLoc = mkRealSrcLoc (mkFastString "") 0 0
+ fakeLoc = mkRealSrcLoc nilFS 0 0
validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName)
validateIdentWith identParser mloc str0 =
@@ -191,7 +191,7 @@ validateIdentWith identParser mloc str0 =
buffer = stringBufferFromByteString str0
realSrcLc = case mloc of
RealSrcSpan loc _ -> realSrcSpanStart loc
- UnhelpfulSpan _ -> mkRealSrcLoc (mkFastString "") 0 0
+ UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0
pstate = initParserState pflags buffer realSrcLc
in case unP identParser pstate of
POk _ name -> Just $ case mloc of
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -965,8 +965,7 @@ mkRuleTyVarBndrs = fmap cvt_one
checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
where check (L loc (Unqual occ)) =
- -- TODO: don't use string here, OccName has a Unique/FastString
- when ((occNameString occ ==) `any` ["forall","family","role"])
+ when (occNameFS occ `elem` [fsLit "forall",fsLit "family",fsLit "role"])
(addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrParseErrorOnInput occ))
check _ = panic "checkRuleTyVarBndrNames"
@@ -1009,7 +1008,7 @@ checkTyClHdr is_cls ty
-- workaround to define '*' despite StarIsType
go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
= do { addPsMessage (locA l) PsWarnStarBinder
- ; let name = mkOccName tcClsName (starSym isUni)
+ ; let name = mkOccNameFS tcClsName (starSym isUni)
; let a' = newAnns l an
; return (L a' (Unqual name), acc, fix
, (reverse ops') ++ cps') }
@@ -2776,7 +2775,7 @@ mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
--
mkExtName :: RdrName -> CLabelString
-mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
+mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm)
--------------------------------------------------------------------------------
-- Help with module system imports/exports
@@ -3142,9 +3141,9 @@ token_location_widenR (TokenLoc (EpaDelta _ _)) _ =
-----------------------------------------------------------------------------
-- Token symbols
-starSym :: Bool -> String
-starSym True = "★"
-starSym False = "*"
+starSym :: Bool -> FastString
+starSym True = fsLit "★"
+starSym False = fsLit "*"
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -46,9 +46,18 @@ are as follows:
t_1 :: TYPE r_1, ..., t_n :: TYPE r_n
s_1 :: TYPE p_1, ..., a_n :: TYPE p_n
-Then we must check that each r_i is compatible with s_i. Compatibility
-is weaker than on-the-nose equality: for example, IntRep and WordRep are
-compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.
+Before unarisation, we must check that each r_i is compatible with s_i.
+Compatibility is weaker than on-the-nose equality: for example,
+IntRep and WordRep are compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.
+
+After unarisation, a single type might correspond to multiple arguments, e.g.
+
+ (# Int# | Bool #) :: TYPE (SumRep '[ IntRep, LiftedRep ])
+
+will result in two arguments: [Int# :: TYPE 'IntRep, Bool :: TYPE LiftedRep]
+This means post unarise we potentially have to match up multiple arguments with
+the reps of a single argument in the type's definition, because the type of the function
+is *not* in unarised form.
Wrinkle: it can sometimes happen that an argument type in the type of
the function does not have a fixed runtime representation, i.e.
@@ -119,7 +128,7 @@ import Data.Maybe
import GHC.Utils.Misc
import GHC.Core.Multiplicity (scaledThing)
import GHC.Settings (Platform)
-import GHC.Core.TyCon (primRepCompatible)
+import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
import GHC.Utils.Panic.Plain (panic)
lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
@@ -332,14 +341,18 @@ lintStgAppReps _fun [] = return ()
lintStgAppReps fun args = do
lf <- getLintFlags
let platform = lf_platform lf
+
(fun_arg_tys, _res) = splitFunTys (idType fun)
- fun_arg_tys' = map (scaledThing ) fun_arg_tys :: [Type]
+ fun_arg_tys' = map scaledThing fun_arg_tys :: [Type]
+
+ -- Might be "wrongly" typed as polymorphic. See #21399
+ -- In these cases typePrimRep_maybe will return Nothing
+ -- and we abort kind checking.
fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'
actual_arg_reps = map (typePrimRep_maybe . stgArgType) args
match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
- -- Might be wrongly typed as polymorphic. See #21399
match_args (Nothing:_) _ = return ()
match_args (_) (Nothing:_) = return ()
match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left)
@@ -353,21 +366,36 @@ lintStgAppReps fun args = do
-- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.
-- We check for that here with primRepCompatible
- | and $ zipWith (primRepCompatible platform) actual_rep expected_rep
+ | primRepsCompatible platform actual_rep expected_rep
= match_args actual_reps_left expected_reps_left
+ -- We might distribute args from within one unboxed sum over multiple
+ -- single rep args. This means we might need to match up things like:
+ -- [Just [WordRep, LiftedRep]] with [Just [WordRep],Just [LiftedRep]]
+ -- which happens here.
+ -- See Note [Linting StgApp].
+ | Just (actual,actuals) <- getOneRep actual_rep actual_reps_left
+ , Just (expected,expecteds) <- getOneRep expected_rep expected_reps_left
+ , primRepCompatible platform actual expected
+ = match_args actuals expecteds
+
| otherwise = addErrL $ hang (text "Function type reps and function argument reps mismatched") 2 $
(text "In application " <> ppr fun <+> ppr args $$
- text "argument rep:" <> ppr actual_rep $$
- text "expected rep:" <> ppr expected_rep $$
+ text "argument rep:" <> ppr actual_arg_reps $$
+ text "expected rep:" <> ppr fun_arg_tys_reps $$
-- text "expected reps:" <> ppr arg_ty_reps $$
text "unarised?:" <> ppr (lf_unarised lf))
where
isVoidRep [] = True
isVoidRep [VoidRep] = True
isVoidRep _ = False
-
- -- n_arg_ty_reps = length arg_ty_reps
+ -- Try to strip one non-void arg rep from the current argument type returning
+ -- the remaining list of arguments. We return Nothing for invalid input which
+ -- will result in a lint failure in match_args.
+ getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
+ getOneRep [] _rest = Nothing -- Void rep args are invalid at this point.
+ getOneRep [rep] rest = Just (rep,rest) -- A single arg rep arg
+ getOneRep (rep:reps) rest = Just (rep,Just reps:rest) -- Multi rep arg.
match_args _ _ = return () -- Functions are allowed to be over/under applied.
=====================================
compiler/GHC/SysTools/Cpp.hs
=====================================
@@ -0,0 +1,234 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+
+#include <ghcplatform.h>
+
+module GHC.SysTools.Cpp
+ ( doCpp
+ , CppOpts (..)
+ , getGhcVersionPathName
+ , applyCDefs
+ , offsetIncludePaths
+ )
+where
+
+import GHC.Prelude
+import GHC.Driver.Session
+import GHC.Driver.Backend
+import GHC.CmmToLlvm.Config
+import GHC.Platform
+import GHC.Platform.ArchOS
+
+import GHC.SysTools
+
+import GHC.Unit.Env
+import GHC.Unit.Info
+import GHC.Unit.State
+import GHC.Unit.Types
+
+import GHC.Utils.Logger
+import GHC.Utils.TmpFs
+import GHC.Utils.Panic
+
+import Data.Version
+import Data.List (intercalate)
+import Data.Maybe
+
+import Control.Monad
+
+import System.Directory
+import System.FilePath
+
+data CppOpts = CppOpts
+ { cppUseCc :: !Bool -- ^ Use "cc -E" as preprocessor, otherwise use "cpp"
+ , cppLinePragmas :: !Bool -- ^ Enable generation of LINE pragmas
+ }
+
+-- | Run CPP
+--
+-- UnitEnv is needed to compute MIN_VERSION macros
+doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO ()
+doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
+ let hscpp_opts = picPOpts dflags
+ let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
+ let unit_state = ue_units unit_env
+ pkg_include_dirs <- mayThrowUnitErr
+ (collectIncludeDirs <$> preloadUnitsInfo unit_env)
+ -- MP: This is not quite right, the headers which are supposed to be installed in
+ -- the package might not be the same as the provided include paths, but it's a close
+ -- enough approximation for things to work. A proper solution would be to have to declare which paths should
+ -- be propagated to dependent packages.
+ let home_pkg_deps =
+ [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]
+ dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]
+
+ let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+ (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
+ ++ concatMap includePathsGlobal dep_pkg_extra_inputs)
+ let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+ (includePathsQuote cmdline_include_paths ++
+ includePathsQuoteImplicit cmdline_include_paths)
+ let include_paths = include_paths_quote ++ include_paths_global
+
+ let verbFlags = getVerbFlags dflags
+
+ let cpp_prog args
+ | cppUseCc opts = GHC.SysTools.runCc Nothing logger tmpfs dflags
+ (GHC.SysTools.Option "-E" : args)
+ | otherwise = GHC.SysTools.runCpp logger dflags args
+
+ let platform = targetPlatform dflags
+ targetArch = stringEncodeArch $ platformArch platform
+ targetOS = stringEncodeOS $ platformOS platform
+ isWindows = platformOS platform == OSMinGW32
+ let target_defs =
+ [ "-D" ++ HOST_OS ++ "_BUILD_OS",
+ "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
+ "-D" ++ targetOS ++ "_HOST_OS",
+ "-D" ++ targetArch ++ "_HOST_ARCH" ]
+ -- remember, in code we *compile*, the HOST is the same our TARGET,
+ -- and BUILD is the same as our HOST.
+
+ let io_manager_defs =
+ [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++
+ [ "-D__IO_MANAGER_MIO__=1" ]
+
+ let sse_defs =
+ [ "-D__SSE__" | isSseEnabled platform ] ++
+ [ "-D__SSE2__" | isSse2Enabled platform ] ++
+ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
+
+ let avx_defs =
+ [ "-D__AVX__" | isAvxEnabled dflags ] ++
+ [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
+ [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
+ [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
+ [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
+ [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
+
+ backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags
+
+ let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
+ -- Default CPP defines in Haskell source
+ ghcVersionH <- getGhcVersionPathName dflags unit_env
+ let hsSourceCppOpts = [ "-include", ghcVersionH ]
+
+ -- MIN_VERSION macros
+ let uids = explicitUnits unit_state
+ pkgs = mapMaybe (lookupUnit unit_state . fst) uids
+ mb_macro_include <-
+ if not (null pkgs) && gopt Opt_VersionMacros dflags
+ then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"
+ writeFile macro_stub (generatePackageVersionMacros pkgs)
+ -- Include version macros for every *exposed* package.
+ -- Without -hide-all-packages and with a package database
+ -- size of 1000 packages, it takes cpp an estimated 2
+ -- milliseconds to process this file. See #10970
+ -- comment 8.
+ return [GHC.SysTools.FileOption "-include" macro_stub]
+ else return []
+
+ let line_pragmas
+ | cppLinePragmas opts = [] -- on by default
+ | otherwise = [GHC.SysTools.Option "-P"] -- disable LINE markers
+
+ cpp_prog ( map GHC.SysTools.Option verbFlags
+ ++ map GHC.SysTools.Option include_paths
+ ++ map GHC.SysTools.Option hsSourceCppOpts
+ ++ map GHC.SysTools.Option target_defs
+ ++ map GHC.SysTools.Option backend_defs
+ ++ map GHC.SysTools.Option th_defs
+ ++ map GHC.SysTools.Option hscpp_opts
+ ++ map GHC.SysTools.Option sse_defs
+ ++ map GHC.SysTools.Option avx_defs
+ ++ map GHC.SysTools.Option io_manager_defs
+ ++ mb_macro_include
+ ++ line_pragmas
+ -- Set the language mode to assembler-with-cpp when preprocessing. This
+ -- alleviates some of the C99 macro rules relating to whitespace and the hash
+ -- operator, which we tend to abuse. Clang in particular is not very happy
+ -- about this.
+ ++ [ GHC.SysTools.Option "-x"
+ , GHC.SysTools.Option "assembler-with-cpp"
+ , GHC.SysTools.Option input_fn
+ -- We hackily use Option instead of FileOption here, so that the file
+ -- name is not back-slashed on Windows. cpp is capable of
+ -- dealing with / in filenames, so it works fine. Furthermore
+ -- if we put in backslashes, cpp outputs #line directives
+ -- with *double* backslashes. And that in turn means that
+ -- our error messages get double backslashes in them.
+ -- In due course we should arrange that the lexer deals
+ -- with these \\ escapes properly.
+ , GHC.SysTools.Option "-o"
+ , GHC.SysTools.FileOption "" output_fn
+ ])
+
+-- ---------------------------------------------------------------------------
+-- Macros (cribbed from Cabal)
+
+generatePackageVersionMacros :: [UnitInfo] -> String
+generatePackageVersionMacros pkgs = concat
+ -- Do not add any C-style comments. See #3389.
+ [ generateMacros "" pkgname version
+ | pkg <- pkgs
+ , let version = unitPackageVersion pkg
+ pkgname = map fixchar (unitPackageNameString pkg)
+ ]
+
+fixchar :: Char -> Char
+fixchar '-' = '_'
+fixchar c = c
+
+generateMacros :: String -> String -> Version -> String
+generateMacros prefix name version =
+ concat
+ ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
+ ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
+ ," (major1) < ",major1," || \\\n"
+ ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
+ ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
+ ,"\n\n"
+ ]
+ where
+ take3 = \case
+ (a:b:c:_) -> (a,b,c)
+ _ -> error "take3"
+ (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0"
+
+
+-- | Find out path to @ghcversion.h@ file
+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
+getGhcVersionPathName dflags unit_env = do
+ candidates <- case ghcVersionFile dflags of
+ Just path -> return [path]
+ Nothing -> do
+ ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
+ return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
+
+ found <- filterM doesFileExist candidates
+ case found of
+ [] -> throwGhcExceptionIO (InstallationError
+ ("ghcversion.h missing; tried: "
+ ++ intercalate ", " candidates))
+ (x:_) -> return x
+
+applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]
+applyCDefs NoCDefs _ _ = return []
+applyCDefs LlvmCDefs logger dflags = do
+ llvmVer <- figureLlvmVersion logger dflags
+ return $ case fmap llvmVersionList llvmVer of
+ Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
+ Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
+ _ -> []
+ where
+ format (major, minor)
+ | minor >= 100 = error "backendCDefs: Unsupported minor version"
+ | otherwise = show (100 * major + minor :: Int) -- Contract is Int
+
+
+-- Note [Filepaths and Multiple Home Units]
+offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
+offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =
+ let go = map (augmentByWorkingDirectory dflags)
+ in IncludeSpecs (go incs) (go quotes) (go impl)
+
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -3781,13 +3781,13 @@ pprConversionFailReason = \case
text "Illegal" <+> pprNameSpace ctxt_ns
<+> text "name:" <+> quotes (text occ)
SumAltArityExceeded alt arity ->
- text "Sum alternative" <+> text (show alt)
- <+> text "exceeds its arity," <+> text (show arity)
+ text "Sum alternative" <+> int alt
+ <+> text "exceeds its arity," <+> int arity
IllegalSumAlt alt ->
- vcat [ text "Illegal sum alternative:" <+> text (show alt)
+ vcat [ text "Illegal sum alternative:" <+> int alt
, nest 2 $ text "Sum alternatives must start from 1" ]
IllegalSumArity arity ->
- vcat [ text "Illegal sum arity:" <+> text (show arity)
+ vcat [ text "Illegal sum arity:" <+> int arity
, nest 2 $ text "Sums must have an arity of at least 2" ]
MalformedType typeOrKind ty ->
text "Malformed " <> text ty_str <+> text (show ty)
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -259,7 +259,7 @@ instance Outputable CostCentre where
ppr cc = getPprStyle $ \ sty ->
if codeStyle sty
then ppCostCentreLbl cc
- else text (costCentreUserName cc)
+ else ftext (costCentreUserNameFS cc)
-- Printing in Core
pprCostCentreCore :: CostCentre -> SDoc
=====================================
compiler/GHC/Types/FieldLabel.hs
=====================================
@@ -188,7 +188,7 @@ fieldSelectorOccName lbl dc dup_fields_ok has_sel
| otherwise = mkVarOccFS fl
where
fl = field_label lbl
- str = ":" ++ unpackFS fl ++ ":" ++ occNameString dc
+ str = concatFS [fsLit ":", fl, fsLit ":", occNameFS dc]
-- | Undo the name mangling described in Note [FieldLabel] to produce a Name
-- that has the user-visible OccName (but the selector's unique). This should
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -904,7 +904,7 @@ pprLiteral add_par (LitLabel l mb fod) =
add_par (text "__label" <+> b <+> ppr fod)
where b = case mb of
Nothing -> pprHsString l
- Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
+ Just x -> doubleQuotes (ftext l <> text ('@':show x))
pprLiteral _ (LitRubbish rep)
= text "RUBBISH" <> parens (ppr rep)
=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -646,8 +646,8 @@ mkGenR = mk_simple_deriv tcName "Rep_"
mkGen1R = mk_simple_deriv tcName "Rep1_"
-- Overloaded record field selectors
-mkRecFldSelOcc :: String -> OccName
-mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]
+mkRecFldSelOcc :: FastString -> OccName
+mkRecFldSelOcc s = mk_deriv varName "$sel" [s]
mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName
mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ]
=====================================
compiler/GHC/Types/Name/Occurrence.hs-boot
=====================================
@@ -1,6 +1,5 @@
module GHC.Types.Name.Occurrence where
-import GHC.Prelude (String)
import GHC.Data.FastString
data OccName
@@ -8,6 +7,6 @@ data OccName
class HasOccName name where
occName :: name -> OccName
-occNameString :: OccName -> String
-mkRecFldSelOcc :: String -> OccName
+occNameFS :: OccName -> FastString
+mkRecFldSelOcc :: FastString -> OccName
mkVarOccFS :: FastString -> OccName
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -2036,7 +2036,7 @@ mayThrowUnitErr = \case
instance Outputable UnitErr where
ppr = \case
CloseUnitErr p mb_parent
- -> (ftext (fsLit "unknown unit:") <+> ppr p)
+ -> (text "unknown unit:" <+> ppr p)
<> case mb_parent of
Nothing -> Outputable.empty
Just parent -> space <> parens (text "dependency of"
=====================================
compiler/ghc.cabal.in
=====================================
@@ -632,6 +632,7 @@ Library
GHC.SysTools
GHC.SysTools.Ar
GHC.SysTools.BaseDir
+ GHC.SysTools.Cpp
GHC.SysTools.Elf
GHC.SysTools.Info
GHC.SysTools.Process
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3423,7 +3423,7 @@ pprStopped res =
text "Stopped in"
<+> ((case mb_mod_name of
Nothing -> empty
- Just mod_name -> text (moduleNameString mod_name) <> char '.')
+ Just mod_name -> ftext (moduleNameFS mod_name) <> char '.')
<> text (GHC.resumeDecl res))
<> char ',' <+> ppr (GHC.resumeSpan res)
where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c42cf2a2cc14673e3dc43efda169740d6224ca1e...e318bfde35bcc6a44fefb703b4d6c8e9cbe78bfe
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c42cf2a2cc14673e3dc43efda169740d6224ca1e...e318bfde35bcc6a44fefb703b4d6c8e9cbe78bfe
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221025/7f40f8a5/attachment-0001.html>
More information about the ghc-commits
mailing list