summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2021-11-22 21:18:20 -0500
committerBen Gamari <ben@smart-cactus.org>2022-03-02 22:49:17 -0500
commit299bddfc6198c6f65a20d1a79074d828e9ca4649 (patch)
tree4f8862b3056aa2b83e9eb5ccb548ed2c2da9d123
parent934fce23db27cbe767c1758b7fff177c05d8ed43 (diff)
downloadhaskell-299bddfc6198c6f65a20d1a79074d828e9ca4649.tar.gz
CmmToC: Fix width of shift operations
Under C's implicit widening rules, the result of an operation like (a >> b) where a::Word8 and b::Word will have type Word, yet we want Word. (cherry picked from commit e19e9e71739ffd01d6557256b59b3bd26651a4ad)
-rw-r--r--compiler/GHC/CmmToC.hs18
1 files changed, 15 insertions, 3 deletions
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index 3c604f0f96..f4ff57cdfc 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -436,12 +436,18 @@ pprMachOpApp platform mop args
| otherwise
= pprMachOpApp' platform mop args
--- Comparisons in C have type 'int', but we want type W_ (this is what
--- resultRepOfMachOp says). The other C operations inherit their type
--- from their operands, so no casting is required.
+-- | The type of most operations is determined by the operands. However, there are a few exceptions. For these we explicitly cast the result.
machOpNeedsCast :: MachOp -> Maybe SDoc
machOpNeedsCast mop
+ -- Comparisons in C have type 'int', but we want type W_ (this is what
+ -- resultRepOfMachOp says).
| isComparisonMachOp mop = Just mkW_
+ -- A shift operation like (a >> b) where a::Word8 and b::Word has type Word
+ -- in C yet we want a Word8
+ | w <- shiftMachOp mop = let ty
+ | signedOp mop = machRep_S_CType platform w
+ | otherwise = machRep_U_CType platform w
+ in Just $ parens ty
| otherwise = Nothing
pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc
@@ -769,6 +775,12 @@ signedOp (MO_SS_Conv _ _) = True
signedOp (MO_SF_Conv _ _) = True
signedOp _ = False
+shiftOp :: MachOp -> Maybe Width
+shiftOp (MO_Shl w) = Just w
+shiftOp (MO_U_Shr w) = Just w
+shiftOp (MO_S_Shr w) = Just w
+shiftOp _ = Nothing
+
floatComparison :: MachOp -> Bool -- comparison between float args
floatComparison (MO_F_Eq _) = True
floatComparison (MO_F_Ne _) = True