    -----------------------------------------------------------------------------
    --
    -- (c) The University of Glasgow 2011
    --
    -- CmmLint: checking the correctness of Cmm statements and expressions
    --
    -----------------------------------------------------------------------------
    {-# LANGUAGE DeriveFunctor #-}
    {-# 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.Collections
    import GHC.Cmm.Dataflow.Graph
    import GHC.Cmm.Dataflow.Label
    import GHC.Cmm
    import GHC.Cmm.Utils
    import GHC.Cmm.Liveness
    import GHC.Cmm.Switch (switchTargetsToList)
    import GHC.Cmm.Ppr () -- For Outputable instances
    import GHC.Utils.Outputable

    import Control.Monad (ap, unless)

    -- 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 ([SDoc] -> SDoc
    vcat [String -> SDoc
    text String
    "Cmm lint error:",
                                 Int -> SDoc -> SDoc
    nest Int
    2 SDoc
    err,
                                 String -> SDoc
    text String
    "Program was:",
                                 Int -> SDoc -> SDoc
    nest Int
    2 (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 [GlobalReg]
    _ CmmGraph
    g)
      = do
        Platform
    platform <- CmmLint Platform
    getPlatform
        SDoc -> CmmLint () -> CmmLint ()
    forall a. SDoc -> CmmLint a -> CmmLint a
    addLintInfo (String -> SDoc
    text String
    "in proc " SDoc -> SDoc -> SDoc
    <> Platform -> CLabel -> SDoc
    forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform CLabel
    lbl) (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
    forall a b. (a -> b) -> a -> b
    $ CmmGraph -> CmmLint ()
    lintCmmGraph CmmGraph
    g
    lintCmmDecl (CmmData {})
      = () -> CmmLint ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    lintCmmGraph :: CmmGraph -> CmmLint ()
    lintCmmGraph :: CmmGraph -> CmmLint ()
    lintCmmGraph CmmGraph
    g = do
       Platform
    platform <- CmmLint Platform
    getPlatform
       let
          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 :: Extensibility -> Extensibility -> *)
           (x :: Extensibility).
    NonLocal thing =>
    thing C x -> Label
    entryLabel [CmmBlock]
    blocks)
       Platform -> CmmGraph -> BlockEntryLiveness LocalReg
    cmmLocalLiveness Platform
    platform CmmGraph
    g BlockEntryLiveness LocalReg -> CmmLint () -> CmmLint ()
    `seq` (CmmBlock -> CmmLint ()) -> [CmmBlock] -> CmmLint ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (LabelSet -> CmmBlock -> CmmLint ()
    lintCmmBlock LabelSet
    labels) [CmmBlock]
    blocks
       -- cmmLiveness throws an error if there are registers
       -- live on entry to the graph (i.e. undefined
       -- variables)

    lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
    lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
    lintCmmBlock LabelSet
    labels CmmBlock
    block
      = SDoc -> CmmLint () -> CmmLint ()
    forall a. SDoc -> CmmLint a -> CmmLint a
    addLintInfo (String -> SDoc
    text String
    "in basic block " SDoc -> SDoc -> SDoc
    <> Label -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CmmBlock -> Label
    forall (thing :: 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
      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) >= platformWordSizeInBytes platform) $
      --   cmmCheckWordAddress expr
      CmmType -> CmmLint CmmType
    forall (m :: * -> *) a. Monad m => a -> m a
    return CmmType
    rep
    lintCmmExpr expr :: CmmExpr
    expr@(CmmMachOp MachOp
    op [CmmExpr]
    args) = do
      Platform
    platform <- CmmLint Platform
    getPlatform
      [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
      MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
    lintShiftOp MachOp
    op ([CmmExpr] -> [CmmType] -> [(CmmExpr, CmmType)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [CmmExpr]
    args [CmmType]
    tys)
      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
    . Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform) [CmmExpr]
    args [Width] -> [Width] -> Bool
    forall a. Eq a => a -> a -> Bool
    == Platform -> MachOp -> [Width]
    machOpArgReps Platform
    platform 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 (Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform) [CmmExpr]
    args) (Platform -> MachOp -> [Width]
    machOpArgReps Platform
    platform MachOp
    op)
    lintCmmExpr (CmmRegOff CmmReg
    reg Int
    offset)
      = do Platform
    platform <- CmmLint Platform
    getPlatform
           let rep :: Width
    rep = CmmType -> Width
    typeWidth (Platform -> CmmReg -> CmmType
    cmmRegType Platform
    platform 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
    platform <- CmmLint Platform
    getPlatform
         CmmType -> CmmLint CmmType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform CmmExpr
    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
    text String
    "Shift operation" SDoc -> SDoc -> SDoc
    <+> MachOp -> SDoc
    pprMachOp MachOp
    op
                    SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "has out-of-range offset" SDoc -> SDoc -> SDoc
    <+> Integer -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Integer
    n
                    SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    ". This will result in undefined behavior")
    lintShiftOp MachOp
    _ [(CmmExpr, CmmType)]
    _ = () -> CmmLint ()
    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
    platform <- CmmLint Platform
    getPlatform
           CmmType -> CmmLint CmmType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Platform -> MachOp -> [CmmType] -> CmmType
    machOpResultType Platform
    platform 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 (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 (m :: * -> *) a. Monad m => a -> m a
    return ()
      CmmTick CmmTickish
    _    -> () -> CmmLint ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      CmmUnwind{}  -> () -> CmmLint ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

      CmmAssign CmmReg
    reg CmmExpr
    expr -> do
                Platform
    platform <- CmmLint Platform
    getPlatform
                CmmType
    erep <- CmmExpr -> CmmLint CmmType
    lintCmmExpr CmmExpr
    expr
                let reg_ty :: CmmType
    reg_ty = Platform -> CmmReg -> CmmType
    cmmRegType Platform
    platform 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 :: Extensibility) (x :: Extensibility) a.
    CmmNode e x -> CmmType -> CmmType -> CmmLint a
    cmmLintAssignErr (CmmReg -> CmmExpr -> CmmNode O O
    CmmAssign CmmReg
    reg CmmExpr
    expr) CmmType
    erep CmmType
    reg_ty

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

      CmmUnsafeForeignCall ForeignTarget
    target [LocalReg]
    _formals [CmmExpr]
    actuals -> do
                ForeignTarget -> CmmLint ()
    lintTarget ForeignTarget
    target
                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
    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
    platform <- CmmLint Platform
    getPlatform
                (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
                Platform -> CmmExpr -> CmmLint ()
    checkCond Platform
    platform CmmExpr
    e

      CmmSwitch CmmExpr
    e SwitchTargets
    ids -> do
                Platform
    platform <- CmmLint Platform
    getPlatform
                (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` Platform -> CmmType
    bWord Platform
    platform)
                  then () -> CmmLint ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                  else SDoc -> CmmLint ()
    forall a. SDoc -> CmmLint a
    cmmLintErr (String -> SDoc
    text String
    "switch scrutinee is not a word: " SDoc -> SDoc -> SDoc
    <>
                                   Platform -> CmmExpr -> SDoc
    forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform CmmExpr
    e SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " :: " SDoc -> SDoc -> SDoc
    <> CmmType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CmmType
    erep)

      CmmCall { cml_target :: CmmNode O C -> CmmExpr
    cml_target = CmmExpr
    target, cml_cont :: CmmNode O C -> Maybe Label
    cml_cont = Maybe Label
    cont } -> do
              CmmType
    _ <- CmmExpr -> CmmLint CmmType
    lintCmmExpr CmmExpr
    target
              CmmLint () -> (Label -> CmmLint ()) -> Maybe Label -> CmmLint ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (() -> CmmLint ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()) Label -> CmmLint ()
    checkTarget Maybe Label
    cont

      CmmForeignCall ForeignTarget
    tgt [LocalReg]
    _ [CmmExpr]
    args Label
    succ Int
    _ Int
    _ Bool
    _ -> do
              ForeignTarget -> CmmLint ()
    lintTarget ForeignTarget
    tgt
              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
    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
         | ElemOf LabelSet -> LabelSet -> Bool
    forall set. IsSet set => ElemOf set -> set -> Bool
    setMember ElemOf LabelSet
    Label
    id LabelSet
    labels = () -> CmmLint ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
         | Bool
    otherwise = SDoc -> CmmLint ()
    forall a. SDoc -> CmmLint a
    cmmLintErr (String -> SDoc
    text String
    "Branch to nonexistent id" SDoc -> SDoc -> SDoc
    <+> Label -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Label
    id)

    lintTarget :: ForeignTarget -> CmmLint ()
    lintTarget :: ForeignTarget -> CmmLint ()
    lintTarget (ForeignTarget CmmExpr
    e ForeignConvention
    _) = do
        SDoc -> CmmExpr -> CmmLint ()
    forall a.
    (UserOfRegs GlobalReg a, OutputableP Platform a) =>
    SDoc -> a -> CmmLint ()
    mayNotMentionCallerSavedRegs (String -> SDoc
    text String
    "foreign target") CmmExpr
    e
        CmmType
    _ <- CmmExpr -> CmmLint CmmType
    lintCmmExpr CmmExpr
    e
        () -> CmmLint ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    lintTarget (PrimTarget {})     = () -> CmmLint ()
    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
    platform <- CmmLint Platform
    getPlatform
        let badRegs :: [GlobalReg]
    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 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
        Bool -> CmmLint () -> CmmLint ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([GlobalReg] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [GlobalReg]
    badRegs)
          (CmmLint () -> CmmLint ()) -> CmmLint () -> CmmLint ()
    forall a b. (a -> b) -> a -> b
    $ SDoc -> CmmLint ()
    forall a. SDoc -> CmmLint a
    cmmLintErr (SDoc
    what SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "mentions caller-saved registers: " SDoc -> SDoc -> SDoc
    <> [GlobalReg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [GlobalReg]
    badRegs SDoc -> SDoc -> SDoc
    $$ Platform -> a -> SDoc
    forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform a
    thing)

    checkCond :: Platform -> CmmExpr -> CmmLint ()
    checkCond :: Platform -> CmmExpr -> CmmLint ()
    checkCond Platform
    _ (CmmMachOp MachOp
    mop [CmmExpr]
    _) | MachOp -> Bool
    isComparisonMachOp MachOp
    mop = () -> CmmLint ()
    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 (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
    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 ((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
    <$ :: forall a b. a -> CmmLint b -> CmmLint a
    $c<$ :: forall a b. a -> CmmLint b -> CmmLint a
    fmap :: forall a b. (a -> b) -> CmmLint a -> CmmLint b
    $cfmap :: forall a b. (a -> b) -> CmmLint a -> CmmLint b
    Functor)

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

    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
    platform <- CmmLint Platform
    getPlatform
           SDoc -> CmmLint a
    forall a. SDoc -> CmmLint a
    cmmLintErr (String -> SDoc
    text String
    "in MachOp application: " SDoc -> SDoc -> SDoc
    $$
                       Int -> SDoc -> SDoc
    nest Int
    2 (Platform -> CmmExpr -> SDoc
    forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform CmmExpr
    expr) SDoc -> SDoc -> SDoc
    $$
                          (String -> SDoc
    text String
    "op is expecting: " SDoc -> SDoc -> SDoc
    <+> [Width] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Width]
    opExpectsRep) SDoc -> SDoc -> SDoc
    $$
                          (String -> SDoc
    text String
    "arguments provide: " SDoc -> SDoc -> SDoc
    <+> [CmmType] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [CmmType]
    argsRep))

    cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
    cmmLintAssignErr :: 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
    platform <- CmmLint Platform
    getPlatform
        SDoc -> CmmLint a
    forall a. SDoc -> CmmLint a
    cmmLintErr (String -> SDoc
    text String
    "in assignment: " SDoc -> SDoc -> SDoc
    $$
                    Int -> SDoc -> SDoc
    nest Int
    2 ([SDoc] -> SDoc
    vcat [Platform -> CmmNode e x -> SDoc
    forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform CmmNode e x
    stmt,
                                  String -> SDoc
    text String
    "Reg ty:" SDoc -> SDoc -> SDoc
    <+> CmmType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CmmType
    r_ty,
                                  String -> SDoc
    text String
    "Rhs ty:" SDoc -> SDoc -> SDoc
    <+> CmmType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CmmType
    e_ty]))

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