-----------------------------------------------------------------------------
--
-- (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 = forall a b.
OutputableP Platform a =>
Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint Platform
platform (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 = 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 forall a. CmmLint a -> Platform -> Either SDoc a
unCL (a -> CmmLint b
l a
p) Platform
platform of
     Left SDoc
err -> forall a. a -> Maybe a
Just (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat
                            [forall doc. IsLine doc => String -> doc
text String
"Cmm lint error:",
                             Int -> SDoc -> SDoc
nest Int
2 SDoc
err,
                             forall doc. IsLine doc => String -> doc
text String
"Program was:",
                             Int -> SDoc -> SDoc
nest Int
2 (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform a
p)])
     Right b
_  -> 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
    forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo (forall doc. IsLine doc => String -> doc
text String
"in proc " forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CLabel -> SDoc
pprDebugCLabel Platform
platform CLabel
lbl) forall a b. (a -> b) -> a -> b
$ CmmGraph -> CmmLint ()
lintCmmGraph CmmGraph
g
lintCmmDecl (CmmData {})
  = 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 = forall set. IsSet set => [ElemOf set] -> set
setFromList (forall a b. (a -> b) -> [a] -> [b]
map forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel [CmmBlock]
blocks)
   Platform -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness Platform
platform CmmGraph
g seq :: forall a b. a -> b -> b
`seq` 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
  = forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo (forall doc. IsLine doc => String -> doc
text String
"in basic block " forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr (forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block)) forall a b. (a -> b) -> a -> b
$ do
        let (CmmNode C O
_, Block CmmNode O O
middle, CmmNode O C
last) = forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmNode O O -> CmmLint ()
lintCmmMiddle (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
  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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmExpr -> CmmLint CmmType
lintCmmExpr [CmmExpr]
args
  MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
lintShiftOp MachOp
op (forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [CmmType]
tys)
  if forall a b. (a -> b) -> [a] -> [b]
map (CmmType -> Width
typeWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
args 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 forall a. CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr CmmExpr
expr (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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset) Width
rep)])
lintCmmExpr CmmExpr
expr =
  do Platform
platform <- CmmLint Platform
getPlatform
     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 forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits (CmmType -> Width
typeWidth CmmType
arg_ty))
  = forall a. SDoc -> CmmLint a
cmmLintErr (forall doc. IsLine doc => String -> doc
text String
"Shift operation" forall doc. IsLine doc => doc -> doc -> doc
<+> MachOp -> SDoc
pprMachOp MachOp
op
                forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"has out-of-range offset" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Integer
n
                forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
". This will result in undefined behavior")
lintShiftOp MachOp
_ [(CmmExpr, CmmType)]
_ = 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
       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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CmmTick CmmTickish
_    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CmmUnwind{}  -> 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
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CmmType -> CmmType -> Bool
compat_regs CmmType
erep CmmType
reg_ty) forall a b. (a -> b) -> a -> b
$
              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 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
            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].
                  forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (forall doc. IsLine doc => String -> doc
text String
"foreign call argument") CmmExpr
expr
                  CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr

            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
            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
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Label -> CmmLint ()
checkTarget forall a b. (a -> b) -> a -> b
$ SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
ids
            CmmType
erep <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
e
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CmmType -> Bool
isWordAny CmmType
erep) forall a b. (a -> b) -> a -> b
$
              forall a. SDoc -> CmmLint a
cmmLintErr (forall doc. IsLine doc => String -> doc
text String
"switch scrutinee is not a word (of any size): " forall doc. IsLine doc => doc -> doc -> doc
<>
                          forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
e forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
" :: " forall doc. IsLine doc => doc -> doc -> doc
<> 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
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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.
                forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (forall doc. IsLine doc => String -> doc
text String
"foreign call argument") CmmExpr
expr
                CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
          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
     | forall set. IsSet set => ElemOf set -> set -> Bool
setMember Label
id LabelSet
labels = forall (m :: * -> *) a. Monad m => a -> m a
return ()
     | Bool
otherwise = forall a. SDoc -> CmmLint a
cmmLintErr (forall doc. IsLine doc => String -> doc
text String
"Branch to nonexistent id" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Label
id)

lintTarget :: ForeignTarget -> CmmLint ()
lintTarget :: ForeignTarget -> CmmLint ()
lintTarget (ForeignTarget CmmExpr
e ForeignConvention
_) = do
    forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (forall doc. IsLine doc => String -> doc
text String
"foreign target") CmmExpr
e
    CmmType
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
e
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintTarget (PrimTarget {})     = 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform)
                  forall a b. (a -> b) -> a -> b
$ forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform (forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] a
thing
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GlobalReg]
badRegs)
      forall a b. (a -> b) -> a -> b
$ forall a. SDoc -> CmmLint a
cmmLintErr (SDoc
what forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"mentions caller-saved registers: " forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr [GlobalReg]
badRegs forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCond Platform
platform (CmmLit (CmmInt Integer
x Width
t)) | Integer
x forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
|| Integer
x forall a. Eq a => a -> a -> Bool
== Integer
1, Width
t forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = forall (m :: * -> *) a. Monad m => a -> m a
return () -- constant values
checkCond Platform
platform CmmExpr
expr
    = forall a. SDoc -> CmmLint a
cmmLintErr (SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"expression is not a conditional:") Int
2
                         (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 -> 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
<$ :: forall a b. a -> CmmLint b -> CmmLint a
$c<$ :: forall a b. a -> CmmLint b -> CmmLint a
fmap :: forall a b. (a -> b) -> CmmLint a -> CmmLint b
$cfmap :: forall a b. (a -> b) -> CmmLint a -> CmmLint b
Functor)
  deriving (Functor 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
<* :: forall a b. CmmLint a -> CmmLint b -> CmmLint a
$c<* :: forall a b. CmmLint a -> CmmLint b -> CmmLint a
*> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
$c*> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
liftA2 :: forall a b c. (a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c
$cliftA2 :: forall a b c. (a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c
<*> :: forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b
$c<*> :: forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b
pure :: forall a. a -> CmmLint a
$cpure :: forall a. a -> CmmLint a
Applicative, Applicative 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
return :: forall a. a -> CmmLint a
$creturn :: forall a. a -> CmmLint a
>> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
$c>> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
>>= :: forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b
$c>>= :: forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b
Monad) via ReaderT Platform (Except SDoc)

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

cmmLintErr :: SDoc -> CmmLint a
cmmLintErr :: forall a. SDoc -> CmmLint a
cmmLintErr SDoc
msg = forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint (\Platform
_ -> 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 = forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint forall a b. (a -> b) -> a -> b
$ \Platform
platform ->
   case forall a. CmmLint a -> Platform -> Either SDoc a
unCL CmmLint a
thing Platform
platform of
        Left SDoc
err -> forall a b. a -> Either a b
Left (SDoc -> Int -> SDoc -> SDoc
hang SDoc
info Int
2 SDoc
err)
        Right a
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
       forall a. SDoc -> CmmLint a
cmmLintErr (forall doc. IsLine doc => String -> doc
text String
"in MachOp application: " forall doc. IsDoc doc => doc -> doc -> doc
$$
                   Int -> SDoc -> SDoc
nest Int
2 (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr) forall doc. IsDoc doc => doc -> doc -> doc
$$
                      (forall doc. IsLine doc => String -> doc
text String
"op is expecting: " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [Width]
opExpectsRep) forall doc. IsDoc doc => doc -> doc -> doc
$$
                      (forall doc. IsLine doc => String -> doc
text String
"arguments provide: " forall doc. IsLine doc => doc -> doc -> doc
<+> 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
    forall a. SDoc -> CmmLint a
cmmLintErr (forall doc. IsLine doc => String -> doc
text String
"in assignment: " forall doc. IsDoc doc => doc -> doc -> doc
$$
                Int -> SDoc -> SDoc
nest Int
2 (forall doc. IsDoc doc => [doc] -> doc
vcat [forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt,
                              forall doc. IsLine doc => String -> doc
text String
"Reg ty:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CmmType
r_ty,
                              forall doc. IsLine doc => String -> doc
text String
"Rhs ty:" forall doc. IsLine doc => doc -> doc -> doc
<+> 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))
-}