[Git][ghc/ghc][wip/int64-everywhere] WIP: Add missing floats <-> int/word 64 rule and primops
John Ericson
gitlab at gitlab.haskell.org
Tue Sep 8 15:37:21 UTC 2020
John Ericson pushed to branch wip/int64-everywhere at Glasgow Haskell Compiler / GHC
Commits:
e57c5969 by John Ericson at 2020-09-08T10:59:00-04:00
WIP: Add missing floats <-> int/word 64 rule and primops
- - - - -
16 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/CmmToAsm/CPrim.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Types/Literal.hs
- includes/stg/Prim.h
- libraries/base/GHC/Float.hs
- libraries/base/GHC/Int.hs
- libraries/base/GHC/Word.hs
- libraries/ghc-prim/cbits/word2float.c
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -774,11 +774,15 @@ primop ChrOp "chr#" GenPrimOp Int# -> Char#
primop IntToWordOp "int2Word#" GenPrimOp Int# -> Word#
with code_size = 0
-primop IntToFloatOp "int2Float#" GenPrimOp Int# -> Float#
-primop IntToDoubleOp "int2Double#" GenPrimOp Int# -> Double#
+primop IntToFloatOp "int2Float#" GenPrimOp Int# -> Float#
+primop IntToDoubleOp "int2Double#" GenPrimOp Int# -> Double#
+primop Int64ToFloatOp "int64ToFloat#" GenPrimOp Int64# -> Float#
+primop Int64ToDoubleOp "int64ToDouble#" GenPrimOp Int64# -> Double#
-primop WordToFloatOp "word2Float#" GenPrimOp Word# -> Float#
-primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double#
+primop WordToFloatOp "word2Float#" GenPrimOp Word# -> Float#
+primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double#
+primop Word64ToFloatOp "word64ToFloat#" GenPrimOp Word64# -> Float#
+primop Word64ToDoubleOp "word64ToDouble#" GenPrimOp Word64# -> Double#
primop IntSllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int#
{Shift left. Result undefined if shift amount is not
@@ -1016,6 +1020,7 @@ primop DoubleToIntOp "double2Int#" GenPrimOp Double# -> Int#
{Truncates a {\tt Double#} value to the nearest {\tt Int#}.
Results are undefined if the truncation if truncation yields
a value outside the range of {\tt Int#}.}
+primop DoubleToInt64Op "doubleToInt64#" GenPrimOp Double# -> Int64#
primop DoubleToFloatOp "double2Float#" GenPrimOp Double# -> Float#
@@ -1170,6 +1175,7 @@ primop FloatToIntOp "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 FloatToInt64Op "floatToInt64#" GenPrimOp Float# -> Int64#
primop FloatExpOp "expFloat#" GenPrimOp
Float# -> Float#
=====================================
compiler/GHC/Cmm/MachOp.hs
=====================================
@@ -122,6 +122,7 @@ data MachOp
-- is equivalent to just x.
| MO_FF_Conv Width Width -- Float -> Float
+
-- Vector element insertion and extraction operations
| MO_V_Insert Length Width -- Insert scalar into vector
| MO_V_Extract Length Width -- Extract scalar from vector
@@ -586,7 +587,7 @@ data CallishMachOp
| MO_F32_Fabs
| MO_F32_Sqrt
- | MO_UF_Conv Width
+ | MO_UF_Conv Width Width -- unsigned int -> Float
| MO_S_Mul2 Width
| MO_S_QuotRem Width
=====================================
compiler/GHC/CmmToAsm/CPrim.hs
=====================================
@@ -84,8 +84,8 @@ ctzLabel w = "hs_ctz" ++ pprWidth w
pprWidth W64 = "64"
pprWidth w = pprPanic "ctzLabel: Unsupported word width " (ppr w)
-word2FloatLabel :: Width -> String
-word2FloatLabel w = "hs_word2float" ++ pprWidth w
+word2FloatLabel :: Width -> Width -> String
+word2FloatLabel wFrom wTo = "hs_word" ++ pprWidth wFrom ++ "_to_float" ++ pprWidth wTo
where
pprWidth W32 = "32"
pprWidth W64 = "64"
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -2009,7 +2009,7 @@ genCCall' config gcp target dest_regs args
MO_F64_Acosh -> (fsLit "acosh", False)
MO_F64_Atanh -> (fsLit "atanh", False)
- MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)
+ MO_UF_Conv wFrom wTo -> (fsLit $ word2FloatLabel wFrom wTo, False)
MO_Memcpy _ -> (fsLit "memcpy", False)
MO_Memset _ -> (fsLit "memset", False)
=====================================
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
=====================================
@@ -661,7 +661,7 @@ outOfLineMachOp_table mop
MO_F64_Acosh -> fsLit "acosh"
MO_F64_Atanh -> fsLit "atanh"
- MO_UF_Conv w -> fsLit $ word2FloatLabel w
+ MO_UF_Conv wFrom wTo -> fsLit $ word2FloatLabel wFrom wTo
MO_Memcpy _ -> fsLit "memcpy"
MO_Memset _ -> fsLit "memset"
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -2507,7 +2507,7 @@ genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src]
bw = widthInBits width
lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))
-genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do
+genCCall' config is32Bit (PrimTarget (MO_UF_Conv wFrom wTo)) dest_regs args bid = do
targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
@@ -2515,7 +2515,7 @@ genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do
CmmMayReturn)
genCCall' config is32Bit target dest_regs args bid
where
- lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))
+ lbl = mkCmmCodeLabel primUnitId $ fsLit $ word2FloatLabel wFrom wTo
genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do
load_code <- intLoadCode (MOV (intFormat width)) addr
@@ -3341,7 +3341,7 @@ outOfLineCmmOp bid mop res args
MO_Cmpxchg _ -> fsLit "cmpxchg"
MO_Xchg _ -> should_be_inline
- MO_UF_Conv _ -> unsupported
+ MO_UF_Conv _ _ -> unsupported
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -821,7 +821,7 @@ pprCallishMachOp_for_C mop
(MO_Xchg w) -> ptext (sLit $ xchgLabel w)
(MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w)
(MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
- (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)
+ (MO_UF_Conv wFrom wTo) -> ptext (sLit $ word2FloatLabel wFrom wTo)
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -201,7 +201,7 @@ genCall (PrimTarget MO_WriteBarrier) _ _ = do
genCall (PrimTarget MO_Touch) _ _
= return (nilOL, [])
-genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
+genCall (PrimTarget (MO_UF_Conv _ w)) [dst] [e] = runStmtsDecls $ do
dstV <- getCmmRegW (CmmLocal dst)
let ty = cmmToLlvmType $ localRegType dst
width = widthToLlvmFloat w
@@ -210,7 +210,7 @@ genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
statement $ Assignment castV $ Cast LM_Uitofp ve width
statement $ Store castV dstV
-genCall (PrimTarget (MO_UF_Conv _)) [_] args =
+genCall (PrimTarget (MO_UF_Conv _ _)) [_] args =
panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
"Can only handle 1, given" ++ show (length args) ++ "."
@@ -897,7 +897,7 @@ cmmPrimOpFunctions mop = do
MO_ReadBarrier -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
- MO_UF_Conv _ -> unsupported
+ MO_UF_Conv _ _ -> unsupported
MO_AtomicRead _ -> unsupported
MO_AtomicRMW _ _ -> unsupported
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -315,6 +315,10 @@ primOpRules nm = \case
IntToFloatOp -> mkPrimOpRule nm 1 [ liftLit intToFloatLit ]
DoubleToIntOp -> mkPrimOpRule nm 1 [ liftLit doubleToIntLit ]
IntToDoubleOp -> mkPrimOpRule nm 1 [ liftLit intToDoubleLit ]
+ FloatToInt64Op -> mkPrimOpRule nm 1 [ liftLit floatToInt64Lit ]
+ Int64ToFloatOp -> mkPrimOpRule nm 1 [ liftLit int64ToFloatLit ]
+ DoubleToInt64Op -> mkPrimOpRule nm 1 [ liftLit doubleToInt64Lit ]
+ Int64ToDoubleOp -> mkPrimOpRule nm 1 [ liftLit int64ToDoubleLit ]
-- SUP: Not sure what the standard says about precision in the following 2 cases
FloatToDoubleOp -> mkPrimOpRule nm 1 [ liftLit floatToDoubleLit ]
DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ]
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -841,9 +841,14 @@ emitPrimOp dflags primop = case primop of
-- Unsigned int to floating point conversions
WordToFloatOp -> \[w] -> opIntoRegs $ \[res] -> do
- emitPrimCall [res] (MO_UF_Conv W32) [w]
+ emitPrimCall [res] (MO_UF_Conv (wordWidth platform) W32) [w]
+ Word64ToFloatOp -> \[w] -> opIntoRegs $ \[res] -> do
+ emitPrimCall [res] (MO_UF_Conv W64 W32) [w]
+
WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> do
- emitPrimCall [res] (MO_UF_Conv W64) [w]
+ emitPrimCall [res] (MO_UF_Conv (wordWidth platform) W64) [w]
+ Word64ToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> do
+ emitPrimCall [res] (MO_UF_Conv W64 W64) [w]
-- Atomic operations
InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] ->
@@ -1408,9 +1413,15 @@ emitPrimOp dflags primop = case primop of
IntToDoubleOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)
DoubleToIntOp -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform))
+ Int64ToDoubleOp -> \args -> opTranslate args (MO_SF_Conv W64 W64)
+ DoubleToInt64Op -> \args -> opTranslate args (MO_FS_Conv W64 W64)
+
IntToFloatOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32)
FloatToIntOp -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform))
+ Int64ToFloatOp -> \args -> opTranslate args (MO_SF_Conv W64 W32)
+ FloatToInt64Op -> \args -> opTranslate args (MO_FS_Conv W32 W64)
+
FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)
DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -45,8 +45,12 @@ module GHC.Types.Literal
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, charToIntLit, intToCharLit
- , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit
- , nullAddrLit, rubbishLit, floatToDoubleLit, doubleToFloatLit
+ , floatToIntLit, intToFloatLit
+ , floatToInt64Lit, int64ToFloatLit
+ , doubleToIntLit, intToDoubleLit
+ , doubleToInt64Lit, int64ToDoubleLit
+ , floatToDoubleLit, doubleToFloatLit
+ , nullAddrLit, rubbishLit
) where
#include "HsVersions.h"
@@ -487,7 +491,10 @@ isLitValue = isJust . isLitValue_maybe
narrow8IntLit, narrow16IntLit, narrow32IntLit,
narrow8WordLit, narrow16WordLit, narrow32WordLit,
charToIntLit, intToCharLit,
- floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit,
+ floatToIntLit, intToFloatLit,
+ floatToInt64Lit, int64ToFloatLit,
+ doubleToIntLit, intToDoubleLit,
+ doubleToInt64Lit, int64ToDoubleLit,
floatToDoubleLit, doubleToFloatLit
:: Literal -> Literal
@@ -553,11 +560,21 @@ floatToIntLit l = pprPanic "floatToIntLit" (ppr l)
intToFloatLit (LitNumber _ i) = LitFloat (fromInteger i)
intToFloatLit l = pprPanic "intToFloatLit" (ppr l)
+floatToInt64Lit (LitFloat f) = mkLitInt64Unchecked (truncate f)
+floatToInt64Lit l = pprPanic "floatToInt64Lit" (ppr l)
+int64ToFloatLit (LitNumber _ i) = LitFloat (fromInteger i)
+int64ToFloatLit l = pprPanic "int64ToFloatLit" (ppr l)
+
doubleToIntLit (LitDouble f) = mkLitIntUnchecked (truncate f)
doubleToIntLit l = pprPanic "doubleToIntLit" (ppr l)
intToDoubleLit (LitNumber _ i) = LitDouble (fromInteger i)
intToDoubleLit l = pprPanic "intToDoubleLit" (ppr l)
+doubleToInt64Lit (LitDouble f) = mkLitInt64Unchecked (truncate f)
+doubleToInt64Lit l = pprPanic "doubleToInt64Lit" (ppr l)
+int64ToDoubleLit (LitNumber _ i) = LitDouble (fromInteger i)
+int64ToDoubleLit l = pprPanic "int64ToDoubleLit" (ppr l)
+
floatToDoubleLit (LitFloat f) = LitDouble f
floatToDoubleLit l = pprPanic "floatToDoubleLit" (ppr l)
doubleToFloatLit (LitDouble d) = LitFloat d
=====================================
includes/stg/Prim.h
=====================================
@@ -88,8 +88,10 @@ StgWord hs_popcnt64(StgWord64 x);
StgWord hs_popcnt(StgWord x);
/* libraries/ghc-prim/cbits/word2float.c */
-StgFloat hs_word2float32(StgWord x);
-StgDouble hs_word2float64(StgWord x);
+StgFloat hs_word32_to_float32(StgWord32 x);
+StgDouble hs_word32_to_float64(StgWord32 x);
+StgFloat hs_word64_to_float32(StgWord64 x);
+StgDouble hs_word64_to_float64(StgWord64 x);
/* libraries/ghc-prim/cbits/clz.c */
StgWord hs_clz8(StgWord x);
=====================================
libraries/base/GHC/Float.hs
=====================================
@@ -1296,8 +1296,11 @@ word2Float (W# w) = F# (word2Float# w)
"realToFrac/Float->Double" realToFrac = float2Double
"realToFrac/Double->Float" realToFrac = double2Float
"realToFrac/Double->Double" realToFrac = id :: Double -> Double
-"realToFrac/Int->Double" realToFrac = int2Double -- See Note [realToFrac int-to-float]
-"realToFrac/Int->Float" realToFrac = int2Float -- ..ditto
+-- See Note [realToFrac int-to-float] on the below
+"realToFrac/Int->Double" realToFrac = int2Double
+"realToFrac/Int->Float" realToFrac = int2Float
+"realToFrac/Word->Double" realToFrac = word2Double
+"realToFrac/Word->Float" realToFrac = word2Float
#-}
{-
=====================================
libraries/base/GHC/Int.hs
=====================================
@@ -33,7 +33,10 @@ module GHC.Int (
eqInt8, neInt8, gtInt8, geInt8, ltInt8, leInt8,
eqInt16, neInt16, gtInt16, geInt16, ltInt16, leInt16,
eqInt32, neInt32, gtInt32, geInt32, ltInt32, leInt32,
- eqInt64, neInt64, gtInt64, geInt64, ltInt64, leInt64
+ eqInt64, neInt64, gtInt64, geInt64, ltInt64, leInt64,
+ -- * Floating point converions
+ doubleToInt64, int64ToDouble,
+ floatToInt64, int64ToFloat
) where
import Data.Bits
@@ -992,6 +995,18 @@ a `iShiftRA64#` b | isTrue# (b >=# 64#) = if isTrue# (a `ltInt64#` (intToInt64#
else intToInt64# 0#
| otherwise = a `uncheckedIShiftRA64#` b
+doubleToInt64 :: Double -> Int64
+doubleToInt64 (D# x) = I64# (doubleToInt64# x)
+
+int64ToDouble :: Int64 -> Double
+int64ToDouble (I64# i) = D# (int64ToDouble# i)
+
+floatToInt64 :: Float -> Int64
+floatToInt64 (F# x) = I64# (floatToInt64# x)
+
+int64ToFloat :: Int64 -> Float
+int64ToFloat (I64# i) = F# (int64ToFloat# i)
+
{-# RULES
"fromIntegral/Int->Int64" fromIntegral = \(I# x#) -> I64# (intToInt64# x#)
"fromIntegral/Word->Int64" fromIntegral = \(W# x#) -> I64# (word64ToInt64# (wordToWord64# x#))
@@ -1000,6 +1015,11 @@ a `iShiftRA64#` b | isTrue# (b >=# 64#) = if isTrue# (a `ltInt64#` (intToInt64#
"fromIntegral/Int64->Word" fromIntegral = \(I64# x#) -> W# (int2Word# (int64ToInt# x#))
"fromIntegral/Int64->Word64" fromIntegral = \(I64# x#) -> W64# (int64ToWord64# x#)
"fromIntegral/Int64->Int64" fromIntegral = id :: Int64 -> Int64
+-- See Note [realToFrac int-to-float] about below
+"fromIntegral/Int64->Float" fromIntegral = int64ToFloat
+"fromIntegral/Int64->Double" fromIntegral = int64ToDouble
+"realToFrac/Int64->Double" realToFrac = int64ToDouble
+"realToFrac/Int64->Float" realToFrac = int64ToFloat
#-}
-- No RULES for RealFrac methods if Int is smaller than Int64, we can't
=====================================
libraries/base/GHC/Word.hs
=====================================
@@ -43,7 +43,11 @@ module GHC.Word (
eqWord8, neWord8, gtWord8, geWord8, ltWord8, leWord8,
eqWord16, neWord16, gtWord16, geWord16, ltWord16, leWord16,
eqWord32, neWord32, gtWord32, geWord32, ltWord32, leWord32,
- eqWord64, neWord64, gtWord64, geWord64, ltWord64, leWord64
+ eqWord64, neWord64, gtWord64, geWord64, ltWord64, leWord64,
+
+ -- * Floating point converions
+ word64ToDouble,
+ word64ToFloat
) where
import Data.Bits
@@ -940,12 +944,23 @@ a `shiftL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0##
a `shiftRL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0##
| otherwise = a `uncheckedShiftRL64#` b
+word64ToDouble :: Word64 -> Double
+word64ToDouble (W64# w) = D# (word64ToDouble# w)
+
+word64ToFloat :: Word64 -> Float
+word64ToFloat (W64# w) = F# (word64ToFloat# w)
+
{-# RULES
"fromIntegral/Int->Word64" fromIntegral = \(I# x#) -> W64# (int64ToWord64# (intToInt64# x#))
"fromIntegral/Word->Word64" fromIntegral = \(W# x#) -> W64# (wordToWord64# x#)
"fromIntegral/Word64->Int" fromIntegral = \(W64# x#) -> I# (word2Int# (word64ToWord# x#))
"fromIntegral/Word64->Word" fromIntegral = \(W64# x#) -> W# (word64ToWord# x#)
"fromIntegral/Word64->Word64" fromIntegral = id :: Word64 -> Word64
+-- See Note [realToFrac int-to-float] about below
+"fromIntegral/Word64->Float" fromIntegral = word64ToFloat
+"fromIntegral/Word64->Double" fromIntegral = word64ToDouble
+"realToFrac/Word64->Double" realToFrac = word64ToDouble
+"realToFrac/Word64->Float" realToFrac = word64ToFloat
#-}
#if WORD_SIZE_IN_BITS == 64
=====================================
libraries/ghc-prim/cbits/word2float.c
=====================================
@@ -1,15 +1,29 @@
#include "Rts.h"
-extern StgFloat hs_word2float32(StgWord x);
+extern StgFloat hs_word32_to_float32(StgWord32 x);
StgFloat
-hs_word2float32(StgWord x)
+hs_word32_to_float32(StgWord32 x)
{
return x;
}
-extern StgDouble hs_word2float64(StgWord x);
+extern StgDouble hs_word32_to_float64(StgWord32 x);
StgDouble
-hs_word2float64(StgWord x)
+hs_word32_to_float64(StgWord32 x)
+{
+ return x;
+}
+
+extern StgFloat hs_word64_to_float32(StgWord64 x);
+StgFloat
+hs_word64_to_float32(StgWord64 x)
+{
+ return x;
+}
+
+extern StgDouble hs_word64_to_float64(StgWord64 x);
+StgDouble
+hs_word64_to_float64(StgWord64 x)
{
return x;
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e57c5969a0e4b3ad65fe029a23a742928449fd16
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e57c5969a0e4b3ad65fe029a23a742928449fd16
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/20200908/3a7a7665/attachment-0001.html>
More information about the ghc-commits
mailing list