never executed always true always false
    1 -----------------------------------------------------------------------------
    2 --
    3 -- (c) The University of Glasgow 2011
    4 --
    5 -- CmmLint: checking the correctness of Cmm statements and expressions
    6 --
    7 -----------------------------------------------------------------------------
    8 {-# LANGUAGE DeriveFunctor #-}
    9 {-# LANGUAGE FlexibleContexts #-}
   10 {-# LANGUAGE GADTs #-}
   11 module GHC.Cmm.Lint (
   12     cmmLint, cmmLintGraph
   13   ) where
   14 
   15 import GHC.Prelude
   16 
   17 import GHC.Platform
   18 import GHC.Platform.Regs (callerSaves)
   19 import GHC.Cmm.Dataflow.Block
   20 import GHC.Cmm.Dataflow.Collections
   21 import GHC.Cmm.Dataflow.Graph
   22 import GHC.Cmm.Dataflow.Label
   23 import GHC.Cmm
   24 import GHC.Cmm.Utils
   25 import GHC.Cmm.Liveness
   26 import GHC.Cmm.Switch (switchTargetsToList)
   27 import GHC.Cmm.Ppr () -- For Outputable instances
   28 import GHC.Utils.Outputable
   29 
   30 import Control.Monad (ap, unless)
   31 
   32 -- Things to check:
   33 --     - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)
   34 --     - check for branches to blocks that don't exist
   35 --     - check types
   36 
   37 -- -----------------------------------------------------------------------------
   38 -- Exported entry points:
   39 
   40 cmmLint :: (OutputableP Platform d, OutputableP Platform h)
   41         => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
   42 cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops
   43 
   44 cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
   45 cmmLintGraph platform g = runCmmLint platform lintCmmGraph g
   46 
   47 runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
   48 runCmmLint platform l p =
   49    case unCL (l p) platform of
   50      Left err -> Just (vcat [text "Cmm lint error:",
   51                              nest 2 err,
   52                              text "Program was:",
   53                              nest 2 (pdoc platform p)])
   54      Right _  -> Nothing
   55 
   56 lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
   57 lintCmmDecl (CmmProc _ lbl _ g)
   58   = do
   59     platform <- getPlatform
   60     addLintInfo (text "in proc " <> pdoc platform lbl) $ lintCmmGraph g
   61 lintCmmDecl (CmmData {})
   62   = return ()
   63 
   64 
   65 lintCmmGraph :: CmmGraph -> CmmLint ()
   66 lintCmmGraph g = do
   67    platform <- getPlatform
   68    let
   69       blocks = toBlockList g
   70       labels = setFromList (map entryLabel blocks)
   71    cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) blocks
   72    -- cmmLiveness throws an error if there are registers
   73    -- live on entry to the graph (i.e. undefined
   74    -- variables)
   75 
   76 
   77 lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
   78 lintCmmBlock labels block
   79   = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
   80         let (_, middle, last) = blockSplit block
   81         mapM_ lintCmmMiddle (blockToList middle)
   82         lintCmmLast labels last
   83 
   84 -- -----------------------------------------------------------------------------
   85 -- lintCmmExpr
   86 
   87 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
   88 -- byte/word mismatches.
   89 
   90 lintCmmExpr :: CmmExpr -> CmmLint CmmType
   91 lintCmmExpr (CmmLoad expr rep) = do
   92   _ <- lintCmmExpr expr
   93   -- Disabled, if we have the inlining phase before the lint phase,
   94   -- we can have funny offsets due to pointer tagging. -- EZY
   95   -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
   96   --   cmmCheckWordAddress expr
   97   return rep
   98 lintCmmExpr expr@(CmmMachOp op args) = do
   99   platform <- getPlatform
  100   tys <- mapM lintCmmExpr args
  101   if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op
  102         then cmmCheckMachOp op args tys
  103         else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)
  104 lintCmmExpr (CmmRegOff reg offset)
  105   = do platform <- getPlatform
  106        let rep = typeWidth (cmmRegType platform reg)
  107        lintCmmExpr (CmmMachOp (MO_Add rep)
  108                 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
  109 lintCmmExpr expr =
  110   do platform <- getPlatform
  111      return (cmmExprType platform expr)
  112 
  113 -- Check for some common byte/word mismatches (eg. Sp + 1)
  114 cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
  115 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
  116   = cmmCheckMachOp op [reg, lit] tys
  117 cmmCheckMachOp op _ tys
  118   = do platform <- getPlatform
  119        return (machOpResultType platform op tys)
  120 
  121 {-
  122 isOffsetOp :: MachOp -> Bool
  123 isOffsetOp (MO_Add _) = True
  124 isOffsetOp (MO_Sub _) = True
  125 isOffsetOp _ = False
  126 
  127 -- This expression should be an address from which a word can be loaded:
  128 -- check for funny-looking sub-word offsets.
  129 _cmmCheckWordAddress :: CmmExpr -> CmmLint ()
  130 _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
  131   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
  132   = cmmLintDubiousWordOffset e
  133 _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
  134   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
  135   = cmmLintDubiousWordOffset e
  136 _cmmCheckWordAddress _
  137   = return ()
  138 
  139 -- No warnings for unaligned arithmetic with the node register,
  140 -- which is used to extract fields from tagged constructor closures.
  141 notNodeReg :: CmmExpr -> Bool
  142 notNodeReg (CmmReg reg) | reg == nodeReg = False
  143 notNodeReg _                             = True
  144 -}
  145 
  146 lintCmmMiddle :: CmmNode O O -> CmmLint ()
  147 lintCmmMiddle node = case node of
  148   CmmComment _ -> return ()
  149   CmmTick _    -> return ()
  150   CmmUnwind{}  -> return ()
  151 
  152   CmmAssign reg expr -> do
  153             platform <- getPlatform
  154             erep <- lintCmmExpr expr
  155             let reg_ty = cmmRegType platform reg
  156             if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
  157                 then return ()
  158                 else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
  159 
  160   CmmStore l r -> do
  161             _ <- lintCmmExpr l
  162             _ <- lintCmmExpr r
  163             return ()
  164 
  165   CmmUnsafeForeignCall target _formals actuals -> do
  166             lintTarget target
  167             let lintArg expr = do
  168                   -- Arguments can't mention caller-saved
  169                   -- registers. See Note [Register parameter passing].
  170                   mayNotMentionCallerSavedRegs (text "foreign call argument") expr
  171                   lintCmmExpr expr
  172 
  173             mapM_ lintArg actuals
  174 
  175 
  176 lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
  177 lintCmmLast labels node = case node of
  178   CmmBranch id -> checkTarget id
  179 
  180   CmmCondBranch e t f _ -> do
  181             platform <- getPlatform
  182             mapM_ checkTarget [t,f]
  183             _ <- lintCmmExpr e
  184             checkCond platform e
  185 
  186   CmmSwitch e ids -> do
  187             platform <- getPlatform
  188             mapM_ checkTarget $ switchTargetsToList ids
  189             erep <- lintCmmExpr e
  190             unless (isWordAny erep) $
  191               cmmLintErr (text "switch scrutinee is not a word (of any size): " <>
  192                           pdoc platform e <> text " :: " <> ppr erep)
  193 
  194   CmmCall { cml_target = target, cml_cont = cont } -> do
  195           _ <- lintCmmExpr target
  196           maybe (return ()) checkTarget cont
  197 
  198   CmmForeignCall tgt _ args succ _ _ _ -> do
  199           lintTarget tgt
  200           let lintArg expr = do
  201                 -- Arguments can't mention caller-saved
  202                 -- registers. See Note [Register
  203                 -- parameter passing].
  204                 -- N.B. This won't catch local registers
  205                 -- which the NCG's register allocator later
  206                 -- places in caller-saved registers.
  207                 mayNotMentionCallerSavedRegs (text "foreign call argument") expr
  208                 lintCmmExpr expr
  209           mapM_ lintArg args
  210           checkTarget succ
  211  where
  212   checkTarget id
  213      | setMember id labels = return ()
  214      | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
  215 
  216 lintTarget :: ForeignTarget -> CmmLint ()
  217 lintTarget (ForeignTarget e _) = do
  218     mayNotMentionCallerSavedRegs (text "foreign target") e
  219     _ <- lintCmmExpr e
  220     return ()
  221 lintTarget (PrimTarget {})     = return ()
  222 
  223 -- | As noted in Note [Register parameter passing], the arguments and
  224 -- 'ForeignTarget' of a foreign call mustn't mention
  225 -- caller-saved registers.
  226 mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, OutputableP Platform a)
  227                              => SDoc -> a -> CmmLint ()
  228 mayNotMentionCallerSavedRegs what thing = do
  229     platform <- getPlatform
  230     let badRegs = filter (callerSaves platform)
  231                   $ foldRegsUsed platform (flip (:)) [] thing
  232     unless (null badRegs)
  233       $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ pdoc platform thing)
  234 
  235 checkCond :: Platform -> CmmExpr -> CmmLint ()
  236 checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
  237 checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values
  238 checkCond platform expr
  239     = cmmLintErr (hang (text "expression is not a conditional:") 2
  240                          (pdoc platform expr))
  241 
  242 -- -----------------------------------------------------------------------------
  243 -- CmmLint monad
  244 
  245 -- just a basic error monad:
  246 
  247 newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a }
  248     deriving (Functor)
  249 
  250 instance Applicative CmmLint where
  251       pure a = CmmLint (\_ -> Right a)
  252       (<*>) = ap
  253 
  254 instance Monad CmmLint where
  255   CmmLint m >>= k = CmmLint $ \platform ->
  256                                 case m platform of
  257                                 Left e -> Left e
  258                                 Right a -> unCL (k a) platform
  259 
  260 getPlatform :: CmmLint Platform
  261 getPlatform = CmmLint $ \platform -> Right platform
  262 
  263 cmmLintErr :: SDoc -> CmmLint a
  264 cmmLintErr msg = CmmLint (\_ -> Left msg)
  265 
  266 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
  267 addLintInfo info thing = CmmLint $ \platform ->
  268    case unCL thing platform of
  269         Left err -> Left (hang info 2 err)
  270         Right a  -> Right a
  271 
  272 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
  273 cmmLintMachOpErr expr argsRep opExpectsRep
  274      = do
  275        platform <- getPlatform
  276        cmmLintErr (text "in MachOp application: " $$
  277                    nest 2 (pdoc platform expr) $$
  278                       (text "op is expecting: " <+> ppr opExpectsRep) $$
  279                       (text "arguments provide: " <+> ppr argsRep))
  280 
  281 cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
  282 cmmLintAssignErr stmt e_ty r_ty
  283   = do
  284     platform <- getPlatform
  285     cmmLintErr (text "in assignment: " $$
  286                 nest 2 (vcat [pdoc platform stmt,
  287                               text "Reg ty:" <+> ppr r_ty,
  288                               text "Rhs ty:" <+> ppr e_ty]))
  289 
  290 
  291 {-
  292 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
  293 cmmLintDubiousWordOffset expr
  294    = cmmLintErr (text "offset is not a multiple of words: " $$
  295                  nest 2 (ppr expr))
  296 -}
  297