-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2011
--
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module GHC.Cmm.Lint (
    cmmLint, cmmLintGraph
  ) where

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
import GHC.Cmm.Dataflow.Label
import GHC.Cmm
import GHC.Cmm.Liveness
import GHC.Cmm.Switch (switchTargetsToList)
import GHC.Cmm.CLabel (pprDebugCLabel)
import GHC.Utils.Outputable

import Control.Monad (unless)
import Control.Monad.Trans.Except (ExceptT (..), Except)
import Control.Monad.Trans.Reader (ReaderT (..))
import Data.Functor.Identity (Identity (..))

-- Things to check:
--     - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)
--     - check for branches to blocks that don't exist
--     - check types

-- -----------------------------------------------------------------------------
-- Exported entry points:

cmmLint :: (OutputableP Platform d, OutputableP Platform h)
        => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint :: forall d h.
(OutputableP Platform d, OutputableP Platform h) =>
Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint Platform
platform [GenCmmDecl d h CmmGraph]
tops = Platform
-> ([GenCmmDecl d h CmmGraph] -> CmmLint ())
-> [GenCmmDecl d h CmmGraph]
-> Maybe SDoc
forall a b.
OutputableP Platform a =>
Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint Platform
platform ((GenCmmDecl d h CmmGraph -> CmmLint ())
-> [GenCmmDecl d h CmmGraph] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenCmmDecl d h CmmGraph -> CmmLint ()
forall h i. GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl) [GenCmmDecl d h CmmGraph]
tops

cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
cmmLintGraph Platform
platform CmmGraph
g = Platform -> (CmmGraph -> CmmLint ()) -> CmmGraph -> Maybe SDoc
forall a b.
OutputableP Platform a =>
Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint Platform
platform CmmGraph -> CmmLint ()
lintCmmGraph CmmGraph
g

runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint :: forall a b.
OutputableP Platform a =>
Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint Platform
platform a -> CmmLint b
l a
p =
   case CmmLint b -> Platform -> Either SDoc b
forall a. CmmLint a -> Platform -> Either SDoc a
unCL (a -> CmmLint b
l a
p) Platform
platform of
     Left SDoc
err -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
                            [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Cmm lint error:",
                             Int -> SDoc -> SDoc
nest Int
2 SDoc
err,
                             String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Program was:",
                             Int -> SDoc -> SDoc
nest Int
2 (Platform -> a -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform a
p)])
     Right b
_  -> Maybe SDoc
forall a. Maybe a
Nothing

lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl :: forall h i. GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl (CmmProc i
_ CLabel
lbl [GlobalReg]
_ CmmGraph
g)
  = do
    Platform
platform <- CmmLint Platform
getPlatform
    SDoc -> CmmLint () -> CmmLint ()
forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in proc " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CLabel -> SDoc
pprDebugCLabel Platform
platform CLabel
lbl) (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
forall a b. (a -> b) -> a -> b
$ CmmGraph -> CmmLint ()
lintCmmGraph CmmGraph
g
lintCmmDecl (CmmData {})
  = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


lintCmmGraph :: CmmGraph -> CmmLint ()
lintCmmGraph :: CmmGraph -> CmmLint ()
lintCmmGraph CmmGraph
g = do
   Platform
platform <- CmmLint Platform
getPlatform
   let
      blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockList CmmGraph
g
      labels :: LabelSet
labels = [ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList ((CmmBlock -> Label) -> [CmmBlock] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel [CmmBlock]
blocks)
   Platform -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness Platform
platform CmmGraph
g BlockEntryLiveness LocalReg -> CmmLint () -> CmmLint ()
forall a b. a -> b -> b
`seq` (CmmBlock -> CmmLint ()) -> [CmmBlock] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (LabelSet -> CmmBlock -> CmmLint ()
lintCmmBlock LabelSet
labels) [CmmBlock]
blocks
   -- cmmLiveness throws an error if there are registers
   -- live on entry to the graph (i.e. undefined
   -- variables)


lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
lintCmmBlock LabelSet
labels CmmBlock
block
  = SDoc -> CmmLint () -> CmmLint ()
forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in basic block " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block)) (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
forall a b. (a -> b) -> a -> b
$ do
        let (CmmNode C O
_, Block CmmNode O O
middle, CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
        (CmmNode O O -> CmmLint ()) -> [CmmNode O O] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmNode O O -> CmmLint ()
lintCmmMiddle (Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
middle)
        LabelSet -> CmmNode O C -> CmmLint ()
lintCmmLast LabelSet
labels CmmNode O C
last

-- -----------------------------------------------------------------------------
-- lintCmmExpr

-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.

lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr (CmmLoad CmmExpr
expr CmmType
rep AlignmentSpec
_alignment) = do
  CmmType
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
  -- Disabled, if we have the inlining phase before the lint phase,
  -- we can have funny offsets due to pointer tagging. -- EZY
  -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
  --   cmmCheckWordAddress expr
  CmmType -> CmmLint CmmType
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmType
rep
lintCmmExpr expr :: CmmExpr
expr@(CmmMachOp MachOp
op [CmmExpr]
args) = do
  Platform
platform <- CmmLint Platform
getPlatform
  [CmmType]
tys <- (CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint [CmmType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmExpr -> CmmLint CmmType
lintCmmExpr [CmmExpr]
args
  MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
lintShiftOp MachOp
op ([CmmExpr] -> [CmmType] -> [(CmmExpr, CmmType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [CmmType]
tys)
  if (CmmExpr -> Width) -> [CmmExpr] -> [Width]
forall a b. (a -> b) -> [a] -> [b]
map (CmmType -> Width
typeWidth (CmmType -> Width) -> (CmmExpr -> CmmType) -> CmmExpr -> Width
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
args [Width] -> [Width] -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> MachOp -> [Width]
machOpArgReps Platform
platform MachOp
op
        then MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp MachOp
op [CmmExpr]
args [CmmType]
tys
        else CmmExpr -> [CmmType] -> [Width] -> CmmLint CmmType
forall a. CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr CmmExpr
expr ((CmmExpr -> CmmType) -> [CmmExpr] -> [CmmType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
args) (Platform -> MachOp -> [Width]
machOpArgReps Platform
platform MachOp
op)
lintCmmExpr (CmmRegOff CmmReg
reg Int
offset)
  = do Platform
platform <- CmmLint Platform
getPlatform
       let rep :: Width
rep = CmmType -> Width
typeWidth (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg)
       CmmExpr -> CmmLint CmmType
lintCmmExpr (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
rep)
                [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset) Width
rep)])
lintCmmExpr CmmExpr
expr =
  do Platform
platform <- CmmLint Platform
getPlatform
     CmmType -> CmmLint CmmType
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
expr)

-- | Check for obviously out-of-bounds shift operations
lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
lintShiftOp MachOp
op [(CmmExpr
_, CmmType
arg_ty), (CmmLit (CmmInt Integer
n Width
_), CmmType
_)]
  | MachOp -> Bool
isShiftOp MachOp
op
  , Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits (CmmType -> Width
typeWidth CmmType
arg_ty))
  = SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Shift operation" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> MachOp -> SDoc
pprMachOp MachOp
op
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has out-of-range offset" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Integer -> SDoc
forall a. Outputable a => a -> SDoc
ppr Integer
n
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
". This will result in undefined behavior")
lintShiftOp MachOp
_ [(CmmExpr, CmmType)]
_ = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

isShiftOp :: MachOp -> Bool
isShiftOp :: MachOp -> Bool
isShiftOp (MO_Shl Width
_)   = Bool
True
isShiftOp (MO_U_Shr Width
_) = Bool
True
isShiftOp (MO_S_Shr Width
_) = Bool
True
isShiftOp MachOp
_            = Bool
False

-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp MachOp
op [lit :: CmmExpr
lit@(CmmLit (CmmInt { })), reg :: CmmExpr
reg@(CmmReg CmmReg
_)] [CmmType]
tys
  = MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp MachOp
op [CmmExpr
reg, CmmExpr
lit] [CmmType]
tys
cmmCheckMachOp MachOp
op [CmmExpr]
_ [CmmType]
tys
  = do Platform
platform <- CmmLint Platform
getPlatform
       CmmType -> CmmLint CmmType
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> MachOp -> [CmmType] -> CmmType
machOpResultType Platform
platform MachOp
op [CmmType]
tys)

{-
isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
isOffsetOp _ = False

-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
  = cmmLintDubiousWordOffset e
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
  = cmmLintDubiousWordOffset e
_cmmCheckWordAddress _
  = return ()

-- No warnings for unaligned arithmetic with the node register,
-- which is used to extract fields from tagged constructor closures.
notNodeReg :: CmmExpr -> Bool
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _                             = True
-}

lintCmmMiddle :: CmmNode O O -> CmmLint ()
lintCmmMiddle :: CmmNode O O -> CmmLint ()
lintCmmMiddle CmmNode O O
node = case CmmNode O O
node of
  CmmComment FastString
_ -> () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CmmTick CmmTickish
_    -> () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CmmUnwind{}  -> () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  CmmAssign CmmReg
reg CmmExpr
expr -> do
            Platform
platform <- CmmLint Platform
getPlatform
            CmmType
erep <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
            let reg_ty :: CmmType
reg_ty = Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg
            Bool -> CmmLint () -> CmmLint ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CmmType -> CmmType -> Bool
compat_regs CmmType
erep CmmType
reg_ty) (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
forall a b. (a -> b) -> a -> b
$
              CmmNode O O -> CmmType -> CmmType -> CmmLint ()
forall (e :: Extensibility) (x :: Extensibility) a.
CmmNode e x -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr (CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
reg CmmExpr
expr) CmmType
erep CmmType
reg_ty
    where
      compat_regs :: CmmType -> CmmType -> Bool
      compat_regs :: CmmType -> CmmType -> Bool
compat_regs CmmType
ty1 CmmType
ty2
        -- As noted in #22297, SIMD vector registers can be used for
        -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats,
        -- or 4 Int32s, or 2 Word64s, ...
        -- To allow this, we relax the check: we only ensure that the widths
        -- match, until we can find a more robust solution.
        | CmmType -> Bool
isVecType CmmType
ty1
        , CmmType -> Bool
isVecType CmmType
ty2
        = CmmType -> Width
typeWidth CmmType
ty1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== CmmType -> Width
typeWidth CmmType
ty2
        | Bool
otherwise
        = CmmType -> CmmType -> Bool
cmmEqType_ignoring_ptrhood CmmType
ty1 CmmType
ty2

  CmmStore CmmExpr
l CmmExpr
r AlignmentSpec
_alignment -> do
            CmmType
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
l
            CmmType
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
r
            () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  CmmUnsafeForeignCall ForeignTarget
target [LocalReg]
_formals [CmmExpr]
actuals -> do
            ForeignTarget -> CmmLint ()
lintTarget ForeignTarget
target
            let lintArg :: CmmExpr -> CmmLint CmmType
lintArg CmmExpr
expr = do
                  -- Arguments can't mention caller-saved
                  -- registers. See Note [Register parameter passing].
                  SDoc -> CmmExpr -> CmmLint ()
forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"foreign call argument") CmmExpr
expr
                  CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr

            (CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> CmmLint CmmType
lintArg [CmmExpr]
actuals


lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
lintCmmLast LabelSet
labels CmmNode O C
node = case CmmNode O C
node of
  CmmBranch Label
id -> Label -> CmmLint ()
checkTarget Label
id

  CmmCondBranch CmmExpr
e Label
t Label
f Maybe Bool
_ -> do
            Platform
platform <- CmmLint Platform
getPlatform
            (Label -> CmmLint ()) -> [Label] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Label -> CmmLint ()
checkTarget [Label
t,Label
f]
            CmmType
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
e
            Platform -> CmmExpr -> CmmLint ()
checkCond Platform
platform CmmExpr
e

  CmmSwitch CmmExpr
e SwitchTargets
ids -> do
            Platform
platform <- CmmLint Platform
getPlatform
            (Label -> CmmLint ()) -> [Label] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Label -> CmmLint ()
checkTarget ([Label] -> CmmLint ()) -> [Label] -> CmmLint ()
forall a b. (a -> b) -> a -> b
$ SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
ids
            CmmType
erep <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
e
            Bool -> CmmLint () -> CmmLint ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CmmType -> Bool
isWordAny CmmType
erep) (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
forall a b. (a -> b) -> a -> b
$
              SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"switch scrutinee is not a word (of any size): " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                          Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
e SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" :: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
erep)

  CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
target, cml_cont :: CmmNode O C -> Maybe Label
cml_cont = Maybe Label
cont } -> do
          CmmType
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
target
          CmmLint () -> (Label -> CmmLint ()) -> Maybe Label -> CmmLint ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Label -> CmmLint ()
