[commit: ghc] master: x86: promote arguments to C functions according to the ABI (#7383) (085e814)

[Ian Lynagh]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/085e8145f63c8f42d8bc19cd3cff52b8cd5b6455

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

commit 085e8145f63c8f42d8bc19cd3cff52b8cd5b6455
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Wed Feb 20 11:43:33 2013 +0000

    x86: promote arguments to C functions according to the ABI (#7383)
    
    I don't think the x86-64 version is quite right, but this ought to be
    enough to pass cgrun071.
    
    This code is terrible and needs a complete refactor.  There's a lot of
    duplication, and we ought to be specifying the ABI in a much more
    abstract way (like LLVM).

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

 compiler/nativeGen/X86/CodeGen.hs |   20 ++++++++++++++------
 1 files changed, 14 insertions(+), 6 deletions(-)

diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index c6cdd8a..36aebea 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -1820,6 +1820,8 @@ genCCall32' :: DynFlags
             -> NatM InstrBlock
 genCCall32' dflags target dest_regs args = do
         let
+            prom_args = map (maybePromoteCArg dflags W32) args
+
             -- Align stack to 16n for calls, assuming a starting stack
             -- alignment of 16n - word_size on procedure entry. Which we
             -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
@@ -1831,7 +1833,7 @@ genCCall32' dflags target dest_regs args = do
         setDeltaNat (delta0 - arg_pad_size)
 
         use_sse2 <- sse2Enabled
-        push_codes <- mapM (push_arg use_sse2) (reverse args)
+        push_codes <- mapM (push_arg use_sse2) (reverse prom_args)
         delta <- getDeltaNat
         MASSERT (delta == delta0 - tot_arg_size)
 
@@ -2055,12 +2057,14 @@ genCCall64' :: DynFlags
             -> NatM InstrBlock
 genCCall64' dflags target dest_regs args = do
     -- load up the register arguments
+    let prom_args = map (maybePromoteCArg dflags W32) args
+
     (stack_args, int_regs_used, fp_regs_used, load_args_code)
          <-
         if platformOS platform == OSMinGW32
-        then load_args_win args [] [] (allArgRegs platform) nilOL
+        then load_args_win prom_args [] [] (allArgRegs platform) nilOL
         else do (stack_args, aregs, fregs, load_args_code)
-                    <- load_args args (allIntArgRegs platform) (allFPArgRegs platform) nilOL
+                    <- load_args prom_args (allIntArgRegs platform) (allFPArgRegs platform) nilOL
                 let fp_regs_used  = reverse (drop (length fregs) (reverse (allFPArgRegs platform)))
                     int_regs_used = reverse (drop (length aregs) (reverse (allIntArgRegs platform)))
                 return (stack_args, int_regs_used, fp_regs_used, load_args_code)
@@ -2231,9 +2235,6 @@ genCCall64' dflags target dest_regs args = do
              push_args rest code'
 
            | otherwise = do
-           -- we only ever generate word-sized function arguments.  Promotion
-           -- has already happened: our Int8# type is kept sign-extended
-           -- in an Int#, for example.
              ASSERT(width == W64) return ()
              (arg_op, arg_code) <- getOperand arg
              delta <- getDeltaNat
@@ -2253,6 +2254,13 @@ genCCall64' dflags target dest_regs args = do
                          SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp),
                          DELTA (delta - n * arg_size)]
 
+maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr
+maybePromoteCArg dflags wto arg
+ | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]
+ | otherwise   = arg
+ where
+   wfrom = cmmExprWidth dflags arg
+
 -- | We're willing to inline and unroll memcpy/memset calls that touch
 -- at most these many bytes.  This threshold is the same as the one
 -- used by GCC and LLVM.