add a comment
[ghc.git] / compiler / cmm / CmmLint.hs
index 4b63346..970ce68 100644 (file)
@@ -1,58 +1,77 @@
-{-# 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
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 -----------------------------------------------------------------------------
 --
--- (c) The University of Glasgow 2004-2006
+-- (c) The University of Glasgow 2011
 --
 -- CmmLint: checking the correctness of Cmm statements and expressions
 --
 -----------------------------------------------------------------------------
-
+{-# LANGUAGE GADTs #-}
 module CmmLint (
-  cmmLint, cmmLintTop
+    cmmLint, cmmLintGraph
   ) where
 
-#include "HsVersions.h"
-
+import Hoopl
 import Cmm
-import CLabel
-import MachOp
+import CmmUtils
+import CmmLive
+import PprCmm ()
+import BlockId
+import FastString
 import Outputable
-import PprCmm
-import Unique
-import Constants
+import DynFlags
+
+import Data.Maybe
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
 
-import Control.Monad
+-- Things to check:
+--     - invariant on CmmBlock in CmmExpr (see comment there)
+--     - check for branches to blocks that don't exist
+--     - check types
 
 -- -----------------------------------------------------------------------------
 -- Exported entry points:
 
-cmmLint :: GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
+cmmLint :: (Outputable d, Outputable h)
+        => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
 
-cmmLintTop :: GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLintTop top = runCmmLint $ lintCmmTop top
+cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
+cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
 
-runCmmLint :: CmmLint a -> Maybe SDoc
-runCmmLint l = 
-   case unCL l of
-       Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
-       Right _  -> Nothing
+runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint dflags l p =
+   case unCL (l p) dflags of
+     Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
+                             nest 2 err,
+                             ptext $ sLit ("Program was:"),
+                             nest 2 (ppr p)])
+     Right _  -> Nothing
 
-lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
-  = addLintInfo (text "in proc " <> pprCLabel lbl) $
-       mapM_ lintCmmBlock blocks
-lintCmmTop _other
+lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
+lintCmmDecl dflags (CmmProc _ lbl _ g)
+  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
+lintCmmDecl _ (CmmData {})
   = return ()
 
-lintCmmBlock (BasicBlock id stmts)
-  = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
-       mapM_ lintCmmStmt stmts
+
+lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
+lintCmmGraph dflags g =
+    cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks
+    -- cmmLiveness throws an error if there are registers
+    -- live on entry to the graph (i.e. undefined
+    -- variables)
+  where
+       blocks = toBlockList g
+       labels = setFromList (map entryLabel blocks)
+
+
+lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint ()
+lintCmmBlock labels block
+  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
+        let (_, middle, last) = blockSplit block
+        mapM_ lintCmmMiddle (blockToList middle)
+        lintCmmLast labels last
 
 -- -----------------------------------------------------------------------------
 -- lintCmmExpr
@@ -60,123 +79,181 @@ 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) $
-     cmmCheckWordAddress expr
+  _ <- lintCmmExpr expr
+  -- Disabled, if we have the inlining phase before the lint phase,
+  -- we can have funny offsets due to pointer tagging. -- EZY
+  -- 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)
+  dflags <- getDynFlags
+  tys <- mapM lintCmmExpr args
+  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
+        then cmmCheckMachOp op args tys
+        else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
 lintCmmExpr (CmmRegOff reg offset)
