cmm/CmmLint.hs

    -----------------------------------------------------------------------------
    --
    -- (c) The University of Glasgow 2011
    --
    -- CmmLint: checking the correctness of Cmm statements and expressions
    --
    -----------------------------------------------------------------------------
    {-# LANGUAGE GADTs #-}
    module CmmLint (
        cmmLint, cmmLintGraph
      ) where

    import GhcPrelude

    import Hoopl.Block
    import Hoopl.Collections
    import Hoopl.Graph
    import Hoopl.Label
    import Cmm
    import CmmUtils
    import CmmLive
    import CmmSwitch (switchTargetsToList)
    import PprCmm ()
    import Outputable
    import DynFlags

    import Control.Monad (liftM, ap)

    -- Things to check:
    --     - invariant on CmmBlock in CmmExpr (see comment there)
    --     - check for branches to blocks that don't exist
    --     - check types

    -- -----------------------------------------------------------------------------
    -- Exported entry points:

    cmmLint :: (Outputable d, Outputable h)
            => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
    cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops

    cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
    cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g

    runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
    runCmmLint dflags l p =
       case unCL (l p) dflags of
         Left err -> Just (vcat [text "Cmm lint error:",
                                 nest 2 err,
                                 text "Program was:",
                                 nest 2 (ppr p)])
         Right _  -> Nothing

    lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
    lintCmmDecl dflags (CmmProc _ lbl _ g)
      = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
    lintCmmDecl _ (CmmData {})
      = return ()

    lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
    lintCmmGraph dflags g =
        cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks
        -- cmmLiveness throws an error if there are registers
        -- live on entry to the graph (i.e. undefined
        -- variables)
      where
           blocks = toBlockList g
           labels = setFromList (map entryLabel blocks)

    lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
    lintCmmBlock labels block
      = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
            let (_, middle, last) = blockSplit block
            mapM_ lintCmmMiddle (blockToList middle)
            lintCmmLast labels last

    -- -----------------------------------------------------------------------------
    -- lintCmmExpr

    -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
    -- byte/word mismatches.

    lintCmmExpr :: CmmExpr -> CmmLint CmmType
    lintCmmExpr (CmmLoad expr rep) = do
      _ <- lintCmmExpr 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) >= wORD_SIZE) $
      --   cmmCheckWordAddress expr
      return rep
    lintCmmExpr expr@(CmmMachOp op args) = do
      dflags <- getDynFlags
      tys <- mapM lintCmmExpr args
      if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
            then cmmCheckMachOp op args tys
            else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
    lintCmmExpr (CmmRegOff reg offset)
      = do dflags <- getDynFlags
           let rep = typeWidth (cmmRegType dflags reg)
           lintCmmExpr (CmmMachOp (MO_Add rep)
                    [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
    lintCmmExpr expr =
      do dflags <- getDynFlags
         return (cmmExprType dflags expr)

    -- Check for some common byte/word mismatches (eg. Sp + 1)
    cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
    cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
      = cmmCheckMachOp op [reg, lit] tys
    cmmCheckMachOp op _ tys
      = do dflags <- getDynFlags
           return (machOpResultType dflags 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 (wORD_SIZE dflags) /= 0
      = cmmLintDubiousWordOffset e
    _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
      | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 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 node = case node of
      CmmComment _ -> return ()
      CmmTick _    -> return ()
      CmmUnwind{}  -> return ()

      CmmAssign reg expr -> do
                dflags <- getDynFlags
                erep <- lintCmmExpr expr
                let reg_ty = cmmRegType dflags reg
                if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
                    then return ()
                    else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty

      CmmStore l r -> do
                _ <- lintCmmExpr l
                _ <- lintCmmExpr r
                return ()

      CmmUnsafeForeignCall target _formals actuals -> do
                lintTarget target
                mapM_ lintCmmExpr actuals

    lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
    lintCmmLast labels node = case node of
      CmmBranch id -> checkTarget id

      CmmCondBranch e t f _ -> do
                dflags <- getDynFlags
                mapM_ checkTarget [t,f]
                _ <- lintCmmExpr e
                checkCond dflags e

      CmmSwitch e ids -> do
                dflags <- getDynFlags
                mapM_ checkTarget $ switchTargetsToList ids
                erep <- lintCmmExpr e
                if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
                  then return ()
                  else cmmLintErr (text "switch scrutinee is not a word: " <>
                                   ppr e <> text " :: " <> ppr erep)

      CmmCall { cml_target = target, cml_cont = cont } -> do
              _ <- lintCmmExpr target
              maybe (return ()) checkTarget cont

      CmmForeignCall tgt _ args succ _ _ _ -> do
              lintTarget tgt
              mapM_ lintCmmExpr args
              checkTarget succ
     where
      checkTarget id
         | setMember id labels = return ()
         | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)

    lintTarget :: ForeignTarget -> CmmLint ()
    lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
    lintTarget (PrimTarget {})     = return ()

    checkCond :: DynFlags -> CmmExpr -> CmmLint ()
    checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
    checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
    checkCond _ expr
        = cmmLintErr (hang (text "expression is not a conditional:") 2
                             (ppr expr))

    -- -----------------------------------------------------------------------------
    -- CmmLint monad

    -- just a basic error monad:

    newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }

    instance Functor CmmLint where
          fmap = liftM

    instance Applicative CmmLint where
          pure a = CmmLint (\_ -> Right a)
          (<*>) = ap

    instance Monad CmmLint where
      CmmLint m >>= k = CmmLint $ \dflags ->
                                    case m dflags of
                                    Left e -> Left e
                                    Right a -> unCL (k a) dflags

    instance HasDynFlags CmmLint where
        getDynFlags = CmmLint (\dflags -> Right dflags)

    cmmLintErr :: SDoc -> CmmLint a
    cmmLintErr msg = CmmLint (\_ -> Left msg)

    addLintInfo :: SDoc -> CmmLint a -> CmmLint a
    addLintInfo info thing = CmmLint $ \dflags ->
       case unCL thing dflags of
            Left err -> Left (hang info 2 err)
            Right a  -> Right a

    cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
    cmmLintMachOpErr expr argsRep opExpectsRep
         = cmmLintErr (text "in MachOp application: " $$
                       nest 2 (ppr  expr) $$
                          (text "op is expecting: " <+> ppr opExpectsRep) $$
                          (text "arguments provide: " <+> ppr argsRep))

    cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
    cmmLintAssignErr stmt e_ty r_ty
      = cmmLintErr (text "in assignment: " $$
                    nest 2 (vcat [ppr 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))
    -}