-----------------------------------------------------------------------------
--
-- (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.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 = 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
   -- 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
  = 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

-- 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
  _ <- 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
  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)

-- | 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 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

-- 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 <- CmmLint Platform
getPlatform
       return (machOpResultType platform op 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
_ -> () -> 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
                  -- Arguments can't mention caller-saved
                  -- registers. See Note [Register parameter passing].
                  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
                -- 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.
                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 ()

-- | 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 <- 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 () -- constant values
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))

-- -----------------------------------------------------------------------------
-- 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 -> 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]))


{-
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
   = cmmLintErr (text "offset is not a multiple of words: " $$
                 nest 2 (ppr expr))
-}