compiler/GHC/Cmm/Lint.hs

@@ -6,6 +6,7 @@
 --
 -----------------------------------------------------------------------------
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 module GHC.Cmm.Lint (
     cmmLint, cmmLintGraph
@@ -14,6 +15,7 @@ module GHC.Cmm.Lint (
 import GHC.Prelude
 
 import GHC.Platform
+import GHC.Platform.Regs (callerSaves)
 import GHC.Cmm.Dataflow.Block
 import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Graph
@@ -26,7 +28,7 @@ import GHC.Cmm.Ppr () -- For Outputable instances
 import GHC.Utils.Outputable
 import GHC.Driver.Session
 
-import Control.Monad (ap)
+import Control.Monad (ap, unless)
 
 -- Things to check:
 --     - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)
@@ -160,7 +162,13 @@ lintCmmMiddle node = case node of
 
   CmmUnsafeForeignCall target _formals actuals -> do
             lintTarget target
-            mapM_ lintCmmExpr actuals
+            let lintArg expr = do
+                  -- Arguments can't mention caller-saved
+                  -- registers. See Note [Register parameter passing].
+                  mayNotMentionCallerSavedRegs (text "foreign call argument") expr
+                  lintCmmExpr expr
+
+            mapM_ lintArg actuals
 
 
 lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
@@ -188,18 +196,40 @@ lintCmmLast labels node = case node of
 
   CmmForeignCall tgt _ args succ _ _ _ -> do
           lintTarget tgt
-          mapM_ lintCmmExpr args
+          let lintArg expr = do
+                -- Arguments can't mention caller-saved
+                -- registers. See Note [Register
+                -- parameter passing].
+                -- N.B. This won't catch local registers
+                -- which the NCG's register allocator later
+                -- places in caller-saved registers.
+                mayNotMentionCallerSavedRegs (text "foreign call argument") expr
+                lintCmmExpr expr
+          mapM_ lintArg args
           checkTarget succ
  where
   checkTarget id
      | setMember id labels = return ()
      | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
 
-
 lintTarget :: ForeignTarget -> CmmLint ()
-lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
+lintTarget (ForeignTarget e _) = do
+    mayNotMentionCallerSavedRegs (text "foreign target") e
+    _ <- lintCmmExpr e
+    return ()
 lintTarget (PrimTarget {})     = return ()
 
+-- | As noted in Note [Register parameter passing], the arguments and
+-- 'ForeignTarget' of a foreign call mustn't mention
+-- caller-saved registers.
+mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a)
+                             => SDoc -> a -> CmmLint ()
+mayNotMentionCallerSavedRegs what thing = do
+    dflags <- getDynFlags
+    let badRegs = filter (callerSaves (targetPlatform dflags))
+                  $ foldRegsUsed dflags (flip (:)) [] thing
+    unless (null badRegs)
+      $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing)
 
 checkCond :: Platform -> CmmExpr -> CmmLint ()
 checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()

compiler/GHC/Cmm/MachOp.hs

@@ -45,6 +45,9 @@ native code generators to handle.
 Most operations are parameterised by the 'Width' that they operate on.
 Some operations have separate signed and unsigned versions, and float
 and integer versions.
+
+Note that there are variety of places in the native code generator where we
+assume that the code produced for a MachOp does not introduce new blocks.
 -}
 
 data MachOp

compiler/GHC/Cmm/Node.hs

@@ -93,7 +93,7 @@ data CmmNode e x where
       --
       -- Invariant: the arguments and the ForeignTarget must not
       -- mention any registers for which GHC.Platform.callerSaves
-      -- is True.  See Note [Register Parameter Passing].
+      -- is True.  See Note [Register parameter passing].
 
   CmmBranch :: ULabel -> CmmNode O C
                                    -- Goto another block in the same procedure
@@ -223,11 +223,12 @@ convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
 argument passing.  These are registers R3-R6, which our generated
 code may also be using; as a result, it's necessary to save these
 values before doing a foreign call.  This is done during initial
-code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.  However,
-one result of doing this is that the contents of these registers
-may mysteriously change if referenced inside the arguments.  This
-is dangerous, so you'll need to disable inlining much in the same
-way is done in GHC.Cmm.Opt currently.  We should fix this!
+code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.
+
+However, one result of doing this is that the contents of these registers may
+mysteriously change if referenced inside the arguments.  This is dangerous, so
+you'll need to disable inlining much in the same way is done in GHC.Cmm.Sink
+currently.  We should fix this!
 -}
 
 ---------------------------------------------

