-{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
cmmLint, cmmLintTop
) where
-#include "HsVersions.h"
-
+import BlockId
import Cmm
import CLabel
import MachOp
import PprCmm
import Unique
import Constants
+import FastString
import Control.Monad
runCmmLint :: CmmLint a -> Maybe SDoc
runCmmLint l =
case unCL l of
- Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
+ Left err -> Just (ptext (sLit "Cmm lint error:") $$ nest 2 err)
Right _ -> Nothing
lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmTop (CmmData {})
= return ()
+lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr (getUnique id)) $
mapM_ (lintCmmStmt labels) stmts
return (cmmExprRep expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
+cmmCheckMachOp :: MachOp -> [CmmExpr] -> CmmLint MachRep
cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
| isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset (CmmMachOp op args)
cmmCheckMachOp op _args
= return (resultRepOfMachOp op)
+isWordOffsetReg :: CmmReg -> Bool
isWordOffsetReg (CmmGlobal Sp) = True
-- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
--isWordOffsetReg (CmmGlobal Hp) = True
isWordOffsetReg _ = False
+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 /= 0
= cmmLintDubiousWordOffset e
-- 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
lintCmmExpr r
return ()
lint (CmmCall target _res args _ _) =
- lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
+ lintTarget target >> mapM_ (lintCmmExpr . kindlessCmm) args
lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches
if (erep == wordRep)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
- lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
- lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
+ lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . kindlessCmm) args
+ lint (CmmReturn ress) = mapM_ (lintCmmExpr . kindlessCmm) ress
lint (CmmBranch id) = checkTarget id
checkTarget id = if elemBlockSet id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget (CmmPrim {}) = return ()
+checkCond :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))