checkTarget Maybe Label
cont

  CmmForeignCall ForeignTarget
tgt [LocalReg]
_ [CmmExpr]
args Label
succ Int
_ Int
_ Bool
_ -> do
          ForeignTarget -> CmmLint ()
lintTarget ForeignTarget
tgt
          let lintArg :: CmmExpr -> CmmLint CmmType
lintArg CmmExpr
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.
                SDoc -> CmmExpr -> CmmLint ()
forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"foreign call argument") CmmExpr
expr
                CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
          (CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> CmmLint CmmType
lintArg [CmmExpr]
args
          Label -> CmmLint ()
checkTarget Label
succ
 where
  checkTarget :: Label -> CmmLint ()
checkTarget Label
id
     | ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
Label
id LabelSet
labels = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     | Bool
otherwise = SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Branch to nonexistent id" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
id)

lintTarget :: ForeignTarget -> CmmLint ()
lintTarget :: ForeignTarget -> CmmLint ()
lintTarget (ForeignTarget CmmExpr
e ForeignConvention
_) = do
    SDoc -> CmmExpr -> CmmLint ()
forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"foreign target") CmmExpr
e
    CmmType
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
e
    () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintTarget (PrimTarget {})     = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
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, OutputableP Platform a)
                             => SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs :: forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs SDoc