compiler/GHC/Cmm/Sink.hs

@@ -772,6 +772,7 @@ regAddr _      _ _ _ = AnyMem
 
 {-
 Note [Inline GlobalRegs?]
+~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Should we freely inline GlobalRegs?
 

compiler/GHC/CmmToAsm/X86/CodeGen.hs

@@ -287,11 +287,11 @@ we construct as a separate data type and the actual control flow graph in the co
 Instead we now return the new basic block if a statement causes a change
 in the current block and use the block for all following statements.
 
-For this reason genCCall is also split into two parts.
-One for calls which *won't* change the basic blocks in
-which successive instructions will be placed.
-A different one for calls which *are* known to change the
-basic block.
+For this reason genCCall is also split into two parts.  One for calls which
+*won't* change the basic blocks in which successive instructions will be
+placed (since they only evaluate CmmExpr, which can only contain MachOps, which
+cannot introduce basic blocks in their lowerings).  A different one for calls
+which *are* known to change the basic block.
 
 -}
 
@@ -1028,6 +1028,9 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
           tmp.  This is likely to be better, because the reg alloc can
           eliminate this reg->reg move here (it won't eliminate the other one,
           because the move is into the fixed %ecx).
+      * in the case of C calls the use of ecx here can interfere with arguments.
+        We avoid this with the hack described in Note [Evaluate C-call
+        arguments before placing in destination registers]
     -}
     shift_code width instr x y{-amount-} = do
         x_code <- getAnyReg x
@@ -2022,6 +2025,7 @@ genCCall is32Bit (PrimTarget (MO_AtomicRMW width amop))
     arg <- getNewRegNat format
     arg_code <- getAnyReg n
     platform <- ncgPlatform <$> getConfig
+
     let dst_r    = getRegisterReg platform  (CmmLocal dst)
     (code, lbl) <- op_code dst_r arg amode
     return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)
@@ -2667,9 +2671,12 @@ genCCall' _ is32Bit target dest_regs args bid = do
                return code
         _ -> panic "genCCall: Wrong number of arguments/results for imul2"
 
-    _ -> if is32Bit
-         then genCCall32' target dest_regs args
-         else genCCall64' target dest_regs args
+    _ -> do
+        (instrs0, args') <- evalArgs bid args
+        instrs1 <- if is32Bit
+          then genCCall32' target dest_regs args'
+          else genCCall64' target dest_regs args'
+        return (instrs0 `appOL` instrs1)
 
   where divOp1 platform signed width results [arg_x, arg_y]
             = divOp platform signed width results Nothing arg_x arg_y
@@ -2732,6 +2739,83 @@ genCCall' _ is32Bit target dest_regs args bid = do
         addSubIntC _ _ _ _ _ _ _ _
             = panic "genCCall: Wrong number of arguments/results for addSubIntC"
 
+{-
+Note [Evaluate C-call arguments before placing in destination registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When producing code for C calls we must take care when placing arguments
+in their final registers. Specifically, we must ensure that temporary register
+usage due to evaluation of one argument does not clobber a register in which we
+already placed a previous argument (e.g. as the code generation logic for
+MO_Shl can clobber %rcx due to x86 instruction limitations).
+
+This is precisely what happened in #18527. Consider this C--:
+
+    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));
+
+Here we are calling the C function `doSomething` with three arguments, the last
+involving a non-trivial expression involving MO_Shl. In this case the NCG could
+naively generate the following assembly (where $tmp denotes some temporary
+register and $argN denotes the register for argument N, as dictated by the
+platform's calling convention):
+
+    mov _s2hp, $arg1   # place first argument
+    mov _s2hq, $arg2   # place second argument
+
+    # Compute 1 << _s2hz
+    mov _s2hz, %rcx
+    shl %cl, $tmp
+
+    # Compute (_s2hw | (1 << _s2hz))
+    mov _s2hw, $arg3
+    or $tmp, $arg3
+
+    # Perform the call
+    call func
+
+This code is outright broken on Windows which assigns $arg1 to %rcx. This means
+that the evaluation of the last argument clobbers the first argument.
+
+To avoid this we use a rather awful hack: when producing code for a C call with
+at least one non-trivial argument, we first evaluate all of the arguments into
+local registers before moving them into their final calling-convention-defined
+homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an
+expression which might contain a MachOp since these are the only cases which
+might clobber registers. Furthermore, we use a conservative approximation of
+this condition (only looking at the top-level of CmmExprs) to avoid spending
+too much effort trying to decide whether we want to take the fast path.
+
+Note that this hack *also* applies to calls to out-of-line PrimTargets (which
+are lowered via a C call) since outOfLineCmmOp produces the call via
+(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up
+back in genCCall{32,64}.
+-}
+
+-- | See Note [Evaluate C-call arguments before placing in destination registers]
+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])
+evalArgs bid actuals
+  | any mightContainMachOp actuals = do
+      regs_blks <- mapM evalArg actuals
+      return (concatOL $ map fst regs_blks, map snd regs_blks)
+  | otherwise = return (nilOL, actuals)
+  where
+    mightContainMachOp (CmmReg _)      = False
+    mightContainMachOp (CmmRegOff _ _) = False
+    mightContainMachOp (CmmLit _)      = False
+    mightContainMachOp _               = True
+
+    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)
+    evalArg actual = do
+        platform <- getPlatform
+        lreg <- newLocalReg $ cmmExprType platform actual
+        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual
+        -- The above assignment shouldn't change the current block
+        MASSERT(isNothing bid1)
+        return (instrs, CmmReg $ CmmLocal lreg)
+
+    newLocalReg :: CmmType -> NatM LocalReg
+    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty
+
 -- Note [DIV/IDIV for bytes]
 --
 -- IDIV reminder:

