[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: X86/DWARF: support no tables-next-to-code and asm-shortcutting (#22792)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Jun 30 00:37:55 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
eebe1658 by Sylvain Henry at 2024-06-28T07:13:26-04:00
X86/DWARF: support no tables-next-to-code and asm-shortcutting (#22792)
- Without TNTC (tables-next-to-code), we must be careful to not
duplicate labels in pprNatCmmDecl. Especially, as a CmmProc is
identified by the label of its entry block (and not of its info
table), we can't reuse the same label to delimit the block end and the
proc end.
- We generate debug infos from Cmm blocks. However, when
asm-shortcutting is enabled, some blocks are dropped at the asm
codegen stage and some labels in the DebugBlocks become missing.
We fix this by filtering the generated debug-info after the asm
codegen to only keep valid infos.
Also add some related documentation.
- - - - -
6e86d82b by Sylvain Henry at 2024-06-28T07:14:06-04:00
PPC NCG: handle JMP to ForeignLabels (#23969)
- - - - -
9e4b4b0a by Sylvain Henry at 2024-06-28T07:14:06-04:00
PPC NCG: support loading 64-bit value on 32-bit arch (#23969)
- - - - -
50caef3e by Sylvain Henry at 2024-06-28T07:14:46-04:00
Fix warnings in genapply
- - - - -
37139b17 by Matthew Pickering at 2024-06-28T07:15:21-04:00
libraries: Update os-string to 2.0.4
This updates the os-string submodule to 2.0.4 which removes the usage of
`TemplateHaskell` pragma.
- - - - -
0766a2e4 by Sylvain Henry at 2024-06-29T20:37:23-04:00
Bump array submodule
- - - - -
e8456771 by Sylvain Henry at 2024-06-29T20:37:23-04:00
GHCi: Don't use deprecated sizeofMutableByteArray#
- - - - -
545727a5 by Ben Gamari at 2024-06-29T20:37:23-04:00
primops: Undeprecate addr2Int# and int2Addr#
addr2Int# and int2Addr# were marked as deprecated with the introduction
of the OCaml code generator (1dfaee318171836b32f6b33a14231c69adfdef2f)
due to its use of tagged integers. However, this backend has long
vanished and `base` has all along been using `addr2Int#` in the Show
instance for Ptr.
While it's unlikely that we will have another backend which has tagged
integers, we may indeed support platforms which have tagged pointers.
Consequently we undeprecate the operations but warn the user that the
operations may not be portable.
- - - - -
e449b2ec by Sylvain Henry at 2024-06-29T20:37:23-04:00
primops: Undeprecate par#
par# is still used in base and it's not clear how to replace it with
spark# (see #24825)
- - - - -
3cada13a by Ben Gamari at 2024-06-29T20:37:23-04:00
Primops: Make documentation generation more efficient
Previously we would do a linear search through all primop names, doing a
String comparison on the name of each when preparing the HsDocStringMap.
Fix this.
- - - - -
270a45a9 by Ben Gamari at 2024-06-29T20:37:23-04:00
primops: Ensure that deprecations are properly tracked
We previously failed to insert DEPRECATION pragmas into GHC.Prim's
ModIface, meaning that they would appear in the Haddock documentation
but not issue warnings. Fix this.
See #19629. Haddock also needs to be fixed: https://github.com/haskell/haddock/issues/223
Co-authored-by: Sylvain Henry <sylvain at haskus.fr>
- - - - -
a10d4225 by Mario Blažević at 2024-06-29T20:37:32-04:00
Improved pretty-printing of unboxed TH sums and tuples, fixes #24997
- - - - -
30 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- + compiler/GHC/Iface/Warnings.hs
- compiler/GHC/Platform.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.12.1-notes.rst
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Lint.hs
- hadrian/src/Settings/Builders/GenPrimopCode.hs
- libraries/array
- libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
- libraries/ghci/GHCi/BinaryArray.hs
- libraries/os-string
- testsuite/tests/regalloc/regalloc_unit_tests.hs
- testsuite/tests/th/T12403.stdout
- testsuite/tests/th/T12478_4.stderr
- + testsuite/tests/th/T24997.hs
- + testsuite/tests/th/T24997.stdout
- testsuite/tests/th/all.T
- utils/genapply/Main.hs
- utils/genprimopcode/Main.hs
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Builtin.PrimOps (
primOpOutOfLine, primOpCodeSize,
primOpOkForSpeculation, primOpOkToDiscard,
- primOpIsWorkFree, primOpIsCheap, primOpFixity, primOpDocs,
+ primOpIsWorkFree, primOpIsCheap, primOpFixity, primOpDocs, primOpDeprecations,
primOpIsDiv, primOpIsReallyInline,
PrimOpEffect(..), primOpEffect,
@@ -162,12 +162,15 @@ primOpFixity :: PrimOp -> Maybe Fixity
* *
************************************************************************
-See Note [GHC.Prim Docs]
+See Note [GHC.Prim Docs] in GHC.Builtin.Utils
-}
-primOpDocs :: [(String, String)]
+primOpDocs :: [(FastString, String)]
#include "primop-docs.hs-incl"
+primOpDeprecations :: [(OccName, FastString)]
+#include "primop-deprecations.hs-incl"
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -34,6 +34,8 @@ module GHC.Builtin.Utils (
ghcPrimExports,
ghcPrimDeclDocs,
+ ghcPrimWarns,
+ ghcPrimFixities,
-- * Random other things
maybeCharLikeCon, maybeIntLikeCon,
@@ -61,9 +63,11 @@ import GHC.Core.TyCon
import GHC.Types.Avail
import GHC.Types.Id
+import GHC.Types.Fixity
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Id.Make
+import GHC.Types.SourceText
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
import GHC.Types.TyThing
@@ -73,13 +77,14 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc as Utils
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
+import GHC.Parser.Annotation
import GHC.Hs.Doc
import GHC.Unit.Module.ModIface (IfaceExport)
+import GHC.Unit.Module.Warnings
import GHC.Data.List.SetOps
import Control.Applicative ((<|>))
-import Data.List ( find )
import Data.Maybe
{-
@@ -242,14 +247,69 @@ ghcPrimExports
ghcPrimDeclDocs :: Docs
ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }
where
- names = map idName ghcPrimIds ++
- map idName allThePrimOpIds ++
- map tyConName exposedPrimTyCons
findName (nameStr, doc)
- | Just name <- find ((nameStr ==) . getOccString) names
+ | Just name <- lookupFsEnv ghcPrimNames nameStr
= Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []])
| otherwise = Nothing
+ghcPrimNames :: FastStringEnv Name
+ghcPrimNames
+ = mkFsEnv
+ [ (occNameFS $ nameOccName name, name)
+ | name <-
+ map idName ghcPrimIds ++
+ map idName allThePrimOpIds ++
+ map tyConName exposedPrimTyCons
+ ]
+
+-- See Note [GHC.Prim Deprecations]
+ghcPrimWarns :: Warnings a
+ghcPrimWarns = WarnSome
+ -- declaration warnings
+ (map mk_decl_dep primOpDeprecations)
+ -- export warnings
+ []
+ where
+ mk_txt msg =
+ DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]
+ mk_decl_dep (occ, msg) = (occ, mk_txt msg)
+
+ghcPrimFixities :: [(OccName,Fixity)]
+ghcPrimFixities = fixities
+ where
+ -- The fixity listed here for @`seq`@ should match
+ -- those in primops.txt.pp (from which Haddock docs are generated).
+ fixities = (getOccName seqId, Fixity 0 InfixR)
+ : mapMaybe mkFixity allThePrimOps
+ mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
+
+{-
+Note [GHC.Prim Docs]
+~~~~~~~~~~~~~~~~~~~~
+For haddocks of GHC.Prim we generate a dummy haskell file (gen_hs_source) that
+contains the type signatures and the comments (but no implementations)
+specifically for consumption by haddock.
+
+GHCi's :doc command reads directly from ModIface's though, and GHC.Prim has a
+wired-in iface that has nothing to do with the above haskell file. The code
+below converts primops.txt into an intermediate form that would later be turned
+into a proper DeclDocMap.
+
+We output the docs as a list of pairs (name, docs). We use stringy names here
+because mapping names to "Name"s is difficult for things like primtypes and
+pseudoops.
+
+Note [GHC.Prim Deprecations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Like Haddock documentation, we must record deprecation pragmas in two places:
+in the GHC.Prim source module consumed by Haddock, and in the
+declarations wired-in to GHC. To do the following we generate
+GHC.Builtin.PrimOps.primOpDeprecations, a list of (OccName, DeprecationMessage)
+pairs. We insert these deprecations into the mi_warns field of GHC.Prim's ModIface,
+as though they were written in a source module.
+-}
+
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -74,7 +74,7 @@
-- 2. The dummy Prim.hs file, which is used for Haddock and
-- contains descriptions taken from primops.txt.pp.
-- All definitions are replaced by placeholders.
--- See Note [GHC.Prim Docs] in genprimopcode.
+-- See Note [GHC.Prim Docs] in GHC.Builtin.Utils.
--
-- 3. The module PrimopWrappers.hs, which wraps every call for GHCi;
-- see Note [Primop wrappers] in GHC.Builtin.Primops for details.
@@ -2312,13 +2312,13 @@ primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int#
{Return the remainder when the 'Addr#' arg, treated like an 'Int#',
is divided by the 'Int#' arg.}
primop AddrToIntOp "addr2Int#" GenPrimOp Addr# -> Int#
- {Coerce directly from address to int.}
+ {Coerce directly from address to int. Users are discouraged from using
+ this operation as it makes little sense on platforms with tagged pointers.}
with code_size = 0
- deprecated_msg = { This operation is strongly deprecated. }
primop IntToAddrOp "int2Addr#" GenPrimOp Int# -> Addr#
- {Coerce directly from int to address.}
+ {Coerce directly from int to address. Users are discouraged from using
+ this operation as it makes little sense on platforms with tagged pointers.}
with code_size = 0
- deprecated_msg = { This operation is strongly deprecated. }
primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Int#
primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Int#
@@ -3642,14 +3642,24 @@ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
section "Parallelism"
------------------------------------------------------------------------
-primop ParOp "par#" GenPrimOp
- a -> Int#
+primop ParOp "par#" GenPrimOp a -> Int#
+ {Create a new spark evaluating the given argument.
+ The return value should always be 1.
+ Users are encouraged to use spark# instead.}
with
-- Note that Par is lazy to avoid that the sparked thing
-- gets evaluated strictly, which it should *not* be
effect = ReadWriteEffect
code_size = { primOpCodeSizeForeignCall }
- deprecated_msg = { Use 'spark#' instead }
+ -- `par#` was suppose to be deprecated in favor of `spark#` [1], however it
+ -- wasn't clear how to replace it with `spark#` [2] and `par#` is still used
+ -- to implement `GHC.Internal.Conc.Sync.par`. So we undeprecated it until
+ -- everything is sorted out (see #24825).
+ --
+ -- [1] https://gitlab.haskell.org/ghc/ghc/-/issues/15227#note_154293
+ -- [2] https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5548#note_347791
+ --
+ -- deprecated_msg = { Use 'spark#' instead }
primop SparkOp "spark#" GenPrimOp
a -> State# s -> (# State# s, a #)
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
-----------------------------------------------------------------------------
--
-- Object-file symbols (called CLabel for historical reasons).
@@ -123,6 +125,7 @@ module GHC.Cmm.CLabel (
toSlowEntryLbl,
toEntryLbl,
toInfoLbl,
+ toProcDelimiterLbl,
-- * Pretty-printing
LabelStyle (..),
@@ -923,6 +926,16 @@ toEntryLbl platform lbl = case lbl of
CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet
_ -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl)
+-- | Generate a CmmProc delimiter label from the actual entry label.
+--
+-- This delimiter label might be the entry label itself, except when the entry
+-- label is a LocalBlockLabel. If we reused the entry label to delimit the proc,
+-- we would generate redundant labels (see #22792)
+toProcDelimiterLbl :: CLabel -> CLabel
+toProcDelimiterLbl lbl = case lbl of
+ LocalBlockLabel {} -> mkAsmTempDerivedLabel lbl (fsLit "_entry")
+ _ -> lbl
+
toInfoLbl :: Platform -> CLabel -> CLabel
toInfoLbl platform lbl = case lbl of
IdLabel n c LocalEntry -> IdLabel n c LocalInfoTable
@@ -1457,10 +1470,17 @@ pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel]
-> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
AsmTempDerivedLabel l suf
- -> asmTempLabelPrefix platform
- <> case l of AsmTempLabel u -> pprUniqueAlways u
- LocalBlockLabel u -> pprUniqueAlways u
- _other -> pprCLabelStyle platform sty l
+ -- we print a derived label, so we just print the parent label
+ -- recursively. However we don't want to print the temp prefix (e.g.
+ -- ".L") twice, so we must explicitely handle these cases.
+ -> let skipTempPrefix = \case
+ AsmTempLabel u -> pprUniqueAlways u
+ AsmTempDerivedLabel l suf -> skipTempPrefix l <> ftext suf
+ LocalBlockLabel u -> pprUniqueAlways u
+ lbl -> pprAsmLabel platform lbl
+ in
+ asmTempLabelPrefix platform
+ <> skipTempPrefix l
<> ftext suf
DynamicLinkerLabel info lbl
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -168,11 +168,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
mkBlock top (block, prc)
= DebugBlock { dblProcedure = g_entry graph
, dblLabel = label
- , dblCLabel = case info of
- Just (CmmStaticsRaw infoLbl _) -> infoLbl
- Nothing
- | g_entry graph == label -> entryLbl
- | otherwise -> blockLbl label
+ , dblCLabel = blockLbl label
, dblHasInfoTbl = isJust info
, dblParent = Nothing
, dblTicks = ticks
@@ -181,7 +177,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
, dblBlocks = blocks
, dblUnwind = []
}
- where (CmmProc infos entryLbl _ graph) = prc
+ where (CmmProc infos _entryLbl _ graph) = prc
label = entryLabel block
info = mapLookup label infos
blocks | top = seqList childs childs
@@ -238,8 +234,8 @@ blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
insertMulti k v = Map.insertWith (const (v:)) k [v]
-cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
-cmmDebugLabels isMeta nats = seqList lbls lbls
+cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
+cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls
where -- Find order in which procedures will be generated by the
-- back-end (that actually matters for DWARF generation).
--
@@ -247,7 +243,7 @@ cmmDebugLabels isMeta nats = seqList lbls lbls
-- consist of meta instructions -- we will declare them missing,
-- which will skip debug data generation without messing up the
-- block hierarchy.
- lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
+ lbls = filter is_valid_label $ map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
getBlocks _other = []
allMeta (BasicBlock _ instrs) = all isMeta instrs
@@ -256,14 +252,18 @@ cmmDebugLabels isMeta nats = seqList lbls lbls
-- native generated code.
cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
-> [DebugBlock] -> [DebugBlock]
-cmmDebugLink labels unwindPts blocks = map link blocks
+cmmDebugLink labels unwindPts blocks = mapMaybe link blocks
where blockPos :: LabelMap Int
blockPos = mapFromList $ flip zip [0..] labels
- link block = block { dblPosition = mapLookup (dblLabel block) blockPos
- , dblBlocks = map link (dblBlocks block)
- , dblUnwind = fromMaybe mempty
- $ mapLookup (dblLabel block) unwindPts
- }
+ link block = case mapLookup (dblLabel block) blockPos of
+ -- filter dead blocks: we generated debug infos from Cmm blocks but
+ -- asm-shortcutting may remove some blocks later (#22792)
+ Nothing -> Nothing
+ pos -> Just $ block
+ { dblPosition = pos
+ , dblBlocks = mapMaybe link (dblBlocks block)
+ , dblUnwind = fromMaybe mempty $ mapLookup (dblLabel block) unwindPts
+ }
-- | Converts debug blocks into a label map for easier lookups
debugToMap :: [DebugBlock] -> LabelMap DebugBlock
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -362,7 +362,7 @@ cmmNativeGens logger config ncgImpl h dbgMap = go
go us (cmm : cmms) ngs count = do
let fileIds = ngs_dwarfFiles ngs
- (us', fileIds', native, imports, colorStats, linearStats, unwinds)
+ (us', fileIds', native, imports, colorStats, linearStats, unwinds, mcfg)
<- {-# SCC "cmmNativeGen" #-}
cmmNativeGen logger ncgImpl us fileIds dbgMap
cmm count
@@ -390,7 +390,13 @@ cmmNativeGens logger config ncgImpl h dbgMap = go
{-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) ()
let !labels' = if ncgDwarfEnabled config
- then cmmDebugLabels isMetaInstr native else []
+ then cmmDebugLabels is_valid_label isMetaInstr native else []
+ is_valid_label
+ -- filter dead labels: asm-shortcutting may remove some blocks
+ -- (#22792)
+ | Just cfg <- mcfg = hasNode cfg
+ | otherwise = const True
+
!natives' = if logHasDumpFlag logger Opt_D_dump_asm_stats
then native : ngs_natives ngs else []
@@ -436,6 +442,7 @@ cmmNativeGen
, Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
, Maybe [Linear.RegAllocStats] -- stats for the linear register allocators
, LabelMap [UnwindPoint] -- unwinding information for blocks
+ , Maybe CFG -- final CFG
)
cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
@@ -673,7 +680,9 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
, lastMinuteImports ++ imports
, ppr_raStatsColor
, ppr_raStatsLinear
- , unwinds )
+ , unwinds
+ , optimizedCFG
+ )
maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg _logger Nothing _ _ = return ()
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -449,6 +449,7 @@ getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])
getRegister' _ platform (CmmLoad mem pk _)
| not (isWord64 pk) = do
Amode addr addr_code <- getAmode D mem
+ let format = cmmTypeFormat pk
let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $
addr_code `snocOL` LD format dst addr
return (Any format code)
@@ -457,7 +458,12 @@ getRegister' _ platform (CmmLoad mem pk _)
let code dst = addr_code `snocOL` LD II64 dst addr
return (Any II64 code)
- where format = cmmTypeFormat pk
+ | otherwise = do -- 32-bit arch & 64-bit load
+ (hi_addr, lo_addr, addr_code) <- getI64Amodes mem
+ let code dst = addr_code
+ `snocOL` LD II32 dst lo_addr
+ `snocOL` LD II32 (getHiVRegFromLo dst) hi_addr
+ return (Any II64 code)
-- catch simple cases of zero- or sign-extended load
getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do
=====================================
compiler/GHC/CmmToAsm/PPC/Ppr.hs
=====================================
@@ -586,8 +586,12 @@ pprInstr platform instr = case instr of
Just False -> char '+'
JMP lbl _
- -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"
- | isForeignLabel lbl -> pprPanic "PPC.Ppr.pprInstr: JMP to ForeignLabel" (pprDebugCLabel platform lbl)
+ | OSAIX <- platformOS platform ->
+ line $ hcat [ -- an alias for b that takes a CLabel
+ text "\tb.\t", -- add the ".", cf Note [AIX function descriptors and entry-code addresses]
+ pprAsmLabel platform lbl
+ ]
+
| otherwise ->
line $ hcat [ -- an alias for b that takes a CLabel
text "\tb\t",
@@ -611,6 +615,8 @@ pprInstr platform instr = case instr of
BL lbl _
-> case platformOS platform of
OSAIX ->
+ -- Note [AIX function descriptors and entry-code addresses]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- On AIX, "printf" denotes a function-descriptor (for use
-- by function pointers), whereas the actual entry-code
-- address is denoted by the dot-prefixed ".printf" label.
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -71,45 +71,74 @@ pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics)
pprNatCmmDecl config (CmmData section dats) =
pprSectionAlign config section $$ pprDatas config dats
-pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
- let platform = ncgPlatform config in
- case topInfoTable proc of
- Nothing ->
- -- special case for code without info table:
- pprSectionAlign config (Section Text lbl) $$
- pprProcAlignment config $$
- pprProcLabel config lbl $$
- pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
- vcat (map (pprBasicBlock config top_info) blocks) $$
- ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) $$
- pprSizeDecl platform lbl
-
- Just (CmmStaticsRaw info_lbl _) ->
- pprSectionAlign config (Section Text info_lbl) $$
- pprProcAlignment config $$
- pprProcLabel config lbl $$
- (if platformHasSubsectionsViaSymbols platform
- then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon)
- else empty) $$
- vcat (map (pprBasicBlock config top_info) blocks) $$
- ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl)) $$
- -- above: Even the first block gets a label, because with branch-chain
+pprNatCmmDecl config proc@(CmmProc top_info entry_lbl _ (ListGraph blocks)) =
+ let platform = ncgPlatform config
+ top_info_table = topInfoTable proc
+ -- we need a label to delimit the proc code (e.g. in debug builds). When
+ -- we have an info table, we reuse the info table label. Otherwise we make
+ -- a fresh "entry" label from the label of the entry block. We can't reuse
+ -- the entry block label as-is, otherwise we get redundant labels:
+ -- delimiters for the entry block and for the whole proc are the same (see
+ -- #22792).
+ proc_lbl = case top_info_table of
+ Just (CmmStaticsRaw info_lbl _) -> info_lbl
+ Nothing -> toProcDelimiterLbl entry_lbl
+
+ -- handle subsections_via_symbols when enabled and when we have an
+ -- info-table to link to. See Note [Subsections Via Symbols]
+ (sub_via_sym_label,sub_via_sym_offset)
+ | platformHasSubsectionsViaSymbols platform
+ , Just (CmmStaticsRaw info_lbl _) <- top_info_table
+ , info_dsp_lbl <- pprAsmLabel platform (mkDeadStripPreventer info_lbl)
+ = ( line (info_dsp_lbl <> colon)
+ , line $ text "\t.long " <+> pprAsmLabel platform info_lbl <+> char '-' <+> info_dsp_lbl
+ )
+ | otherwise = (empty,empty)
+
+ in vcat
+ [ -- section directive. Requires proc_lbl when split-section is enabled to
+ -- use as a subsection name.
+ pprSectionAlign config (Section Text proc_lbl)
+
+ -- section alignment. Note that when there is an info table, we align the
+ -- info table and not the entry code!
+ , pprProcAlignment config
+
+ -- Special label when ncgExposeInternalSymbols is enabled. See Note
+ -- [Internal proc labels] in GHC.Cmm.Label
+ , pprExposedInternalProcLabel config entry_lbl
+
+ -- Subsections-via-symbols label. See Note [Subsections Via Symbols]
+ , sub_via_sym_label
+
+ -- We need to print a label indicating the beginning of the entry code:
+ -- 1. Without tables-next-to-code, we just print it here
+ -- 2. With tables-next-to-code, the proc_lbl is the info-table label and it
+ -- will be printed in pprBasicBlock after the info-table itself.
+ , case top_info_table of
+ Nothing -> pprLabel platform proc_lbl
+ Just _ -> empty
+
+ -- Proc's basic blocks
+ , vcat (map (pprBasicBlock config top_info) blocks)
+ -- Note that even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
- (if platformHasSubsectionsViaSymbols platform
- then -- See Note [Subsections Via Symbols]
- line
- $ text "\t.long "
- <+> pprAsmLabel platform info_lbl
- <+> char '-'
- <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
- else empty) $$
- pprSizeDecl platform info_lbl
+
+ -- Print the proc end label when debugging is enabled
+ , ppWhen (ncgDwarfEnabled config) $ line (pprProcEndLabel platform proc_lbl)
+
+ -- Subsections-via-symbols offset. See Note [Subsections Via Symbols]
+ , sub_via_sym_offset
+
+ -- ELF .size directive (size of the entry code function)
+ , pprSizeDecl platform proc_lbl
+ ]
{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc #-}
{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Output an internal proc label. See Note [Internal proc labels] in CLabel.
-pprProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc
-pprProcLabel config lbl
+pprExposedInternalProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc
+pprExposedInternalProcLabel config lbl
| ncgExposeInternalSymbols config
, Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl
= line (lbl' <> colon)
@@ -118,8 +147,7 @@ pprProcLabel config lbl
pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name
-> doc
-pprProcEndLabel platform lbl =
- pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon
+pprProcEndLabel platform lbl = pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon
pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name
-> doc
@@ -136,16 +164,16 @@ pprSizeDecl platform lbl
pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc
pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $
- pprLabel platform asmLbl $$
+ pprLabel platform block_label $$
vcat (map (pprInstr platform) instrs) $$
ppWhen (ncgDwarfEnabled config) (
-- Emit both end labels since this may end up being a standalone
-- top-level block
- line (pprBlockEndLabel platform asmLbl
- <> pprProcEndLabel platform asmLbl)
+ line (pprBlockEndLabel platform block_label) $$
+ line (pprProcEndLabel platform block_label)
)
where
- asmLbl = blockLbl blockid
+ block_label = blockLbl blockid
platform = ncgPlatform config
maybe_infotable c = case mapLookup blockid info_env of
Nothing -> c
@@ -155,7 +183,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
vcat (map (pprData config) info) $$
pprLabel platform infoLbl $$
c $$
- ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon))
+ ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform infoLbl))
-- Make sure the info table has the right .loc for the block
-- coming right after it. See Note [Info Offset]
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Driver.DynFlags
import GHC.Driver.Hooks
import GHC.Driver.Plugins
+import GHC.Iface.Warnings
import GHC.Iface.Syntax
import GHC.Iface.Ext.Fields
import GHC.Iface.Binary
@@ -74,14 +75,12 @@ import GHC.Settings.Constants
import GHC.Builtin.Names
import GHC.Builtin.Utils
-import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc )
import GHC.Core.Rules
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
-import GHC.Types.Id.Make ( seqId )
import GHC.Types.Annotations
import GHC.Types.Name
import GHC.Types.Name.Cache
@@ -100,6 +99,7 @@ import GHC.Types.PkgQual
import GHC.Unit.External
import GHC.Unit.Module
+import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
import GHC.Unit.State
@@ -1019,19 +1019,18 @@ ghcPrimIface
= empty_iface
& set_mi_exports ghcPrimExports
& set_mi_decls []
- & set_mi_fixities fixities
- & set_mi_final_exts ((mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities })
- & set_mi_docs (Just ghcPrimDeclDocs) -- See Note [GHC.Prim Docs]
+ & set_mi_fixities ghcPrimFixities
+ & set_mi_final_exts ((mi_final_exts empty_iface)
+ { mi_fix_fn = mkIfaceFixCache ghcPrimFixities
+ , mi_decl_warn_fn = mkIfaceDeclWarnCache ghcPrimWarns
+ , mi_export_warn_fn = mkIfaceExportWarnCache ghcPrimWarns
+ })
+ & set_mi_docs (Just ghcPrimDeclDocs) -- See Note [GHC.Prim Docs] in GHC.Builtin.Utils
+ & set_mi_warns (toIfaceWarnings ghcPrimWarns) -- See Note [GHC.Prim Deprecations] in GHC.Builtin.Utils
where
empty_iface = emptyFullModIface gHC_PRIM
- -- The fixity listed here for @`seq`@ should match
- -- those in primops.txt.pp (from which Haddock docs are generated).
- fixities = (getOccName seqId, Fixity 0 InfixR)
- : mapMaybe mkFixity allThePrimOps
- mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
-
{-
*********************************************************
* *
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -14,7 +14,6 @@ module GHC.Iface.Make
, mkFullIface
, mkIfaceTc
, mkIfaceExports
- , toIfaceWarningTxt
)
where
@@ -28,6 +27,7 @@ import GHC.StgToCmm.Types (CmmCgInfos (..))
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad
+import GHC.Iface.Warnings
import GHC.Iface.Decl
import GHC.Iface.Syntax
import GHC.Iface.Recomp
@@ -67,8 +67,6 @@ import GHC.Types.SourceFile
import GHC.Types.TyThing
import GHC.Types.HpcInfo
import GHC.Types.CompleteMatch
-import GHC.Types.SourceText
-import GHC.Types.SrcLoc ( unLoc )
import GHC.Types.Name.Cache
import GHC.Utils.Outputable
@@ -437,23 +435,6 @@ ifaceRoughMatchTcs tcs = map do_rough tcs
do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n)
--------------------------
-toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings
-toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt)
-toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
- where
- vs' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- vs]
- ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
-
-toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
-toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs)
-toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
-
-toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
-toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)
-
-toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral
-toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs
-
coreRuleToIfaceRule :: CoreRule -> IfaceRule
-- A plugin that installs a BuiltinRule in a CoreDoPluginPass should
-- ensure that there's another CoreDoPluginPass that removes the rule.
=====================================
compiler/GHC/Iface/Warnings.hs
=====================================
@@ -0,0 +1,34 @@
+module GHC.Iface.Warnings
+ ( toIfaceWarnings
+ , toIfaceWarningTxt
+ )
+where
+
+import GHC.Prelude
+
+import GHC.Hs
+
+import GHC.Iface.Syntax
+
+import GHC.Types.SourceText
+import GHC.Types.SrcLoc ( unLoc )
+
+import GHC.Unit.Module.Warnings
+
+toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings
+toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt)
+toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
+ where
+ vs' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- vs]
+ ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
+
+toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
+toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
+
+toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
+toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)
+
+toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral
+toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs
+
=====================================
compiler/GHC/Platform.hs
=====================================
@@ -75,6 +75,9 @@ data Platform = Platform
, platformHasGnuNonexecStack :: !Bool
, platformHasIdentDirective :: !Bool
, platformHasSubsectionsViaSymbols :: !Bool
+ -- ^ Enable Darwin .subsections_via_symbols directive
+ --
+ -- See Note [Subsections Via Symbols] in GHC.CmmToAsm.X86.Ppr
, platformIsCrossCompiling :: !Bool
, platformLeadingUnderscore :: !Bool -- ^ Symbols need underscore prefix
, platformTablesNextToCode :: !Bool
=====================================
compiler/ghc.cabal.in
=====================================
@@ -594,6 +594,7 @@ Library
GHC.Iface.Syntax
GHC.Iface.Tidy
GHC.Iface.Tidy.StaticPtrTable
+ GHC.Iface.Warnings
GHC.IfaceToCore
GHC.Iface.Type
GHC.JS.Ident
=====================================
docs/users_guide/9.12.1-notes.rst
=====================================
@@ -103,6 +103,9 @@ Runtime system
``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~
+- Usage of deprecated primops is now correctly reported (#19629).
+
+
``ghc`` library
~~~~~~~~~~~~~~~
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -95,6 +95,7 @@ compilerDependencies = do
, "primop-vector-tys.hs-incl"
, "primop-vector-uniques.hs-incl"
, "primop-docs.hs-incl"
+ , "primop-deprecations.hs-incl"
, "GHC/Platform/Constants.hs"
, "GHC/Settings/Config.hs"
]
=====================================
hadrian/src/Rules/Lint.hs
=====================================
@@ -115,6 +115,7 @@ hsIncls path = [ path </> "primop-vector-tycons.hs-incl"
, path </> "primop-is-cheap.hs-incl"
, path </> "primop-fixity.hs-incl"
, path </> "primop-docs.hs-incl"
+ , path </> "primop-deprecations.hs-incl"
, path </> "primop-primop-info.hs-incl"
, path </> "primop-out-of-line.hs-incl"
, path </> "primop-effects.hs-incl"
=====================================
hadrian/src/Settings/Builders/GenPrimopCode.hs
=====================================
@@ -23,4 +23,5 @@ genPrimopCodeBuilderArgs = builder GenPrimopCode ? mconcat
, output "//primop-vector-tys-exports.hs-incl" ? arg "--primop-vector-tys-exports"
, output "//primop-vector-tycons.hs-incl" ? arg "--primop-vector-tycons"
, output "//primop-docs.hs-incl" ? arg "--wired-in-docs"
+ , output "//primop-deprecations.hs-incl" ? arg "--wired-in-deprecations"
, output "//primop-usage.hs-incl" ? arg "--usage" ]
=====================================
libraries/array
=====================================
@@ -1 +1 @@
-Subproject commit 510456786715d96dfc9e9bc4cead9aace1ce2db6
+Subproject commit ba5e9dcf1370190239395b8361b1c92ea9fc7632
=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
=====================================
@@ -12,7 +12,8 @@ import Text.PrettyPrint (render)
import GHC.Internal.TH.PprLib
import GHC.Internal.TH.Syntax
import Data.Word ( Word8 )
-import Data.Char ( toLower, chr)
+import Data.Char ( toLower, chr )
+import Data.List ( intersperse )
import GHC.Show ( showMultiLineString )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
@@ -836,7 +837,7 @@ pprType _ (TupleT 0) = text "()"
pprType p (TupleT 1) = pprType p (ConT (tupleTypeName 1))
pprType _ (TupleT n) = parens (hcat (replicate (n-1) comma))
pprType _ (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
-pprType _ (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
+pprType _ (UnboxedSumT arity) = hashParens $ hsep $ replicate (arity-1) bar
pprType _ ArrowT = parens (text "->")
pprType _ MulArrowT = text "FUN"
pprType _ ListT = text "[]"
@@ -929,6 +930,12 @@ pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), a
pprTyApp _ (PromotedTupleT n, args)
| length args == n, Just args' <- traverse fromTANormal args
= quoteParens (commaSep args')
+pprTyApp _ (UnboxedTupleT n, args)
+ | length args == n, Just args' <- traverse fromTANormal args
+ = hashParens (commaSep args')
+pprTyApp _ (UnboxedSumT n, args)
+ | length args == n, Just args' <- traverse fromTANormal args
+ = hashParens (sep $ intersperse bar $ map ppr args')
pprTyApp p (fun, args) =
parensIf (p >= appPrec) $ pprParendType fun <+> sep (map pprParendTypeArg args)
=====================================
libraries/ghci/GHCi/BinaryArray.hs
=====================================
@@ -62,7 +62,9 @@ getArray = do
copyAddrToByteArray ptr arr# off n
go (remaining - n) (off + n)
where n = min chunkSize remaining
- go (I# (sizeofMutableByteArray# arr#)) 0
+ sz <- return $ unsafeDupablePerformIO $ IO $ \s -> case getSizeofMutableByteArray# arr# s of
+ (# s2, n #) -> (# s2, I# n #)
+ go sz 0
return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr
where
chunkSize = 10*1024
=====================================
libraries/os-string
=====================================
@@ -1 +1 @@
-Subproject commit e1dd3bcfab56a6616c73ee9220de425d55545bc8
+Subproject commit 6d31aafde2f7b8c3050ffee7dd9f658225cfd1a4
=====================================
testsuite/tests/regalloc/regalloc_unit_tests.hs
=====================================
@@ -155,7 +155,7 @@ compileCmmForRegAllocStats logger home_unit dflags cmmFile ncgImplF us = do
mapM (\ (count, thisCmm) ->
cmmNativeGen logger ncgImpl
usb dwarfFileIds dbgMap thisCmm count >>=
- (\(_, _, _, _, colorStats, linearStats, _) ->
+ (\(_, _, _, _, colorStats, linearStats, _, _) ->
-- scrub unneeded output from cmmNativeGen
return (colorStats, linearStats)))
$ zip [0.. (length collectedCmms)] collectedCmms
=====================================
testsuite/tests/th/T12403.stdout
=====================================
@@ -1 +1 @@
-data Main.T = Main.T ((# , #) GHC.Types.Int GHC.Types.Int)
+data Main.T = Main.T (# GHC.Types.Int, GHC.Types.Int #)
=====================================
testsuite/tests/th/T12478_4.stderr
=====================================
@@ -1,6 +1,6 @@
-
T12478_4.hs:7:7: error: [GHC-97721]
• Illegal sum arity: 1
Sums must have an arity of at least 2
- When splicing a TH type: (# #) GHC.Tuple.Unit
+ When splicing a TH type: (# GHC.Tuple.Unit #)
• In the untyped splice: $(unboxedSumT 1 `appT` conT ''())
+
=====================================
testsuite/tests/th/T24997.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE Haskell2010, TemplateHaskell, UnboxedSums #-}
+
+import Language.Haskell.TH (runQ, Type (UnboxedSumT, UnboxedTupleT))
+import Language.Haskell.TH.Ppr (pprint)
+
+main = do
+ runQ [t| (# Int | Char | Bool #) |] >>= putStrLn . pprint
+ runQ [t| (# Int, Char, Bool #) |] >>= putStrLn . pprint
+ runQ [t| $(pure (UnboxedTupleT 3)) Int Char |] >>= putStrLn . pprint
+ runQ [t| $(pure (UnboxedSumT 3)) Int Char |] >>= putStrLn . pprint
=====================================
testsuite/tests/th/T24997.stdout
=====================================
@@ -0,0 +1,4 @@
+(# GHC.Types.Int | GHC.Types.Char | GHC.Types.Bool #)
+(# GHC.Types.Int, GHC.Types.Char, GHC.Types.Bool #)
+(# ,, #) GHC.Types.Int GHC.Types.Char
+(# | | #) GHC.Types.Int GHC.Types.Char
=====================================
testsuite/tests/th/all.T
=====================================
@@ -616,3 +616,4 @@ test('T24702a', normal, compile, [''])
test('T24702b', normal, compile, [''])
test('T24837', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T24911', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T24997', normal, compile_and_run, [''])
=====================================
utils/genapply/Main.hs
=====================================
@@ -15,9 +15,7 @@ import Text.PrettyPrint
import Data.Word
import Data.Bits
import Data.List ( intersperse, nub, sort )
-import System.Exit
import System.Environment
-import System.IO
import Control.Arrow ((***))
{-
@@ -78,8 +76,10 @@ data TargetInfo = TargetInfo
parseTargetInfo :: FilePath -> IO TargetInfo
parseTargetInfo path = do
header <- readFile path
- let tups = [ (k, read v) | '/':'/':' ':l <- lines header, let [k, v] = words l ]
- tups_get k = v where Just v = lookup k tups
+ let tups = [ (k, read v) | '/':'/':' ':l <- lines header, [k, v] <- [words l] ]
+ tups_get k = case lookup k tups of
+ Nothing -> error "genapply.parseTargetInfo: Missing key"
+ Just v -> v
tag_bits = tups_get "TAG_BITS"
pure TargetInfo {
maxRealVanillaReg = tups_get "MAX_Real_Vanilla_REG",
@@ -442,7 +442,7 @@ genMkPAP targetInfo at TargetInfo {..} macro jump live _ticker disamb
adj_reg_locs = [ (reg, off - adj + 1) |
(reg,off) <- extra_reg_locs ]
adj = case extra_reg_locs of
- (reg, fst_off):_ -> fst_off
+ (_reg, fst_off):_ -> fst_off
[] -> error "Impossible: genapply.hs : No extra register locations"
size = snd (last adj_reg_locs) + 1
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -199,6 +199,9 @@ main = getArgs >>= \args ->
"--wired-in-docs"
-> putStr (gen_wired_in_docs p_o_specs)
+ "--wired-in-deprecations"
+ -> putStr (gen_wired_in_deprecations p_o_specs)
+
_ -> error "Should not happen, known_args out of sync?"
)
@@ -223,7 +226,8 @@ known_args
"--make-haskell-wrappers",
"--make-haskell-source",
"--make-latex-doc",
- "--wired-in-docs"
+ "--wired-in-docs",
+ "--wired-in-deprecations"
]
------------------------------------------------------------------
@@ -639,30 +643,37 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
-> unlines alternatives
++ fn_name ++ " _thisOp = " ++ getAltRhs xx ++ "\n"
-{-
-Note [GHC.Prim Docs]
-~~~~~~~~~~~~~~~~~~~~
-For haddocks of GHC.Prim we generate a dummy haskell file (gen_hs_source) that
-contains the type signatures and the comments (but no implementations)
-specifically for consumption by haddock.
-
-GHCi's :doc command reads directly from ModIface's though, and GHC.Prim has a
-wired-in iface that has nothing to do with the above haskell file. The code
-below converts primops.txt into an intermediate form that would later be turned
-into a proper DeclDocMap.
-
-We output the docs as a list of pairs (name, docs). We use stringy names here
-because mapping names to "Name"s is difficult for things like primtypes and
-pseudoops.
--}
+-- See Note [GHC.Prim Docs] in GHC.Builtin.Utils
gen_wired_in_docs :: Info -> String
gen_wired_in_docs (Info _ entries)
= "primOpDocs =\n [ " ++ intercalate "\n , " (catMaybes $ map mkDoc $ concatMap desugarVectorSpec entries) ++ "\n ]\n"
where
mkDoc po | Just poName <- getName po
- , not $ null $ desc po = Just $ show (poName, desc po)
+ , not $ null $ desc po = Just $ "(fsLit " ++ show poName ++ "," ++ show (desc po) ++ ")"
| otherwise = Nothing
+-- See Note [GHC.Prim Deprecations] in GHC.Builtin.Utils
+gen_wired_in_deprecations :: Info -> String
+gen_wired_in_deprecations (Info _ entries)
+ = "primOpDeprecations =\n [ "
+ ++ intercalate "\n , " (catMaybes $ map mkDep $ concatMap desugarVectorSpec entries)
+ ++ "\n ]\n"
+ where
+ mkDep po
+ | Just poName <- getName po
+ , Just (OptionString _ depMsg) <- lookup_attrib "deprecated_msg" (opts po)
+ = let mkOcc =
+ case po of
+ PrimOpSpec{} -> "mkVarOcc"
+ PrimVecOpSpec{} -> "mkVarOcc"
+ PseudoOpSpec{} -> "mkVarOcc"
+ PrimTypeSpec{} -> "mkTcOcc"
+ PrimVecTypeSpec{} -> "mkTcOcc"
+ Section{} -> error "impossible(Section)"
+ in Just $ "(" ++ mkOcc ++ " " ++ show poName ++ ", fsLit " ++ show depMsg ++ ")"
+ | otherwise = Nothing
+
+
------------------------------------------------------------------
-- Create PrimOpInfo text from PrimOpSpecs -----------------------
------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/73670c1eaddc27c45e38cf211730fb1b556d56fa...a10d42253a1ce874b40d6b1d037ba1219032bd7d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/73670c1eaddc27c45e38cf211730fb1b556d56fa...a10d42253a1ce874b40d6b1d037ba1219032bd7d
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/20240629/e8d60541/attachment-0001.html>
More information about the ghc-commits
mailing list