what a
thing = do
    Platform
platform <- CmmLint Platform
getPlatform
    let badRegs :: [GlobalReg]
badRegs = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform)
                  ([GlobalReg] -> [GlobalReg]) -> [GlobalReg] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Platform
-> ([GlobalReg] -> GlobalReg -> [GlobalReg])
-> [GlobalReg]
-> a
-> [GlobalReg]
forall b. Platform -> (b -> GlobalReg -> b) -> b -> a -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform ((GlobalReg -> [GlobalReg] -> [GlobalReg])
-> [GlobalReg] -> GlobalReg -> [GlobalReg]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] a
thing
    Bool -> CmmLint () -> CmmLint ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GlobalReg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GlobalReg]
badRegs)
      (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (SDoc
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mentions caller-saved registers: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [GlobalReg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GlobalReg]
badRegs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Platform -> a -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform a
thing)

checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond Platform
_ (CmmMachOp MachOp
mop [CmmExpr]
_) | MachOp -> Bool
isComparisonMachOp MachOp
mop = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCond Platform
platform (CmmLit (CmmInt Integer
x Width
t)) | Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
|| Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1, Width
t Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- constant values
checkCond Platform
platform CmmExpr
expr
    = SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expression is not a conditional:") Int
2
                         (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr))

-- -----------------------------------------------------------------------------
-- CmmLint monad

-- just a basic error monad:

