diff options
author | Ben Gamari <ben@smart-cactus.org> | 2020-08-04 15:07:58 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-08-07 08:35:21 -0400 |
commit | 6402c1240d5bd768b8fe8b4368413932bedbe107 (patch) | |
tree | d43d2ddecd7a2e6da3109d795aa79f3100acec84 | |
parent | 5f03606319f745b10e9918c76a47426b293f0bf9 (diff) | |
download | haskell-6402c1240d5bd768b8fe8b4368413932bedbe107.tar.gz |
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.
-rw-r--r-- | compiler/GHC/Cmm/Lint.hs | 40 |
1 files changed, 35 insertions, 5 deletions
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index aa3e3a896e..83932aebe6 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/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 () |