[commit: ghc] master: Implement word2Float# and word2Double# (2e8c769)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/2e8c769422740c001e0a247bfec61d4f78598582

>---------------------------------------------------------------

commit 2e8c769422740c001e0a247bfec61d4f78598582
Author: Johan Tibell <[email protected]>
Date:   Wed Dec 5 19:08:48 2012 -0800

    Implement word2Float# and word2Double#

>---------------------------------------------------------------

 compiler/cmm/CmmMachOp.hs               |    2 ++
 compiler/cmm/PprC.hs                    |    1 +
 compiler/codeGen/StgCmmPrim.hs          |    6 ++++++
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs |   12 ++++++++++++
 compiler/nativeGen/CPrim.hs             |   12 +++++++++++-
 compiler/nativeGen/PPC/CodeGen.hs       |    2 ++
 compiler/nativeGen/SPARC/CodeGen.hs     |    2 ++
 compiler/nativeGen/X86/CodeGen.hs       |   13 +++++++++++++
 compiler/prelude/primops.txt.pp         |    3 +++
 9 files changed, 52 insertions(+), 1 deletions(-)

diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index c00cdb5..a6c9bee 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -441,6 +441,8 @@ data CallishMachOp
   | MO_F32_Exp
   | MO_F32_Sqrt
 
+  | MO_UF_Conv Width
+
   | MO_S_QuotRem Width
   | MO_U_QuotRem Width
   | MO_U_QuotRem2 Width
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 927f7eb..bcfb5dc 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -681,6 +681,7 @@ pprCallishMachOp_for_C mop
         MO_Memset       -> ptext (sLit "memset")
         MO_Memmove      -> ptext (sLit "memmove")
         (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
+        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)
 
         MO_S_QuotRem  {} -> unsupported
         MO_U_QuotRem  {} -> unsupported
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index fe2a021..66832c1 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -491,6 +491,12 @@ emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32
 emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64
 emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)
 
+-- Unsigned int to floating point conversions
+emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]
+                                            (MO_UF_Conv W32) [w]
+emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]
+                                            (MO_UF_Conv W64) [w]
+
 -- The rest just translate straightforwardly
 emitPrimOp dflags [res] op [arg]
    | nopOp op
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index fd9d701..c510185 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -187,6 +187,17 @@ genCall env (PrimTarget MO_WriteBarrier) _ _
 genCall env (PrimTarget MO_Touch) _ _
  = return (env, nilOL, [])
 
+genCall env (PrimTarget (MO_UF_Conv w)) [dst] [e] = do
+    let (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
+        width = widthToLlvmFloat w
+    (env2, ve, stmts2, top2) <- exprToVar env1 e
+    let stmt = Assignment dstV $ Cast LM_Uitofp ve width
+        stmts = stmts1 `appOL` stmts2 `snocOL` stmt
+    return (env2, stmts, top1 ++ top2)
+genCall _ (PrimTarget (MO_UF_Conv _)) [_] args =
+    panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
+    "Can only handle 1, given" ++ show (length args) ++ "."
+
 -- Handle popcnt function specifically since GHC only really has i32 and i64
 -- types and things like Word8 are backed by an i32 and just present a logical
 -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
@@ -513,6 +524,7 @@ cmmPrimOpFunctions env mop
     MO_U_Mul2 {}     -> unsupported
     MO_WriteBarrier  -> unsupported
     MO_Touch         -> unsupported
+    MO_UF_Conv _     -> unsupported
 
     where
         dflags = getDflags env
diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs
index 09707ac..dd9d38f 100644
--- a/compiler/nativeGen/CPrim.hs
+++ b/compiler/nativeGen/CPrim.hs
@@ -1,5 +1,8 @@
 -- | Generating C symbol names emitted by the compiler.
-module CPrim (popCntLabel) where
+module CPrim
+    ( popCntLabel
+    , word2FloatLabel
+    ) where
 
 import CmmType
 import Outputable
@@ -12,3 +15,10 @@ popCntLabel w = "hs_popcnt" ++ pprWidth w
     pprWidth W32 = "32"
     pprWidth W64 = "64"
     pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)
+
+word2FloatLabel :: Width -> String
+word2FloatLabel w = "hs_word2float" ++ pprWidth w
+  where
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "word2FloatLabel: Unsupported word width " (ppr w)
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 5e05047..e9a5b43 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -1149,6 +1149,8 @@ genCCall' dflags gcp target dest_regs args0
                     MO_F64_Tanh  -> (fsLit "tanh", False)
                     MO_F64_Pwr   -> (fsLit "pow", False)
 
+                    MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)
+
                     MO_Memcpy    -> (fsLit "memcpy", False)
                     MO_Memset    -> (fsLit "memset", False)
                     MO_Memmove   -> (fsLit "memmove", False)
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index f3b70e7..880b5c6 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -641,6 +641,8 @@ outOfLineMachOp_table mop
         MO_F64_Cosh   -> fsLit "cosh"
         MO_F64_Tanh   -> fsLit "tanh"
 
+        MO_UF_Conv w -> fsLit $ word2FloatLabel w
+
         MO_Memcpy    -> fsLit "memcpy"
         MO_Memset    -> fsLit "memset"
         MO_Memmove   -> fsLit "memmove"
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 36f9e2d..30cf060 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -1659,6 +1659,17 @@ genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
     size = intSize width
     lbl = mkCmmCodeLabel primPackageId (fsLit (popCntLabel width))
 
+genCCall is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do
+    dflags <- getDynFlags
+    targetExpr <- cmmMakeDynamicReference dflags addImportNat
+                  CallReference lbl
+    let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                           [NoHint] [NoHint]
+                                           CmmMayReturn)
+    genCCall is32Bit target dest_regs args
+  where
+    lbl = mkCmmCodeLabel primPackageId (fsLit (word2FloatLabel width))
+
 genCCall is32Bit target dest_regs args
  | is32Bit   = genCCall32 target dest_regs args
  | otherwise = genCCall64 target dest_regs args
@@ -2280,6 +2291,8 @@ outOfLineCmmOp mop res args
 
               MO_PopCnt _  -> fsLit "popcnt"
 
+              MO_UF_Conv _ -> unsupported
+
               MO_S_QuotRem {}  -> unsupported
               MO_U_QuotRem {}  -> unsupported
               MO_U_QuotRem2 {} -> unsupported
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index c6e1b47..77236a1 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -259,6 +259,9 @@ primop   Int2WordOp "int2Word#" GenPrimOp Int# -> Word#
 primop   Int2FloatOp   "int2Float#"      GenPrimOp  Int# -> Float#
 primop   Int2DoubleOp   "int2Double#"          GenPrimOp  Int# -> Double#
 
+primop   Word2FloatOp   "word2Float#"      GenPrimOp  Word# -> Float#
+primop   Word2DoubleOp   "word2Double#"          GenPrimOp  Word# -> Double#
+
 primop   ISllOp   "uncheckedIShiftL#" GenPrimOp  Int# -> Int# -> Int#
 	 {Shift left.  Result undefined if shift amount is not
           in the range 0 to word size - 1 inclusive.}