-----------------------------------------------------------------------------
--
-- (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 dflags :: DynFlags
dflags tops :: 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 dflags :: DynFlags
dflags g :: 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 dflags :: DynFlags
dflags l :: a -> CmmLint b
l p :: 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 err :: SDoc
err -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just ([SDoc] -> SDoc
vcat [String -> SDoc
text "Cmm lint error:",
                             Int -> SDoc -> SDoc
nest 2 SDoc
err,
                             String -> SDoc
text "Program was:",
                             Int -> SDoc -> SDoc
nest 2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
p)])
     Right _  -> Maybe SDoc
forall a. Maybe a
Nothing

lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl dflags :: DynFlags
dflags (CmmProc _ lbl :: CLabel
lbl _ g :: CmmGraph
g)
  = SDoc -> CmmLint () -> CmmLint ()
forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo (String -> SDoc
text "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 _ (CmmData {})
  = () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
lintCmmGraph dflags :: DynFlags
dflags g :: CmmGraph
g =
    DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness DynFlags
dflags 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)
  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 labels :: LabelSet
labels block :: CmmBlock
block
  = SDoc -> CmmLint () -> CmmLint ()
forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo (String -> SDoc
text "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 (_, middle :: Block CmmNode O O
middle, last :: 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 expr :: CmmExpr
expr rep :: 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 op :: MachOp
op args :: [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 reg :: CmmReg
reg offset :: 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 expr :: 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 op :: MachOp
op [lit :: CmmExpr
lit@(CmmLit (CmmInt { })), reg :: CmmExpr
reg@(CmmReg _)] tys :: [CmmType]
tys
  = MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp MachOp
op [CmmExpr
reg, CmmExpr
lit] [CmmType]
tys
cmmCheckMachOp op :: MachOp
op _ tys :: [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 node :: CmmNode O O
node = case CmmNode O O
node of
  CmmComment _ -> () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CmmTick _    -> () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CmmUnwind{}  -> () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  CmmAssign reg :: CmmReg
reg expr :: 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 l :: CmmExpr
l r :: 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 target :: ForeignTarget
target _formals :: [LocalReg]
_formals actuals :: [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 labels :: LabelSet
labels node :: CmmNode O C
node = case CmmNode O C
node of
  CmmBranch id :: Label
id -> Label -> CmmLint ()
checkTarget Label
id

  CmmCondBranch e :: CmmExpr
e t :: Label
t f :: Label
f _ -> 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 e :: CmmExpr
e ids :: 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 "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 " :: " 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 tgt :: ForeignTarget
tgt _ args :: [CmmExpr]
args succ :: Label
succ _ _ _ -> 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 id :: 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 "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 e :: CmmExpr
e _) = 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 _ (CmmMachOp mop :: MachOp
mop _) | MachOp -> Bool
isComparisonMachOp MachOp
mop = () -> CmmLint ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCond dflags :: DynFlags
dflags (CmmLit (CmmInt x :: Integer
x t :: Width
t)) | Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 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 _ expr :: CmmExpr
expr
    = SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "expression is not a conditional:") 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
a = (DynFlags -> Either SDoc a) -> CmmLint a
forall a. (DynFlags -> Either SDoc a) -> CmmLint a
CmmLint (\_ -> 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 m :: DynFlags -> Either SDoc a
m >>= :: CmmLint a -> (a -> CmmLint b) -> CmmLint b
>>= k :: 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
$ \dflags :: DynFlags
dflags ->
                                case DynFlags -> Either SDoc a
m DynFlags
dflags of
                                Left e :: SDoc
e -> SDoc -> Either SDoc b
forall a b. a -> Either a b
Left SDoc
e
                                Right a :: 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 (\dflags :: 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 msg :: SDoc
msg = (DynFlags -> Either SDoc a) -> CmmLint a
forall a. (DynFlags -> Either SDoc a) -> CmmLint a
CmmLint (\_ -> 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 info :: SDoc
info thing :: 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
$ \dflags :: 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 err :: SDoc
err -> SDoc -> Either SDoc a
forall a b. a -> Either a b
Left (SDoc -> Int -> SDoc -> SDoc
hang SDoc
info 2 SDoc
err)
        Right a :: 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 expr :: CmmExpr
expr argsRep :: [CmmType]
argsRep opExpectsRep :: [Width]
opExpectsRep
     = SDoc -> CmmLint a
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
text "in MachOp application: " SDoc -> SDoc -> SDoc
$$
                   Int -> SDoc -> SDoc
nest 2 (CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr  CmmExpr
expr) SDoc -> SDoc -> SDoc
$$
                      (String -> SDoc
text "op is expecting: " SDoc -> SDoc -> SDoc
<+> [Width] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Width]
opExpectsRep) SDoc -> SDoc -> SDoc
$$
                      (String -> SDoc
text "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 stmt :: CmmNode e x
stmt e_ty :: CmmType
e_ty r_ty :: CmmType
r_ty
  = SDoc -> CmmLint a
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
text "in assignment: " SDoc -> SDoc -> SDoc
$$
                Int -> SDoc -> SDoc
nest 2 ([SDoc] -> SDoc
vcat [CmmNode e x -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmNode e x
stmt,
                              String -> SDoc
text "Reg ty:" SDoc -> SDoc -> SDoc
<+> CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
r_ty,
                              String -> SDoc
text "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))
-}