[Git][ghc/ghc][wip/supersven/AArch64-simplify-stmtToInstrs-type] 9 commits: Bump array submodule
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Jun 30 11:31:35 UTC 2024
Sven Tennie pushed to branch wip/supersven/AArch64-simplify-stmtToInstrs-type at Glasgow Haskell Compiler / GHC
Commits:
0f3d3bd6 by Sylvain Henry at 2024-06-30T00:47:40-04:00
Bump array submodule
- - - - -
354c350c by Sylvain Henry at 2024-06-30T00:47:40-04:00
GHCi: Don't use deprecated sizeofMutableByteArray#
- - - - -
35d65098 by Ben Gamari at 2024-06-30T00:47:40-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.
- - - - -
3157d817 by Sylvain Henry at 2024-06-30T00:47:41-04:00
primops: Undeprecate par#
par# is still used in base and it's not clear how to replace it with
spark# (see #24825)
- - - - -
c8d5b959 by Ben Gamari at 2024-06-30T00:47:41-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.
- - - - -
65165fe4 by Ben Gamari at 2024-06-30T00:47:41-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>
- - - - -
bc1d435e by Mario Blažević at 2024-06-30T00:48:20-04:00
Improved pretty-printing of unboxed TH sums and tuples, fixes #24997
- - - - -
62fb03ae by Sven Tennie at 2024-06-30T11:31:18+00:00
AArch64: Simplify stmtToInstrs type
There's no need to hand `Nothing`s around... (there was no case with a
`BlockId`.)
- - - - -
d7cbe048 by Sven Tennie at 2024-06-30T11:31:18+00:00
AArch64: Simplify stmtsToInstrs type
The `BlockId` parameter (`bid`) is never used, only handed around.
Deleting it simplifies the surrounding code.
- - - - -
21 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- + compiler/GHC/Iface/Warnings.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
- 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/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/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -51,7 +51,6 @@ import GHC.Data.OrdList
import GHC.Utils.Outputable
import Control.Monad ( mapAndUnzipM, foldM )
-import Data.Maybe
import GHC.Float
import GHC.Types.Basic
@@ -149,8 +148,8 @@ basicBlockCodeGen block = do
let line = srcSpanStartLine span; col = srcSpanStartCol span
return $ unitOL $ LOCATION fileId line col (unpackFS name)
_ -> return nilOL
- (mid_instrs,mid_bid) <- stmtsToInstrs id stmts
- (!tail_instrs,_) <- stmtToInstrs mid_bid tail
+ mid_instrs <- stmtsToInstrs stmts
+ (!tail_instrs) <- stmtToInstrs tail
let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs
-- TODO: Then x86 backend run @verifyBasicBlock@ here and inserts
-- unwinding info. See Ticket 19913
@@ -252,38 +251,27 @@ generateJumpTableForInstr _ _ = Nothing
-- -----------------------------------------------------------------------------
-- Top-level of the instruction selector
--- See Note [Keeping track of the current block] for why
--- we pass the BlockId.
-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
- -> [CmmNode O O] -- ^ Cmm Statement
- -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
-stmtsToInstrs bid stmts =
- go bid stmts nilOL
+stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements
+ -> NatM InstrBlock -- ^ Resulting instructions
+stmtsToInstrs stmts =
+ go stmts nilOL
where
- go bid [] instrs = return (instrs,bid)
- go bid (s:stmts) instrs = do
- (instrs',bid') <- stmtToInstrs bid s
- -- If the statement introduced a new block, we use that one
- let !newBid = fromMaybe bid bid'
- go newBid stmts (instrs `appOL` instrs')
-
--- | `bid` refers to the current block and is used to update the CFG
--- if new blocks are inserted in the control flow.
--- See Note [Keeping track of the current block] for more details.
-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
- -> CmmNode e x
- -> NatM (InstrBlock, Maybe BlockId)
- -- ^ Instructions, and bid of new block if successive
- -- statements are placed in a different basic block.
-stmtToInstrs bid stmt = do
+ go [] instrs = return instrs
+ go (s:stmts) instrs = do
+ instrs' <- stmtToInstrs s
+ go stmts (instrs `appOL` instrs')
+
+stmtToInstrs :: CmmNode e x -- ^ Cmm Statement
+ -> NatM InstrBlock -- ^ Resulting Instructions
+stmtToInstrs stmt = do
-- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"
-- ++ showSDocUnsafe (ppr stmt)
platform <- getPlatform
case stmt of
CmmUnsafeForeignCall target result_regs args
- -> genCCall target result_regs args bid
+ -> genCCall target result_regs args
- _ -> (,Nothing) <$> case stmt of
+ _ -> case stmt of
CmmComment s -> return (unitOL (COMMENT (ftext s)))
CmmTick {} -> return nilOL
@@ -304,7 +292,7 @@ stmtToInstrs bid stmt = do
--We try to arrange blocks such that the likely branch is the fallthrough
--in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
CmmCondBranch arg true false _prediction ->
- genCondBranch bid true false arg
+ genCondBranch true false arg
CmmSwitch arg ids -> genSwitch arg ids
@@ -1456,14 +1444,12 @@ genCondFarJump cond far_target = do
, B far_target
, NEWBLOCK skip_lbl_id]
-genCondBranch
- :: BlockId -- the source of the jump
- -> BlockId -- the true branch target
+genCondBranch :: BlockId -- the true branch target
-> BlockId -- the false branch target
-> CmmExpr -- the condition on which to branch
-> NatM InstrBlock -- Instructions
-genCondBranch _ true false expr = do
+genCondBranch true false expr = do
b1 <- genCondJump true expr
b2 <- genBranch false
return (b1 `appOL` b2)
@@ -1549,11 +1535,10 @@ genCCall
:: ForeignTarget -- function to call
-> [CmmFormal] -- where to put the result
-> [CmmActual] -- arguments (of mixed type)
- -> BlockId -- The block we are in
- -> NatM (InstrBlock, Maybe BlockId)
+ -> NatM InstrBlock
-- TODO: Specialize where we can.
-- Generic impl
-genCCall target dest_regs arg_regs bid = do
+genCCall target dest_regs arg_regs = do
-- we want to pass arg_regs into allArgRegs
-- pprTraceM "genCCall target" (ppr target)
-- pprTraceM "genCCall formal" (ppr dest_regs)
@@ -1617,7 +1602,7 @@ genCCall target dest_regs arg_regs bid = do
`appOL` (unitOL $ BL call_target passRegs) -- branch and link.
`appOL` readResultsCode -- parse the results into registers
`appOL` moveStackUp (stackSpace `div` 8)
- return (code, Nothing)
+ return code
PrimTarget MO_F32_Fabs
| [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
@@ -1642,7 +1627,7 @@ genCCall target dest_regs arg_regs bid = do
let lo = getRegisterReg platform (CmmLocal dst_lo)
hi = getRegisterReg platform (CmmLocal dst_hi)
nd = getRegisterReg platform (CmmLocal dst_needed)
- return (
+ return $
code_x `appOL`
code_y `snocOL`
MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`
@@ -1651,7 +1636,6 @@ genCCall target dest_regs arg_regs bid = do
-- nd = (hi == ASR(lo,width-1)) ? 1 : 0
CMP (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL`
CSET (OpReg W64 nd) NE
- , Nothing)
-- For sizes < platform width, we can just perform a multiply and shift
-- using the normal 64 bit multiply. Calculating the dst_needed value is
-- complicated a little by the need to be careful when truncation happens.
@@ -1674,7 +1658,7 @@ genCCall target dest_regs arg_regs bid = do
(reg_a, code_a') <- signExtendReg w w' reg_a'
(reg_b, code_b') <- signExtendReg w w' reg_b'
- return (
+ return $
code_a `appOL`
code_b `appOL`
code_a' `appOL`
@@ -1704,7 +1688,6 @@ genCCall target dest_regs arg_regs bid = do
CSET (OpReg w' nd) EQ `appOL`
-- Finally truncate hi to drop any extraneous sign bits.
truncateReg w' w hi
- , Nothing)
-- Can't handle > 64 bit operands
| otherwise -> unsupported (MO_S_Mul2 w)
PrimTarget (MO_U_Mul2 w)
@@ -1724,7 +1707,7 @@ genCCall target dest_regs arg_regs bid = do
code_y `snocOL`
MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`
UMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b)
- , Nothing)
+ )
-- For sizes < platform width, we can just perform a multiply and shift
-- Need to be careful to truncate the low half, but the upper half should be
-- be ok if the invariant in [Signed arithmetic on AArch64] is maintained.
@@ -1755,7 +1738,7 @@ genCCall target dest_regs arg_regs bid = do
(OpImm (ImmInt $ widthInBits w)) -- width to extract
`appOL`
truncateReg W64 w lo
- , Nothing)
+ )
| otherwise -> unsupported (MO_U_Mul2 w)
PrimTarget (MO_Clz w)
| w == W64 || w == W32
@@ -1767,7 +1750,7 @@ genCCall target dest_regs arg_regs bid = do
return (
code_x `snocOL`
CLZ (OpReg w dst_reg) (OpReg w reg_a)
- , Nothing)
+ )
| w == W16
, [src] <- arg_regs
, [dst] <- dest_regs
@@ -1783,7 +1766,7 @@ genCCall target dest_regs arg_regs bid = do
, ORR (r dst') (r dst') (imm 0x00008000)
, CLZ (r dst') (r dst')
]
- , Nothing)
+ )
| w == W8
, [src] <- arg_regs
, [dst] <- dest_regs
@@ -1793,13 +1776,12 @@ genCCall target dest_regs arg_regs bid = do
r n = OpReg W32 n
imm n = OpImm (ImmInt n)
{- dst = clz(x << 24 | 0x0080_0000) -}
- return (
+ return $
code_x `appOL` toOL
[ LSL (r dst') (r reg_a) (imm 24)
, ORR (r dst') (r dst') (imm 0x00800000)
, CLZ (r dst') (r dst')
]
- , Nothing)
| otherwise -> unsupported (MO_Clz w)
PrimTarget (MO_Ctz w)
| w == W64 || w == W32
@@ -1808,11 +1790,10 @@ genCCall target dest_regs arg_regs bid = do
-> do
(reg_a, _format_x, code_x) <- getSomeReg src
let dst_reg = getRegisterReg platform (CmmLocal dst)
- return (
+ return $
code_x `snocOL`
RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL`
CLZ (OpReg w dst_reg) (OpReg w dst_reg)
- , Nothing)
| w == W16
, [src] <- arg_regs
, [dst] <- dest_regs
@@ -1822,13 +1803,12 @@ genCCall target dest_regs arg_regs bid = do
r n = OpReg W32 n
imm n = OpImm (ImmInt n)
{- dst = clz(reverseBits(x) | 0x0000_8000) -}
- return (
+ return $
code_x `appOL` toOL
[ RBIT (r dst') (r reg_a)
, ORR (r dst') (r dst') (imm 0x00008000)
, CLZ (r dst') (r dst')
]
- , Nothing)
| w == W8
, [src] <- arg_regs
, [dst] <- dest_regs
@@ -1838,13 +1818,12 @@ genCCall target dest_regs arg_regs bid = do
r n = OpReg W32 n
imm n = OpImm (ImmInt n)
{- dst = clz(reverseBits(x) | 0x0080_0000) -}
- return (
+ return $
code_x `appOL` toOL
[ RBIT (r dst') (r reg_a)
, ORR (r dst') (r dst') (imm 0x00800000)
, CLZ (r dst') (r dst')
]
- , Nothing)
| otherwise -> unsupported (MO_Ctz w)
PrimTarget (MO_BRev w)
| w == W64 || w == W32
@@ -1853,10 +1832,9 @@ genCCall target dest_regs arg_regs bid = do
-> do
(reg_a, _format_x, code_x) <- getSomeReg src
let dst_reg = getRegisterReg platform (CmmLocal dst)
- return (
+ return $
code_x `snocOL`
RBIT (OpReg w dst_reg) (OpReg w reg_a)
- , Nothing)
| w == W16
, [src] <- arg_regs
, [dst] <- dest_regs
@@ -1866,12 +1844,11 @@ genCCall target dest_regs arg_regs bid = do
r n = OpReg W32 n
imm n = OpImm (ImmInt n)
{- dst = reverseBits32(x << 16) -}
- return (
+ return $
code_x `appOL` toOL
[ LSL (r dst') (r reg_a) (imm 16)
, RBIT (r dst') (r dst')
]
- , Nothing)
| w == W8
, [src] <- arg_regs
, [dst] <- dest_regs
@@ -1881,12 +1858,11 @@ genCCall target dest_regs arg_regs bid = do
r n = OpReg W32 n
imm n = OpImm (ImmInt n)
{- dst = reverseBits32(x << 24) -}
- return (
+ return $
code_x `appOL` toOL
[ LSL (r dst') (r reg_a) (imm 24)
, RBIT (r dst') (r dst')
]
- , Nothing)
| otherwise -> unsupported (MO_BRev w)
@@ -1989,12 +1965,12 @@ genCCall target dest_regs arg_regs bid = do
MO_SubIntC _w -> unsupported mop
-- Memory Ordering
- MO_AcquireFence -> return (unitOL DMBISH, Nothing)
- MO_ReleaseFence -> return (unitOL DMBISH, Nothing)
- MO_SeqCstFence -> return (unitOL DMBISH, Nothing)
- MO_Touch -> return (nilOL, Nothing) -- Keep variables live (when using interior pointers)
+ MO_AcquireFence -> return (unitOL DMBISH)
+ MO_ReleaseFence -> return (unitOL DMBISH)
+ MO_SeqCstFence -> return (unitOL DMBISH)
+ MO_Touch -> return nilOL -- Keep variables live (when using interior pointers)
-- Prefetch
- MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint.
+ MO_Prefetch_Data _n -> return nilOL -- Prefetch hint.
-- Memory copy/set/move/cmp, with alignment for optimization
@@ -2029,7 +2005,7 @@ genCCall target dest_regs arg_regs bid = do
code =
code_p `snocOL`
instr (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)
- return (code, Nothing)
+ return code
| otherwise -> panic "mal-formed AtomicRead"
MO_AtomicWrite w ord
| [p_reg, val_reg] <- arg_regs -> do
@@ -2042,7 +2018,7 @@ genCCall target dest_regs arg_regs bid = do
code_p `appOL`
code_val `snocOL`
instr fmt_val (OpReg w val) (OpAddr $ AddrReg p)
- return (code, Nothing)
+ return code
| otherwise -> panic "mal-formed AtomicWrite"
MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
MO_Cmpxchg w -> mkCCall (cmpxchgLabel w)
@@ -2055,13 +2031,13 @@ genCCall target dest_regs arg_regs bid = do
unsupported :: Show a => a -> b
unsupported mop = panic ("outOfLineCmmOp: " ++ show mop
++ " not supported here")
- mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)
+ mkCCall :: FastString -> NatM InstrBlock
mkCCall name = do
config <- getConfig
target <- cmmMakeDynamicReference config CallReference $
mkForeignLabel name ForeignLabelInThisPackage IsFunction
let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
- genCCall (ForeignTarget target cconv) dest_regs arg_regs bid
+ genCCall (ForeignTarget target cconv) dest_regs arg_regs
-- TODO: Optimize using paired stores and loads (STP, LDP). It is
-- automatically done by the allocator for us. However it's not optimal,
@@ -2227,7 +2203,7 @@ genCCall target dest_regs arg_regs bid = do
(reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
let dst = getRegisterReg platform (CmmLocal dest_reg)
let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
- return (code, Nothing)
+ return code
{- Note [AArch64 far jumps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
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.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
=====================================
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/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/a0f769bd39ad0fcd4af5df230c7c2d6308d9bde2...d7cbe048865126fce44c2b5034c7efb699e1d1ca
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a0f769bd39ad0fcd4af5df230c7c2d6308d9bde2...d7cbe048865126fce44c2b5034c7efb699e1d1ca
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/20240630/303bd977/attachment-0001.html>
More information about the ghc-commits
mailing list