1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2004-2006
5 -- CmmLint: checking the correctness of Cmm statements and expressions
7 -----------------------------------------------------------------------------
13 #include "HsVersions.h"
25 -- -----------------------------------------------------------------------------
26 -- Exported entry points:
28 cmmLint :: Cmm -> Maybe SDoc
29 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
31 cmmLintTop :: CmmTop -> Maybe SDoc
32 cmmLintTop top = runCmmLint $ lintCmmTop top
34 runCmmLint :: CmmLint a -> Maybe SDoc
37 Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
40 lintCmmTop (CmmProc _info lbl _args blocks)
41 = addLintInfo (text "in proc " <> pprCLabel lbl) $
42 mapM_ lintCmmBlock blocks
46 lintCmmBlock (BasicBlock id stmts)
47 = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
48 mapM_ lintCmmStmt stmts
50 -- -----------------------------------------------------------------------------
53 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
54 -- byte/word mismatches.
56 lintCmmExpr :: CmmExpr -> CmmLint MachRep
57 lintCmmExpr (CmmLoad expr rep) = do
59 when (machRepByteWidth rep >= wORD_SIZE) $
60 cmmCheckWordAddress expr
62 lintCmmExpr expr@(CmmMachOp op args) = do
63 mapM_ lintCmmExpr args
64 if map cmmExprRep args == machOpArgReps op
65 then cmmCheckMachOp op args
66 else cmmLintMachOpErr expr
67 lintCmmExpr (CmmRegOff reg offset)
68 = lintCmmExpr (CmmMachOp (MO_Add rep)
69 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
70 where rep = cmmRegRep reg
71 lintCmmExpr lit@(CmmLit (CmmInt _ rep))
73 = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
75 return (cmmExprRep expr)
77 -- Check for some common byte/word mismatches (eg. Sp + 1)
78 cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
79 | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
80 = cmmLintDubiousWordOffset (CmmMachOp op args)
81 cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
82 = cmmCheckMachOp op [reg, lit]
83 cmmCheckMachOp op@(MO_U_Conv from to) args
84 | isFloatingRep from || isFloatingRep to
85 = cmmLintErr (text "unsigned conversion from/to floating rep: "
86 <> ppr (CmmMachOp op args))
87 cmmCheckMachOp op args
88 = return (resultRepOfMachOp op)
90 isWordOffsetReg (CmmGlobal Sp) = True
91 isWordOffsetReg (CmmGlobal Hp) = True
92 isWordOffsetReg _ = False
94 isOffsetOp (MO_Add _) = True
95 isOffsetOp (MO_Sub _) = True
98 -- This expression should be an address from which a word can be loaded:
99 -- check for funny-looking sub-word offsets.
100 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
101 | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
102 = cmmLintDubiousWordOffset e
103 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
104 | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
105 = cmmLintDubiousWordOffset e
106 cmmCheckWordAddress _
110 lintCmmStmt :: CmmStmt -> CmmLint ()
111 lintCmmStmt stmt@(CmmAssign reg expr) = do
112 erep <- lintCmmExpr expr
113 if (erep == cmmRegRep reg)
115 else cmmLintAssignErr stmt
116 lintCmmStmt (CmmStore l r) = do
120 lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
121 lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
122 lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return ()
123 lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return ()
124 lintCmmStmt _other = return ()
126 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
127 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
130 -- -----------------------------------------------------------------------------
133 -- just a basic error monad:
135 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
137 instance Monad CmmLint where
138 CmmLint m >>= k = CmmLint $ case m of
140 Right a -> unCL (k a)
141 return a = CmmLint (Right a)
143 cmmLintErr :: SDoc -> CmmLint a
144 cmmLintErr msg = CmmLint (Left msg)
146 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
147 addLintInfo info thing = CmmLint $
149 Left err -> Left (hang info 2 err)
152 cmmLintMachOpErr :: CmmExpr -> CmmLint a
153 cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$
154 nest 2 (pprExpr expr))
156 cmmLintAssignErr :: CmmStmt -> CmmLint a
157 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
158 nest 2 (pprStmt stmt))
160 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
161 cmmLintDubiousWordOffset expr
162 = cmmLintErr (text "offset is not a multiple of words: " $$
163 nest 2 (pprExpr expr))