projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
fix haddock submodule pointer
[ghc-hetmet.git]
/
compiler
/
cmm
/
CmmLint.hs
diff --git
a/compiler/cmm/CmmLint.hs
b/compiler/cmm/CmmLint.hs
index
7c8f2b3
..
32fead3
100644
(file)
--- a/
compiler/cmm/CmmLint.hs
+++ b/
compiler/cmm/CmmLint.hs
@@
-17,16
+17,14
@@
module CmmLint (
) where
import BlockId
) where
import BlockId
-import Cmm
+import OldCmm
import CLabel
import CLabel
-import Maybe
import Outputable
import Outputable
-import PprCmm
-import Unique
+import OldPprCmm()
import Constants
import FastString
import Constants
import FastString
-import Control.Monad
+import Data.Maybe
-- -----------------------------------------------------------------------------
-- Exported entry points:
-- -----------------------------------------------------------------------------
-- Exported entry points:
@@
-49,9
+47,9
@@
runCmmLint l p =
Right _ -> Nothing
lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
Right _ -> Nothing
lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
-lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
+lintCmmTop (CmmProc _ lbl (ListGraph blocks))
= addLintInfo (text "in proc " <> pprCLabel lbl) $
= addLintInfo (text "in proc " <> pprCLabel lbl) $
- let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
+ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
in mapM_ (lintCmmBlock labels) blocks
lintCmmTop (CmmData {})
in mapM_ (lintCmmBlock labels) blocks
lintCmmTop (CmmData {})
@@
-59,7
+57,7
@@
lintCmmTop (CmmData {})
lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock labels (BasicBlock id stmts)
lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock labels (BasicBlock id stmts)
- = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
+ = addLintInfo (text "in basic block " <> ppr id) $
mapM_ (lintCmmStmt labels) stmts
-- -----------------------------------------------------------------------------
mapM_ (lintCmmStmt labels) stmts
-- -----------------------------------------------------------------------------
@@
-70,9
+68,11
@@
lintCmmBlock labels (BasicBlock id stmts)
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr (CmmLoad expr rep) = do
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr (CmmLoad expr rep) = do
- lintCmmExpr expr
- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
- cmmCheckWordAddress expr
+ _ <- lintCmmExpr expr
+ -- Disabled, if we have the inlining phase before the lint phase,
+ -- we can have funny offsets due to pointer tagging. -- EZY
+ -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
+ -- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
tys <- mapM lintCmmExpr args
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
tys <- mapM lintCmmExpr args
@@
-88,20
+88,11
@@
lintCmmExpr expr =
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
-cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)] _
- | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
- = cmmLintDubiousWordOffset (CmmMachOp op args)
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
= return (machOpResultType op tys)
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
= return (machOpResultType op tys)
-isWordOffsetReg :: CmmReg -> Bool
-isWordOffsetReg (CmmGlobal Sp) = True
--- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
---isWordOffsetReg (CmmGlobal Hp) = True
-isWordOffsetReg _ = False
-
isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
@@
-109,14
+100,14
@@
isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
-cmmCheckWordAddress :: CmmExpr -> CmmLint ()
-cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
+_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
+_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
-cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
+_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
-cmmCheckWordAddress _
+_cmmCheckWordAddress _
= return ()
-- No warnings for unaligned arithmetic with the node register,
= return ()
-- No warnings for unaligned arithmetic with the node register,
@@
-136,8
+127,8
@@
lintCmmStmt labels = lint
then return ()
else cmmLintAssignErr stmt erep reg_ty
lint (CmmStore l r) = do
then return ()
else cmmLintAssignErr stmt erep reg_ty
lint (CmmStore l r) = do
- lintCmmExpr l
- lintCmmExpr r
+ _ <- lintCmmExpr l
+ _ <- lintCmmExpr r
return ()
lint (CmmCall target _res args _ _) =
lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
return ()
lint (CmmCall target _res args _ _) =
lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
@@
-152,7
+143,7
@@
lintCmmStmt labels = lint
lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
lint (CmmBranch id) = checkTarget id
lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
lint (CmmBranch id) = checkTarget id
- checkTarget id = if elemBlockSet id labels then return ()
+ checkTarget id = if setMember id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget :: CmmCallTarget -> CmmLint ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget :: CmmCallTarget -> CmmLint ()
@@
-162,6
+153,7
@@
lintTarget (CmmPrim {}) = return ()
checkCond :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
@@
-190,14
+182,14
@@
addLintInfo info thing = CmmLint $
cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr expr argsRep opExpectsRep
= cmmLintErr (text "in MachOp application: " $$
cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr expr argsRep opExpectsRep
= cmmLintErr (text "in MachOp application: " $$
- nest 2 (pprExpr expr) $$
+ nest 2 (ppr expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep))
cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr stmt e_ty r_ty
= cmmLintErr (text "in assignment: " $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep))
cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr stmt e_ty r_ty
= cmmLintErr (text "in assignment: " $$
- nest 2 (vcat [pprStmt stmt,
+ nest 2 (vcat [ppr stmt,
text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty]))
text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty]))
@@
-206,4
+198,4
@@
cmmLintAssignErr stmt e_ty r_ty
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$
- nest 2 (pprExpr expr))
+ nest 2 (ppr expr))