1 -- The above warning supression flag is a temporary kludge.
2 -- While working on this module you are encouraged to remove it and fix
3 -- any warnings in the module. See
4 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
7 -----------------------------------------------------------------------------
9 -- (c) The University of Glasgow 2004-2006
11 -- CmmLint: checking the correctness of Cmm statements and expressions
13 -----------------------------------------------------------------------------
30 -- -----------------------------------------------------------------------------
31 -- Exported entry points:
33 cmmLint :: (Outputable d, Outputable h)
34 => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
35 cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops
37 cmmLintTop :: (Outputable d, Outputable h)
38 => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
39 cmmLintTop top = runCmmLint lintCmmTop top
41 runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
44 Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
46 ptext $ sLit ("Program was:"),
50 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
51 lintCmmTop (CmmProc _ lbl (ListGraph blocks))
52 = addLintInfo (text "in proc " <> pprCLabel lbl) $
53 let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
54 in mapM_ (lintCmmBlock labels) blocks
56 lintCmmTop (CmmData {})
59 lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
60 lintCmmBlock labels (BasicBlock id stmts)
61 = addLintInfo (text "in basic block " <> ppr id) $
62 mapM_ (lintCmmStmt labels) stmts
64 -- -----------------------------------------------------------------------------
67 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
68 -- byte/word mismatches.
70 lintCmmExpr :: CmmExpr -> CmmLint CmmType
71 lintCmmExpr (CmmLoad expr rep) = do
73 when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
74 cmmCheckWordAddress expr
76 lintCmmExpr expr@(CmmMachOp op args) = do
77 tys <- mapM lintCmmExpr args
78 if map (typeWidth . cmmExprType) args == machOpArgReps op
79 then cmmCheckMachOp op args tys
80 else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
81 lintCmmExpr (CmmRegOff reg offset)
82 = lintCmmExpr (CmmMachOp (MO_Add rep)
83 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
84 where rep = typeWidth (cmmRegType reg)
86 return (cmmExprType expr)
88 -- Check for some common byte/word mismatches (eg. Sp + 1)
89 cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
90 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
91 = cmmCheckMachOp op [reg, lit] tys
92 cmmCheckMachOp op _ tys
93 = return (machOpResultType op tys)
95 isOffsetOp :: MachOp -> Bool
96 isOffsetOp (MO_Add _) = True
97 isOffsetOp (MO_Sub _) = True
100 -- This expression should be an address from which a word can be loaded:
101 -- check for funny-looking sub-word offsets.
102 cmmCheckWordAddress :: CmmExpr -> CmmLint ()
103 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
104 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
105 = cmmLintDubiousWordOffset e
106 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
107 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
108 = cmmLintDubiousWordOffset e
109 cmmCheckWordAddress _
112 -- No warnings for unaligned arithmetic with the node register,
113 -- which is used to extract fields from tagged constructor closures.
114 notNodeReg :: CmmExpr -> Bool
115 notNodeReg (CmmReg reg) | reg == nodeReg = False
118 lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
119 lintCmmStmt labels = lint
120 where lint (CmmNop) = return ()
121 lint (CmmComment {}) = return ()
122 lint stmt@(CmmAssign reg expr) = do
123 erep <- lintCmmExpr expr
124 let reg_ty = cmmRegType reg
125 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
127 else cmmLintAssignErr stmt erep reg_ty
128 lint (CmmStore l r) = do
132 lint (CmmCall target _res args _ _) =
133 lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
134 lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
135 lint (CmmSwitch e branches) = do
136 mapM_ checkTarget $ catMaybes branches
137 erep <- lintCmmExpr e
138 if (erep `cmmEqType_ignoring_ptrhood` bWord)
140 else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
141 text " :: " <> ppr erep)
142 lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
143 lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
144 lint (CmmBranch id) = checkTarget id
145 checkTarget id = if setMember id labels then return ()
146 else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
148 lintTarget :: CmmCallTarget -> CmmLint ()
149 lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
150 lintTarget (CmmPrim {}) = return ()
153 checkCond :: CmmExpr -> CmmLint ()
154 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
155 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
158 -- -----------------------------------------------------------------------------
161 -- just a basic error monad:
163 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
165 instance Monad CmmLint where
166 CmmLint m >>= k = CmmLint $ case m of
168 Right a -> unCL (k a)
169 return a = CmmLint (Right a)
171 cmmLintErr :: SDoc -> CmmLint a
172 cmmLintErr msg = CmmLint (Left msg)
174 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
175 addLintInfo info thing = CmmLint $
177 Left err -> Left (hang info 2 err)
180 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
181 cmmLintMachOpErr expr argsRep opExpectsRep
182 = cmmLintErr (text "in MachOp application: " $$
184 (text "op is expecting: " <+> ppr opExpectsRep) $$
185 (text "arguments provide: " <+> ppr argsRep))
187 cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
188 cmmLintAssignErr stmt e_ty r_ty
189 = cmmLintErr (text "in assignment: " $$
190 nest 2 (vcat [ppr stmt,
191 text "Reg ty:" <+> ppr r_ty,
192 text "Rhs ty:" <+> ppr e_ty]))
196 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
197 cmmLintDubiousWordOffset expr
198 = cmmLintErr (text "offset is not a multiple of words: " $$