diff options
23 files changed, 639 insertions, 150 deletions
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index 2512612b5b..25e673b192 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -601,6 +601,43 @@ section "Int64#" primtype Int64# +primop Int64ToIntOp "int64ToInt#" GenPrimOp Int64# -> Int# +primop IntToInt64Op "intToInt64#" GenPrimOp Int# -> Int64# + +primop Int64NegOp "negateInt64#" GenPrimOp Int64# -> Int64# + +primop Int64AddOp "plusInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + commutable = True + +primop Int64SubOp "subInt64#" GenPrimOp Int64# -> Int64# -> Int64# + +primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + commutable = True + +primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + can_fail = True + +primop Int64RemOp "remInt64#" GenPrimOp 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# + +primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64# + with code_size = 0 + +primop Int64EqOp "eqInt64#" Compare Int64# -> Int64# -> Int# +primop Int64GeOp "geInt64#" Compare Int64# -> Int64# -> Int# +primop Int64GtOp "gtInt64#" Compare Int64# -> Int64# -> Int# +primop Int64LeOp "leInt64#" Compare Int64# -> Int64# -> Int# +primop Int64LtOp "ltInt64#" Compare Int64# -> Int64# -> Int# +primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int# + ------------------------------------------------------------------------ section "Word64#" {Operations on 64-bit unsigned words. This type is only used @@ -610,6 +647,51 @@ section "Word64#" primtype Word64# +primop Word64ToWordOp "word64ToWord#" GenPrimOp Word64# -> Word# +primop WordToWord64Op "wordToWord64#" GenPrimOp Word# -> Word64# + +primop Word64AddOp "plusWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + commutable = True + +primop Word64SubOp "subWord64#" GenPrimOp Word64# -> Word64# -> Word64# + +primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + commutable = True + +primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + can_fail = True + +primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + can_fail = True + +primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64OrOp "or64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64# + +primop Word64SllOp "uncheckedShiftL64#" GenPrimOp Word64# -> Int# -> Word64# +primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64# + +primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64# + with code_size = 0 + +primop Word64EqOp "eqWord64#" Compare Word64# -> Word64# -> Int# +primop Word64GeOp "geWord64#" Compare Word64# -> Word64# -> Int# +primop Word64GtOp "gtWord64#" Compare Word64# -> Word64# -> Int# +primop Word64LeOp "leWord64#" Compare Word64# -> Word64# -> Int# +primop Word64LtOp "ltWord64#" Compare Word64# -> Word64# -> Int# +primop Word64NeOp "neWord64#" Compare Word64# -> Word64# -> Int# + #endif ------------------------------------------------------------------------ diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs index b91263ce47..b5aa278ad7 100644 --- a/compiler/GHC/Cmm/MachOp.hs +++ b/compiler/GHC/Cmm/MachOp.hs @@ -586,6 +586,41 @@ data CallishMachOp | MO_F32_Fabs | MO_F32_Sqrt + -- 64-bit int/word ops for when they exceed the native word size + -- (i.e. on 32-bit architectures) + | MO_I64_ToI + | MO_I64_FromI + | MO_W64_ToW + | MO_W64_FromW + + | MO_x64_Neg + | MO_x64_Add + | MO_x64_Sub + | MO_x64_Mul + | MO_I64_Quot + | MO_I64_Rem + | MO_W64_Quot + | MO_W64_Rem + + | MO_x64_And + | MO_x64_Or + | MO_x64_Xor + | MO_x64_Not + | MO_x64_Shl + | MO_I64_Shr + | MO_W64_Shr + + | MO_x64_Eq + | MO_x64_Ne + | MO_I64_Ge + | MO_I64_Gt + | MO_I64_Le + | MO_I64_Lt + | MO_W64_Ge + | MO_W64_Gt + | MO_W64_Le + | MO_W64_Lt + | MO_UF_Conv Width | MO_S_Mul2 Width diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs index f637aeba90..19e5845a00 100644 --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -1281,6 +1281,37 @@ genCCall target dest_regs arg_regs bid = do MO_F32_Fabs -> mkCCall "fasbf" MO_F32_Sqrt -> mkCCall "sqrtf" + -- 64-bit primops + MO_I64_ToI -> mkCCall "hs_int64ToInt" + MO_I64_FromI -> mkCCall "hs_intToInt64" + MO_W64_ToW -> mkCCall "hs_word64ToWord" + MO_W64_FromW -> mkCCall "hs_wordToWord64" + MO_x64_Neg -> mkCCall "hs_neg64" + MO_x64_Add -> mkCCall "hs_add64" + MO_x64_Sub -> mkCCall "hs_sub64" + MO_x64_Mul -> mkCCall "hs_mul64" + MO_I64_Quot -> mkCCall "hs_quotInt64" + MO_I64_Rem -> mkCCall "hs_remInt64" + MO_W64_Quot -> mkCCall "hs_quotWord64" + MO_W64_Rem -> mkCCall "hs_remWord64" + MO_x64_And -> mkCCall "hs_and64" + MO_x64_Or -> mkCCall "hs_or64" + MO_x64_Xor -> mkCCall "hs_xor64" + MO_x64_Not -> mkCCall "hs_not64" + MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64" + MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64" + MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64" + MO_x64_Eq -> mkCCall "hs_eq64" + MO_x64_Ne -> mkCCall "hs_ne64" + MO_I64_Ge -> mkCCall "hs_geInt64" + MO_I64_Gt -> mkCCall "hs_gtInt64" + MO_I64_Le -> mkCCall "hs_leInt64" + MO_I64_Lt -> mkCCall "hs_ltInt64" + MO_W64_Ge -> mkCCall "hs_geWord64" + MO_W64_Gt -> mkCCall "hs_gtWord64" + MO_W64_Le -> mkCCall "hs_leWord64" + MO_W64_Lt -> mkCCall "hs_ltWord64" + -- Conversion MO_UF_Conv w -> mkCCall (word2FloatLabel w) diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index c821ea71a2..8ee20e06f5 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -2006,6 +2006,39 @@ genCCall' config gcp target dest_regs args MO_F64_Acosh -> (fsLit "acosh", False) MO_F64_Atanh -> (fsLit "atanh", False) + MO_I64_ToI -> (fsLit "hs_int64ToInt", False) + MO_I64_FromI -> (fsLit "hs_intToInt64", False) + MO_W64_ToW -> (fsLit "hs_word64ToWord", False) + MO_W64_FromW -> (fsLit "hs_wordToWord64", False) + + MO_x64_Neg -> (fsLit "hs_neg64", False) + MO_x64_Add -> (fsLit "hs_add64", False) + MO_x64_Sub -> (fsLit "hs_sub64", False) + MO_x64_Mul -> (fsLit "hs_mul64", False) + MO_I64_Quot -> (fsLit "hs_quotInt64", False) + MO_I64_Rem -> (fsLit "hs_remInt64", False) + MO_W64_Quot -> (fsLit "hs_quotWord64", False) + MO_W64_Rem -> (fsLit "hs_remWord64", False) + + MO_x64_And -> (fsLit "hs_and64", False) + MO_x64_Or -> (fsLit "hs_or64", False) + MO_x64_Xor -> (fsLit "hs_xor64", False) + MO_x64_Not -> (fsLit "hs_not64", False) + MO_x64_Shl -> (fsLit "hs_uncheckedShiftL64", False) + MO_I64_Shr -> (fsLit "hs_uncheckedIShiftRA64", False) + MO_W64_Shr -> (fsLit "hs_uncheckedShiftRL64", False) + + MO_x64_Eq -> (fsLit "hs_eq64", False) + MO_x64_Ne -> (fsLit "hs_ne64", False) + MO_I64_Ge -> (fsLit "hs_geInt64", False) + MO_I64_Gt -> (fsLit "hs_gtInt64", False) + MO_I64_Le -> (fsLit "hs_leInt64", False) + MO_I64_Lt -> (fsLit "hs_ltInt64", False) + MO_W64_Ge -> (fsLit "hs_geWord64", False) + MO_W64_Gt -> (fsLit "hs_gtWord64", False) + MO_W64_Le -> (fsLit "hs_leWord64", False) + MO_W64_Lt -> (fsLit "hs_ltWord64", False) + MO_UF_Conv w -> (word2FloatLabel w, False) MO_Memcpy _ -> (fsLit "memcpy", False) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs index 0a5152f425..56f764560c 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -658,6 +658,36 @@ outOfLineMachOp_table mop MO_F64_Acosh -> fsLit "acosh" MO_F64_Atanh -> fsLit "atanh" + MO_I64_ToI -> fsLit "hs_int64ToInt" + MO_I64_FromI -> fsLit "hs_intToInt64" + MO_W64_ToW -> fsLit "hs_word64ToWord" + MO_W64_FromW -> fsLit "hs_wordToWord64" + MO_x64_Neg -> fsLit "hs_neg64" + MO_x64_Add -> fsLit "hs_add64" + MO_x64_Sub -> fsLit "hs_sub64" + MO_x64_Mul -> fsLit "hs_mul64" + MO_I64_Quot -> fsLit "hs_quotInt64" + MO_I64_Rem -> fsLit "hs_remInt64" + MO_W64_Quot -> fsLit "hs_quotWord64" + MO_W64_Rem -> fsLit "hs_remWord64" + MO_x64_And -> fsLit "hs_and64" + MO_x64_Or -> fsLit "hs_or64" + MO_x64_Xor -> fsLit "hs_xor64" + MO_x64_Not -> fsLit "hs_not64" + MO_x64_Shl -> fsLit "hs_uncheckedShiftL64" + MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64" + MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64" + MO_x64_Eq -> fsLit "hs_eq64" + MO_x64_Ne -> fsLit "hs_ne64" + MO_I64_Ge -> fsLit "hs_geInt64" + MO_I64_Gt -> fsLit "hs_gtInt64" + MO_I64_Le -> fsLit "hs_leInt64" + MO_I64_Lt -> fsLit "hs_ltInt64" + MO_W64_Ge -> fsLit "hs_geWord64" + MO_W64_Gt -> fsLit "hs_gtWord64" + MO_W64_Le -> fsLit "hs_leWord64" + MO_W64_Lt -> fsLit "hs_ltWord64" + MO_UF_Conv w -> word2FloatLabel w MO_Memcpy _ -> fsLit "memcpy" diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index 2fbe91dc34..ff25a2e53f 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -3388,6 +3388,36 @@ outOfLineCmmOp bid mop res args MO_F64_Acosh -> fsLit "acosh" MO_F64_Atanh -> fsLit "atanh" + MO_I64_ToI -> fsLit "hs_int64ToInt" + MO_I64_FromI -> fsLit "hs_intToInt64" + MO_W64_ToW -> fsLit "hs_word64ToWord" + MO_W64_FromW -> fsLit "hs_wordToWord64" + MO_x64_Neg -> fsLit "hs_neg64" + MO_x64_Add -> fsLit "hs_add64" + MO_x64_Sub -> fsLit "hs_sub64" + MO_x64_Mul -> fsLit "hs_mul64" + MO_I64_Quot -> fsLit "hs_quotInt64" + MO_I64_Rem -> fsLit "hs_remInt64" + MO_W64_Quot -> fsLit "hs_quotWord64" + MO_W64_Rem -> fsLit "hs_remWord64" + MO_x64_And -> fsLit "hs_and64" + MO_x64_Or -> fsLit "hs_or64" + MO_x64_Xor -> fsLit "hs_xor64" + MO_x64_Not -> fsLit "hs_not64" + MO_x64_Shl -> fsLit "hs_uncheckedShiftL64" + MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64" + MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64" + MO_x64_Eq -> fsLit "hs_eq64" + MO_x64_Ne -> fsLit "hs_ne64" + MO_I64_Ge -> fsLit "hs_geInt64" + MO_I64_Gt -> fsLit "hs_gtInt64" + MO_I64_Le -> fsLit "hs_leInt64" + MO_I64_Lt -> fsLit "hs_ltInt64" + MO_W64_Ge -> fsLit "hs_geWord64" + MO_W64_Gt -> fsLit "hs_gtWord64" + MO_W64_Le -> fsLit "hs_leWord64" + MO_W64_Lt -> fsLit "hs_ltWord64" + MO_Memcpy _ -> fsLit "memcpy" MO_Memset _ -> fsLit "memset" MO_Memmove _ -> fsLit "memmove" diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 4e828e29f4..8349393f0d 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -861,6 +861,35 @@ pprCallishMachOp_for_C mop (MO_Prefetch_Data _ ) -> unsupported --- we could support prefetch via "__builtin_prefetch" --- Not adding it for now + MO_I64_ToI -> unsupported + MO_I64_FromI -> unsupported + MO_W64_ToW -> unsupported + MO_W64_FromW -> unsupported + MO_x64_Neg -> unsupported + MO_x64_Add -> unsupported + MO_x64_Sub -> unsupported + MO_x64_Mul -> unsupported + MO_I64_Quot -> unsupported + MO_I64_Rem -> unsupported + MO_W64_Quot -> unsupported + MO_W64_Rem -> unsupported + MO_x64_And -> unsupported + MO_x64_Or -> unsupported + MO_x64_Xor -> unsupported + MO_x64_Not -> unsupported + MO_x64_Shl -> unsupported + MO_I64_Shr -> unsupported + MO_W64_Shr -> unsupported + MO_x64_Eq -> unsupported + MO_x64_Ne -> unsupported + MO_I64_Ge -> unsupported + MO_I64_Gt -> unsupported + MO_I64_Le -> unsupported + MO_I64_Lt -> unsupported + MO_W64_Ge -> unsupported + MO_W64_Gt -> unsupported + MO_W64_Le -> unsupported + MO_W64_Lt -> unsupported where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop ++ " not supported!") diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs index bfeb39171d..dd2779ef71 100644 --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -911,6 +911,37 @@ cmmPrimOpFunctions mop = do MO_Cmpxchg _ -> unsupported MO_Xchg _ -> unsupported + MO_I64_ToI -> fsLit "hs_int64ToInt" + MO_I64_FromI -> fsLit "hs_intToInt64" + MO_W64_ToW -> fsLit "hs_word64ToWord" + MO_W64_FromW -> fsLit "hs_wordToWord64" + MO_x64_Neg -> fsLit "hs_neg64" + MO_x64_Add -> fsLit "hs_add64" + MO_x64_Sub -> fsLit "hs_sub64" + MO_x64_Mul -> fsLit "hs_mul64" + MO_I64_Quot -> fsLit "hs_quotInt64" + MO_I64_Rem -> fsLit "hs_remInt64" + MO_W64_Quot -> fsLit "hs_quotWord64" + MO_W64_Rem -> fsLit "hs_remWord64" + MO_x64_And -> fsLit "hs_and64" + MO_x64_Or -> fsLit "hs_or64" + MO_x64_Xor -> fsLit "hs_xor64" + MO_x64_Not -> fsLit "hs_not64" + MO_x64_Shl -> fsLit "hs_uncheckedShiftL64" + MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64" + MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64" + MO_x64_Eq -> fsLit "hs_eq64" + MO_x64_Ne -> fsLit "hs_ne64" + MO_I64_Ge -> fsLit "hs_geInt64" + MO_I64_Gt -> fsLit "hs_gtInt64" + MO_I64_Le -> fsLit "hs_leInt64" + MO_I64_Lt -> fsLit "hs_ltInt64" + MO_W64_Ge -> fsLit "hs_geWord64" + MO_W64_Gt -> fsLit "hs_gtWord64" + MO_W64_Le -> fsLit "hs_leWord64" + MO_W64_Lt -> fsLit "hs_ltWord64" + + -- | Tail function calls genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index df3fbf3b73..163c9e0d5d 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -10,6 +10,7 @@ ToDo: (i1 + i2) only if it results in a valid Float. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} @@ -30,6 +31,8 @@ module GHC.Core.Opt.ConstantFold ) where +#include "MachDeps.h" + import GHC.Prelude import GHC.Platform @@ -314,6 +317,77 @@ primOpRules nm = \case Word32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 (const shiftL) ] Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 $ const $ shiftRightLogical @Word32 ] +#if WORD_SIZE_IN_BITS < 64 + -- Int64 operations + Int64AddOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (+)) + , identity zeroI64 + , addFoldingRules Int64AddOp int64Ops + ] + Int64SubOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (-)) + , rightIdentity zeroI64 + , equalArgs $> Lit zeroI64 + , subFoldingRules Int64SubOp int64Ops + ] + Int64MulOp -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (*)) + , zeroElem + , identity oneI64 + , mulFoldingRules Int64MulOp int64Ops + ] + Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot) + , leftZero + , rightIdentity oneI64 + , equalArgs $> Lit oneI64 ] + Int64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroI64 + , equalArgs $> Lit zeroI64 ] + Int64NegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , semiInversePrimOp Int64NegOp ] + Int64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftL) + , rightIdentity zeroI64 ] + Int64SraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftR) + , rightIdentity zeroI64 ] + Int64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 $ const $ shiftRightLogical @Word64 + , rightIdentity zeroI64 ] + + -- Word64 operations + Word64AddOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (+)) + , identity zeroW64 + , addFoldingRules Word64AddOp word64Ops + ] + Word64SubOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (-)) + , rightIdentity zeroW64 + , equalArgs $> Lit zeroW64 + , subFoldingRules Word64SubOp word64Ops + ] + Word64MulOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (*)) + , identity oneW64 + , mulFoldingRules Word64MulOp word64Ops + ] + Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot) + , rightIdentity oneW64 ] + Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem) + , leftZero + , oneLit 1 $> Lit zeroW64 + , equalArgs $> Lit zeroW64 ] + Word64AndOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.&.)) + , idempotent + , zeroElem + , sameArgIdempotentCommut Word64AndOp + ] + Word64OrOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.|.)) + , idempotent + , identity zeroW64 + , sameArgIdempotentCommut Word64OrOp + ] + Word64XorOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 xor) + , identity zeroW64 + , equalArgs $> Lit zeroW64 ] + Word64NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , semiInversePrimOp Word64NotOp ] + Word64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 (const shiftL) ] + Word64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 $ const $ shiftRightLogical @Word64 ] +#endif -- Int operations IntAddOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) @@ -415,6 +489,9 @@ primOpRules nm = \case Int8ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] Int16ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] Int32ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] +#if WORD_SIZE_IN_BITS < 64 + Int64ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] +#endif IntToInt8Op -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit , semiInversePrimOp Int8ToIntOp , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ] @@ -424,6 +501,9 @@ primOpRules nm = \case IntToInt32Op -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit , semiInversePrimOp Int32ToIntOp , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ] +#if WORD_SIZE_IN_BITS < 64 + IntToInt64Op -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ] +#endif Word8ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit , extendNarrowPassthrough WordToWord8Op 0xFF @@ -434,6 +514,10 @@ primOpRules nm = \case Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit , extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF ] +#if WORD_SIZE_IN_BITS < 64 + Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ] +#endif + WordToWord8Op -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit , semiInversePrimOp Word8ToWordOp , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ] @@ -443,7 +527,9 @@ primOpRules nm = \case WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit , semiInversePrimOp Word32ToWordOp , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ] - +#if WORD_SIZE_IN_BITS < 64 + WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ] +#endif Word8ToInt8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8) , semiInversePrimOp Int8ToWord8Op ] @@ -457,6 +543,13 @@ primOpRules nm = \case , semiInversePrimOp Int32ToWord32Op ] Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32) , semiInversePrimOp Word32ToInt32Op ] +#if WORD_SIZE_IN_BITS < 64 + Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64) + , semiInversePrimOp Int64ToWord64Op ] + Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64) + , semiInversePrimOp Word64ToInt64Op ] +#endif + WordToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt) , semiInversePrimOp IntToWordOp ] IntToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord) @@ -724,6 +817,14 @@ oneI32 = mkLitInt32 1 zeroW32 = mkLitWord32 0 oneW32 = mkLitWord32 1 +#if WORD_SIZE_IN_BITS < 64 +zeroI64, oneI64, zeroW64, oneW64 :: Literal +zeroI64 = mkLitInt64 0 +oneI64 = mkLitInt64 1 +zeroW64 = mkLitWord64 0 +oneW64 = mkLitWord64 1 +#endif + zerof, onef, twof, zerod, oned, twod :: Literal zerof = mkLitFloat 0.0 onef = mkLitFloat 1.0 @@ -789,6 +890,16 @@ int32Op2 op _ (LitNumber LitNumInt32 i1) (LitNumber LitNumInt32 i2) = int32Result (fromInteger i1 `op` fromInteger i2) int32Op2 _ _ _ _ = Nothing +#if WORD_SIZE_IN_BITS < 64 +int64Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +int64Op2 op _ (LitNumber LitNumInt64 i1) (LitNumber LitNumInt64 i2) = + int64Result (fromInteger i1 `op` fromInteger i2) +int64Op2 _ _ _ _ = Nothing +#endif + intOp2 :: (Integral a, Integral b) => (a -> b -> Integer) -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr @@ -839,7 +950,7 @@ word8Op2 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr word8Op2 op _ (LitNumber LitNumWord8 i1) (LitNumber LitNumWord8 i2) = word8Result (fromInteger i1 `op` fromInteger i2) -word8Op2 _ _ _ _ = Nothing -- Could find LitLit +word8Op2 _ _ _ _ = Nothing word16Op2 :: (Integral a, Integral b) @@ -847,7 +958,7 @@ word16Op2 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr word16Op2 op _ (LitNumber LitNumWord16 i1) (LitNumber LitNumWord16 i2) = word16Result (fromInteger i1 `op` fromInteger i2) -word16Op2 _ _ _ _ = Nothing -- Could find LitLit +word16Op2 _ _ _ _ = Nothing word32Op2 :: (Integral a, Integral b) @@ -855,7 +966,17 @@ word32Op2 -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr word32Op2 op _ (LitNumber LitNumWord32 i1) (LitNumber LitNumWord32 i2) = word32Result (fromInteger i1 `op` fromInteger i2) -word32Op2 _ _ _ _ = Nothing -- Could find LitLit +word32Op2 _ _ _ _ = Nothing + +#if WORD_SIZE_IN_BITS < 64 +word64Op2 + :: (Integral a, Integral b) + => (a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +word64Op2 op _ (LitNumber LitNumWord64 i1) (LitNumber LitNumWord64 i2) = + word64Result (fromInteger i1 `op` fromInteger i2) +word64Op2 _ _ _ _ = Nothing +#endif wordOp2 :: (Integral a, Integral b) => (a -> b -> Integer) @@ -871,34 +992,41 @@ wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) = wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) wordOpC2 _ _ _ _ = Nothing -shiftRule :: LitNumType -- Type of the result, either LitNumInt or LitNumWord +shiftRule :: LitNumType -> (Platform -> Integer -> Int -> Integer) -> RuleM CoreExpr -- Shifts take an Int; hence third arg of op is Int -- Used for shift primops -- IntSllOp, IntSraOp, IntSrlOp :: Int# -> Int# -> Int# -- SllOp, SrlOp :: Word# -> Int# -> Word# -shiftRule lit_num_ty shift_op - = do { platform <- getPlatform - ; [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs - ; case e1 of - _ | shift_len == 0 - -> return e1 - -- See Note [Guarding against silly shifts] - | shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform) - -> return $ Lit $ mkLitNumberWrap platform lit_num_ty 0 - -- Be sure to use lit_num_ty here, so we get a correctly typed zero - -- of type Int# or Word# resp. See #18589 - - -- Do the shift at type Integer, but shift length is Int - Lit (LitNumber nt x) - | 0 < shift_len - , shift_len <= toInteger (platformWordSizeInBits platform) - -> let op = shift_op platform - y = x `op` fromInteger shift_len - in liftMaybe $ Just (Lit (mkLitNumberWrap platform nt y)) - - _ -> mzero } +shiftRule lit_num_ty shift_op = do + platform <- getPlatform + [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs + + bit_size <- case litNumBitSize platform lit_num_ty of + Nothing -> mzero + Just bs -> pure (toInteger bs) + + case e1 of + _ | shift_len == 0 -> pure e1 + + -- See Note [Guarding against silly shifts] + _ | shift_len < 0 || shift_len > bit_size + -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0 + -- Be sure to use lit_num_ty here, so we get a correctly typed zero. + -- See #18589 + + Lit (LitNumber nt x) + | 0 < shift_len && shift_len <= bit_size + -> assert (nt == lit_num_ty) $ + let op = shift_op platform + -- Do the shift at type Integer, but shift length is Int. + -- Using host's Int is ok even if target's Int has a different size + -- because we test that shift_len <= bit_size (which is at most 64) + y = x `op` fromInteger shift_len + in pure $ Lit $ mkLitNumberWrap platform nt y + + _ -> mzero -------------------------- floatOp2 :: (Rational -> Rational -> Rational) @@ -1090,6 +1218,21 @@ wordCResult platform result = Just (mkPair [Lit lit, Lit c]) (lit, b) = mkLitWordWrapC platform result c = if b then onei platform else zeroi platform +#if WORD_SIZE_IN_BITS < 64 +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) +#endif + + -- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'. semiInversePrimOp :: PrimOp -> RuleM CoreExpr semiInversePrimOp primop = do @@ -1919,7 +2062,9 @@ builtinBignumRules = , id_passthrough "Word# -> Natural -> Word# (clamp)" naturalToWordClampName naturalNSName - -- identity passthrough with a conversion that can be done directly instead + -- passthrough bignum small constructors with a conversion that can be done + -- directly instead + , small_passthrough "Int# -> Integer -> Word#" integerISName integerToWordName (mkPrimOpId IntToWordOp) , small_passthrough "Int# -> Integer -> Float#" @@ -1936,6 +2081,27 @@ builtinBignumRules = , small_passthrough "Word# -> Natural -> Double#" naturalNSName naturalToDoubleName (mkPrimOpId WordToDoubleOp) +#if WORD_SIZE_IN_BITS < 64 + , id_passthrough "Int64# -> Integer -> Int64#" + integerToInt64Name integerFromInt64Name + , id_passthrough "Word64# -> Integer -> Word64#" + integerToWord64Name integerFromWord64Name + + , small_passthrough "Int64# -> Integer -> Word64#" + integerFromInt64Name integerToWord64Name (mkPrimOpId Int64ToWord64Op) + , small_passthrough "Word64# -> Integer -> Int64#" + integerFromWord64Name integerToInt64Name (mkPrimOpId Word64ToInt64Op) + + , small_passthrough "Word# -> Integer -> Word64#" + integerFromWordName integerToWord64Name (mkPrimOpId WordToWord64Op) + , small_passthrough "Word64# -> Integer -> Word#" + integerFromWord64Name integerToWordName (mkPrimOpId Word64ToWordOp) + , small_passthrough "Int# -> Integer -> Int64#" + integerISName integerToInt64Name (mkPrimOpId IntToInt64Op) + , small_passthrough "Int64# -> Integer -> Int#" + integerFromInt64Name integerToIntName (mkPrimOpId Int64ToIntOp) +#endif + -- Bits.bit , bignum_bit "integerBit" integerBitName mkLitInteger , bignum_bit "naturalBit" naturalBitName mkLitNatural @@ -2786,6 +2952,24 @@ word32Ops = NumOps , numLitType = LitNumWord32 } +#if WORD_SIZE_IN_BITS < 64 +int64Ops :: NumOps +int64Ops = NumOps + { numAdd = Int64AddOp + , numSub = Int64SubOp + , numMul = Int64MulOp + , numLitType = LitNumInt64 + } + +word64Ops :: NumOps +word64Ops = NumOps + { numAdd = Word64AddOp + , numSub = Word64SubOp + , numMul = Word64MulOp + , numLitType = LitNumWord64 + } +#endif + intOps :: NumOps intOps = NumOps { numAdd = IntAddOp diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 2db8e4cd38..542372105e 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -16,6 +16,8 @@ module GHC.StgToCmm.Prim ( shouldInlinePrimOp ) where +#include "MachDeps.h" + import GHC.Prelude hiding ((<*>)) import GHC.Platform @@ -1080,6 +1082,10 @@ emitPrimOp dflags primop = case primop of Word16ToInt16Op -> \args -> opNop args Int32ToWord32Op -> \args -> opNop args Word32ToInt32Op -> \args -> opNop args +#if WORD_SIZE_IN_BITS < 64 + Int64ToWord64Op -> \args -> opNop args + Word64ToInt64Op -> \args -> opNop args +#endif IntToWordOp -> \args -> opNop args WordToIntOp -> \args -> opNop args IntToAddrOp -> \args -> opNop args @@ -1332,6 +1338,54 @@ emitPrimOp dflags primop = case primop of Word32LtOp -> \args -> opTranslate args (MO_U_Lt W32) Word32NeOp -> \args -> opTranslate args (MO_Ne W32) +#if WORD_SIZE_IN_BITS < 64 +-- Int64# signed ops + + Int64ToIntOp -> \args -> opTranslate64 args (\w -> MO_SS_Conv w (wordWidth platform)) MO_I64_ToI + IntToInt64Op -> \args -> opTranslate64 args (\w -> MO_SS_Conv (wordWidth platform) w) MO_I64_FromI + Int64NegOp -> \args -> opTranslate64 args MO_S_Neg MO_x64_Neg + Int64AddOp -> \args -> opTranslate64 args MO_Add MO_x64_Add + Int64SubOp -> \args -> opTranslate64 args MO_Sub MO_x64_Sub + Int64MulOp -> \args -> opTranslate64 args MO_Mul MO_x64_Mul + Int64QuotOp -> \args -> opTranslate64 args MO_S_Quot MO_I64_Quot + Int64RemOp -> \args -> opTranslate64 args MO_S_Rem MO_I64_Rem + + Int64SllOp -> \args -> opTranslate64 args MO_Shl MO_x64_Shl + Int64SraOp -> \args -> opTranslate64 args MO_S_Shr MO_I64_Shr + Int64SrlOp -> \args -> opTranslate64 args MO_U_Shr MO_W64_Shr + + Int64EqOp -> \args -> opTranslate64 args MO_Eq MO_x64_Eq + Int64GeOp -> \args -> opTranslate64 args MO_S_Ge MO_I64_Ge + Int64GtOp -> \args -> opTranslate64 args MO_S_Gt MO_I64_Gt + Int64LeOp -> \args -> opTranslate64 args MO_S_Le MO_I64_Le + Int64LtOp -> \args -> opTranslate64 args MO_S_Lt MO_I64_Lt + Int64NeOp -> \args -> opTranslate64 args MO_Ne MO_x64_Ne + +-- Word64# unsigned ops + + Word64ToWordOp -> \args -> opTranslate64 args (\w -> MO_UU_Conv w (wordWidth platform)) MO_W64_ToW + WordToWord64Op -> \args -> opTranslate64 args (\w -> MO_UU_Conv (wordWidth platform) w) MO_W64_FromW + Word64AddOp -> \args -> opTranslate64 args MO_Add MO_x64_Add + Word64SubOp -> \args -> opTranslate64 args MO_Sub MO_x64_Sub + Word64MulOp -> \args -> opTranslate64 args MO_Mul MO_x64_Mul + Word64QuotOp -> \args -> opTranslate64 args MO_U_Quot MO_W64_Quot + Word64RemOp -> \args -> opTranslate64 args MO_U_Rem MO_W64_Rem + + Word64AndOp -> \args -> opTranslate64 args MO_And MO_x64_And + Word64OrOp -> \args -> opTranslate64 args MO_Or MO_x64_Or + Word64XorOp -> \args -> opTranslate64 args MO_Xor MO_x64_Xor + Word64NotOp -> \args -> opTranslate64 args MO_Not MO_x64_Not + Word64SllOp -> \args -> opTranslate64 args MO_Shl MO_x64_Shl + Word64SrlOp -> \args -> opTranslate64 args MO_U_Shr MO_W64_Shr + + Word64EqOp -> \args -> opTranslate64 args MO_Eq MO_x64_Eq + Word64GeOp -> \args -> opTranslate64 args MO_U_Ge MO_W64_Ge + Word64GtOp -> \args -> opTranslate64 args MO_U_Gt MO_W64_Gt + Word64LeOp -> \args -> opTranslate64 args MO_U_Le MO_W64_Le + Word64LtOp -> \args -> opTranslate64 args MO_U_Lt MO_W64_Lt + Word64NeOp -> \args -> opTranslate64 args MO_Ne MO_x64_Ne +#endif + -- Char# ops CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth platform)) @@ -1649,6 +1703,18 @@ emitPrimOp dflags primop = case primop of let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) emit stmt +#if WORD_SIZE_IN_BITS < 64 + opTranslate64 + :: [CmmExpr] + -> (Width -> MachOp) + -> CallishMachOp + -> PrimopCmmEmit + opTranslate64 args mkMop callish = + case platformWordSize platform of + PW4 -> opCallish args callish + PW8 -> opTranslate args $ mkMop W64 +#endif + -- | Basically a "manual" case, rather than one of the common repetitive forms -- above. The results are a parameter to the returned function so we know the -- choice of variant never depends on them. diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 806c00e63e..e9d12f7a79 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -39,6 +40,8 @@ module GHC.Tc.Deriv.Generate ( getPossibleDataCons, tyConInstArgTys ) where +#include "MachDeps.h" + import GHC.Prelude import GHC.Tc.Utils.Monad @@ -1490,10 +1493,12 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR, eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR , + eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_RDR , eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR, + eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_RDR, eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, @@ -1547,6 +1552,12 @@ leInt32_RDR = varQual_RDR gHC_PRIM (fsLit "leInt32#") gtInt32_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt32#" ) geInt32_RDR = varQual_RDR gHC_PRIM (fsLit "geInt32#") +eqInt64_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt64#") +ltInt64_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt64#" ) +leInt64_RDR = varQual_RDR gHC_PRIM (fsLit "leInt64#") +gtInt64_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt64#" ) +geInt64_RDR = varQual_RDR gHC_PRIM (fsLit "geInt64#") + eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") @@ -1571,6 +1582,12 @@ leWord32_RDR = varQual_RDR gHC_PRIM (fsLit "leWord32#") gtWord32_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord32#" ) geWord32_RDR = varQual_RDR gHC_PRIM (fsLit "geWord32#") +eqWord64_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord64#") +ltWord64_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord64#" ) +leWord64_RDR = varQual_RDR gHC_PRIM (fsLit "leWord64#") +gtWord64_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord64#" ) +geWord64_RDR = varQual_RDR gHC_PRIM (fsLit "geWord64#") + eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") @@ -1598,7 +1615,6 @@ int16ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int16ToInt#") word32ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word32ToWord#") int32ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int32ToInt#") - {- ************************************************************************ * * @@ -2345,6 +2361,8 @@ ordOpTbl , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) ,(int32PrimTy , (ltInt32_RDR , leInt32_RDR , eqInt32_RDR , geInt32_RDR , gtInt32_RDR )) + ,(int64PrimTy , (ltInt64_RDR , leInt64_RDR + , eqInt64_RDR , geInt64_RDR , gtInt64_RDR )) ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR @@ -2353,6 +2371,8 @@ ordOpTbl , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) ,(word32PrimTy, (ltWord32_RDR, leWord32_RDR , eqWord32_RDR, geWord32_RDR, gtWord32_RDR )) + ,(word64PrimTy, (ltWord64_RDR, leWord64_RDR + , eqWord64_RDR, geWord64_RDR, gtWord64_RDR )) ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index 9d079f8a85..9d3f8f0a29 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -42,6 +42,7 @@ module GHC.Types.Literal , litNumWrap , litNumCoerce , litNumNarrow + , litNumBitSize , isMinBound , isMaxBound @@ -54,8 +55,8 @@ module GHC.Types.Literal , isLitValue_maybe, isLitRubbish -- ** Coercions - , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit - , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit + , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, narrowInt64Lit + , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit, narrowWord64Lit , extendIntLit, extendWordLit , charToIntLit, intToCharLit , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit @@ -190,6 +191,22 @@ litNumIsSigned nt = case nt of LitNumWord32 -> False LitNumWord64 -> False +-- | Number of bits +litNumBitSize :: Platform -> LitNumType -> Maybe Word +litNumBitSize platform nt = case nt of + LitNumInteger -> Nothing + LitNumNatural -> Nothing + LitNumInt -> Just (fromIntegral (platformWordSizeInBits platform)) + LitNumInt8 -> Just 8 + LitNumInt16 -> Just 16 + LitNumInt32 -> Just 32 + LitNumInt64 -> Just 64 + LitNumWord -> Just (fromIntegral (platformWordSizeInBits platform)) + LitNumWord8 -> Just 8 + LitNumWord16 -> Just 16 + LitNumWord32 -> Just 32 + LitNumWord64 -> Just 64 + instance Binary LitNumType where put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) get bh = do @@ -652,14 +669,16 @@ narrowLit' :: forall a. Integral a => LitNumType -> Literal -> Literal narrowLit' nt' (LitNumber _ i) = LitNumber nt' (toInteger (fromInteger i :: a)) narrowLit' _ l = pprPanic "narrowLit" (ppr l) -narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, - narrowWord8Lit, narrowWord16Lit, narrowWord32Lit :: Literal -> Literal +narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, narrowInt64Lit, + narrowWord8Lit, narrowWord16Lit, narrowWord32Lit, narrowWord64Lit :: Literal -> Literal narrowInt8Lit = narrowLit' @Int8 LitNumInt8 narrowInt16Lit = narrowLit' @Int16 LitNumInt16 narrowInt32Lit = narrowLit' @Int32 LitNumInt32 +narrowInt64Lit = narrowLit' @Int64 LitNumInt64 narrowWord8Lit = narrowLit' @Word8 LitNumWord8 narrowWord16Lit = narrowLit' @Word16 LitNumWord16 narrowWord32Lit = narrowLit' @Word32 LitNumWord32 +narrowWord64Lit = narrowLit' @Word64 LitNumWord64 -- | Extend a fixed-width literal (e.g. 'Int16#') to a word-sized literal (e.g. -- 'Int#'). diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index e3d0529eda..86890b6a8b 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -37,8 +37,6 @@ module GHC.Exts module GHC.Prim, module GHC.Prim.Ext, shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#, - uncheckedShiftL64#, uncheckedShiftRL64#, - uncheckedIShiftL64#, uncheckedIShiftRA64#, isTrue#, Void#, -- Previously exported by GHC.Prim @@ -123,8 +121,6 @@ import GHC.Prim hiding ( coerce, TYPE ) import qualified GHC.Prim import qualified GHC.Prim.Ext import GHC.Base hiding ( coerce ) -import GHC.Word -import GHC.Int import GHC.Ptr import GHC.Stack diff --git a/libraries/base/GHC/Float/ConversionUtils.hs b/libraries/base/GHC/Float/ConversionUtils.hs index dc35bd09a3..fe78ee3101 100644 --- a/libraries/base/GHC/Float/ConversionUtils.hs +++ b/libraries/base/GHC/Float/ConversionUtils.hs @@ -23,9 +23,6 @@ module GHC.Float.ConversionUtils ( elimZerosInteger, elimZerosInt# ) where import GHC.Base import GHC.Num.Integer -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif default () diff --git a/libraries/base/GHC/Float/RealFracMethods.hs b/libraries/base/GHC/Float/RealFracMethods.hs index 91756419e2..5f971ad126 100644 --- a/libraries/base/GHC/Float/RealFracMethods.hs +++ b/libraries/base/GHC/Float/RealFracMethods.hs @@ -61,11 +61,9 @@ import GHC.Num () #if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 - #define TO64 integerToInt64# #define FROM64 integerFromInt64# -#define MINUS64 minusInt64# +#define MINUS64 subInt64# #define NEGATE64 negateInt64# #else diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index e25205d064..64019bc8ac 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -43,7 +43,7 @@ import Data.Bits import Data.Maybe #if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 +import GHC.Prim #endif import GHC.Base @@ -487,12 +487,6 @@ instance FiniteBits Int16 where -- type Int32 ------------------------------------------------------------------------ --- Int32 is represented in the same way as Int. -#if WORD_SIZE_IN_BITS > 32 --- Operations may assume and must ensure that it holds only values --- from its logical range. -#endif - data {-# CTYPE "HsInt32" #-} Int32 = I32# Int32# -- ^ 32-bit signed integer type @@ -753,7 +747,7 @@ instance Show Int64 where -- | @since 2.01 instance Num Int64 where (I64# x#) + (I64# y#) = I64# (x# `plusInt64#` y#) - (I64# x#) - (I64# y#) = I64# (x# `minusInt64#` y#) + (I64# x#) - (I64# y#) = I64# (x# `subInt64#` y#) (I64# x#) * (I64# y#) = I64# (x# `timesInt64#` y#) negate (I64# x#) = I64# (negateInt64# x#) abs x | x >= 0 = x @@ -827,9 +821,9 @@ divInt64#, modInt64# :: Int64# -> Int64# -> Int64# -- Define div in terms of quot, being careful to avoid overflow (#7233) x# `divInt64#` y# | isTrue# (x# `gtInt64#` zero) && isTrue# (y# `ltInt64#` zero) - = ((x# `minusInt64#` one) `quotInt64#` y#) `minusInt64#` one + = ((x# `subInt64#` one) `quotInt64#` y#) `subInt64#` one | isTrue# (x# `ltInt64#` zero) && isTrue# (y# `gtInt64#` zero) - = ((x# `plusInt64#` one) `quotInt64#` y#) `minusInt64#` one + = ((x# `plusInt64#` one) `quotInt64#` y#) `subInt64#` one | otherwise = x# `quotInt64#` y# where diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs index 8a50951344..8569c875bb 100644 --- a/libraries/base/GHC/Word.hs +++ b/libraries/base/GHC/Word.hs @@ -49,7 +49,7 @@ module GHC.Word ( import Data.Maybe #if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 +import GHC.Prim #endif import GHC.Base @@ -731,7 +731,7 @@ gtWord64, geWord64, ltWord64, leWord64 :: Word64 -> Word64 -> Bool -- | @since 2.01 instance Num Word64 where (W64# x#) + (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `plusInt64#` word64ToInt64# y#)) - (W64# x#) - (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `minusInt64#` word64ToInt64# y#)) + (W64# x#) - (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `subInt64#` word64ToInt64# y#)) (W64# x#) * (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `timesInt64#` word64ToInt64# y#)) negate (W64# x#) = W64# (int64ToWord64# (negateInt64# (word64ToInt64# x#))) abs x = x diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs index b2e0fd3c75..a9104caefb 100644 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs @@ -25,10 +25,6 @@ import GHC.Num.Primitives import GHC.Num.WordArray import GHC.Num.Backend -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - default () -- | A BigNat diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs index 6334e1636f..2dd2185592 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs @@ -34,10 +34,6 @@ import GHC.Num.BigNat import GHC.Num.Natural import qualified GHC.Num.Backend as Backend -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - default () -- | Arbitrary precision integers. In contrast with fixed-size integral types diff --git a/libraries/ghc-prim/GHC/Classes.hs b/libraries/ghc-prim/GHC/Classes.hs index dfd707bd8c..a81cb12e8c 100644 --- a/libraries/ghc-prim/GHC/Classes.hs +++ b/libraries/ghc-prim/GHC/Classes.hs @@ -58,7 +58,6 @@ module GHC.Classes( -- GHC.Magic is used in some derived instances import GHC.Magic () -import GHC.IntWord64 import GHC.Prim import GHC.Tuple import GHC.CString (unpackCString#) diff --git a/libraries/ghc-prim/GHC/IntWord64.hs b/libraries/ghc-prim/GHC/IntWord64.hs deleted file mode 100644 index 15a878ccd6..0000000000 --- a/libraries/ghc-prim/GHC/IntWord64.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, UnliftedFFITypes #-} -{-# OPTIONS_HADDOCK not-home #-} ------------------------------------------------------------------------------ --- | --- Module : GHC.IntWord64 --- Copyright : (c) The University of Glasgow, 1997-2008 --- License : see libraries/ghc-prim/LICENSE --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Primitive operations on Int64# and Word64# on platforms where --- WORD_SIZE_IN_BITS < 64. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module GHC.IntWord64 ( -#if WORD_SIZE_IN_BITS < 64 - Int64#, Word64#, module GHC.IntWord64 -#endif - ) where - -import GHC.Types () -- Make implicit dependency known to build system - -#if WORD_SIZE_IN_BITS < 64 - -import GHC.Prim - -foreign import ccall unsafe "hs_eqWord64" eqWord64# :: Word64# -> Word64# -> Int# -foreign import ccall unsafe "hs_neWord64" neWord64# :: Word64# -> Word64# -> Int# -foreign import ccall unsafe "hs_ltWord64" ltWord64# :: Word64# -> Word64# -> Int# -foreign import ccall unsafe "hs_leWord64" leWord64# :: Word64# -> Word64# -> Int# -foreign import ccall unsafe "hs_gtWord64" gtWord64# :: Word64# -> Word64# -> Int# -foreign import ccall unsafe "hs_geWord64" geWord64# :: Word64# -> Word64# -> Int# - -foreign import ccall unsafe "hs_eqInt64" eqInt64# :: Int64# -> Int64# -> Int# -foreign import ccall unsafe "hs_neInt64" neInt64# :: Int64# -> Int64# -> Int# -foreign import ccall unsafe "hs_ltInt64" ltInt64# :: Int64# -> Int64# -> Int# -foreign import ccall unsafe "hs_leInt64" leInt64# :: Int64# -> Int64# -> Int# -foreign import ccall unsafe "hs_gtInt64" gtInt64# :: Int64# -> Int64# -> Int# -foreign import ccall unsafe "hs_geInt64" geInt64# :: Int64# -> Int64# -> Int# -foreign import ccall unsafe "hs_quotInt64" quotInt64# :: Int64# -> Int64# -> Int64# -foreign import ccall unsafe "hs_remInt64" remInt64# :: Int64# -> Int64# -> Int64# - -foreign import ccall unsafe "hs_plusInt64" plusInt64# :: Int64# -> Int64# -> Int64# -foreign import ccall unsafe "hs_minusInt64" minusInt64# :: Int64# -> Int64# -> Int64# -foreign import ccall unsafe "hs_timesInt64" timesInt64# :: Int64# -> Int64# -> Int64# -foreign import ccall unsafe "hs_negateInt64" negateInt64# :: Int64# -> Int64# -foreign import ccall unsafe "hs_quotWord64" quotWord64# :: Word64# -> Word64# -> Word64# -foreign import ccall unsafe "hs_remWord64" remWord64# :: Word64# -> Word64# -> Word64# - -foreign import ccall unsafe "hs_and64" and64# :: Word64# -> Word64# -> Word64# -foreign import ccall unsafe "hs_or64" or64# :: Word64# -> Word64# -> Word64# -foreign import ccall unsafe "hs_xor64" xor64# :: Word64# -> Word64# -> Word64# -foreign import ccall unsafe "hs_not64" not64# :: Word64# -> Word64# - -foreign import ccall unsafe "hs_uncheckedShiftL64" uncheckedShiftL64# :: Word64# -> Int# -> Word64# -foreign import ccall unsafe "hs_uncheckedShiftRL64" uncheckedShiftRL64# :: Word64# -> Int# -> Word64# -foreign import ccall unsafe "hs_uncheckedIShiftL64" uncheckedIShiftL64# :: Int64# -> Int# -> Int64# -foreign import ccall unsafe "hs_uncheckedIShiftRA64" uncheckedIShiftRA64# :: Int64# -> Int# -> Int64# -foreign import ccall unsafe "hs_uncheckedIShiftRL64" uncheckedIShiftRL64# :: Int64# -> Int# -> Int64# - -foreign import ccall unsafe "hs_int64ToWord64" int64ToWord64# :: Int64# -> Word64# -foreign import ccall unsafe "hs_word64ToInt64" word64ToInt64# :: Word64# -> Int64# -foreign import ccall unsafe "hs_intToInt64" intToInt64# :: Int# -> Int64# -foreign import ccall unsafe "hs_int64ToInt" int64ToInt# :: Int64# -> Int# -foreign import ccall unsafe "hs_wordToWord64" wordToWord64# :: Word# -> Word64# -foreign import ccall unsafe "hs_word64ToWord" word64ToWord# :: Word64# -> Word# - -#endif - diff --git a/libraries/ghc-prim/cbits/longlong.c b/libraries/ghc-prim/cbits/longlong.c index 7f3554b930..0631bdad58 100644 --- a/libraries/ghc-prim/cbits/longlong.c +++ b/libraries/ghc-prim/cbits/longlong.c @@ -32,31 +32,32 @@ The exceptions to the rule are primops that cast to and from /* Relational operators */ +HsInt hs_eq64 (HsWord64 a, HsWord64 b) {return a == b;} +HsInt hs_ne64 (HsWord64 a, HsWord64 b) {return a != b;} + HsInt hs_gtWord64 (HsWord64 a, HsWord64 b) {return a > b;} HsInt hs_geWord64 (HsWord64 a, HsWord64 b) {return a >= b;} -HsInt hs_eqWord64 (HsWord64 a, HsWord64 b) {return a == b;} -HsInt hs_neWord64 (HsWord64 a, HsWord64 b) {return a != b;} HsInt hs_ltWord64 (HsWord64 a, HsWord64 b) {return a < b;} HsInt hs_leWord64 (HsWord64 a, HsWord64 b) {return a <= b;} HsInt hs_gtInt64 (HsInt64 a, HsInt64 b) {return a > b;} HsInt hs_geInt64 (HsInt64 a, HsInt64 b) {return a >= b;} -HsInt hs_eqInt64 (HsInt64 a, HsInt64 b) {return a == b;} -HsInt hs_neInt64 (HsInt64 a, HsInt64 b) {return a != b;} HsInt hs_ltInt64 (HsInt64 a, HsInt64 b) {return a < b;} HsInt hs_leInt64 (HsInt64 a, HsInt64 b) {return a <= b;} /* Arithmetic operators */ +HsInt64 hs_neg64 (HsInt64 a) {return - a;} + +HsWord64 hs_add64 (HsWord64 a, HsWord64 b) {return a + b;} +HsWord64 hs_sub64 (HsWord64 a, HsWord64 b) {return a - b;} +HsWord64 hs_mul64 (HsWord64 a, HsWord64 b) {return a * b;} + HsWord64 hs_remWord64 (HsWord64 a, HsWord64 b) {return a % b;} HsWord64 hs_quotWord64 (HsWord64 a, HsWord64 b) {return a / b;} HsInt64 hs_remInt64 (HsInt64 a, HsInt64 b) {return a % b;} HsInt64 hs_quotInt64 (HsInt64 a, HsInt64 b) {return a / b;} -HsInt64 hs_negateInt64 (HsInt64 a) {return -a;} -HsInt64 hs_plusInt64 (HsInt64 a, HsInt64 b) {return a + b;} -HsInt64 hs_minusInt64 (HsInt64 a, HsInt64 b) {return a - b;} -HsInt64 hs_timesInt64 (HsInt64 a, HsInt64 b) {return a * b;} /* Logical operators: */ @@ -71,10 +72,7 @@ HsWord64 hs_uncheckedShiftRL64 (HsWord64 a, HsInt b) {return a >> b;} the behaviour you'll get from using these primops depends on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98 */ -HsInt64 hs_uncheckedIShiftL64 (HsInt64 a, HsInt b) {return a << b;} HsInt64 hs_uncheckedIShiftRA64 (HsInt64 a, HsInt b) {return a >> b;} -HsInt64 hs_uncheckedIShiftRL64 (HsInt64 a, HsInt b) - {return (HsInt64) ((HsWord64) a >> b);} /* Casting between longs and longer longs. */ diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index 61840021c1..812324e117 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -43,7 +43,6 @@ Library GHC.CString GHC.Classes GHC.Debug - GHC.IntWord64 GHC.Magic GHC.Magic.Dict GHC.Prim.Ext |