-  = 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)
-lintCmmExpr expr = 
-  return (cmmExprRep expr)
+  = do dflags <- getDynFlags
+       let rep = typeWidth (cmmRegType dflags reg)
+       lintCmmExpr (CmmMachOp (MO_Add rep)
+                [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
+lintCmmExpr expr =
+  do dflags <- getDynFlags
+     return (cmmExprType dflags expr)
 
 -- Check for some common byte/word mismatches (eg. Sp + 1)
-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)
-
-isWordOffsetReg (CmmGlobal Sp) = True
--- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
---isWordOffsetReg (CmmGlobal Hp) = True
-isWordOffsetReg _ = False
+cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
+cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
+  = cmmCheckMachOp op [reg, lit] tys
+cmmCheckMachOp op _ tys
+  = do dflags <- getDynFlags
+       return (machOpResultType dflags op tys)
 
+{-
+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 e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
+_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
+_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
   = cmmLintDubiousWordOffset e
-cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
+_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
   = cmmLintDubiousWordOffset e
-cmmCheckWordAddress _
+_cmmCheckWordAddress _
   = return ()
 
 -- 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
+-}
+
+lintCmmMiddle :: CmmNode O O -> CmmLint ()
+lintCmmMiddle node = case node of
+  CmmComment _ -> return ()
+
+  CmmAssign reg expr -> do
+            dflags <- getDynFlags
+            erep <- lintCmmExpr expr
+            let reg_ty = cmmRegType dflags reg
+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
+                then return ()
+                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
+
+  CmmStore l r -> do
+            _ <- lintCmmExpr l
+            _ <- lintCmmExpr r
+            return ()
+
+  CmmUnsafeForeignCall target _formals actuals -> do
+            lintTarget target
+            mapM_ lintCmmExpr actuals
+
+
+lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint ()
+lintCmmLast labels node = case node of
+  CmmBranch id -> checkTarget id
 
-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 ()
-
-checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
-checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
-                                   (ppr expr))
+  CmmCondBranch e t f -> do
+            dflags <- getDynFlags
+            mapM_ checkTarget [t,f]
+            _ <- lintCmmExpr e
+            checkCond dflags e
+
+  CmmSwitch e branches -> do
+            dflags <- getDynFlags
+            mapM_ checkTarget $ catMaybes branches
+            erep <- lintCmmExpr e
+            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
+              then return ()
+              else cmmLintErr (text "switch scrutinee is not a word: " <>
+                               ppr e <> text " :: " <> ppr erep)
+
+  CmmCall { cml_target = target, cml_cont = cont } -> do
+          _ <- lintCmmExpr target
+          maybe (return ()) checkTarget cont
+
+  CmmForeignCall tgt _ args succ _ _ _ -> do
+          lintTarget tgt
+          mapM_ lintCmmExpr args
+          checkTarget succ
+ where
+  checkTarget id
+     | setMember id labels = return ()
+     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
+
+
+lintTarget :: ForeignTarget -> CmmLint ()
+lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
+lintTarget (PrimTarget {})     = return ()
+
+
+checkCond :: DynFlags -> CmmExpr -> CmmLint ()
+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
+checkCond _ expr
+    = cmmLintErr (hang (text "expression is not a conditional:") 2
+                         (ppr expr))
 
 -- -----------------------------------------------------------------------------
 -- CmmLint monad
 
 -- just a basic error monad:
 
-newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
+newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
+
+instance Functor CmmLint where
+      fmap = liftM
+
+instance Applicative CmmLint where
+      pure = return
+      (<*>) = ap
 
 instance Monad CmmLint where
-  CmmLint m >>= k = CmmLint $ case m of 
-                               Left e -> Left e
-                               Right a -> unCL (k a)
-  return a = CmmLint (Right a)
+  CmmLint m >>= k = CmmLint $ \dflags ->
+                                case m dflags of
+                                Left e -> Left e
+                                Right a -> unCL (k a) dflags
+  return a = CmmLint (\_ -> Right a)
+
+instance HasDynFlags CmmLint where
+    getDynFlags = CmmLint (\dflags -> Right dflags)
 
 cmmLintErr :: SDoc -> CmmLint a
-cmmLintErr msg = CmmLint (Left msg)
+cmmLintErr msg = CmmLint (\_ -> Left msg)
 
 addLintInfo :: SDoc -> CmmLint a -> CmmLint a
-addLintInfo info thing = CmmLint $ 
-   case unCL thing of
-       Left err -> Left (hang info 2 err)
-       Right a  -> Right a
+addLintInfo info thing = CmmLint $ \dflags ->
+   case unCL thing dflags of
+        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))
+     = cmmLintErr (text "in MachOp application: " $$
+                   nest 2 (ppr  expr) $$
+                      (text "op is expecting: " <+> ppr opExpectsRep) $$
+                      (text "arguments provide: " <+> ppr argsRep))
+
+cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
+cmmLintAssignErr stmt e_ty r_ty
+  = cmmLintErr (text "in assignment: " $$
+                nest 2 (vcat [ppr stmt,
+                              text "Reg ty:" <+> ppr r_ty,
+                              text "Rhs ty:" <+> ppr e_ty]))
 
-cmmLintAssignErr :: CmmStmt -> CmmLint a
-cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$ 
-                                       nest 2 (pprStmt stmt))
 
+{-
 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 cmmLintDubiousWordOffset expr
    = cmmLintErr (text "offset is not a multiple of words: " $$
-                       nest 2 (pprExpr expr))
+                 nest 2 (ppr expr))
+-}
+