X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmLint.hs;h=0812347c06335220c774cc314aaf9a8966efd172;hb=bd3a364da7956c269d31645995d0d775c52f6a84;hp=80ad9ef49d6f406b250bffa1365bea183ded5490;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 80ad9ef..0812347 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -63,7 +63,7 @@ lintCmmExpr expr@(CmmMachOp op args) = do
   mapM_ lintCmmExpr args
   if map cmmExprRep args == machOpArgReps op
   	then cmmCheckMachOp op args
-	else cmmLintMachOpErr expr
+	else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
 lintCmmExpr (CmmRegOff reg offset)
   = lintCmmExpr (CmmMachOp (MO_Add rep) 
 		[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
@@ -117,9 +117,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 ()
 
@@ -149,9 +153,12 @@ addLintInfo info thing = CmmLint $
 	Left err -> Left (hang info 2 err)
 	Right a  -> Right a
 
-cmmLintMachOpErr :: CmmExpr -> CmmLint a
-cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$ 
-					nest 2 (pprExpr expr))
+cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
+cmmLintMachOpErr expr argsRep opExpectsRep
+     = cmmLintErr (text "in MachOp application: " $$ 
+					nest 2 (pprExpr expr) $$
+				        (text "op is expecting: " <+> ppr opExpectsRep) $$
+					(text "arguments provide: " <+> ppr argsRep))
 
 cmmLintAssignErr :: CmmStmt -> CmmLint a
 cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$