Do not assume that XMM registers are used to pass floating point arguments.

On x86-32, the C calling convention specifies that when SSE2 is enabled, vector
arguments are passed in xmm* registers; however, float and double arguments are
still passed on the stack. This patch allows us to make the same choice for
GHC. Even when SSE2 is enabled, we don't want to pass Float and Double arguments
in registers because this would change the ABI and break the ability to link
with code that was compiled without -msse2.

The next patch will enable passing vector arguments in xmm registers on x86-32.

1 files changed, 24 insertions, 15 deletions

diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index 35499333d0..de10d56490 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -14,6 +14,7 @@ import Cmm (Convention(..))
 import PprCmm ()
 
 import DynFlags
+import Platform
 import Outputable
 
 -- Calculate the 'GlobalReg' or stack locations for function call
@@ -68,12 +69,14 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
                       (W128, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
                       _ -> (assts, (r:rs))
               float = case (w, regs) of
-                        (W32, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
+                        (W32, (vs, fs, ds, ls, s:ss))
+                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
                         (W32, (vs, f:fs, ds, ls, ss))
-                            | not hasXmmRegs          -> k (RegisterParam f, (vs, fs, ds, ls, ss))
-                        (W64, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
+                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))
+                        (W64, (vs, fs, ds, ls, s:ss))
+                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
                         (W64, (vs, fs, d:ds, ls, ss))
-                            | not hasXmmRegs          -> k (RegisterParam d, (vs, fs, ds, ls, ss))
+                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))
                         (W80, _) -> panic "F80 unsupported register type"
                         _ -> (assts, (r:rs))
               int = case (w, regs) of
@@ -88,8 +91,12 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
               w  = typeWidth ty
               gcp | isGcPtrType ty = VGcPtr
                   | otherwise      = VNonGcPtr
-              hasXmmRegs = mAX_Real_XMM_REG dflags /= 0
+              passFloatInXmm = passFloatArgsInXmm dflags
 
+passFloatArgsInXmm :: DynFlags -> Bool
+passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
+                              ArchX86_64 -> True
+                              _          -> False
 
 assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
             -> (
@@ -158,7 +165,10 @@ realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
 realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)
 realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)
 realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)
-realXmmRegNos   dflags =                  regList (mAX_Real_XMM_REG     dflags)
+
+realXmmRegNos dflags
+    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)
+    | otherwise            = []
 
 regList :: Int -> [Int]
 regList n = [1 .. n]
@@ -180,12 +190,11 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
 -- only use this functionality in hand-written C-- code in the RTS.
 realArgRegsCover :: DynFlags -> [GlobalReg]
 realArgRegsCover dflags
-    | hasXmmRegs = map ($VGcPtr) (realVanillaRegs dflags) ++
-                   realDoubleRegs dflags ++
-                   realLongRegs dflags
-    | otherwise  = map ($VGcPtr) (realVanillaRegs dflags) ++
-                   realFloatRegs dflags ++
-                   realDoubleRegs dflags ++
-                   realLongRegs dflags
-  where
-    hasXmmRegs = mAX_Real_XMM_REG dflags /= 0
+    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
+                                  realLongRegs dflags ++
+                                  map XmmReg (realXmmRegNos dflags)
+    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) ++
+                                  realFloatRegs dflags ++
+                                  realDoubleRegs dflags ++
+                                  realLongRegs dflags ++
+                                  map XmmReg (realXmmRegNos dflags)