[commit: ghc] wip/ghc-8.8-merges: PPC NCG: Promote integers to word size in C calls (e1b41ac)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/ghc-8.8-merges
Link       : http://ghc.haskell.org/trac/ghc/changeset/e1b41ac3322e7b9636a68b969b2412a566ed57a0/ghc

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

commit e1b41ac3322e7b9636a68b969b2412a566ed57a0
Author: Peter Trommler <ptrommler at acm.org>
Date:   Wed Jan 23 23:13:57 2019 +0100

    PPC NCG: Promote integers to word size in C calls
    
    Fixes #16222
    
    (cherry picked from commit 4376d8811418d91bb4d19d61801e95a449b98378)


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

e1b41ac3322e7b9636a68b969b2412a566ed57a0
 compiler/cmm/CmmType.hs           |  8 ++++++--
 compiler/nativeGen/PPC/CodeGen.hs | 36 +++++++++++++++++++++++-------------
 2 files changed, 29 insertions(+), 15 deletions(-)

diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs
index 77d894b..0d6e770 100644
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/cmm/CmmType.hs
@@ -4,7 +4,8 @@ module CmmType
     , cInt
     , cmmBits, cmmFloat
     , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
-    , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
+    , isFloatType, isGcPtrType, isBitsType
+    , isWord32, isWord64, isFloat64, isFloat32
 
     , Width(..)
     , widthInBits, widthInBytes, widthInLog, widthFromBytes
@@ -132,13 +133,16 @@ cInt :: DynFlags -> CmmType
 cInt dflags = cmmBits (cIntWidth  dflags)
 
 ------------ Predicates ----------------
-isFloatType, isGcPtrType :: CmmType -> Bool
+isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool
 isFloatType (CmmType FloatCat    _) = True
 isFloatType _other                  = False
 
 isGcPtrType (CmmType GcPtrCat _) = True
 isGcPtrType _other               = False
 
+isBitsType (CmmType BitsCat _) = True
+isBitsType _                   = False
+
 isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool
 -- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise)
 -- isFloat32 and 64 are obvious
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index c6e5304..516a49a 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -1634,15 +1634,13 @@ genCCall'
 
 
 genCCall' dflags gcp target dest_regs args
-  = ASSERT(not $ any (`elem` [II16]) $ map cmmTypeFormat argReps)
-        -- we rely on argument promotion in the codeGen
-    do
+  = do
         (finalStack,passArgumentsCode,usedRegs) <- passArguments
-                                                        (zip args argReps)
-                                                        allArgRegs
-                                                        (allFPArgRegs platform)
-                                                        initialStackOffset
-                                                        (toOL []) []
+                                                   (zip3 args argReps argHints)
+                                                   allArgRegs
+                                                   (allFPArgRegs platform)
+                                                   initialStackOffset
+                                                   nilOL []
 
         (labelOrExpr, reduceToFF32) <- case target of
             ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
@@ -1733,6 +1731,7 @@ genCCall' dflags gcp target dest_regs args
                                 _ -> panic "genCall': unknown calling conv."
 
         argReps = map (cmmExprType dflags) args
+        (argHints, _) = foreignTargetHints target
 
         roundTo a x | x `mod` a == 0 = x
                     | otherwise = x + a - (x `mod` a)
@@ -1769,7 +1768,7 @@ genCCall' dflags gcp target dest_regs args
            _               -> panic "maybeNOP: Unknown PowerPC 64-bit ABI"
 
         passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
-        passArguments ((arg,arg_ty):args) gprs fprs stackOffset
+        passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset
                accumCode accumUsed | isWord64 arg_ty
                                      && target32Bit (targetPlatform dflags) =
             do
@@ -1811,9 +1810,9 @@ genCCall' dflags gcp target dest_regs args
                                                  stackCode accumUsed
                     GCP64ELF _ -> panic "passArguments: 32 bit code"
 
-        passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed
+        passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed
             | reg : _ <- regs = do
-                register <- getRegister arg
+                register <- getRegister arg_pro
                 let code = case register of
                             Fixed _ freg fcode -> fcode `snocOL` MR reg freg
                             Any _ acode -> acode reg
@@ -1833,14 +1832,25 @@ genCCall' dflags gcp target dest_regs args
                               (accumCode `appOL` code)
                               (reg : accumUsed)
             | otherwise = do
-                (vr, code) <- getSomeReg arg
+                (vr, code) <- getSomeReg arg_pro
                 passArguments args
                               (drop nGprs gprs)
                               (drop nFprs fprs)
                               (stackOffset' + stackBytes)
-                              (accumCode `appOL` code `snocOL` ST (cmmTypeFormat rep) vr stackSlot)
+                              (accumCode `appOL` code
+                                         `snocOL` ST format_pro vr stackSlot)
                               accumUsed
             where
+                arg_pro
+                   | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth dflags)) [arg]
+                   | otherwise      = arg
+                format_pro
+                   | isBitsType rep = intFormat (wordWidth dflags)
+                   | otherwise      = cmmTypeFormat rep
+                conv_op = case hint of
+                            SignedHint -> MO_SS_Conv
+                            _          -> MO_UU_Conv
+
                 stackOffset' = case gcp of
                                GCPAIX ->
                                    -- The 32bit PowerOPEN ABI is happy with