add a comment
[ghc.git] / compiler / cmm / CmmLint.hs
index 0afe2a3..970ce68 100644 (file)
@@ -18,10 +18,11 @@ import PprCmm ()
 import BlockId
 import FastString
 import Outputable
-import Constants
 import DynFlags
 
 import Data.Maybe
+import Control.Monad (liftM, ap)
+import Control.Applicative (Applicative(..))
 
 -- Things to check:
 --     - invariant on CmmBlock in CmmExpr (see comment there)
@@ -33,10 +34,10 @@ import Data.Maybe
 
 cmmLint :: (Outputable d, Outputable h)
         => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
-cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops
+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
 
 cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
-cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g
+cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
 
 runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
 runCmmLint dflags l p =
@@ -47,18 +48,19 @@ runCmmLint dflags l p =
                              nest 2 (ppr p)])
      Right _  -> Nothing
 
-lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
-lintCmmDecl (CmmProc _ lbl g)
-  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g
-lintCmmDecl (CmmData {})
+lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
+lintCmmDecl dflags (CmmProc _ lbl _ g)
+  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
+lintCmmDecl (CmmData {})
   = return ()
 
 
-lintCmmGraph :: CmmGraph -> CmmLint ()
-lintCmmGraph g = cmmLiveness g `seq` mapM_ (lintCmmBlock labels) blocks
-                 -- cmmLiveness throws an error if there are registers
-                 -- live on entry to the graph (i.e. undefined
-                 -- variables)
+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)
@@ -108,6 +110,7 @@ cmmCheckMachOp op _ tys
   = do dflags <- getDynFlags
        return (machOpResultType dflags op tys)
 
+{-
 isOffsetOp :: MachOp -> Bool
 isOffsetOp (MO_Add _) = True
 isOffsetOp (MO_Sub _) = True
@@ -117,10 +120,10 @@ isOffsetOp _ = False
 -- 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
+  | 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
+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
   = cmmLintDubiousWordOffset e
 _cmmCheckWordAddress _
   = return ()
@@ -130,6 +133,7 @@ _cmmCheckWordAddress _
 notNodeReg :: CmmExpr -> Bool
 notNodeReg (CmmReg reg) | reg == nodeReg = False
 notNodeReg _                             = True
+-}
 
 lintCmmMiddle :: CmmNode O O -> CmmLint ()
 lintCmmMiddle node = case node of
@@ -176,7 +180,7 @@ lintCmmLast labels node = case node of
           _ <- lintCmmExpr target
           maybe (return ()) checkTarget cont
 
-  CmmForeignCall tgt _ args succ _ _ -> do
+  CmmForeignCall tgt _ args succ _ _ -> do
           lintTarget tgt
           mapM_ lintCmmExpr args
           checkTarget succ
@@ -205,6 +209,13 @@ checkCond _ expr
 
 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 $ \dflags ->
                                 case m dflags of
@@ -239,7 +250,10 @@ cmmLintAssignErr stmt e_ty r_ty
                               text "Rhs ty:" <+> ppr e_ty]))
 
 
+{-
 cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
 cmmLintDubiousWordOffset expr
    = cmmLintErr (text "offset is not a multiple of words: " $$
                  nest 2 (ppr expr))
+-}
+