X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmLint.hs;h=7069457a40e6d35e6d57d68256ba11161b21193c;hb=022fc24719ba4b98b8d9f19bfe7f75dd0f19d585;hp=632337fbeb2d814d7f591affdccd443de36bffc6;hpb=2a2f7ba65a4ed59f6690751d0c096c7484fa8101;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 632337f..7069457 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -25,10 +25,10 @@ import Control.Monad
 -- -----------------------------------------------------------------------------
 -- Exported entry points:
 
-cmmLint :: Cmm -> Maybe SDoc
+cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
 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
@@ -37,7 +37,7 @@ runCmmLint l =
 	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
@@ -88,7 +88,8 @@ cmmCheckMachOp op args
   = 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
@@ -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 _)])
-  | 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])
-  | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
   = 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
@@ -117,9 +122,13 @@ lintCmmStmt (CmmStore l r) = do
   lintCmmExpr l
   lintCmmExpr r
   return ()
-lintCmmStmt (CmmCall _target _res args _vols) = 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) = lintCmmExpr e >> return ()
+lintCmmStmt (CmmSwitch e _branches) = do
+  erep <- lintCmmExpr e
+  if (erep == wordRep)
+    then return ()
+    else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
 lintCmmStmt (CmmJump e _args)       = lintCmmExpr e >> return ()
 lintCmmStmt _other 		    = return ()