-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2011
--
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveFunctor #-}
{-# 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.Utils
import GHC.Cmm.Liveness
import GHC.Cmm.Switch (switchTargetsToList)
import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Utils.Outputable

import Control.Monad (ap, unless)

-- 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 ([SDoc] -> SDoc
vcat [String -> SDoc
text String
"Cmm lint error:",
                             Int -> SDoc -> SDoc
nest Int
2 SDoc
err,
                             String -> SDoc
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
text String
"in proc " SDoc -> SDoc -> SDoc
<> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc 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
text String
"in basic block " SDoc -> SDoc -> SDoc
<> 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
text String
"Shift operation" SDoc -> SDoc -> SDoc
<+> MachOp -> SDoc
pprMachOp MachOp
op
                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has out-of-range offset" SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
forall a. Outputable a => a -> SDoc
ppr Integer
n
                SDoc -> SDoc -> SDoc
<> String -> SDoc
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
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
text String
"switch scrutinee is not a word (of any size): " SDoc -> SDoc -> SDoc
<>
                          Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
e SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" :: " SDoc -> SDoc -> SDoc
<> 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
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
text String
"Branch to nonexistent id" SDoc -> SDoc -> SDoc
<+> 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
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
<+> String -> SDoc
text String
"mentions caller-saved registers: " SDoc -> SDoc -> SDoc
<> [GlobalReg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GlobalReg]
badRegs SDoc -> SDoc -> SDoc
$$ 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
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 ((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)

instance Applicative CmmLint where
      pure :: forall a. a -> CmmLint a
pure a
a = (Platform -> Either SDoc a) -> CmmLint a
forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint (\Platform
_ -> a -> Either SDoc a
forall a b. b -> Either a b
Right a
a)
      <*> :: forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b
(<*>) = CmmLint (a -> b) -> CmmLint a -> CmmLint b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad CmmLint where
  CmmLint Platform -> Either SDoc a
m >>= :: forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b
>>= a -> CmmLint b
k = (Platform -> Either SDoc b) -> CmmLint b
forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint ((Platform -> Either SDoc b) -> CmmLint b)
-> (Platform -> Either SDoc b) -> CmmLint b
forall a b. (a -> b) -> a -> b
$ \Platform
platform ->
                                case Platform -> Either SDoc a
m Platform
platform of
                                Left SDoc
e -> SDoc -> Either SDoc b
forall a b. a -> Either a b
Left SDoc
e
                                Right a
a -> CmmLint b -> Platform -> Either SDoc b
forall a. CmmLint a -> Platform -> Either SDoc a
unCL (a -> CmmLint b
k a
a) Platform
platform

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
text String
"in MachOp application: " SDoc -> SDoc -> SDoc
$$
                   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
$$
                      (String -> SDoc
text String
"op is expecting: " SDoc -> SDoc -> SDoc
<+> [Width] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Width]
opExpectsRep) SDoc -> SDoc -> SDoc
$$
                      (String -> SDoc
text String
"arguments provide: " SDoc -> SDoc -> SDoc
<+> [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
text String
"in assignment: " SDoc -> SDoc -> SDoc
$$
                Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat [Platform -> CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt,
                              String -> SDoc
text String
"Reg ty:" SDoc -> SDoc -> SDoc
<+> CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
r_ty,
                              String -> SDoc
text String
"Rhs ty:" SDoc -> SDoc -> SDoc
<+> 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))
-}