newtype CmmLint a = CmmLint { forall a. CmmLint a -> Platform -> Either SDoc a
unCL :: Platform -> Either SDoc a }
  deriving stock ((forall a b. (a -> b) -> CmmLint a -> CmmLint b)
-> (forall a b. a -> CmmLint b -> CmmLint a) -> Functor CmmLint
forall a b. a -> CmmLint b -> CmmLint a
forall a b. (a -> b) -> CmmLint a -> CmmLint b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CmmLint a -> CmmLint b
fmap :: forall a b. (a -> b) -> CmmLint a -> CmmLint b
$c<$ :: forall a b. a -> CmmLint b -> CmmLint a
<$ :: forall a b. a -> CmmLint b -> CmmLint a
Functor)
  deriving (Functor CmmLint
Functor CmmLint =>
(forall a. a -> CmmLint a)
-> (forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b)
-> (forall a b c.
    (a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c)
-> (forall a b. CmmLint a -> CmmLint b -> CmmLint b)
-> (forall a b. CmmLint a -> CmmLint b -> CmmLint a)
-> Applicative CmmLint
forall a. a -> CmmLint a
forall a b. CmmLint a -> CmmLint b -> CmmLint a
forall a b. CmmLint a -> CmmLint b -> CmmLint b
forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b
forall a b c. (a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> CmmLint a
pure :: forall a. a -> CmmLint a
$c<*> :: forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b
<*> :: forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b
$cliftA2 :: forall a b c. (a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c
liftA2 :: forall a b c. (a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c
$c*> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
*> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
$c<* :: forall a b. CmmLint a -> CmmLint b -> CmmLint a
<* :: forall a b. CmmLint a -> CmmLint b -> CmmLint a
Applicative, Applicative CmmLint
Applicative CmmLint =>
(forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b)
-> (forall a b. CmmLint a -> CmmLint b -> CmmLint b)
-> (forall a. a -> CmmLint a)
-> Monad CmmLint
forall a. a -> CmmLint a
forall a b. CmmLint a -> CmmLint b -> CmmLint b
forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b
>>= :: forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b
$c>> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
>> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
$creturn :: forall a. a -> CmmLint a
return :: forall a. a -> CmmLint a
Monad) via ReaderT Platform (Except SDoc)

getPlatform :: CmmLint Platform
getPlatform :: CmmLint Platform
getPlatform = (Platform -> Either SDoc Platform) -> CmmLint Platform
forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint ((Platform -> Either SDoc Platform) -> CmmLint Platform)
-> (Platform -> Either SDoc Platform) -> CmmLint Platform
forall a b. (a -> b) -> a -> b
$ \Platform
platform -> Platform -> Either SDoc Platform
forall a b. b -> Either a b
Right Platform
platform

cmmLintErr :: SDoc -> CmmLint a
cmmLintErr :: forall a. SDoc -> CmmLint a
cmmLintErr SDoc
msg = (Platform -> Either SDoc a) -> CmmLint a
forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint (\Platform
_ -> SDoc -> Either SDoc a
forall a b. a -> Either a b
Left SDoc
msg)

addLintInfo :: SDoc -> CmmLint a -> CmmLint a
addLintInfo :: forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo SDoc
info CmmLint a
thing = (Platform -> Either SDoc a) -> CmmLint a
forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint ((Platform -> Either SDoc a) -> CmmLint a)
-> (Platform -> Either SDoc a) -> CmmLint a
forall a b. (a -> b) -> a -> b
$ \Platform
platform ->
   case CmmLint a -> Platform -> Either SDoc a
forall a. CmmLint a -> Platform -> Either SDoc a
unCL CmmLint a
thing Platform
platform of
        Left SDoc
err -> SDoc -> Either SDoc a
forall a b. a -> Either a b
Left (SDoc -> Int -> SDoc -> SDoc
hang SDoc
info Int
2 SDoc
err)
        Right a
a  -> a -> Either SDoc a
forall a b. b -> Either a b
Right a
a

cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr :: forall a. CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr CmmExpr
expr [CmmType]
argsRep [Width]
opExpectsRep
     = do
       Platform
platform <- CmmLint Platform
getPlatform
       SDoc -> CmmLint a
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in MachOp application: " SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                   Int -> SDoc -> SDoc
nest Int
2 (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                      (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"op is expecting: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Width] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Width]
opExpectsRep) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                      (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arguments provide: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CmmType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmType]
argsRep))

cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr :: forall (e :: Extensibility) (x :: Extensibility) a.
CmmNode e x -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr CmmNode e x
stmt CmmType
e_ty CmmType
r_ty
  = do
    Platform
platform <- CmmLint Platform
getPlatform
    SDoc -> CmmLint a
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in assignment: " SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Platform -> CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt,
                              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Reg ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
r_ty,
                              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Rhs ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
e_ty]))


{-
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
   = cmmLintErr (text "offset is not a multiple of words: " $$
                 nest 2 (ppr expr))
-}