summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Builtin/primops.txt.pp16
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs40
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs10
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs14
4 files changed, 56 insertions, 24 deletions
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index b2a45ad79f..868837d5b1 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -584,9 +584,7 @@ primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int#
------------------------------------------------------------------------
section "Int64#"
- {Operations on 64-bit unsigned words. This type is only used
- if plain {\tt Int\#} has less than 64 bits. In any case, the operations
- are not primops; they are implemented (if needed) as ccalls instead.}
+ {Operations on 64-bit integers.}
------------------------------------------------------------------------
primtype Int64#
@@ -614,6 +612,10 @@ primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#
with
can_fail = True
+primop Int64QuotRemOp "quotRemInt64#" GenPrimOp Int64# -> Int64# -> (# Int64#, Int64# #)
+ with
+ can_fail = True
+
primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64#
primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64#
primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64#
@@ -630,9 +632,7 @@ primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int#
------------------------------------------------------------------------
section "Word64#"
- {Operations on 64-bit unsigned words. This type is only used
- if plain {\tt Word\#} has less than 64 bits. In any case, the operations
- are not primops; they are implemented (if needed) as ccalls instead.}
+ {Operations on 64-bit unsigned words.}
------------------------------------------------------------------------
primtype Word64#
@@ -658,6 +658,10 @@ primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64#
with
can_fail = True
+primop Word64QuotRemOp "quotRemWord64#" GenPrimOp Word64# -> Word64# -> (# Word64#, Word64# #)
+ with
+ can_fail = True
+
primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64#
with commutable = True
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index cce8830a97..4c4fbf4d01 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -567,7 +567,8 @@ primOpRules nm = \case
, narrowSubsumesAnd IntAndOp IntToInt16Op 16 ]
IntToInt32Op -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit
, narrowSubsumesAnd IntAndOp IntToInt32Op 32 ]
- IntToInt64Op -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ]
+ IntToInt64Op -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit
+ , narrowSubsumesAnd IntAndOp IntToInt64Op 64 ]
Word8ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit
, extendNarrowPassthrough WordToWord8Op 0xFF
@@ -578,15 +579,17 @@ primOpRules nm = \case
Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit
, extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF
]
- Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit ]
-
+ Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit
+ , extendNarrowPassthrough WordToWord64Op 0xFFFFFFFFFFFFFFFF
+ ]
WordToWord8Op -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit
, narrowSubsumesAnd WordAndOp WordToWord8Op 8 ]
WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit
, narrowSubsumesAnd WordAndOp WordToWord16Op 16 ]
WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit
, narrowSubsumesAnd WordAndOp WordToWord32Op 32 ]
- WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ]
+ WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit
+ , narrowSubsumesAnd WordAndOp WordToWord64Op 64 ]
Word8ToInt8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8) ]
Int8ToWord8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8) ]
@@ -1215,6 +1218,14 @@ int32Result result = Just (int32Result' result)
int32Result' :: Integer -> CoreExpr
int32Result' result = Lit (mkLitInt32Wrap result)
+int64Result :: Integer -> Maybe CoreExpr
+int64Result result = Just (int64Result' result)
+
+int64Result' :: Integer -> CoreExpr
+int64Result' result = Lit (mkLitInt64Wrap result)
+
+-- | Create an Int literal expression while ensuring the given Integer is in the
+-- target Int range
intResult :: Platform -> Integer -> Maybe CoreExpr
intResult platform result = Just (intResult' platform result)
@@ -1257,6 +1268,14 @@ word32Result' result = Lit (mkLitWord32Wrap result)
-- | Create a Word literal expression while ensuring the given Integer is in the
-- target Word range
+word64Result :: Integer -> Maybe CoreExpr
+word64Result result = Just (word64Result' result)
+
+word64Result' :: Integer -> CoreExpr
+word64Result' result = Lit (mkLitWord64Wrap result)
+
+-- | Create a Word literal expression while ensuring the given Integer is in the
+-- target Word range
wordResult :: Platform -> Integer -> Maybe CoreExpr
wordResult platform result = Just (wordResult' platform result)
@@ -1273,19 +1292,6 @@ wordCResult platform result = Just (mkPair [Lit lit, Lit c])
(lit, b) = mkLitWordWrapC platform result
c = if b then onei platform else zeroi platform
-int64Result :: Integer -> Maybe CoreExpr
-int64Result result = Just (int64Result' result)
-
-int64Result' :: Integer -> CoreExpr
-int64Result' result = Lit (mkLitInt64Wrap result)
-
-word64Result :: Integer -> Maybe CoreExpr
-word64Result result = Just (word64Result' result)
-
-word64Result' :: Integer -> CoreExpr
-word64Result' result = Lit (mkLitWord64Wrap result)
-
-
-- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'.
semiInversePrimOp :: PrimOp -> RuleM CoreExpr
semiInversePrimOp primop = do
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index c8a2ba8aad..446927daeb 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1500,6 +1500,11 @@ emitPrimOp dflags primop = case primop of
then Left (MO_S_QuotRem W32)
else Right (genericIntQuotRemOp W32)
+ Int64QuotRemOp -> \args -> opCallishHandledLater args $
+ if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
+ then Left (MO_S_QuotRem W64)
+ else Right (genericIntQuotRemOp W64)
+
WordQuotRemOp -> \args -> opCallishHandledLater args $
if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
then Left (MO_U_QuotRem (wordWidth platform))
@@ -1525,6 +1530,11 @@ emitPrimOp dflags primop = case primop of
then Left (MO_U_QuotRem W32)
else Right (genericWordQuotRemOp W32)
+ Word64QuotRemOp -> \args -> opCallishHandledLater args $
+ if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
+ then Left (MO_U_QuotRem W64)
+ else Right (genericWordQuotRemOp W64)
+
WordAdd2Op -> \args -> opCallishHandledLater args $
if (ncg && (x86ish || ppc)) || llvm
then Left (MO_Add2 (wordWidth platform))
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index a061674af9..054d4a1fa1 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1507,7 +1507,8 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR,
eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
word8ToWord_RDR , int8ToInt_RDR ,
word16ToWord_RDR, int16ToInt_RDR,
- word32ToWord_RDR, int32ToInt_RDR
+ word32ToWord_RDR, int32ToInt_RDR,
+ word64ToWord_RDR, int64ToInt_RDR
:: RdrName
gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
@@ -1618,6 +1619,9 @@ int16ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int16ToInt#")
word32ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word32ToWord#")
int32ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int32ToInt#")
+word64ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word64ToWord#")
+int64ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int64ToInt#")
+
{-
************************************************************************
* *
@@ -2428,6 +2432,12 @@ boxConTbl =
, (word32PrimTy,
nlHsApp (nlHsVar $ getRdrName wordDataCon)
. nlHsApp (nlHsVar word32ToWord_RDR))
+ , (int64PrimTy,
+ nlHsApp (nlHsVar $ getRdrName intDataCon)
+ . nlHsApp (nlHsVar int64ToInt_RDR))
+ , (word64PrimTy,
+ nlHsApp (nlHsVar $ getRdrName wordDataCon)
+ . nlHsApp (nlHsVar word64ToWord_RDR))
]
@@ -2455,6 +2465,8 @@ primConvTbl =
, (word16PrimTy, "wordToWord16#")
, (int32PrimTy, "intToInt32#")
, (word32PrimTy, "wordToWord32#")
+ , (int64PrimTy, "intToInt64#")
+ , (word64PrimTy, "wordToWord64#")
]
litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
View Lorry Controller Status