allow build settings to be overriden by adding mk/validate.mk
[ghc-hetmet.git] / compiler / cmm / CmmLint.hs
index 83444e5..130dba0 100644 (file)
@@ -1,8 +1,8 @@
 -----------------------------------------------------------------------------
 --
--- CmmLint: checking the correctness of Cmm statements and expressions
+-- (c) The University of Glasgow 2004-2006
 --
--- (c) The University of Glasgow 2004
+-- CmmLint: checking the correctness of Cmm statements and expressions
 --
 -----------------------------------------------------------------------------
 
@@ -13,22 +13,22 @@ module CmmLint (
 #include "HsVersions.h"
 
 import Cmm
-import CLabel          ( pprCLabel )
+import CLabel
 import MachOp
 import Outputable
 import PprCmm
-import Unique          ( getUnique )
-import Constants       ( wORD_SIZE )
+import Unique
+import Constants
 
-import Monad           ( when )
+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
@@ -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: " $$