[Git][ghc/ghc][wip/T18527] CmmLint: Check foreign call argument register invariant

[Ben Gamari]

Ben Gamari pushed to branch wip/T18527 at Glasgow Haskell Compiler / GHC


Commits:
d04d0eaf by Ben Gamari at 2020-08-04T15:35:12-04:00
CmmLint: Check foreign call argument register invariant

As mentioned in Note [Register parameter passing] the arguments of
foreign calls cannot refer to caller-saved registers.

- - - - -


1 changed file:

- compiler/GHC/Cmm/Lint.hs


Changes:

=====================================
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,14 @@ 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 See Note [Register
+                  -- parameter passing].
+                  mayNotMentionCallerSavedRegs (text "foreign call argument") expr
+                  lintCmmExpr expr
+
+            mapM_ lintArg actuals
 
 
 lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
@@ -188,18 +197,37 @@ 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 See Note [Register
+                -- parameter passing].
+                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 ()



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d04d0eafefa6ace6d5addd20a344cb731eec0903

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d04d0eafefa6ace6d5addd20a344cb731eec0903
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200804/b4793df4/attachment-0001.html>