compiler/GHC/StgToCmm/Foreign.hs

@@ -261,7 +261,7 @@ load_target_into_temp other_target@(PrimTarget _) =
 -- What we want to do here is create a new temporary for the foreign
 -- call argument if it is not safe to use the expression directly,
 -- because the expression mentions caller-saves GlobalRegs (see
--- Note [Register Parameter Passing]).
+-- Note [Register parameter passing]).
 --
 -- However, we can't pattern-match on the expression here, because
 -- this is used in a loop by GHC.Cmm.Parser, and testing the expression

compiler/GHC/StgToCmm/Utils.hs

@@ -243,7 +243,7 @@ emitRtsCallGen res lbl args safe
 -- shouldn't be doing the workaround at this point in the pipeline, see
 -- Note [Register parameter passing] and the ToDo on CmmCall in
 -- "GHC.Cmm.Node".  Right now the workaround is to avoid inlining across
--- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly
 -- temporary.
 callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)
 callerSaveVolatileRegs platform = (caller_save, caller_load)

includes/stg/MachRegs.h

@@ -61,6 +61,8 @@
    are the RX, FX, DX and USER registers; as a result, if you
    decide to caller save a system register (e.g. SP, HP, etc), note that
    this code path is completely untested! -- EZY
+
+   See Note [Register parameter passing] for details.
    -------------------------------------------------------------------------- */
 
 /* -----------------------------------------------------------------------------

testsuite/tests/codeGen/should_run/T18527.hs

+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Main where
+
+import Data.Bits (setBit)
+import Data.Word (Word32)
+import Data.Int (Int64)
+
+main :: IO ()
+main = offending 100 0 1
+
+offending :: Int64 -> Int64 -> Word32 -> IO ()
+offending h i id = do
+    oldMask <- sendMessage h (2245) i 0
+    let newMask = setBit oldMask (fromIntegral id)
+    sendMessage h (2244) i newMask
+    return ()
+
+foreign import ccall "func"
+    sendMessage :: Int64 -> Word32 -> Int64 -> Int64 -> IO Int64

testsuite/tests/codeGen/should_run/T18527.stdout

+ffi call
+ffi call
+

testsuite/tests/codeGen/should_run/T18527FFI.c

+#include <stdio.h>
+#include <stdint.h>
+
+int64_t func(int64_t a, uint32_t b, int64_t c, int64_t d) {
+    printf("ffi call");
+    if (a == 1) {
+        printf(" with corrupted convention\n");
+    }
+    else {
+        printf("\n");
+    }
+    return 0;
+}
+

testsuite/tests/codeGen/should_run/all.T

@@ -207,3 +207,4 @@ test('T16449_2', exit_code(0), compile_and_run, [''])
 test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, [''])
 
 test('T17920', cmm_src, compile_and_run, [''])
+test('T18527', normal, compile_and_run, ['T18527FFI.c'])

testsuite/tests/concurrent/prog001/all.T

@@ -16,4 +16,4 @@ test('concprog001', [extra_files(['Arithmetic.hs', 'Converter.hs', 'Mult.hs', 'S
                      when(fast(), skip), only_ways(['threaded2']),
                      fragile(16604),
                      run_timeout_multiplier(2)],
-     multimod_compile_and_run, ['Mult', ''])
+     multimod_compile_and_run, ['Mult', '-package ghc'])