    -----------------------------------------------------------------------------
    --
    -- (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)
      let machop_arg_widths = Platform -> MachOp -> [Width]
    machOpArgReps Platform
    platform MachOp
    op
          arg_tys           = (CmmExpr -> CmmType) -> [CmmExpr] -> [CmmType]
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform) [CmmExpr]
    args
      if map typeWidth arg_tys == machop_arg_widths
        then cmmCheckMachOp op args tys
        else cmmLintMachOpErr expr arg_tys machop_arg_widths
    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
                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
                arg_tys <- (CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint [CmmType]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM CmmExpr -> CmmLint CmmType
    lintArg [CmmExpr]
    actuals
                lintTarget arg_tys target

    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
              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
              arg_tys <- (CmmExpr -> CmmLint CmmType) -> [CmmExpr] -> CmmLint [CmmType]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM CmmExpr -> CmmLint CmmType
    lintArg [CmmExpr]
    args
              lintTarget arg_tys tgt
              checkTarget 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 :: [CmmType] -> ForeignTarget -> CmmLint ()
    lintTarget :: [CmmType] -> ForeignTarget -> CmmLint ()
    lintTarget [CmmType]
    _arg_tys (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 [CmmType]
    arg_tys (PrimTarget CallishMachOp
    mop) = do
      platform <- CmmLint Platform
    getPlatform
      let machop_arg_tys = Platform -> CallishMachOp -> [CmmType]
    callishMachOpArgTys Platform
    platform CallishMachOp
    mop
      unless (and $ zipWith cmmCompatType arg_tys machop_arg_tys) $
        cmmLintCallishMachOpErr mop arg_tys machop_arg_tys

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

    cmmLintCallishMachOpErr :: CallishMachOp -> [CmmType] -> [CmmType] -> CmmLint a
    cmmLintCallishMachOpErr :: forall a. CallishMachOp -> [CmmType] -> [CmmType] -> CmmLint a
    cmmLintCallishMachOpErr CallishMachOp
    mop [CmmType]
    argTys [CmmType]
    mopTys
         = SDoc -> CmmLint a
    forall a. SDoc -> CmmLint a
    cmmLintErr (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "in Callish MachOp application: " SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                       Int -> SDoc -> SDoc
    nest Int
    2 (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (String -> SDoc) -> String -> SDoc
    forall a b. (a -> b) -> a -> b
    $ CallishMachOp -> String
    forall a. Show a => a -> String
    show CallishMachOp
    mop) SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                          (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "op is expecting: " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [CmmType] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [CmmType]
    mopTys) SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
                          (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "arguments provide: " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> [CmmType] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [CmmType]
    argTys))

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