{-# 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.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 (..))
cmmLint :: (OutputableP Platform d, OutputableP Platform h)
=> Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint :: forall d h.
(OutputableP Platform d, OutputableP Platform h) =>
Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint Platform
platform [GenCmmDecl d h CmmGraph]
tops = Platform
-> ([GenCmmDecl d h CmmGraph] -> CmmLint ())
-> [GenCmmDecl d h CmmGraph]
-> Maybe SDoc
forall a b.
OutputableP Platform a =>
Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint Platform
platform ((GenCmmDecl d h CmmGraph -> CmmLint ())
-> [GenCmmDecl d h CmmGraph] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenCmmDecl d h CmmGraph -> CmmLint ()
forall h i. GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl) [GenCmmDecl d h CmmGraph]
tops
cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
cmmLintGraph Platform
platform CmmGraph
g = Platform -> (CmmGraph -> CmmLint ()) -> CmmGraph -> Maybe SDoc
forall a b.
OutputableP Platform a =>
Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint Platform
platform CmmGraph -> CmmLint ()
lintCmmGraph CmmGraph
g
runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint :: forall a b.
OutputableP Platform a =>
Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint Platform
platform a -> CmmLint b
l a
p =
case CmmLint b -> Platform -> Either SDoc b
forall a. CmmLint a -> Platform -> Either SDoc a
unCL (a -> CmmLint b
l a
p) Platform
platform of
Left SDoc
err -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Cmm lint error:",
Int -> SDoc -> SDoc
nest Int
2 SDoc
err,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Program was:",
Int -> SDoc -> SDoc
nest Int
2 (Platform -> a -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform a
p)])
Right b
_ -> Maybe SDoc
forall a. Maybe a
Nothing
lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl :: forall h i. GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl (CmmProc i
_ CLabel
lbl [GlobalRegUse]
_ CmmGraph
g)
= do
platform <- CmmLint Platform
getPlatform
addLintInfo (text "in proc " <> pprDebugCLabel platform lbl) $ lintCmmGraph g
lintCmmDecl (CmmData {})
= () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintCmmGraph :: CmmGraph -> CmmLint ()
lintCmmGraph :: CmmGraph -> CmmLint ()
lintCmmGraph CmmGraph
g = do
platform <- CmmLint Platform
getPlatform
let
blocks = CmmGraph -> [CmmBlock]
toBlockList CmmGraph
g
labels = [Label] -> LabelSet
setFromList ((CmmBlock -> Label) -> [CmmBlock] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel [CmmBlock]
blocks)
cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) 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
forall doc. IsLine doc => String -> doc
text String
"in basic block " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block)) (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
forall a b. (a -> b) -> a -> b
$ do
let (CmmNode C O
_, Block CmmNode O O
middle, CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
(CmmNode O O -> CmmLint ()) -> [CmmNode O O] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmNode O O -> CmmLint ()
lintCmmMiddle (Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
middle)
LabelSet -> CmmNode O C -> CmmLint ()
lintCmmLast LabelSet
labels CmmNode O C
last
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr (CmmLoad CmmExpr
expr CmmType
rep AlignmentSpec
_alignment) = do
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
return rep
lintCmmExpr expr :: CmmExpr
expr@(CmmMachOp MachOp
op [CmmExpr]
args) = do
platform <- CmmLint Platform
getPlatform
tys <- mapM lintCmmExpr args
lintShiftOp op (zip args tys)
if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op
then cmmCheckMachOp op args tys
else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)
lintCmmExpr (CmmRegOff CmmReg
reg Int
offset)
= do let rep :: Width
rep = CmmType -> Width
typeWidth (CmmReg -> CmmType
cmmRegType CmmReg
reg)
CmmExpr -> CmmLint CmmType
lintCmmExpr (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
rep)
[CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset) Width
rep)])
lintCmmExpr CmmExpr
expr =
do platform <- CmmLint Platform
getPlatform
return (cmmExprType platform expr)
lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
lintShiftOp MachOp
op [(CmmExpr
_, CmmType
arg_ty), (CmmLit (CmmInt Integer
n Width
_), CmmType
_)]
| MachOp -> Bool
isShiftOp MachOp
op
, Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits (CmmType -> Width
typeWidth CmmType
arg_ty))
= SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Shift operation" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> MachOp -> SDoc
pprMachOp MachOp
op
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has out-of-range offset" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Integer -> SDoc
forall a. Outputable a => a -> SDoc
ppr Integer
n
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
". This will result in undefined behavior")
lintShiftOp MachOp
_ [(CmmExpr, CmmType)]
_ = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isShiftOp :: MachOp -> Bool
isShiftOp :: MachOp -> Bool
isShiftOp (MO_Shl Width
_) = Bool
True
isShiftOp (MO_U_Shr Width
_) = Bool
True
isShiftOp (MO_S_Shr Width
_) = Bool
True
isShiftOp MachOp
_ = Bool
False
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 <- CmmLint Platform
getPlatform
return (machOpResultType platform op tys)
lintCmmMiddle :: CmmNode O O -> CmmLint ()
lintCmmMiddle :: CmmNode O O -> CmmLint ()
lintCmmMiddle CmmNode O O
node = case CmmNode O O
node of
CmmComment FastString
_ -> () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CmmTick CmmTickish
_ -> () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CmmUnwind{} -> () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CmmAssign CmmReg
reg CmmExpr
expr -> do
erep <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
let reg_ty = CmmReg -> CmmType
cmmRegType CmmReg
reg
unless (erep `cmmCompatType` reg_ty) $
cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
CmmStore CmmExpr
l CmmExpr
r AlignmentSpec
_alignment -> do
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
l
_ <- lintCmmExpr r
return ()
CmmUnsafeForeignCall ForeignTarget
target [LocalReg]
_formals [CmmExpr]
actuals -> do
ForeignTarget -> CmmLint ()
lintTarget ForeignTarget
target
let lintArg :: CmmExpr -> CmmLint CmmType
lintArg CmmExpr
expr = do
SDoc -> CmmExpr -> CmmLint ()
forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"foreign call argument") CmmExpr
expr
CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
(CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> CmmLint CmmType
lintArg [CmmExpr]
actuals
lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
lintCmmLast LabelSet
labels CmmNode O C
node = case CmmNode O C
node of
CmmBranch Label
id -> Label -> CmmLint ()
checkTarget Label
id
CmmCondBranch CmmExpr
e Label
t Label
f Maybe Bool
_ -> do
platform <- CmmLint Platform
getPlatform
mapM_ checkTarget [t,f]
_ <- lintCmmExpr e
checkCond platform e
CmmSwitch CmmExpr
e SwitchTargets
ids -> do
platform <- CmmLint Platform
getPlatform
mapM_ checkTarget $ switchTargetsToList ids
erep <- lintCmmExpr e
unless (isWordAny erep) $
cmmLintErr (text "switch scrutinee is not a word (of any size): " <>
pdoc platform e <> text " :: " <> ppr 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
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
target
maybe (return ()) checkTarget 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
SDoc -> CmmExpr -> CmmLint ()
forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"foreign call argument") CmmExpr
expr
CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
expr
(CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> CmmLint CmmType
lintArg [CmmExpr]
args
Label -> CmmLint ()
checkTarget Label
succ
where
checkTarget :: Label -> CmmLint ()
checkTarget Label
id
| Label -> LabelSet -> Bool
setMember Label
id LabelSet
labels = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Branch to nonexistent id" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
id)
lintTarget :: ForeignTarget -> CmmLint ()
lintTarget :: ForeignTarget -> CmmLint ()
lintTarget (ForeignTarget CmmExpr
e ForeignConvention
_) = do
SDoc -> CmmExpr -> CmmLint ()
forall a.
(UserOfRegs GlobalReg a, OutputableP Platform a) =>
SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"foreign target") CmmExpr
e
_ <- CmmExpr -> CmmLint CmmType
lintCmmExpr CmmExpr
e
return ()
lintTarget (PrimTarget {}) = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 <- CmmLint Platform
getPlatform
let badRegs = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform)
([GlobalReg] -> [GlobalReg]) -> [GlobalReg] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Platform
-> ([GlobalReg] -> GlobalReg -> [GlobalReg])
-> [GlobalReg]
-> a
-> [GlobalReg]
forall b. Platform -> (b -> GlobalReg -> b) -> b -> a -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform ((GlobalReg -> [GlobalReg] -> [GlobalReg])
-> [GlobalReg] -> GlobalReg -> [GlobalReg]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] a
thing
unless (null badRegs)
$ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ pdoc platform thing)
checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond Platform
_ (CmmMachOp MachOp
mop [CmmExpr]
_) | MachOp -> Bool
isComparisonMachOp MachOp
mop = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCond Platform
platform (CmmLit (CmmInt Integer
x Width
t)) | Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
|| Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1, Width
t Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = () -> CmmLint ()
forall a. a -> CmmLint a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkCond Platform
platform CmmExpr
expr
= SDoc -> CmmLint ()
forall a. SDoc -> CmmLint a
cmmLintErr (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expression is not a conditional:") Int
2
(Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr))
newtype CmmLint a = CmmLint { forall a. CmmLint a -> Platform -> Either SDoc a
unCL :: Platform -> Either SDoc a }
deriving stock ((forall a b. (a -> b) -> CmmLint a -> CmmLint b)
-> (forall a b. a -> CmmLint b -> CmmLint a) -> Functor CmmLint
forall a b. a -> CmmLint b -> CmmLint a
forall a b. (a -> b) -> CmmLint a -> CmmLint b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CmmLint a -> CmmLint b
fmap :: forall a b. (a -> b) -> CmmLint a -> CmmLint b
$c<$ :: forall a b. a -> CmmLint b -> CmmLint a
<$ :: forall a b. a -> CmmLint b -> CmmLint a
Functor)
deriving (Functor CmmLint
Functor CmmLint =>
(forall a. a -> CmmLint a)
-> (forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b)
-> (forall a b c.
(a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c)
-> (forall a b. CmmLint a -> CmmLint b -> CmmLint b)
-> (forall a b. CmmLint a -> CmmLint b -> CmmLint a)
-> Applicative 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
$cpure :: forall a. a -> CmmLint a
pure :: forall a. a -> CmmLint a
$c<*> :: forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b
<*> :: forall a b. CmmLint (a -> b) -> CmmLint a -> CmmLint b
$cliftA2 :: forall a b c. (a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c
liftA2 :: forall a b c. (a -> b -> c) -> CmmLint a -> CmmLint b -> CmmLint c
$c*> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
*> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
$c<* :: forall a b. CmmLint a -> CmmLint b -> CmmLint a
<* :: forall a b. CmmLint a -> CmmLint b -> CmmLint a
Applicative, Applicative CmmLint
Applicative CmmLint =>
(forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b)
-> (forall a b. CmmLint a -> CmmLint b -> CmmLint b)
-> (forall a. a -> CmmLint a)
-> Monad 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
$c>>= :: forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b
>>= :: forall a b. CmmLint a -> (a -> CmmLint b) -> CmmLint b
$c>> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
>> :: forall a b. CmmLint a -> CmmLint b -> CmmLint b
$creturn :: forall a. a -> CmmLint a
return :: forall a. a -> CmmLint a
Monad) via ReaderT Platform (Except SDoc)
getPlatform :: CmmLint Platform
getPlatform :: CmmLint Platform
getPlatform = (Platform -> Either SDoc Platform) -> CmmLint Platform
forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint ((Platform -> Either SDoc Platform) -> CmmLint Platform)
-> (Platform -> Either SDoc Platform) -> CmmLint Platform
forall a b. (a -> b) -> a -> b
$ \Platform
platform -> Platform -> Either SDoc Platform
forall a b. b -> Either a b
Right Platform
platform
cmmLintErr :: SDoc -> CmmLint a
cmmLintErr :: forall a. SDoc -> CmmLint a
cmmLintErr SDoc
msg = (Platform -> Either SDoc a) -> CmmLint a
forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint (\Platform
_ -> SDoc -> Either SDoc a
forall a b. a -> Either a b
Left SDoc
msg)
addLintInfo :: SDoc -> CmmLint a -> CmmLint a
addLintInfo :: forall a. SDoc -> CmmLint a -> CmmLint a
addLintInfo SDoc
info CmmLint a
thing = (Platform -> Either SDoc a) -> CmmLint a
forall a. (Platform -> Either SDoc a) -> CmmLint a
CmmLint ((Platform -> Either SDoc a) -> CmmLint a)
-> (Platform -> Either SDoc a) -> CmmLint a
forall a b. (a -> b) -> a -> b
$ \Platform
platform ->
case CmmLint a -> Platform -> Either SDoc a
forall a. CmmLint a -> Platform -> Either SDoc a
unCL CmmLint a
thing Platform
platform of
Left SDoc
err -> SDoc -> Either SDoc a
forall a b. a -> Either a b
Left (SDoc -> Int -> SDoc -> SDoc
hang SDoc
info Int
2 SDoc
err)
Right a
a -> a -> Either SDoc a
forall a b. b -> Either a b
Right a
a
cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr :: forall a. CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr CmmExpr
expr [CmmType]
argsRep [Width]
opExpectsRep
= do
platform <- CmmLint Platform
getPlatform
cmmLintErr (text "in MachOp application: " $$
nest 2 (pdoc platform expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr 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 <- CmmLint Platform
getPlatform
cmmLintErr (text "in assignment: " $$
nest 2 (vcat [pdoc platform stmt,
text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty]))