[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: PPC and X86: Portable printing of IEEE floats
Marge Bot
gitlab at gitlab.haskell.org
Thu Aug 27 12:19:32 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fcb10b6c by Peter Trommler at 2020-08-26T10:42:30-04:00
PPC and X86: Portable printing of IEEE floats
GNU as and the AIX assembler support floating point literals.
SPARC seems to have support too but I cannot test on SPARC.
Curiously, `doubleToBytes` is also used in the LLVM backend.
To avoid endianness issues when cross-compiling float and double literals
are printed as C-style floating point values. The assembler then takes
care of memory layout and endianness.
This was brought up in #18431 by @hsyl20.
- - - - -
770100e0 by Krzysztof Gogolewski at 2020-08-26T10:43:13-04:00
primops: Remove Monadic and Dyadic categories
There were four categories of primops: Monadic, Dyadic, Compare, GenPrimOp.
The compiler does not treat Monadic and Dyadic in any special way,
we can just replace them with GenPrimOp.
Compare is still used in isComparisonPrimOp.
- - - - -
bcd1cba0 by Aditya Gupta at 2020-08-27T08:19:18-04:00
Consolidate imports in getMinimalImports (#18264)
- - - - -
e0b3cbda by Ryan Scott at 2020-08-27T08:19:19-04:00
Make {hsExpr,hsType,pat}NeedsParens aware of boxed 1-tuples
`hsExprNeedsParens`, `hsTypeNeedsParens`, and `patNeedsParens`
previously assumed that all uses of explicit tuples in the source
syntax never need to be parenthesized. This is true save for one
exception: boxed one-tuples, which use the `Solo` data type from
`GHC.Tuple` instead of special tuple syntax. This patch adds the
necessary logic to the three `*NeedsParens` functions to handle
`Solo` correctly.
Fixes #18612.
- - - - -
23 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToAsm/SPARC/Ppr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/StgToCmm/Prim.hs
- testsuite/tests/rename/should_compile/Makefile
- + testsuite/tests/rename/should_compile/T18264.hs
- + testsuite/tests/rename/should_compile/T18264.stdout
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/th/T18612.hs
- + testsuite/tests/th/T18612.stderr
- testsuite/tests/th/all.T
- utils/genprimopcode/Lexer.x
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Parser.y
- utils/genprimopcode/ParserM.hs
- utils/genprimopcode/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -38,7 +38,7 @@ import GHC.Types.Name
import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )
import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) )
import GHC.Core.Type
-import GHC.Types.RepType ( typePrimRep1, tyConPrimRep1 )
+import GHC.Types.RepType ( tyConPrimRep1 )
import GHC.Types.Basic ( Arity, Fixity(..), FixityDirection(..), Boxity(..),
SourceText(..) )
import GHC.Types.SrcLoc ( wiredInSrcSpan )
@@ -103,33 +103,17 @@ tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp)
\subsection[PrimOp-info]{The essential info about each @PrimOp@}
* *
************************************************************************
-
-The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may
-refer to the primitive operation. The conventional \tr{#}-for-
-unboxed ops is added on later.
-
-The reason for the funny characters in the names is so we do not
-interfere with the programmer's Haskell name spaces.
-
-We use @PrimKinds@ for the ``type'' information, because they're
-(slightly) more convenient to use than @TyCons at .
-}
data PrimOpInfo
- = Dyadic OccName -- string :: T -> T -> T
- Type
- | Monadic OccName -- string :: T -> T
- Type
- | Compare OccName -- string :: T -> T -> Int#
+ = Compare OccName -- string :: T -> T -> Int#
Type
| GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T
[TyVar]
[Type]
Type
-mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo
-mkDyadic str ty = Dyadic (mkVarOccFS str) ty
-mkMonadic str ty = Monadic (mkVarOccFS str) ty
+mkCompare :: FastString -> Type -> PrimOpInfo
mkCompare str ty = Compare (mkVarOccFS str) ty
mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo
@@ -575,8 +559,6 @@ primOpCodeSizeForeignCall = 4
primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
= case primOpInfo op of
- Dyadic _occ ty -> dyadic_fun_ty ty
- Monadic _occ ty -> monadic_fun_ty ty
Compare _occ ty -> compare_fun_ty ty
GenPrimOp _occ tyvars arg_tys res_ty ->
@@ -585,15 +567,11 @@ primOpType op
primOpResultType :: PrimOp -> Type
primOpResultType op
= case primOpInfo op of
- Dyadic _occ ty -> ty
- Monadic _occ ty -> ty
Compare _occ _ty -> intPrimTy
GenPrimOp _occ _tyvars _arg_tys res_ty -> res_ty
primOpOcc :: PrimOp -> OccName
primOpOcc op = case primOpInfo op of
- Dyadic occ _ -> occ
- Monadic occ _ -> occ
Compare occ _ -> occ
GenPrimOp occ _ _ _ -> occ
@@ -692,8 +670,8 @@ primOpWrapperId op = mkVanillaGlobalWithInfo name ty info
isComparisonPrimOp :: PrimOp -> Bool
isComparisonPrimOp op = case primOpInfo op of
- Compare {} -> True
- _ -> False
+ Compare {} -> True
+ GenPrimOp {} -> False
-- primOpSig is like primOpType but gives the result split apart:
-- (type variables, argument types, result type)
@@ -706,8 +684,6 @@ primOpSig op
arity = length arg_tys
(tyvars, arg_tys, res_ty)
= case (primOpInfo op) of
- Monadic _occ ty -> ([], [ty], ty )
- Dyadic _occ ty -> ([], [ty,ty], ty )
Compare _occ ty -> ([], [ty,ty], intPrimTy)
GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty )
@@ -722,8 +698,6 @@ data PrimOpResultInfo
getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
getPrimOpResultInfo op
= case (primOpInfo op) of
- Dyadic _ ty -> ReturnsPrim (typePrimRep1 ty)
- Monadic _ ty -> ReturnsPrim (typePrimRep1 ty)
Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)
GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)
| otherwise -> ReturnsAlg tc
@@ -747,9 +721,7 @@ commutableOp :: PrimOp -> Bool
-- Utils:
-dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type
-dyadic_fun_ty ty = mkVisFunTysMany [ty, ty] ty
-monadic_fun_ty ty = mkVisFunTyMany ty ty
+compare_fun_ty :: Type -> Type
compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy
-- Output stuff:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -42,11 +42,9 @@
-- (eg, out_of_line), whilst avoiding parsing complex expressions
-- needed for strictness info.
--
--- type refers to the general category of the primop. Valid settings include,
+-- type refers to the general category of the primop. There are only two:
--
-- * Compare: A comparison operation of the shape a -> a -> Int#
--- * Monadic: A unary operation of shape a -> a
--- * Dyadic: A binary operation of shape a -> a -> a
-- * GenPrimOp: Any other sort of primop
--
@@ -238,23 +236,23 @@ primtype Int8#
primop Int8Extend "extendInt8#" GenPrimOp Int8# -> Int#
primop Int8Narrow "narrowInt8#" GenPrimOp Int# -> Int8#
-primop Int8NegOp "negateInt8#" Monadic Int8# -> Int8#
+primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8#
-primop Int8AddOp "plusInt8#" Dyadic Int8# -> Int8# -> Int8#
+primop Int8AddOp "plusInt8#" GenPrimOp Int8# -> Int8# -> Int8#
with
commutable = True
-primop Int8SubOp "subInt8#" Dyadic Int8# -> Int8# -> Int8#
+primop Int8SubOp "subInt8#" GenPrimOp Int8# -> Int8# -> Int8#
-primop Int8MulOp "timesInt8#" Dyadic Int8# -> Int8# -> Int8#
+primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8#
with
commutable = True
-primop Int8QuotOp "quotInt8#" Dyadic Int8# -> Int8# -> Int8#
+primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8#
with
can_fail = True
-primop Int8RemOp "remInt8#" Dyadic Int8# -> Int8# -> Int8#
+primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8#
with
can_fail = True
@@ -279,23 +277,23 @@ primtype Word8#
primop Word8Extend "extendWord8#" GenPrimOp Word8# -> Word#
primop Word8Narrow "narrowWord8#" GenPrimOp Word# -> Word8#
-primop Word8NotOp "notWord8#" Monadic Word8# -> Word8#
+primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8#
-primop Word8AddOp "plusWord8#" Dyadic Word8# -> Word8# -> Word8#
+primop Word8AddOp "plusWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with
commutable = True
-primop Word8SubOp "subWord8#" Dyadic Word8# -> Word8# -> Word8#
+primop Word8SubOp "subWord8#" GenPrimOp Word8# -> Word8# -> Word8#
-primop Word8MulOp "timesWord8#" Dyadic Word8# -> Word8# -> Word8#
+primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with
commutable = True
-primop Word8QuotOp "quotWord8#" Dyadic Word8# -> Word8# -> Word8#
+primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with
can_fail = True
-primop Word8RemOp "remWord8#" Dyadic Word8# -> Word8# -> Word8#
+primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with
can_fail = True
@@ -320,23 +318,23 @@ primtype Int16#
primop Int16Extend "extendInt16#" GenPrimOp Int16# -> Int#
primop Int16Narrow "narrowInt16#" GenPrimOp Int# -> Int16#
-primop Int16NegOp "negateInt16#" Monadic Int16# -> Int16#
+primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16#
-primop Int16AddOp "plusInt16#" Dyadic Int16# -> Int16# -> Int16#
+primop Int16AddOp "plusInt16#" GenPrimOp Int16# -> Int16# -> Int16#
with
commutable = True
-primop Int16SubOp "subInt16#" Dyadic Int16# -> Int16# -> Int16#
+primop Int16SubOp "subInt16#" GenPrimOp Int16# -> Int16# -> Int16#
-primop Int16MulOp "timesInt16#" Dyadic Int16# -> Int16# -> Int16#
+primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16#
with
commutable = True
-primop Int16QuotOp "quotInt16#" Dyadic Int16# -> Int16# -> Int16#
+primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16#
with
can_fail = True
-primop Int16RemOp "remInt16#" Dyadic Int16# -> Int16# -> Int16#
+primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16#
with
can_fail = True
@@ -361,23 +359,23 @@ primtype Word16#
primop Word16Extend "extendWord16#" GenPrimOp Word16# -> Word#
primop Word16Narrow "narrowWord16#" GenPrimOp Word# -> Word16#
-primop Word16NotOp "notWord16#" Monadic Word16# -> Word16#
+primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16#
-primop Word16AddOp "plusWord16#" Dyadic Word16# -> Word16# -> Word16#
+primop Word16AddOp "plusWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with
commutable = True
-primop Word16SubOp "subWord16#" Dyadic Word16# -> Word16# -> Word16#
+primop Word16SubOp "subWord16#" GenPrimOp Word16# -> Word16# -> Word16#
-primop Word16MulOp "timesWord16#" Dyadic Word16# -> Word16# -> Word16#
+primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with
commutable = True
-primop Word16QuotOp "quotWord16#" Dyadic Word16# -> Word16# -> Word16#
+primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with
can_fail = True
-primop Word16RemOp "remWord16#" Dyadic Word16# -> Word16# -> Word16#
+primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with
can_fail = True
@@ -420,16 +418,16 @@ section "Int#"
primtype Int#
-primop IntAddOp "+#" Dyadic
+primop IntAddOp "+#" GenPrimOp
Int# -> Int# -> Int#
with commutable = True
fixity = infixl 6
-primop IntSubOp "-#" Dyadic Int# -> Int# -> Int#
+primop IntSubOp "-#" GenPrimOp Int# -> Int# -> Int#
with fixity = infixl 6
primop IntMulOp "*#"
- Dyadic Int# -> Int# -> Int#
+ GenPrimOp Int# -> Int# -> Int#
{Low word of signed integer multiply.}
with commutable = True
fixity = infixl 7
@@ -442,7 +440,7 @@ primop IntMul2Op "timesInt2#" GenPrimOp
0#) or not (isHighNeeded = 1#).}
primop IntMulMayOfloOp "mulIntMayOflo#"
- Dyadic Int# -> Int# -> Int#
+ GenPrimOp Int# -> Int# -> Int#
{Return non-zero if there is any possibility that the upper word of a
signed integer multiply might contain useful information. Return
zero only if you are completely sure that no overflow can occur.
@@ -465,14 +463,14 @@ primop IntMulMayOfloOp "mulIntMayOflo#"
}
with commutable = True
-primop IntQuotOp "quotInt#" Dyadic
+primop IntQuotOp "quotInt#" GenPrimOp
Int# -> Int# -> Int#
{Rounds towards zero. The behavior is undefined if the second argument is
zero.
}
with can_fail = True
-primop IntRemOp "remInt#" Dyadic
+primop IntRemOp "remInt#" GenPrimOp
Int# -> Int# -> Int#
{Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}. The
behavior is undefined if the second argument is zero.
@@ -484,22 +482,22 @@ primop IntQuotRemOp "quotRemInt#" GenPrimOp
{Rounds towards zero.}
with can_fail = True
-primop AndIOp "andI#" Dyadic Int# -> Int# -> Int#
+primop AndIOp "andI#" GenPrimOp Int# -> Int# -> Int#
{Bitwise "and".}
with commutable = True
-primop OrIOp "orI#" Dyadic Int# -> Int# -> Int#
+primop OrIOp "orI#" GenPrimOp Int# -> Int# -> Int#
{Bitwise "or".}
with commutable = True
-primop XorIOp "xorI#" Dyadic Int# -> Int# -> Int#
+primop XorIOp "xorI#" GenPrimOp Int# -> Int# -> Int#
{Bitwise "xor".}
with commutable = True
-primop NotIOp "notI#" Monadic Int# -> Int#
+primop NotIOp "notI#" GenPrimOp Int# -> Int#
{Bitwise "not", also known as the binary complement.}
-primop IntNegOp "negateInt#" Monadic Int# -> Int#
+primop IntNegOp "negateInt#" GenPrimOp Int# -> Int#
{Unary negation.
Since the negative {\tt Int#} range extends one further than the
positive range, {\tt negateInt#} of the most negative number is an
@@ -573,7 +571,7 @@ section "Word#"
primtype Word#
-primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word#
+primop WordAddOp "plusWord#" GenPrimOp Word# -> Word# -> Word#
with commutable = True
primop WordAddCOp "addWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #)
@@ -596,9 +594,9 @@ primop WordAdd2Op "plusWord2#" GenPrimOp Word# -> Word# -> (# Word#, Wor
with code_size = 2
commutable = True
-primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word#
+primop WordSubOp "minusWord#" GenPrimOp Word# -> Word# -> Word#
-primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word#
+primop WordMulOp "timesWord#" GenPrimOp Word# -> Word# -> Word#
with commutable = True
-- Returns (# high, low #)
@@ -606,10 +604,10 @@ primop WordMul2Op "timesWord2#" GenPrimOp
Word# -> Word# -> (# Word#, Word# #)
with commutable = True
-primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word#
+primop WordQuotOp "quotWord#" GenPrimOp Word# -> Word# -> Word#
with can_fail = True
-primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word#
+primop WordRemOp "remWord#" GenPrimOp Word# -> Word# -> Word#
with can_fail = True
primop WordQuotRemOp "quotRemWord#" GenPrimOp
@@ -622,16 +620,16 @@ primop WordQuotRem2Op "quotRemWord2#" GenPrimOp
Requires that high word < divisor.}
with can_fail = True
-primop AndOp "and#" Dyadic Word# -> Word# -> Word#
+primop AndOp "and#" GenPrimOp Word# -> Word# -> Word#
with commutable = True
-primop OrOp "or#" Dyadic Word# -> Word# -> Word#
+primop OrOp "or#" GenPrimOp Word# -> Word# -> Word#
with commutable = True
-primop XorOp "xor#" Dyadic Word# -> Word# -> Word#
+primop XorOp "xor#" GenPrimOp Word# -> Word# -> Word#
with commutable = True
-primop NotOp "not#" Monadic Word# -> Word#
+primop NotOp "not#" GenPrimOp Word# -> Word#
primop SllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word#
{Shift left logical. Result undefined if shift amount is not
@@ -650,79 +648,79 @@ primop WordNeOp "neWord#" Compare Word# -> Word# -> Int#
primop WordLtOp "ltWord#" Compare Word# -> Word# -> Int#
primop WordLeOp "leWord#" Compare Word# -> Word# -> Int#
-primop PopCnt8Op "popCnt8#" Monadic Word# -> Word#
+primop PopCnt8Op "popCnt8#" GenPrimOp Word# -> Word#
{Count the number of set bits in the lower 8 bits of a word.}
-primop PopCnt16Op "popCnt16#" Monadic Word# -> Word#
+primop PopCnt16Op "popCnt16#" GenPrimOp Word# -> Word#
{Count the number of set bits in the lower 16 bits of a word.}
-primop PopCnt32Op "popCnt32#" Monadic Word# -> Word#
+primop PopCnt32Op "popCnt32#" GenPrimOp Word# -> Word#
{Count the number of set bits in the lower 32 bits of a word.}
primop PopCnt64Op "popCnt64#" GenPrimOp WORD64 -> Word#
{Count the number of set bits in a 64-bit word.}
-primop PopCntOp "popCnt#" Monadic Word# -> Word#
+primop PopCntOp "popCnt#" GenPrimOp Word# -> Word#
{Count the number of set bits in a word.}
-primop Pdep8Op "pdep8#" Dyadic Word# -> Word# -> Word#
+primop Pdep8Op "pdep8#" GenPrimOp Word# -> Word# -> Word#
{Deposit bits to lower 8 bits of a word at locations specified by a mask.}
-primop Pdep16Op "pdep16#" Dyadic Word# -> Word# -> Word#
+primop Pdep16Op "pdep16#" GenPrimOp Word# -> Word# -> Word#
{Deposit bits to lower 16 bits of a word at locations specified by a mask.}
-primop Pdep32Op "pdep32#" Dyadic Word# -> Word# -> Word#
+primop Pdep32Op "pdep32#" GenPrimOp Word# -> Word# -> Word#
{Deposit bits to lower 32 bits of a word at locations specified by a mask.}
primop Pdep64Op "pdep64#" GenPrimOp WORD64 -> WORD64 -> WORD64
{Deposit bits to a word at locations specified by a mask.}
-primop PdepOp "pdep#" Dyadic Word# -> Word# -> Word#
+primop PdepOp "pdep#" GenPrimOp Word# -> Word# -> Word#
{Deposit bits to a word at locations specified by a mask.}
-primop Pext8Op "pext8#" Dyadic Word# -> Word# -> Word#
+primop Pext8Op "pext8#" GenPrimOp Word# -> Word# -> Word#
{Extract bits from lower 8 bits of a word at locations specified by a mask.}
-primop Pext16Op "pext16#" Dyadic Word# -> Word# -> Word#
+primop Pext16Op "pext16#" GenPrimOp Word# -> Word# -> Word#
{Extract bits from lower 16 bits of a word at locations specified by a mask.}
-primop Pext32Op "pext32#" Dyadic Word# -> Word# -> Word#
+primop Pext32Op "pext32#" GenPrimOp Word# -> Word# -> Word#
{Extract bits from lower 32 bits of a word at locations specified by a mask.}
primop Pext64Op "pext64#" GenPrimOp WORD64 -> WORD64 -> WORD64
{Extract bits from a word at locations specified by a mask.}
-primop PextOp "pext#" Dyadic Word# -> Word# -> Word#
+primop PextOp "pext#" GenPrimOp Word# -> Word# -> Word#
{Extract bits from a word at locations specified by a mask.}
-primop Clz8Op "clz8#" Monadic Word# -> Word#
+primop Clz8Op "clz8#" GenPrimOp Word# -> Word#
{Count leading zeros in the lower 8 bits of a word.}
-primop Clz16Op "clz16#" Monadic Word# -> Word#
+primop Clz16Op "clz16#" GenPrimOp Word# -> Word#
{Count leading zeros in the lower 16 bits of a word.}
-primop Clz32Op "clz32#" Monadic Word# -> Word#
+primop Clz32Op "clz32#" GenPrimOp Word# -> Word#
{Count leading zeros in the lower 32 bits of a word.}
primop Clz64Op "clz64#" GenPrimOp WORD64 -> Word#
{Count leading zeros in a 64-bit word.}
-primop ClzOp "clz#" Monadic Word# -> Word#
+primop ClzOp "clz#" GenPrimOp Word# -> Word#
{Count leading zeros in a word.}
-primop Ctz8Op "ctz8#" Monadic Word# -> Word#
+primop Ctz8Op "ctz8#" GenPrimOp Word# -> Word#
{Count trailing zeros in the lower 8 bits of a word.}
-primop Ctz16Op "ctz16#" Monadic Word# -> Word#
+primop Ctz16Op "ctz16#" GenPrimOp Word# -> Word#
{Count trailing zeros in the lower 16 bits of a word.}
-primop Ctz32Op "ctz32#" Monadic Word# -> Word#
+primop Ctz32Op "ctz32#" GenPrimOp Word# -> Word#
{Count trailing zeros in the lower 32 bits of a word.}
primop Ctz64Op "ctz64#" GenPrimOp WORD64 -> Word#
{Count trailing zeros in a 64-bit word.}
-primop CtzOp "ctz#" Monadic Word# -> Word#
+primop CtzOp "ctz#" GenPrimOp Word# -> Word#
{Count trailing zeros in a word.}
-primop BSwap16Op "byteSwap16#" Monadic Word# -> Word#
+primop BSwap16Op "byteSwap16#" GenPrimOp Word# -> Word#
{Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. }
-primop BSwap32Op "byteSwap32#" Monadic Word# -> Word#
+primop BSwap32Op "byteSwap32#" GenPrimOp Word# -> Word#
{Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }
-primop BSwap64Op "byteSwap64#" Monadic WORD64 -> WORD64
+primop BSwap64Op "byteSwap64#" GenPrimOp WORD64 -> WORD64
{Swap bytes in a 64 bits of a word.}
-primop BSwapOp "byteSwap#" Monadic Word# -> Word#
+primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word#
{Swap bytes in a word.}
-primop BRev8Op "bitReverse8#" Monadic Word# -> Word#
+primop BRev8Op "bitReverse8#" GenPrimOp Word# -> Word#
{Reverse the order of the bits in a 8-bit word.}
-primop BRev16Op "bitReverse16#" Monadic Word# -> Word#
+primop BRev16Op "bitReverse16#" GenPrimOp Word# -> Word#
{Reverse the order of the bits in a 16-bit word.}
-primop BRev32Op "bitReverse32#" Monadic Word# -> Word#
+primop BRev32Op "bitReverse32#" GenPrimOp Word# -> Word#
{Reverse the order of the bits in a 32-bit word.}
-primop BRev64Op "bitReverse64#" Monadic WORD64 -> WORD64
+primop BRev64Op "bitReverse64#" GenPrimOp WORD64 -> WORD64
{Reverse the order of the bits in a 64-bit word.}
-primop BRevOp "bitReverse#" Monadic Word# -> Word#
+primop BRevOp "bitReverse#" GenPrimOp Word# -> Word#
{Reverse the order of the bits in a word.}
------------------------------------------------------------------------
@@ -730,12 +728,12 @@ section "Narrowings"
{Explicit narrowing of native-sized ints or words.}
------------------------------------------------------------------------
-primop Narrow8IntOp "narrow8Int#" Monadic Int# -> Int#
-primop Narrow16IntOp "narrow16Int#" Monadic Int# -> Int#
-primop Narrow32IntOp "narrow32Int#" Monadic Int# -> Int#
-primop Narrow8WordOp "narrow8Word#" Monadic Word# -> Word#
-primop Narrow16WordOp "narrow16Word#" Monadic Word# -> Word#
-primop Narrow32WordOp "narrow32Word#" Monadic Word# -> Word#
+primop Narrow8IntOp "narrow8Int#" GenPrimOp Int# -> Int#
+primop Narrow16IntOp "narrow16Int#" GenPrimOp Int# -> Int#
+primop Narrow32IntOp "narrow32Int#" GenPrimOp Int# -> Int#
+primop Narrow8WordOp "narrow8Word#" GenPrimOp Word# -> Word#
+primop Narrow16WordOp "narrow16Word#" GenPrimOp Word# -> Word#
+primop Narrow32WordOp "narrow32Word#" GenPrimOp Word# -> Word#
------------------------------------------------------------------------
section "Double#"
@@ -766,27 +764,27 @@ primop DoubleLtOp "<##" Compare Double# -> Double# -> Int#
primop DoubleLeOp "<=##" Compare Double# -> Double# -> Int#
with fixity = infix 4
-primop DoubleAddOp "+##" Dyadic
+primop DoubleAddOp "+##" GenPrimOp
Double# -> Double# -> Double#
with commutable = True
fixity = infixl 6
-primop DoubleSubOp "-##" Dyadic Double# -> Double# -> Double#
+primop DoubleSubOp "-##" GenPrimOp Double# -> Double# -> Double#
with fixity = infixl 6
-primop DoubleMulOp "*##" Dyadic
+primop DoubleMulOp "*##" GenPrimOp
Double# -> Double# -> Double#
with commutable = True
fixity = infixl 7
-primop DoubleDivOp "/##" Dyadic
+primop DoubleDivOp "/##" GenPrimOp
Double# -> Double# -> Double#
with can_fail = True
fixity = infixl 7
-primop DoubleNegOp "negateDouble#" Monadic Double# -> Double#
+primop DoubleNegOp "negateDouble#" GenPrimOp Double# -> Double#
-primop DoubleFabsOp "fabsDouble#" Monadic Double# -> Double#
+primop DoubleFabsOp "fabsDouble#" GenPrimOp Double# -> Double#
primop Double2IntOp "double2Int#" GenPrimOp Double# -> Int#
{Truncates a {\tt Double#} value to the nearest {\tt Int#}.
@@ -795,96 +793,96 @@ primop Double2IntOp "double2Int#" GenPrimOp Double# -> Int#
primop Double2FloatOp "double2Float#" GenPrimOp Double# -> Float#
-primop DoubleExpOp "expDouble#" Monadic
+primop DoubleExpOp "expDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleExpM1Op "expm1Double#" Monadic
+primop DoubleExpM1Op "expm1Double#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleLogOp "logDouble#" Monadic
+primop DoubleLogOp "logDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
can_fail = True
-primop DoubleLog1POp "log1pDouble#" Monadic
+primop DoubleLog1POp "log1pDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
can_fail = True
-primop DoubleSqrtOp "sqrtDouble#" Monadic
+primop DoubleSqrtOp "sqrtDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleSinOp "sinDouble#" Monadic
+primop DoubleSinOp "sinDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleCosOp "cosDouble#" Monadic
+primop DoubleCosOp "cosDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleTanOp "tanDouble#" Monadic
+primop DoubleTanOp "tanDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleAsinOp "asinDouble#" Monadic
+primop DoubleAsinOp "asinDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
can_fail = True
-primop DoubleAcosOp "acosDouble#" Monadic
+primop DoubleAcosOp "acosDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
can_fail = True
-primop DoubleAtanOp "atanDouble#" Monadic
+primop DoubleAtanOp "atanDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleSinhOp "sinhDouble#" Monadic
+primop DoubleSinhOp "sinhDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleCoshOp "coshDouble#" Monadic
+primop DoubleCoshOp "coshDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleTanhOp "tanhDouble#" Monadic
+primop DoubleTanhOp "tanhDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleAsinhOp "asinhDouble#" Monadic
+primop DoubleAsinhOp "asinhDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleAcoshOp "acoshDouble#" Monadic
+primop DoubleAcoshOp "acoshDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoubleAtanhOp "atanhDouble#" Monadic
+primop DoubleAtanhOp "atanhDouble#" GenPrimOp
Double# -> Double#
with
code_size = { primOpCodeSizeForeignCall }
-primop DoublePowerOp "**##" Dyadic
+primop DoublePowerOp "**##" GenPrimOp
Double# -> Double# -> Double#
{Exponentiation.}
with
@@ -924,119 +922,119 @@ primop FloatNeOp "neFloat#" Compare
primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Int#
primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Int#
-primop FloatAddOp "plusFloat#" Dyadic
+primop FloatAddOp "plusFloat#" GenPrimOp
Float# -> Float# -> Float#
with commutable = True
-primop FloatSubOp "minusFloat#" Dyadic Float# -> Float# -> Float#
+primop FloatSubOp "minusFloat#" GenPrimOp Float# -> Float# -> Float#
-primop FloatMulOp "timesFloat#" Dyadic
+primop FloatMulOp "timesFloat#" GenPrimOp
Float# -> Float# -> Float#
with commutable = True
-primop FloatDivOp "divideFloat#" Dyadic
+primop FloatDivOp "divideFloat#" GenPrimOp
Float# -> Float# -> Float#
with can_fail = True
-primop FloatNegOp "negateFloat#" Monadic Float# -> Float#
+primop FloatNegOp "negateFloat#" GenPrimOp Float# -> Float#
-primop FloatFabsOp "fabsFloat#" Monadic Float# -> Float#
+primop FloatFabsOp "fabsFloat#" GenPrimOp Float# -> Float#
primop Float2IntOp "float2Int#" GenPrimOp Float# -> Int#
{Truncates a {\tt Float#} value to the nearest {\tt Int#}.
Results are undefined if the truncation if truncation yields
a value outside the range of {\tt Int#}.}
-primop FloatExpOp "expFloat#" Monadic
+primop FloatExpOp "expFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatExpM1Op "expm1Float#" Monadic
+primop FloatExpM1Op "expm1Float#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatLogOp "logFloat#" Monadic
+primop FloatLogOp "logFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
can_fail = True
-primop FloatLog1POp "log1pFloat#" Monadic
+primop FloatLog1POp "log1pFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
can_fail = True
-primop FloatSqrtOp "sqrtFloat#" Monadic
+primop FloatSqrtOp "sqrtFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatSinOp "sinFloat#" Monadic
+primop FloatSinOp "sinFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatCosOp "cosFloat#" Monadic
+primop FloatCosOp "cosFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatTanOp "tanFloat#" Monadic
+primop FloatTanOp "tanFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatAsinOp "asinFloat#" Monadic
+primop FloatAsinOp "asinFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
can_fail = True
-primop FloatAcosOp "acosFloat#" Monadic
+primop FloatAcosOp "acosFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
can_fail = True
-primop FloatAtanOp "atanFloat#" Monadic
+primop FloatAtanOp "atanFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatSinhOp "sinhFloat#" Monadic
+primop FloatSinhOp "sinhFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatCoshOp "coshFloat#" Monadic
+primop FloatCoshOp "coshFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatTanhOp "tanhFloat#" Monadic
+primop FloatTanhOp "tanhFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatAsinhOp "asinhFloat#" Monadic
+primop FloatAsinhOp "asinhFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatAcoshOp "acoshFloat#" Monadic
+primop FloatAcoshOp "acoshFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatAtanhOp "atanhFloat#" Monadic
+primop FloatAtanhOp "atanhFloat#" GenPrimOp
Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
-primop FloatPowerOp "powerFloat#" Dyadic
+primop FloatPowerOp "powerFloat#" GenPrimOp
Float# -> Float# -> Float#
with
code_size = { primOpCodeSizeForeignCall }
@@ -3575,48 +3573,48 @@ primop VecInsertOp "insert#" GenPrimOp
llvm_only = True
vector = ALL_VECTOR_TYPES
-primop VecAddOp "plus#" Dyadic
+primop VecAddOp "plus#" GenPrimOp
VECTOR -> VECTOR -> VECTOR
{ Add two vectors element-wise. }
with commutable = True
llvm_only = True
vector = ALL_VECTOR_TYPES
-primop VecSubOp "minus#" Dyadic
+primop VecSubOp "minus#" GenPrimOp
VECTOR -> VECTOR -> VECTOR
{ Subtract two vectors element-wise. }
with llvm_only = True
vector = ALL_VECTOR_TYPES
-primop VecMulOp "times#" Dyadic
+primop VecMulOp "times#" GenPrimOp
VECTOR -> VECTOR -> VECTOR
{ Multiply two vectors element-wise. }
with commutable = True
llvm_only = True
vector = ALL_VECTOR_TYPES
-primop VecDivOp "divide#" Dyadic
+primop VecDivOp "divide#" GenPrimOp
VECTOR -> VECTOR -> VECTOR
{ Divide two vectors element-wise. }
with can_fail = True
llvm_only = True
vector = FLOAT_VECTOR_TYPES
-primop VecQuotOp "quot#" Dyadic
+primop VecQuotOp "quot#" GenPrimOp
VECTOR -> VECTOR -> VECTOR
{ Rounds towards zero element-wise. }
with can_fail = True
llvm_only = True
vector = INT_VECTOR_TYPES
-primop VecRemOp "rem#" Dyadic
+primop VecRemOp "rem#" GenPrimOp
VECTOR -> VECTOR -> VECTOR
{ Satisfies \texttt{(quot\# x y) times\# y plus\# (rem\# x y) == x}. }
with can_fail = True
llvm_only = True
vector = INT_VECTOR_TYPES
-primop VecNegOp "negate#" Monadic
+primop VecNegOp "negate#" GenPrimOp
VECTOR -> VECTOR
{ Negate element-wise. }
with llvm_only = True
=====================================
compiler/GHC/CmmToAsm/PPC/Ppr.hs
=====================================
@@ -237,9 +237,8 @@ pprImm (ImmInteger i) = integer i
pprImm (ImmCLbl l) = ppr l
pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
pprImm (ImmLit s) = s
-
-pprImm (ImmFloat _) = text "naughty float immediate"
-pprImm (ImmDouble _) = text "naughty double immediate"
+pprImm (ImmFloat f) = float $ fromRational f
+pprImm (ImmDouble d) = double $ fromRational d
pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
@@ -337,13 +336,8 @@ pprDataItem platform lit
<> int (fromIntegral (fromIntegral x :: Word32))]
- ppr_item FF32 (CmmFloat r _)
- = let bs = floatToBytes (fromRational r)
- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
-
- ppr_item FF64 (CmmFloat r _)
- = let bs = doubleToBytes (fromRational r)
- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+ ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm]
+ ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm]
ppr_item _ _
= panic "PPC.Ppr.pprDataItem: no match"
=====================================
compiler/GHC/CmmToAsm/Ppr.hs
=====================================
@@ -9,9 +9,6 @@
-----------------------------------------------------------------------------
module GHC.CmmToAsm.Ppr (
- castFloatToWord8Array,
- castDoubleToWord8Array,
- floatToBytes,
doubleToBytes,
pprASCII,
pprString,
@@ -44,13 +41,13 @@ import qualified Data.ByteString as BS
import GHC.Exts
import GHC.Word
-
-
-- -----------------------------------------------------------------------------
-- Converting floating-point literals to integrals for printing
-castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
-castFloatToWord8Array = U.castSTUArray
+-- ToDo: this code is currently shared between SPARC and LLVM.
+-- Similar functions for (single precision) floats are
+-- present in the SPARC backend only. We need to fix both
+-- LLVM and SPARC.
castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
castDoubleToWord8Array = U.castSTUArray
@@ -63,19 +60,6 @@ castDoubleToWord8Array = U.castSTUArray
-- ToDo: this stuff is very similar to the shenanigans in PprAbs,
-- could they be merged?
-floatToBytes :: Float -> [Int]
-floatToBytes f
- = runST (do
- arr <- newArray_ ((0::Int),3)
- writeArray arr 0 f
- arr <- castFloatToWord8Array arr
- i0 <- readArray arr 0
- i1 <- readArray arr 1
- i2 <- readArray arr 2
- i3 <- readArray arr 3
- return (map fromIntegral [i0,i1,i2,i3])
- )
-
doubleToBytes :: Double -> [Int]
doubleToBytes d
= runST (do
=====================================
compiler/GHC/CmmToAsm/SPARC/Ppr.hs
=====================================
@@ -25,6 +25,12 @@ where
import GHC.Prelude
+import Data.Word
+import qualified Data.Array.Unsafe as U ( castSTUArray )
+import Data.Array.ST
+
+import Control.Monad.ST
+
import GHC.CmmToAsm.SPARC.Regs
import GHC.CmmToAsm.SPARC.Instr
import GHC.CmmToAsm.SPARC.Cond
@@ -369,6 +375,22 @@ pprDataItem platform lit
ppr_item II64 _ = [text "\t.quad\t" <> pprImm imm]
ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match"
+floatToBytes :: Float -> [Int]
+floatToBytes f
+ = runST (do
+ arr <- newArray_ ((0::Int),3)
+ writeArray arr 0 f
+ arr <- castFloatToWord8Array arr
+ i0 <- readArray arr 0
+ i1 <- readArray arr 1
+ i2 <- readArray arr 2
+ i3 <- readArray arr 3
+ return (map fromIntegral [i0,i1,i2,i3])
+ )
+
+castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
+castFloatToWord8Array = U.castSTUArray
+
-- | Pretty print an instruction.
pprInstr :: Instr -> SDoc
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -423,9 +423,8 @@ pprImm (ImmInteger i) = integer i
pprImm (ImmCLbl l) = ppr l
pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
pprImm (ImmLit s) = s
-
-pprImm (ImmFloat _) = text "naughty float immediate"
-pprImm (ImmDouble _) = text "naughty double immediate"
+pprImm (ImmFloat f) = float $ fromRational f
+pprImm (ImmDouble d) = double $ fromRational d
pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
@@ -514,13 +513,8 @@ pprDataItem config lit
ppr_item II16 _ = [text "\t.word\t" <> pprImm imm]
ppr_item II32 _ = [text "\t.long\t" <> pprImm imm]
- ppr_item FF32 (CmmFloat r _)
- = let bs = floatToBytes (fromRational r)
- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
-
- ppr_item FF64 (CmmFloat r _)
- = let bs = doubleToBytes (fromRational r)
- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+ ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm]
+ ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm]
ppr_item II64 _
= case platformOS platform of
@@ -558,9 +552,6 @@ pprDataItem config lit
_ ->
[text "\t.quad\t" <> pprImm imm]
- ppr_item _ _
- = panic "X86.Ppr.ppr_item: no match"
-
asmComment :: SDoc -> SDoc
asmComment c = whenPprDebug $ text "# " <> c
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1320,6 +1320,11 @@ hsExprNeedsParens p = go
go (NegApp{}) = p > topPrec
go (SectionL{}) = True
go (SectionR{}) = True
+ -- Special-case unary boxed tuple applications so that they are
+ -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)
+ -- See Note [One-tuples] in GHC.Builtin.Types
+ go (ExplicitTuple _ [L _ Present{}] Boxed)
+ = p >= appPrec
go (ExplicitTuple{}) = False
go (ExplicitSum{}) = False
go (HsLam{}) = p > topPrec
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -857,7 +857,12 @@ patNeedsParens p = go
go (BangPat {}) = False
go (ParPat {}) = False
go (AsPat {}) = False
- go (TuplePat {}) = False
+ -- Special-case unary boxed tuple applications so that they are
+ -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)
+ -- See Note [One-tuples] in GHC.Builtin.Types
+ go (TuplePat _ [_] Boxed)
+ = p >= appPrec
+ go (TuplePat{}) = False
go (SumPat {}) = False
go (ListPat {}) = False
go (LitPat _ l) = hsLitNeedsParens p l
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -1979,6 +1979,15 @@ hsTypeNeedsParens p = go_hs_ty
go_hs_ty (HsRecTy{}) = False
go_hs_ty (HsTyVar{}) = False
go_hs_ty (HsFunTy{}) = p >= funPrec
+ -- Special-case unary boxed tuple applications so that they are
+ -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)
+ -- See Note [One-tuples] in GHC.Builtin.Types
+ go_hs_ty (HsTupleTy _ con [L _ ty])
+ = case con of
+ HsBoxedTuple -> p >= appPrec
+ HsBoxedOrConstraintTuple -> p >= appPrec
+ HsConstraintTuple -> go_hs_ty ty
+ HsUnboxedTuple -> False
go_hs_ty (HsTupleTy{}) = False
go_hs_ty (HsSumTy{}) = False
go_hs_ty (HsKindSig{}) = p >= sigPrec
@@ -1986,6 +1995,11 @@ hsTypeNeedsParens p = go_hs_ty
go_hs_ty (HsIParamTy{}) = p > topPrec
go_hs_ty (HsSpliceTy{}) = False
go_hs_ty (HsExplicitListTy{}) = False
+ -- Special-case unary boxed tuple applications so that they are
+ -- parenthesized as `Proxy ('Solo x)`, not `Proxy 'Solo x` (#18612)
+ -- See Note [One-tuples] in GHC.Builtin.Types
+ go_hs_ty (HsExplicitTupleTy _ [_])
+ = p >= appPrec
go_hs_ty (HsExplicitTupleTy{}) = False
go_hs_ty (HsTyLit{}) = False
go_hs_ty (HsWildCardTy{}) = False
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -4,7 +4,7 @@
Extracting imported and top-level names in scope
-}
-{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}
+{-# LANGUAGE CPP, NondecreasingIndentation #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -72,7 +72,7 @@ import Data.Either ( partitionEithers, isRight, rights )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Ord ( comparing )
-import Data.List ( partition, (\\), find, sortBy )
+import Data.List ( partition, (\\), find, sortBy, groupBy, sortOn )
import Data.Function ( on )
import qualified Data.Set as S
import System.FilePath ((</>))
@@ -1570,7 +1570,7 @@ decls, and simply trim their import lists. NB that
-}
getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
-getMinimalImports = mapM mk_minimal
+getMinimalImports = fmap combine . mapM mk_minimal
where
mk_minimal (L l decl, used_gres, unused)
| null unused
@@ -1623,6 +1623,25 @@ getMinimalImports = mapM mk_minimal
all_non_overloaded = all (not . flIsOverloaded)
+ combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn]
+ combine = map merge . groupBy ((==) `on` getKey) . sortOn getKey
+
+ getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName)
+ getKey decl =
+ ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first)
+ , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad)
+ , unLoc . ideclName $ idecl -- Module Name
+ )
+ where
+ idecl :: ImportDecl GhcRn
+ idecl = unLoc decl
+
+ merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn
+ merge [] = error "getMinimalImports: unexpected empty list"
+ merge decls@((L l decl) : _) = L l (decl { ideclHiding = Just (False, L l lies) })
+ where lies = concatMap (unLoc . snd) $ mapMaybe (ideclHiding . unLoc) decls
+
+
printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM ()
-- See Note [Printing minimal imports]
printMinimalImports hsc_src imports_w_usage
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1,6 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
#if __GLASGOW_HASKELL__ <= 808
-- GHC 8.10 deprecates this flag, but GHC 8.8 needs it
@@ -1562,19 +1561,17 @@ emitPrimOp dflags primop = case primop of
-> FCode ())
-> PrimopCmmEmit
opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do
- regs <- if
- | ReturnsPrim VoidRep <- result_info
- -> pure []
+ regs <- case result_info of
+ ReturnsPrim VoidRep -> pure []
+ ReturnsPrim rep
+ -> do reg <- newTemp (primRepCmmType platform rep)
+ pure [reg]
- | ReturnsPrim rep <- result_info
- -> do reg <- newTemp (primRepCmmType platform rep)
- pure [reg]
+ ReturnsAlg tycon | isUnboxedTupleTyCon tycon
+ -> do (regs, _hints) <- newUnboxedTupleRegs res_ty
+ pure regs
- | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
- -> do (regs, _hints) <- newUnboxedTupleRegs res_ty
- pure regs
-
- | otherwise -> panic "cgOpApp"
+ _ -> panic "cgOpApp"
f regs
pure $ map (CmmReg . CmmLocal) regs
=====================================
testsuite/tests/rename/should_compile/Makefile
=====================================
@@ -60,3 +60,8 @@ T7969:
T18497:
'$(TEST_HC)' $(TEST_HC_OPTS) -fno-code T18497_Foo.hs T18497_Bar.hs -ddump-minimal-imports
cat T18497_Bar.imports-boot
+
+T18264:
+ $(RM) T18264.hi T18264.o T18264.imports
+ '$(TEST_HC)' $(TEST_HC_OPTS) -ddump-minimal-imports -c T18264.hs
+ cat T18264.imports
=====================================
testsuite/tests/rename/should_compile/T18264.hs
=====================================
@@ -0,0 +1,20 @@
+module T18264 where
+
+import Data.Char (isDigit)
+import Data.Maybe (isJust)
+import Data.Char (isPrint)
+import Data.List (sortOn)
+import Data.Char (isLetter)
+import Data.Maybe hiding (isNothing)
+
+import qualified Data.List as S (sort)
+import qualified Data.Char as C --only isDigit & isLetter used later
+import qualified Data.List as T (nub)
+
+test1 x = isDigit x || isLetter x
+test2a = isJust
+test2b = fromJust
+test3 x = C.isDigit x || C.isLetter x
+test4 xs = S.sort xs
+test5 xs = T.nub xs
+test6 f xs = sortOn f xs
=====================================
testsuite/tests/rename/should_compile/T18264.stdout
=====================================
@@ -0,0 +1,6 @@
+import Data.Char ( isDigit, isLetter )
+import Data.List ( sortOn )
+import Data.Maybe ( fromJust, isJust )
+import qualified Data.Char as C ( isLetter, isDigit )
+import qualified Data.List as S ( sort )
+import qualified Data.List as T ( nub )
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -175,3 +175,4 @@ test('T17244C', normal, compile, [''])
test('T17832', [], multimod_compile, ['T17832M1', 'T17832M2'])
test('T17837', normal, compile, [''])
test('T18497', [], makefile_test, ['T18497'])
+test('T18264', [], makefile_test, ['T18264'])
=====================================
testsuite/tests/th/T18612.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -ddump-splices #-}
+module T18612 where
+
+import Data.Functor.Identity
+import Data.Proxy
+import Language.Haskell.TH
+
+f :: $(arrowT `appT` (conT ''Identity `appT` (tupleT 1 `appT` (tupleT 0)))
+ `appT` (conT ''Identity `appT` (tupleT 1 `appT` (tupleT 0))))
+f $(conP 'Identity [tupP [tupP []]]) = $(conE 'Identity `appE` tupE [tupE []])
+
+type G = $(conT ''Proxy `appT` (promotedTupleT 1 `appT` (tupleT 0)))
=====================================
testsuite/tests/th/T18612.stderr
=====================================
@@ -0,0 +1,13 @@
+T18612.hs:14:11-68: Splicing type
+ conT ''Proxy `appT` (promotedTupleT 1 `appT` (tupleT 0))
+ ======>
+ Proxy ('Solo ())
+T18612.hs:(10,7)-(11,75): Splicing type
+ arrowT `appT` (conT ''Identity `appT` (tupleT 1 `appT` (tupleT 0)))
+ `appT` (conT ''Identity `appT` (tupleT 1 `appT` (tupleT 0)))
+ ======>
+ Identity (Solo ()) -> Identity (Solo ())
+T18612.hs:12:4-36: Splicing pattern
+ conP 'Identity [tupP [tupP []]] ======> Identity (Solo())
+T18612.hs:12:41-78: Splicing expression
+ conE 'Identity `appE` tupE [tupE []] ======> Identity (Solo ())
=====================================
testsuite/tests/th/all.T
=====================================
@@ -513,3 +513,4 @@ test('T18102b', extra_files(['T18102b_aux.hs']), compile_and_run, [''])
test('T18121', normal, compile, [''])
test('T18123', normal, compile, [''])
test('T18388', normal, compile, [''])
+test('T18612', normal, compile, [''])
=====================================
utils/genprimopcode/Lexer.x
=====================================
@@ -44,8 +44,6 @@ words :-
<0> "defaults" { mkT TDefaults }
<0> "True" { mkT TTrue }
<0> "False" { mkT TFalse }
- <0> "Dyadic" { mkT TDyadic }
- <0> "Monadic" { mkT TMonadic }
<0> "Compare" { mkT TCompare }
<0> "GenPrimOp" { mkT TGenPrimOp }
<0> "fixity" { mkT TFixity }
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -836,16 +836,6 @@ mkPOI_RHS_text i
TyF t1 (TyF _ _)
-> "mkCompare " ++ sl_name i ++ ppType t1
_ -> error "Type error in comparison op"
- Monadic
- -> case ty i of
- TyF t1 _
- -> "mkMonadic " ++ sl_name i ++ ppType t1
- _ -> error "Type error in monadic op"
- Dyadic
- -> case ty i of
- TyF t1 (TyF _ _)
- -> "mkDyadic " ++ sl_name i ++ ppType t1
- _ -> error "Type error in dyadic op"
GenPrimOp
-> let (argTys, resTy) = flatTys (ty i)
tvs = nub (tvsIn (ty i))
=====================================
utils/genprimopcode/Parser.y
=====================================
@@ -36,8 +36,6 @@ import Syntax
defaults { TDefaults }
true { TTrue }
false { TFalse }
- dyadic { TDyadic }
- monadic { TMonadic }
compare { TCompare }
genprimop { TGenPrimOp }
fixity { TFixity }
@@ -122,9 +120,7 @@ pWithOptions : with pOptions { $2 }
| {- empty -} { [] }
pCategory :: { Category }
-pCategory : dyadic { Dyadic }
- | monadic { Monadic }
- | compare { Compare }
+pCategory : compare { Compare }
| genprimop { GenPrimOp }
pDesc :: { String }
=====================================
utils/genprimopcode/ParserM.hs
=====================================
@@ -94,8 +94,6 @@ data Token = TEOF
| TDefaults
| TTrue
| TFalse
- | TDyadic
- | TMonadic
| TCompare
| TGenPrimOp
| TThatsAllFolks
=====================================
utils/genprimopcode/Syntax.hs
=====================================
@@ -65,7 +65,7 @@ data Option
-- categorises primops
data Category
- = Dyadic | Monadic | Compare | GenPrimOp
+ = Compare | GenPrimOp
deriving Show
-- types
@@ -155,10 +155,6 @@ sanityPrimOp def_names p
sane_ty :: Category -> Ty -> Bool
sane_ty Compare (TyF t1 (TyF t2 td))
| t1 == t2 && td == TyApp (TyCon "Int#") [] = True
-sane_ty Monadic (TyF t1 td)
- | t1 == td = True
-sane_ty Dyadic (TyF t1 (TyF t2 td))
- | t1 == td && t2 == td = True
sane_ty GenPrimOp _
= True
sane_ty _ _
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbc1e10b276a2f37d29dc0f35c21866bd1f8202d...e0b3cbdac94de38586d2cbe0654a2ef35e96635f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbc1e10b276a2f37d29dc0f35c21866bd1f8202d...e0b3cbdac94de38586d2cbe0654a2ef35e96635f
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/20200827/bdafeac0/attachment-0001.html>
More information about the ghc-commits
mailing list