projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
convert to use System.FilePath
[ghc-hetmet.git]
/
compiler
/
cmm
/
CmmLint.hs
diff --git
a/compiler/cmm/CmmLint.hs
b/compiler/cmm/CmmLint.hs
index
fd4a99c
..
7069457
100644
(file)
--- a/
compiler/cmm/CmmLint.hs
+++ b/
compiler/cmm/CmmLint.hs
@@
-25,10
+25,10
@@
import Control.Monad
-- -----------------------------------------------------------------------------
-- Exported entry points:
-- -----------------------------------------------------------------------------
-- Exported entry points:
-cmmLint :: Cmm -> Maybe SDoc
+cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
-cmmLintTop :: CmmTop -> Maybe SDoc
+cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
cmmLintTop top = runCmmLint $ lintCmmTop top
runCmmLint :: CmmLint a -> Maybe SDoc
cmmLintTop top = runCmmLint $ lintCmmTop top
runCmmLint :: CmmLint a -> Maybe SDoc
@@
-37,7
+37,7
@@
runCmmLint l =
Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
Right _ -> Nothing
Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
Right _ -> Nothing
-lintCmmTop (CmmProc _info lbl _args blocks)
+lintCmmTop (CmmProc _ lbl _ blocks)
= addLintInfo (text "in proc " <> pprCLabel lbl) $
mapM_ lintCmmBlock blocks
lintCmmTop _other
= addLintInfo (text "in proc " <> pprCLabel lbl) $
mapM_ lintCmmBlock blocks
lintCmmTop _other
@@
-88,7
+88,8
@@
cmmCheckMachOp op args
= return (resultRepOfMachOp op)
isWordOffsetReg (CmmGlobal Sp) = True
= return (resultRepOfMachOp op)
isWordOffsetReg (CmmGlobal Sp) = True
-isWordOffsetReg (CmmGlobal Hp) = True
+-- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
+--isWordOffsetReg (CmmGlobal Hp) = True
isWordOffsetReg _ = False
isOffsetOp (MO_Add _) = True
isWordOffsetReg _ = False
isOffsetOp (MO_Add _) = True
@@
-98,14
+99,18
@@
isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
- | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
= cmmLintDubiousWordOffset e
cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
- | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
cmmCheckWordAddress _
= return ()
= cmmLintDubiousWordOffset e
cmmCheckWordAddress _
= return ()
+-- No warnings for unaligned arithmetic with the node register,
+-- which is used to extract fields from tagged constructor closures.
+notNodeReg (CmmReg reg) | reg == nodeReg = False
+notNodeReg _ = True
lintCmmStmt :: CmmStmt -> CmmLint ()
lintCmmStmt stmt@(CmmAssign reg expr) = do
lintCmmStmt :: CmmStmt -> CmmLint ()
lintCmmStmt stmt@(CmmAssign reg expr) = do
@@
-117,7
+122,7
@@
lintCmmStmt (CmmStore l r) = do
lintCmmExpr l
lintCmmExpr r
return ()
lintCmmExpr l
lintCmmExpr r
return ()
-lintCmmStmt (CmmCall _target _res args _) = mapM_ (lintCmmExpr.fst) args
+lintCmmStmt (CmmCall _target _res args _ _) = mapM_ (lintCmmExpr.fst) args
lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
lintCmmStmt (CmmSwitch e _branches) = do
erep <- lintCmmExpr e
lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
lintCmmStmt (CmmSwitch e _branches) = do
erep <- lintCmmExpr e