Add support for producing position-independent executables
[ghc.git] / compiler / cmm / CmmLint.hs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2011
4 --
5 -- CmmLint: checking the correctness of Cmm statements and expressions
6 --
7 -----------------------------------------------------------------------------
8 {-# LANGUAGE GADTs #-}
9 module CmmLint (
10 cmmLint, cmmLintGraph
11 ) where
12
13 import Hoopl.Block
14 import Hoopl.Collections
15 import Hoopl.Graph
16 import Hoopl.Label
17 import Cmm
18 import CmmUtils
19 import CmmLive
20 import CmmSwitch (switchTargetsToList)
21 import PprCmm ()
22 import Outputable
23 import DynFlags
24
25 import Control.Monad (liftM, ap)
26
27 -- Things to check:
28 -- - invariant on CmmBlock in CmmExpr (see comment there)
29 -- - check for branches to blocks that don't exist
30 -- - check types
31
32 -- -----------------------------------------------------------------------------
33 -- Exported entry points:
34
35 cmmLint :: (Outputable d, Outputable h)
36 => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
37 cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
38
39 cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
40 cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
41
42 runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
43 runCmmLint dflags l p =
44 case unCL (l p) dflags of
45 Left err -> Just (vcat [text "Cmm lint error:",
46 nest 2 err,
47 text "Program was:",
48 nest 2 (ppr p)])
49 Right _ -> Nothing
50
51 lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
52 lintCmmDecl dflags (CmmProc _ lbl _ g)
53 = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
54 lintCmmDecl _ (CmmData {})
55 = return ()
56
57
58 lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
59 lintCmmGraph dflags g =
60 cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks
61 -- cmmLiveness throws an error if there are registers
62 -- live on entry to the graph (i.e. undefined
63 -- variables)
64 where
65 blocks = toBlockList g
66 labels = setFromList (map entryLabel blocks)
67
68
69 lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
70 lintCmmBlock labels block
71 = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
72 let (_, middle, last) = blockSplit block
73 mapM_ lintCmmMiddle (blockToList middle)
74 lintCmmLast labels last
75
76 -- -----------------------------------------------------------------------------
77 -- lintCmmExpr
78
79 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
80 -- byte/word mismatches.
81
82 lintCmmExpr :: CmmExpr -> CmmLint CmmType
83 lintCmmExpr (CmmLoad expr rep) = do
84 _ <- lintCmmExpr expr
85 -- Disabled, if we have the inlining phase before the lint phase,
86 -- we can have funny offsets due to pointer tagging. -- EZY
87 -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
88 -- cmmCheckWordAddress expr
89 return rep
90 lintCmmExpr expr@(CmmMachOp op args) = do
91 dflags <- getDynFlags
92 tys <- mapM lintCmmExpr args
93 if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
94 then cmmCheckMachOp op args tys
95 else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
96 lintCmmExpr (CmmRegOff reg offset)
97 = do dflags <- getDynFlags
98 let rep = typeWidth (cmmRegType dflags reg)
99 lintCmmExpr (CmmMachOp (MO_Add rep)
100 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
101 lintCmmExpr expr =
102 do dflags <- getDynFlags
103 return (cmmExprType dflags expr)
104
105 -- Check for some common byte/word mismatches (eg. Sp + 1)
106 cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
107 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
108 = cmmCheckMachOp op [reg, lit] tys
109 cmmCheckMachOp op _ tys
110 = do dflags <- getDynFlags
111 return (machOpResultType dflags op tys)
112
113 {-
114 isOffsetOp :: MachOp -> Bool
115 isOffsetOp (MO_Add _) = True
116 isOffsetOp (MO_Sub _) = True
117 isOffsetOp _ = False
118
119 -- This expression should be an address from which a word can be loaded:
120 -- check for funny-looking sub-word offsets.
121 _cmmCheckWordAddress :: CmmExpr -> CmmLint ()
122 _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
123 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
124 = cmmLintDubiousWordOffset e
125 _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
126 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
127 = cmmLintDubiousWordOffset e
128 _cmmCheckWordAddress _
129 = return ()
130
131 -- No warnings for unaligned arithmetic with the node register,
132 -- which is used to extract fields from tagged constructor closures.
133 notNodeReg :: CmmExpr -> Bool
134 notNodeReg (CmmReg reg) | reg == nodeReg = False
135 notNodeReg _ = True
136 -}
137
138 lintCmmMiddle :: CmmNode O O -> CmmLint ()
139 lintCmmMiddle node = case node of
140 CmmComment _ -> return ()
141 CmmTick _ -> return ()
142 CmmUnwind{} -> return ()
143
144 CmmAssign reg expr -> do
145 dflags <- getDynFlags
146 erep <- lintCmmExpr expr
147 let reg_ty = cmmRegType dflags reg
148 if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
149 then return ()
150 else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
151
152 CmmStore l r -> do
153 _ <- lintCmmExpr l
154 _ <- lintCmmExpr r
155 return ()
156
157 CmmUnsafeForeignCall target _formals actuals -> do
158 lintTarget target
159 mapM_ lintCmmExpr actuals
160
161
162 lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
163 lintCmmLast labels node = case node of
164 CmmBranch id -> checkTarget id
165
166 CmmCondBranch e t f _ -> do
167 dflags <- getDynFlags
168 mapM_ checkTarget [t,f]
169 _ <- lintCmmExpr e
170 checkCond dflags e
171
172 CmmSwitch e ids -> do
173 dflags <- getDynFlags
174 mapM_ checkTarget $ switchTargetsToList ids
175 erep <- lintCmmExpr e
176 if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
177 then return ()
178 else cmmLintErr (text "switch scrutinee is not a word: " <>
179 ppr e <> text " :: " <> ppr erep)
180
181 CmmCall { cml_target = target, cml_cont = cont } -> do
182 _ <- lintCmmExpr target
183 maybe (return ()) checkTarget cont
184
185 CmmForeignCall tgt _ args succ _ _ _ -> do
186 lintTarget tgt
187 mapM_ lintCmmExpr args
188 checkTarget succ
189 where
190 checkTarget id
191 | setMember id labels = return ()
192 | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
193
194
195 lintTarget :: ForeignTarget -> CmmLint ()
196 lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
197 lintTarget (PrimTarget {}) = return ()
198
199
200 checkCond :: DynFlags -> CmmExpr -> CmmLint ()
201 checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
202 checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
203 checkCond _ expr
204 = cmmLintErr (hang (text "expression is not a conditional:") 2
205 (ppr expr))
206
207 -- -----------------------------------------------------------------------------
208 -- CmmLint monad
209
210 -- just a basic error monad:
211
212 newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
213
214 instance Functor CmmLint where
215 fmap = liftM
216
217 instance Applicative CmmLint where
218 pure a = CmmLint (\_ -> Right a)
219 (<*>) = ap
220
221 instance Monad CmmLint where
222 CmmLint m >>= k = CmmLint $ \dflags ->
223 case m dflags of
224 Left e -> Left e
225 Right a -> unCL (k a) dflags
226
227 instance HasDynFlags CmmLint where
228 getDynFlags = CmmLint (\dflags -> Right dflags)
229
230 cmmLintErr :: SDoc -> CmmLint a
231 cmmLintErr msg = CmmLint (\_ -> Left msg)
232
233 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
234 addLintInfo info thing = CmmLint $ \dflags ->
235 case unCL thing dflags of
236 Left err -> Left (hang info 2 err)
237 Right a -> Right a
238
239 cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
240 cmmLintMachOpErr expr argsRep opExpectsRep
241 = cmmLintErr (text "in MachOp application: " $$
242 nest 2 (ppr expr) $$
243 (text "op is expecting: " <+> ppr opExpectsRep) $$
244 (text "arguments provide: " <+> ppr argsRep))
245
246 cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
247 cmmLintAssignErr stmt e_ty r_ty
248 = cmmLintErr (text "in assignment: " $$
249 nest 2 (vcat [ppr stmt,
250 text "Reg ty:" <+> ppr r_ty,
251 text "Rhs ty:" <+> ppr e_ty]))
252
253
254 {-
255 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
256 cmmLintDubiousWordOffset expr
257 = cmmLintErr (text "offset is not a multiple of words: " $$
258 nest 2 (ppr expr))
259 -}
260