Replacing copyins and copyouts with data-movement instructions

[ghc-hetmet.git] / compiler / cmm / CmmLint.hs

diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index c4aee8a..293c203 100644 (file)
--- 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,8 +16,7 @@ module CmmLint (
   cmmLint, cmmLintTop
   ) where
 
-#include "HsVersions.h"
-
+import BlockId
 import Cmm
 import CLabel
 import MachOp
@@ -43,7 +41,7 @@ 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)
+       Left err -> Just (ptext (sLit "Cmm lint error:") $$ nest 2 err)
        Right _  -> Nothing
 
 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
@@ -55,6 +53,7 @@ lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
 lintCmmTop (CmmData {})
   = return ()
 
+lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
 lintCmmBlock labels (BasicBlock id stmts)
   = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
        mapM_ (lintCmmStmt labels) stmts
@@ -87,6 +86,7 @@ lintCmmExpr expr =
   return (cmmExprRep expr)
 
 -- Check for some common byte/word mismatches (eg. Sp + 1)
+cmmCheckMachOp   :: MachOp -> [CmmExpr] -> CmmLint MachRep
 cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)]
   | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
   = cmmLintDubiousWordOffset (CmmMachOp op args)
@@ -99,17 +99,20 @@ cmmCheckMachOp op@(MO_U_Conv from to) args
 cmmCheckMachOp op _args
   = return (resultRepOfMachOp op)
 
+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
@@ -121,6 +124,7 @@ 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
 
@@ -138,7 +142,7 @@ lintCmmStmt labels = lint
             lintCmmExpr r
             return ()
           lint (CmmCall target _res args _ _) =
-              lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
+              lintTarget target >> mapM_ (lintCmmExpr . kindlessCmm) args
           lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
           lint (CmmSwitch e branches) = do
             mapM_ checkTarget $ catMaybes branches
@@ -146,8 +150,8 @@ lintCmmStmt labels = lint
             if (erep == wordRep)
               then return ()
               else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
-          lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
-          lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
+          lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . kindlessCmm) args
+          lint (CmmReturn ress) = mapM_ (lintCmmExpr . kindlessCmm) ress
           lint (CmmBranch id)    = checkTarget id
           checkTarget id = if elemBlockSet id labels then return ()
                            else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
@@ -157,6 +161,7 @@ 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))