1 -----------------------------------------------------------------------------
3 -- CmmLint: checking the correctness of Cmm statements and expressions
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
13 #include "HsVersions.h"
16 import CLabel ( pprCLabel )
20 import Unique ( getUnique )
21 import Constants ( wORD_SIZE )
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
72 return (cmmExprRep expr)
74 -- Check for some common byte/word mismatches (eg. Sp + 1)
75 cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
76 | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
77 = cmmLintDubiousWordOffset (CmmMachOp op args)
78 cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
79 = cmmCheckMachOp op [reg, lit]
80 cmmCheckMachOp op args
81 = return (resultRepOfMachOp op)
83 isWordOffsetReg (CmmGlobal Sp) = True
84 isWordOffsetReg (CmmGlobal Hp) = True
85 isWordOffsetReg _ = False
87 isOffsetOp (MO_Add _) = True
88 isOffsetOp (MO_Sub _) = True
91 -- This expression should be an address from which a word can be loaded:
92 -- check for funny-looking sub-word offsets.
93 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
94 | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
95 = cmmLintDubiousWordOffset e
96 cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
97 | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
98 = cmmLintDubiousWordOffset e
103 lintCmmStmt :: CmmStmt -> CmmLint ()
104 lintCmmStmt stmt@(CmmAssign reg expr) = do
105 erep <- lintCmmExpr expr
106 if (erep == cmmRegRep reg)
108 else cmmLintAssignErr stmt
109 lintCmmStmt (CmmStore l r) = do
113 lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
114 lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> return ()
115 lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return ()
116 lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return ()
117 lintCmmStmt _other = return ()
119 -- -----------------------------------------------------------------------------
122 -- just a basic error monad:
124 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
126 instance Monad CmmLint where
127 CmmLint m >>= k = CmmLint $ case m of
129 Right a -> unCL (k a)
130 return a = CmmLint (Right a)
132 cmmLintErr :: SDoc -> CmmLint a
133 cmmLintErr msg = CmmLint (Left msg)
135 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
136 addLintInfo info thing = CmmLint $
138 Left err -> Left (hang info 2 err)
141 cmmLintMachOpErr :: CmmExpr -> CmmLint a
142 cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$
143 nest 2 (pprExpr expr))
145 cmmLintAssignErr :: CmmStmt -> CmmLint a
146 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
147 nest 2 (pprStmt stmt))
149 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
150 cmmLintDubiousWordOffset expr
151 = cmmLintErr (text "offset is not a multiple of words: " $$
152 nest 2 (pprExpr expr))