-----------------------------------------------------------------------------
--
-- (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 = 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 ([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 (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 (String -> SDoc
text String
"in proc " SDoc -> SDoc -> SDoc
<> forall env a. OutputableP env a => env -> a -> SDoc
pdoc 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 (String -> SDoc
text String
"in basic block " SDoc -> SDoc -> SDoc
<> 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 (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
<+> 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)]
_ = 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 (String -> SDoc
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
            if (CmmType
erep CmmType -> CmmType -> Bool
`cmmEqType_ignoring_ptrhood` Platform -> CmmType
bWord Platform
platform)
              then forall (m :: * -> *) a. Monad m => a -> m a
return ()
              else forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
text String
"switch scrutinee is not a word: " SDoc -> SDoc -> 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
<> 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 (String -> SDoc
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 (String -> SDoc
text String
"Branch to nonexistent id" SDoc -> SDoc -> SDoc
<+> 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 (String -> SDoc
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 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"mentions caller-saved registers: " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [GlobalReg]
badRegs SDoc -> SDoc -> 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 = 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 (String -> SDoc
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 (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)

instance Applicative CmmLint where
      pure :: forall a. a -> CmmLint a
pure a
a = forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint (\Platform
_ -> forall a b. b -> Either a b
Right a
a)
      <*> :: forall a 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 = forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint forall a b. (a -> b) -> a -> b
$ \Platform
platform ->
                                case Platform -> Either SDoc a
m Platform
platform of
                                Left SDoc
e -> forall a b. a -> Either a b
Left SDoc
e
                                Right a
a -> forall a. CmmLint a -> Platform -> Either SDoc a
unCL (a -> CmmLint b
k a
a) Platform
platform

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 (String -> SDoc
text String
"in MachOp application: " SDoc -> SDoc -> SDoc
$$
                   Int -> SDoc -> SDoc
nest Int
2 (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
<+> forall a. Outputable a => a -> SDoc
ppr [Width]
opExpectsRep) SDoc -> SDoc -> SDoc
$$
                      (String -> SDoc
text String
"arguments provide: " SDoc -> SDoc -> 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
    forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
text String
"in assignment: " SDoc -> SDoc -> SDoc
$$
                Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat [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
<+> forall a. Outputable a => a -> SDoc
ppr CmmType
r_ty,
                              String -> SDoc
text String
"Rhs ty:" SDoc -> SDoc -> 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))
-}