X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmLint.hs;h=7c8f2b3ce45ed1c2decb6cd6f216c4ef7010c6f2;hp=a849924af6853b093c48cad4d87d6f0bdf8eb941;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4

diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index a849924..7c8f2b3 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
@@ -17,42 +16,51 @@ module CmmLint (
   cmmLint, cmmLintTop
   ) where
 
-#include "HsVersions.h"
-
+import BlockId
 import Cmm
 import CLabel
-import MachOp
+import Maybe
 import Outputable
 import PprCmm
 import Unique
 import Constants
+import FastString
 
 import Control.Monad
 
 -- -----------------------------------------------------------------------------
 -- Exported entry points:
 
-cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
-cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
-
-cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
-cmmLintTop top = runCmmLint $ lintCmmTop top
-
-runCmmLint :: CmmLint a -> Maybe SDoc
-runCmmLint l = 
-   case unCL l of
-	Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
-	Right _  -> Nothing
-
-lintCmmTop (CmmProc _ lbl _ blocks)
+cmmLint :: (Outputable d, Outputable h)
+	=> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
+cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops
+
+cmmLintTop :: (Outputable d, Outputable h)
+	   => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
+cmmLintTop top = runCmmLint lintCmmTop top
+
+runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint l p = 
+   case unCL (l p) of
+	Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
+				nest 2 err,
+				ptext $ sLit ("Program was:"),
+				nest 2 (ppr p)])
+  	Right _  -> Nothing
+
+lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
+lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
   = addLintInfo (text "in proc " <> pprCLabel lbl) $
-	mapM_ lintCmmBlock blocks
-lintCmmTop _other
+        let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
+	in  mapM_ (lintCmmBlock labels) blocks
+
+lintCmmTop (CmmData {})
   = return ()
 
-lintCmmBlock (BasicBlock id stmts)
+lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
+lintCmmBlock labels (BasicBlock id stmts)
   = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
-	mapM_ lintCmmStmt stmts
+	mapM_ (lintCmmStmt labels) stmts
 
 -- -----------------------------------------------------------------------------
 -- lintCmmExpr
@@ -60,51 +68,48 @@ lintCmmBlock (BasicBlock id stmts)
 -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
 -- byte/word mismatches.
 
-lintCmmExpr :: CmmExpr -> CmmLint MachRep
+lintCmmExpr :: CmmExpr -> CmmLint CmmType
 lintCmmExpr (CmmLoad expr rep) = do
   lintCmmExpr expr
-  when (machRepByteWidth rep >= wORD_SIZE) $
+  when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
      cmmCheckWordAddress expr
   return rep
 lintCmmExpr expr@(CmmMachOp op args) = do
-  mapM_ lintCmmExpr args
-  if map cmmExprRep args == machOpArgReps op
-  	then cmmCheckMachOp op args
-	else cmmLintMachOpErr expr (map cmmExprRep args) (machOpArgReps op)
+  tys <- mapM lintCmmExpr args
+  if map (typeWidth . cmmExprType) args == machOpArgReps op
+  	then cmmCheckMachOp op args tys
+	else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
 lintCmmExpr (CmmRegOff reg offset)
-  = lintCmmExpr (CmmMachOp (MO_Add rep) 
+  = lintCmmExpr (CmmMachOp (MO_Add rep)
 		[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
-  where rep = cmmRegRep reg
-lintCmmExpr lit@(CmmLit (CmmInt _ rep))
-  | isFloatingRep rep
-  = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
+  where rep = typeWidth (cmmRegType reg)
 lintCmmExpr expr = 
-  return (cmmExprRep expr)
+  return (cmmExprType expr)
 
 -- Check for some common byte/word mismatches (eg. Sp + 1)
-cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)]
+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 i _)), reg@(CmmReg _)]
-  = cmmCheckMachOp op [reg, lit]
-cmmCheckMachOp op@(MO_U_Conv from to) args
-  | isFloatingRep from || isFloatingRep to
-  = cmmLintErr (text "unsigned conversion from/to floating rep: " 
-		<> ppr (CmmMachOp op args))
-cmmCheckMachOp op args
-  = return (resultRepOfMachOp op)
+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 _ = False
 
 -- 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 _)])
   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
   = cmmLintDubiousWordOffset e
@@ -116,29 +121,46 @@ cmmCheckWordAddress _
 
 -- No warnings for unaligned arithmetic with the node register,
 -- which is used to extract fields from tagged constructor closures.
+notNodeReg :: CmmExpr -> Bool
 notNodeReg (CmmReg reg) | reg == nodeReg = False
 notNodeReg _                             = True
 
-lintCmmStmt :: CmmStmt -> CmmLint ()
-lintCmmStmt stmt@(CmmAssign reg expr) = do
-  erep <- lintCmmExpr expr
-  if (erep == cmmRegRep reg)
-	then return ()
-	else cmmLintAssignErr stmt
-lintCmmStmt (CmmStore l r) = do
-  lintCmmExpr l
-  lintCmmExpr r
-  return ()
-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
-  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 ()
-
+lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
+lintCmmStmt labels = lint
+    where lint (CmmNop) = return ()
+          lint (CmmComment {}) = return ()
+          lint stmt@(CmmAssign reg expr) = do
+            erep <- lintCmmExpr expr
+	    let reg_ty = cmmRegType reg
+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
+                then return ()
+                else cmmLintAssignErr stmt erep reg_ty
+          lint (CmmStore l r) = do
+            lintCmmExpr l
+            lintCmmExpr r
+            return ()
+          lint (CmmCall target _res args _ _) =
+              lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
+          lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
+          lint (CmmSwitch e branches) = do
+            mapM_ checkTarget $ catMaybes branches
+            erep <- lintCmmExpr e
+            if (erep `cmmEqType_ignoring_ptrhood` bWord)
+              then return ()
+              else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
+                               text " :: " <> ppr erep)
+          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 ()
+                           else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
+
+lintTarget :: CmmCallTarget -> CmmLint ()
+lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
+lintTarget (CmmPrim {})    = return ()
+
+
+checkCond :: CmmExpr -> CmmLint ()
 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
 				    (ppr expr))
@@ -165,16 +187,21 @@ addLintInfo info thing = CmmLint $
 	Left err -> Left (hang info 2 err)
 	Right a  -> Right a
 
-cmmLintMachOpErr :: CmmExpr -> [MachRep] -> [MachRep] -> CmmLint a
+cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> 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: " $$ 
-					nest 2 (pprStmt stmt))
+cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
+cmmLintAssignErr stmt e_ty r_ty
+  = cmmLintErr (text "in assignment: " $$ 
+		nest 2 (vcat [pprStmt stmt, 
+			      text "Reg ty:" <+> ppr r_ty,
+			      text "Rhs ty:" <+> ppr e_ty]))
+			 
+					
 
 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 cmmLintDubiousWordOffset expr