2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
8 -----------------------------------------------------------------------------
10 -- (c) The University of Glasgow 2004-2006
12 -- CmmLint: checking the correctness of Cmm statements and expressions
14 -----------------------------------------------------------------------------
20 #include "HsVersions.h"
32 -- -----------------------------------------------------------------------------
33 -- Exported entry points:
35 cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
36 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
38 cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
39 cmmLintTop top = runCmmLint $ lintCmmTop top
41 runCmmLint :: CmmLint a -> Maybe SDoc
44 Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
47 lintCmmTop (CmmProc _ lbl _ blocks)
48 = addLintInfo (text "in proc " <> pprCLabel lbl) $
49 mapM_ lintCmmBlock blocks
53 lintCmmBlock (BasicBlock id stmts)
54 = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
55 mapM_ lintCmmStmt stmts
57 -- -----------------------------------------------------------------------------
60 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
61 -- byte/word mismatches.
63 lintCmmExpr :: CmmExpr -> CmmLint MachRep
64 lintCmmExpr (CmmLoad expr rep) = do
66 when (machRepByteWidth rep >= wORD_SIZE) $
67 cmmCheckWordAddress expr
69 lintCmmExpr expr@(CmmMachOp op args) = do
70 mapM_ lintCmmExpr args
71 if map cmmExprRep args == machOpArgReps op
72 then cmmCheckMachOp op args
73 else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
74 lintCmmExpr (CmmRegOff reg offset)
75 = lintCmmExpr (CmmMachOp (MO_Add rep)
76 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
77 where rep = cmmRegRep reg
78 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
80 = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
82 return (cmmExprRep expr)
84 -- Check for some common byte/word mismatches (eg. Sp + 1)
85 cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
86 | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
87 = cmmLintDubiousWordOffset (CmmMachOp op args)
88 cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
89 = cmmCheckMachOp op [reg, lit]
90 cmmCheckMachOp op@(MO_U_Conv from to) args
91 | isFloatingRep from || isFloatingRep to
92 = cmmLintErr (text "unsigned conversion from/to floating rep: "
93 <> ppr (CmmMachOp op args))
94 cmmCheckMachOp op args
95 = return (resultRepOfMachOp op)
97 isWordOffsetReg (CmmGlobal Sp) = True
98 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
99 --isWordOffsetReg (CmmGlobal Hp) = True
100 isWordOffsetReg _ = False
102 isOffsetOp (MO_Add _) = True
103 isOffsetOp (MO_Sub _) = True
106 -- This expression should be an address from which a word can be loaded:
107 -- check for funny-looking sub-word offsets.
108 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
109 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
110 = cmmLintDubiousWordOffset e
111 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
112 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
113 = cmmLintDubiousWordOffset e
114 cmmCheckWordAddress _
117 -- No warnings for unaligned arithmetic with the node register,
118 -- which is used to extract fields from tagged constructor closures.
119 notNodeReg (CmmReg reg) | reg == nodeReg = False
122 lintCmmStmt :: CmmStmt -> CmmLint ()
123 lintCmmStmt stmt@(CmmAssign reg expr) = do
124 erep <- lintCmmExpr expr
125 if (erep == cmmRegRep reg)
127 else cmmLintAssignErr stmt
128 lintCmmStmt (CmmStore l r) = do
132 lintCmmStmt (CmmCall _target _res args _ _) = mapM_ (lintCmmExpr.fst) args
133 lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
134 lintCmmStmt (CmmSwitch e _branches) = do
135 erep <- lintCmmExpr e
138 else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
139 lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return ()
140 lintCmmStmt _other = return ()
142 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
143 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
146 -- -----------------------------------------------------------------------------
149 -- just a basic error monad:
151 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
153 instance Monad CmmLint where
154 CmmLint m >>= k = CmmLint $ case m of
156 Right a -> unCL (k a)
157 return a = CmmLint (Right a)
159 cmmLintErr :: SDoc -> CmmLint a
160 cmmLintErr msg = CmmLint (Left msg)
162 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
163 addLintInfo info thing = CmmLint $
165 Left err -> Left (hang info 2 err)
168 cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
169 cmmLintMachOpErr expr argsRep opExpectsRep
170 = cmmLintErr (text "in MachOp application: " $$
171 nest 2 (pprExpr expr) $$
172 (text "op is expecting: " <+> ppr opExpectsRep) $$
173 (text "arguments provide: " <+> ppr argsRep))
175 cmmLintAssignErr :: CmmStmt -> CmmLint a
176 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
177 nest 2 (pprStmt stmt))
179 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
180 cmmLintDubiousWordOffset expr
181 = cmmLintErr (text "offset is not a multiple of words: " $$
182 nest 2 (pprExpr expr))