[Git][ghc/ghc][master] 2 commits: Minor SDoc cleanup
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Sep 7 20:44:17 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ee1cfaa9 by Krzysztof Gogolewski at 2022-09-07T16:43:58-04:00
Minor SDoc cleanup
Change calls to renderWithContext with showSDocOneLine; it's more
efficient and explanatory.
Remove polyPatSig (unused)
- - - - -
7918265d by Krzysztof Gogolewski at 2022-09-07T16:43:58-04:00
Remove Outputable Char instance
Use 'text' instead of 'ppr'.
Using 'ppr' on the list "hello" rendered as "h,e,l,l,o".
- - - - -
23 changed files:
- compiler/GHC/Cmm/Dominators.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/CFG.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/CmmToLlvm/Ppr.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Cmm/Dominators.hs
=====================================
@@ -38,9 +38,7 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm
-import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>)
- , showSDocUnsafe
- )
+import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -188,7 +186,7 @@ gwdRPNumber g l = findLabelIn l (gwd_rpnumbering g)
findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn lbl = mapFindWithDefault failed lbl
where failed =
- panic $ "label " ++ showSDocUnsafe (ppr lbl) ++ " not found in result of analysis"
+ pprPanic "label not found in result of analysis" (ppr lbl)
-- | Use `gwdDominatorsOf` on the result of the dominator analysis to get
-- a mapping from the `Label` of each reachable block to the dominator
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -449,7 +449,7 @@ cmmproc :: { CmmParse () }
platform <- getPlatform;
ctx <- getContext;
formals <- sequence (fromMaybe [] $3);
- withName (renderWithContext ctx (pprCLabel platform CStyle entry_ret_label))
+ withName (showSDocOneLine ctx (pprCLabel platform CStyle entry_ret_label))
$4;
return (entry_ret_label, info, stk_formals, formals) }
let do_layout = isJust $3
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -696,7 +696,7 @@ maybeDumpCfg logger (Just cfg) msg proc_name
checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
-> [NatCmmDecl statics instr]
checkLayout procsUnsequenced procsSequenced =
- assertPpr (setNull diff) (ppr "Block sequencing dropped blocks:" <> ppr diff)
+ assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff)
procsSequenced
where
blocks1 = foldl' (setUnion) setEmpty $
@@ -785,7 +785,7 @@ makeImportsDoc config imports
| otherwise
= Outputable.empty
- doPpr lbl = (lbl, renderWithContext
+ doPpr lbl = (lbl, showSDocOneLine
(ncgAsmContext config)
(pprAsmLabel platform lbl))
=====================================
compiler/GHC/CmmToAsm/CFG.hs
=====================================
@@ -660,7 +660,7 @@ getCfg platform weights graph =
(CmmCall { cml_cont = Nothing }) -> []
other ->
panic "Foo" $
- assertPpr False (ppr "Unknown successor cause:" <>
+ assertPpr False (text "Unknown successor cause:" <>
(pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) $
map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other
where
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -2015,10 +2015,10 @@ genCondBranch' _ bid id false bool = do
-- Use ASSERT so we don't break releases if
-- LTT/LE creep in somehow.
LTT ->
- assertPpr False (ppr "Should have been turned into >")
+ assertPpr False (text "Should have been turned into >")
and_ordered
LE ->
- assertPpr False (ppr "Should have been turned into >=")
+ assertPpr False (text "Should have been turned into >=")
and_ordered
_ -> and_ordered
@@ -3088,9 +3088,9 @@ condFltReg is32Bit cond x y = condFltReg_sse2
GU -> plain_test dst
GEU -> plain_test dst
-- Use ASSERT so we don't break releases if these creep in.
- LTT -> assertPpr False (ppr "Should have been turned into >") $
+ LTT -> assertPpr False (text "Should have been turned into >") $
and_ordered dst
- LE -> assertPpr False (ppr "Should have been turned into >=") $
+ LE -> assertPpr False (text "Should have been turned into >=") $
and_ordered dst
_ -> and_ordered dst)
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -447,7 +447,7 @@ strCLabel_llvm lbl = do
ctx <- llvmCgContext <$> getConfig
platform <- getPlatform
let sdoc = pprCLabel platform CStyle lbl
- str = Outp.renderWithContext ctx sdoc
+ str = Outp.showSDocOneLine ctx sdoc
return (fsLit str)
-- ----------------------------------------------------------------------------
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -1203,10 +1203,10 @@ genStore_slow addr val alignment meta = do
other ->
pprPanic "genStore: ptr not right type!"
- (pdoc platform addr <+> text (
- "Size of Ptr: " ++ show (llvmPtrBits platform) ++
- ", Size of var: " ++ show (llvmWidthInBits platform other) ++
- ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr)))
+ (pdoc platform addr $$
+ text "Size of Ptr:" <+> ppr (llvmPtrBits platform) $$
+ text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$
+ text "Var:" <+> ppVar cfg vaddr)
mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement
mkStore vval vptr alignment =
@@ -1255,7 +1255,7 @@ genExpectLit expLit expTy var = do
lit = LMLitVar $ LMIntLit expLit expTy
llvmExpectName
- | isInt expTy = fsLit $ "llvm.expect." ++ renderWithContext (llvmCgContext cfg) (ppr expTy)
+ | isInt expTy = fsLit $ "llvm.expect." ++ showSDocOneLine (llvmCgContext cfg) (ppr expTy)
| otherwise = panic "genExpectedLit: Type not an int!"
(llvmExpect, stmts, top) <-
@@ -1874,10 +1874,10 @@ genLoad_slow atomic e ty align meta = do
doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align)
other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
- (pdoc platform e <+> text (
- "Size of Ptr: " ++ show (llvmPtrBits platform) ++
- ", Size of var: " ++ show (llvmWidthInBits platform other) ++
- ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr)))
+ (pdoc platform e $$
+ text "Size of Ptr:" <+> ppr (llvmPtrBits platform) $$
+ text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$
+ text "Var:" <+> (ppVar cfg iptr))
{-
Note [Alignment of vector-typed values]
=====================================
compiler/GHC/CmmToLlvm/Ppr.hs
=====================================
@@ -56,7 +56,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
funDec <- llvmFunSig live lbl link
cfg <- getConfig
platform <- getPlatform
- let buildArg = fsLit . renderWithContext (llvmCgContext cfg). ppPlainName cfg
+ let buildArg = fsLit . showSDocOneLine (llvmCgContext cfg). ppPlainName cfg
funArgs = map buildArg (llvmFunArgs platform live)
funSect = llvmFunSection cfg (decName funDec)
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -1213,7 +1213,7 @@ tryUnfolding logger opts !case_depth id lone_variable
, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]
ctx = log_default_dump_context (logFlags logger)
- str = "Considering inlining: " ++ renderWithContext ctx (ppr id)
+ str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id)
n_val_args = length arg_infos
-- some_benefit is used when the RHS is small enough
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -589,7 +589,7 @@ compileForeign hsc_env lang stub_c = do
-- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.
-- and the same should never happen for asPipeline
-- Future refactoring to not check StopC for this case
- Nothing -> pprPanic "compileForeign" (ppr stub_c)
+ Nothing -> pprPanic "compileForeign" (text stub_c)
Just fp -> return fp
compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -860,9 +860,11 @@ getOutputFilename logger tmpfs stop_phase output basename dflags next_phase mayb
| otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule
suffix
where
- getOutputFile_ dflags = case outputFile_ dflags of
- Nothing -> pprPanic "SpecificFile: No filename" (ppr $ (dynamicNow dflags, outputFile_ dflags, dynOutputFile_ dflags))
- Just fn -> fn
+ getOutputFile_ dflags =
+ case outputFile_ dflags of
+ Nothing -> pprPanic "SpecificFile: No filename" (ppr (dynamicNow dflags) $$
+ text (fromMaybe "-" (dynOutputFile_ dflags)))
+ Just fn -> fn
hcsuf = hcSuf dflags
odir = objectDir dflags
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -848,7 +848,7 @@ pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl)
- = ppr (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
+ = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
pprMinimalSig :: (OutputableBndr name)
=> LBooleanFormula (GenLocated l name) -> SDoc
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -333,7 +333,7 @@ dsFCall fn_id co fcall mDeclHeader = do
toCName :: Id -> String
-toCName i = renderWithContext defaultSDocContext (pprCode (ppr (idName i)))
+toCName i = showSDocOneLine defaultSDocContext (pprCode (ppr (idName i)))
toCType :: Type -> (Maybe Header, SDoc)
toCType = f False
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -118,7 +118,7 @@ readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
check_tag <- get bh
let tag = profileBuildTag profile
- wantedGot "Way" tag check_tag ppr
+ wantedGot "Way" tag check_tag text
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file profile tag" tag check_tag
@@ -381,7 +381,7 @@ getSymtabName _name_cache _dict symtab bh = do
in
return $! case lookupKnownKeyName u of
Nothing -> pprPanic "getSymtabName:unknown known-key unique"
- (ppr i $$ ppr (unpkUnique u))
+ (ppr i $$ ppr u)
Just n -> n
_ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -331,7 +331,7 @@ fromHieName nc hie_name = do
KnownKeyName u -> case lookupKnownKeyName u of
Nothing -> pprPanic "fromHieName:unknown known-key unique"
- (ppr (unpkUnique u))
+ (ppr u)
Just n -> pure n
-- ** Reading and writing `HieName`'s
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -774,7 +774,7 @@ hieNameOcc (KnownKeyName u) =
case lookupKnownKeyName u of
Just n -> nameOccName n
Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
- (ppr (unpkUnique u))
+ (ppr u)
toHieName :: Name -> HieName
toHieName name
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -653,14 +653,14 @@ checkDependencies hsc_env summary iface
text "package " <> quotes (ppr old) <>
text "no longer in dependencies"
return $ needsRecompileBecause $ UnitDepRemoved old
- check_packages (new:news) olds
+ check_packages ((new_name, new_unit):news) olds
| Just (old, olds') <- uncons olds
- , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds'
+ , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds'
| otherwise = do
trace_hi_diffs logger $
- text "imported package " <> quotes (ppr new) <>
- text " not among previous dependencies"
- return $ needsRecompileBecause $ ModulePackageChanged $ fst new
+ text "imported package" <+> text new_name <+> ppr new_unit <+>
+ text "not among previous dependencies"
+ return $ needsRecompileBecause $ ModulePackageChanged new_name
needInterface :: Module -> (ModIface -> IO RecompileRequired)
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -244,7 +244,7 @@ data LibrarySpec
| Framework String -- Only used for darwin, but does no harm
instance Outputable LibrarySpec where
- ppr (Objects objs) = text "Objects" <+> ppr objs
+ ppr (Objects objs) = text "Objects" <+> ppr (map text objs)
ppr (Archive a) = text "Archive" <+> text a
ppr (DLL s) = text "DLL" <+> text s
ppr (DLLPath f) = text "DLLPath" <+> text f
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -783,5 +783,5 @@ closureDescription
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.hs with a description generated from the data constructor
closureDescription mod_name name
- = renderWithContext defaultSDocContext
+ = showSDocOneLine defaultSDocContext
(char '<' <> pprFullName mod_name name <> char '>')
=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -208,7 +208,7 @@ slowCall fun stg_args
r <- direct_call "slow_call" NativeNodeCall
(mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
emitComment $ mkFastString ("slow_call for " ++
- renderWithContext ctx (pdoc platform fun) ++
+ showSDocOneLine ctx (pdoc platform fun) ++
" with pat " ++ unpackFS rts_fun)
return r
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -1926,7 +1926,7 @@ genFamInsts spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism
-- canDeriveAnyClass should ensure that this code can't be reached
-- unless -XDeriveAnyClass is enabled.
assertPpr (xopt LangExt.DeriveAnyClass dflags)
- (ppr "genFamInsts: bad derived class" <+> ppr clas) $
+ (text "genFamInsts: bad derived class" <+> ppr clas) $
mapM (tcATDefault loc mini_subst emptyNameSet)
(classATItems clas)
pure $ concat tyfam_insts
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -20,7 +20,6 @@ module GHC.Tc.Gen.Pat
, tcCheckPat, tcCheckPat_O, tcInferPat
, tcPats
, addDataConStupidTheta
- , polyPatSig
)
where
@@ -36,7 +35,6 @@ import GHC.Tc.Utils.Zonk
import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Instantiate
-import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Id
import GHC.Types.Var
@@ -1503,8 +1501,3 @@ checkGADT conlike ex_tvs arg_tys = \case
where
has_existentials :: Bool
has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
-
-polyPatSig :: TcType -> SDoc
-polyPatSig sig_ty
- = hang (text "Illegal polymorphic type signature in pattern:")
- 2 (ppr sig_ty)
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -895,8 +895,8 @@ keyword = coloured Col.colBold
class Outputable a where
ppr :: a -> SDoc
-instance Outputable Char where
- ppr c = text [c]
+-- There's no Outputable for Char; it's too easy to use Outputable
+-- on String and have ppr "hello" rendered as "h,e,l,l,o".
instance Outputable Bool where
ppr True = text "True"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/04a738cb23e82b32caf38b7965f5042e6af6ee88...7918265d53db963bfd3dd529b1063fb844549733
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/04a738cb23e82b32caf38b7965f5042e6af6ee88...7918265d53db963bfd3dd529b1063fb844549733
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/20220907/db592eb9/attachment-0001.html>
More information about the ghc-commits
mailing list