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

import GhcPrelude

import Hoopl.Block
import Hoopl.Collections
import Hoopl.Graph
import Hoopl.Label
import Cmm
import CmmUtils
import CmmLive
import CmmSwitch (switchTargetsToList)
import PprCmm ()
import Outputable
import DynFlags

import Control.Monad (liftM, ap)

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

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

cmmLint :: (Outputable d, Outputable h)
        => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint :: DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint DynFlags
dflags GenCmmGroup d h CmmGraph
tops = DynFlags
-> (GenCmmGroup d h CmmGraph -> CmmLint ())
-> GenCmmGroup d h CmmGraph
-> Maybe SDoc
forall a b.
Outputable a =>
DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint DynFlags
dflags ((GenCmmDecl d h CmmGraph -> CmmLint ())
-> GenCmmGroup d h CmmGraph -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> GenCmmDecl d h CmmGraph -> CmmLint ()
forall h i. DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl DynFlags
dflags)) GenCmmGroup d h CmmGraph
tops

cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
cmmLintGraph DynFlags
dflags CmmGraph
g = DynFlags -> (CmmGraph -> CmmLint ()) -> CmmGraph -> Maybe SDoc
forall a b.
Outputable a =>
DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint DynFlags
dflags (DynFlags -> CmmGraph -> CmmLint ()
lintCmmGraph DynFlags
dflags) CmmGraph
g

runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint :: DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint DynFlags
dflags a -> CmmLint b
l a
p =
   case CmmLint b -> DynFlags -> Either SDoc b
forall a. CmmLint a -> DynFlags -> Either SDoc a
unCL (a -> CmmLint b
l a
p) DynFlags
dflags 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 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
p)])
     Right b
_  -> Maybe SDoc
forall a. Maybe a
Nothing

lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl DynFlags
dflags (CmmProc i
_ CLabel
lbl [GlobalReg]
_ CmmGraph
g)
  = SDoc -> CmmLint () -> CmmLint ()
forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo (String -> SDoc
text String
"in proc " SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl) (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmGraph -> CmmLint ()
lintCmmGraph DynFlags
dflags CmmGraph
g
lintCmmDecl DynFlags
_ (CmmData {})
  = () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
lintCmmGraph DynFlags
dflags CmmGraph
g =
    DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness DynFlags
dflags CmmGraph
g BlockEntryLiveness LocalReg -> CmmLint () -> CmmLint ()
`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)
  where
       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 (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> Label
entryLabel [CmmBlock]
blocks)


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 (thing :: * -> * -> *) x.
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 :: * -> * -> *).
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 :: * -> * -> *). 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) = 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) >= wORD_SIZE) $
  --   cmmCheckWordAddress expr
  CmmType -> CmmLint CmmType
forall (m :: * -> *) a. Monad m => a -> m a
return CmmType
rep
lintCmmExpr expr :: CmmExpr
expr@(CmmMachOp MachOp
op [CmmExpr]
args) = do
  DynFlags
dflags <- CmmLint DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [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)
mapM CmmExpr -> CmmLint CmmType
lintCmmExpr [CmmExpr]
args
  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
. DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags) [CmmExpr]
args [Width] -> [Width] -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> MachOp -> [Width]
machOpArgReps DynFlags
dflags 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 (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags) [CmmExpr]
args) (DynFlags -> MachOp -> [Width]
machOpArgReps DynFlags
dflags MachOp
op)
lintCmmExpr (CmmRegOff CmmReg
reg Int
offset)
  = do DynFlags
dflags <- CmmLint DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let rep :: Width
rep = CmmType -> Width
typeWidth (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags 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 DynFlags
dflags <- CmmLint DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     CmmType -> CmmLint CmmType
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
expr)

-- 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 DynFlags
dflags <- CmmLint DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       CmmType -> CmmLint CmmType
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> MachOp -> [CmmType] -> CmmType
machOpResultType DynFlags
dflags 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 (wORD_SIZE dflags) /= 0
  = cmmLintDubiousWordOffset e
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 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 (m :: * -> *) a. Monad m => a -> m a
return ()
  CmmTick CmmTickish
_    -> () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CmmUnwind{}  -> () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  CmmAssign CmmReg
reg CmmExpr
expr -> do
            DynFlags
dflags <- CmmLint DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            CmmType
erep <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
            let reg_ty :: CmmType
reg_ty = DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg
            if (CmmType
erep CmmType -> CmmType -> Bool
`cmmEqType_ignoring_ptrhood` CmmType
reg_ty)
                then () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                else CmmNode O O -> CmmType -> CmmType -> CmmLint ()
forall e x a. CmmNode e x -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr (CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
reg CmmExpr
expr) CmmType
erep CmmType
reg_ty

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

  CmmUnsafeForeignCall ForeignTarget
target [LocalReg]
_formals [CmmExpr]
actuals -> do
            ForeignTarget -> CmmLint ()
lintTarget ForeignTarget
target
            (CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> CmmLint CmmType
lintCmmExpr [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
            DynFlags
dflags <- CmmLint DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            (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
            DynFlags -> CmmExpr -> CmmLint ()
checkCond DynFlags
dflags CmmExpr
e

  CmmSwitch CmmExpr
e SwitchTargets
ids -> do
            DynFlags
dflags <- CmmLint DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            (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
            if (CmmType
erep CmmType -> CmmType -> Bool
`cmmEqType_ignoring_ptrhood` DynFlags -> CmmType
bWord DynFlags
dflags)
              then () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              else SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
text String
"switch scrutinee is not a word: " SDoc -> SDoc -> SDoc
<>
                               CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 (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
          (CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> CmmLint CmmType
lintCmmExpr [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 (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
_) = CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
e CmmLint CmmType -> CmmLint () -> CmmLint ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintTarget (PrimTarget {})     = () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


checkCond :: DynFlags -> CmmExpr -> CmmLint ()
checkCond :: DynFlags -> CmmExpr -> CmmLint ()
checkCond DynFlags
_ (CmmMachOp MachOp
mop [CmmExpr]
_) | MachOp -> Bool
isComparisonMachOp MachOp
mop = () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCond DynFlags
dflags (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
== DynFlags -> Width
wordWidth DynFlags
dflags = () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- constant values
checkCond DynFlags
_ 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
                         (CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
expr))

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

-- just a basic error monad:

newtype CmmLint a = CmmLint { CmmLint a -> DynFlags -> Either SDoc a
unCL :: DynFlags -> Either SDoc a }

instance Functor CmmLint where
      fmap :: (a -> b) -> CmmLint a -> CmmLint b
fmap = (a -> b) -> CmmLint a -> CmmLint b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

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

instance HasDynFlags CmmLint where
    getDynFlags :: CmmLint DynFlags
getDynFlags = (DynFlags -> Either SDoc DynFlags) -> CmmLint DynFlags
forall a. (DynFlags -> Either SDoc a) -> CmmLint a
CmmLint (\DynFlags
dflags -> DynFlags -> Either SDoc DynFlags
forall a b. b -> Either a b
Right DynFlags
dflags)

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

addLintInfo :: SDoc -> CmmLint a -> CmmLint a
addLintInfo :: SDoc -> CmmLint a -> CmmLint a
addLintInfo SDoc
info CmmLint a
thing = (DynFlags -> Either SDoc a) -> CmmLint a
forall a. (DynFlags -> Either SDoc a) -> CmmLint a
CmmLint ((DynFlags -> Either SDoc a) -> CmmLint a)
-> (DynFlags -> Either SDoc a) -> CmmLint a
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
   case CmmLint a -> DynFlags -> Either SDoc a
forall a. CmmLint a -> DynFlags -> Either SDoc a
unCL CmmLint a
thing DynFlags
dflags 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 :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr CmmExpr
expr [CmmType]
argsRep [Width]
opExpectsRep
     = 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 (CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr  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 :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr CmmNode e x
stmt CmmType
e_ty CmmType
r_ty
  = 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 [CmmNode e x -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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))
-}