Commit d92bd17f authored by Simon Marlow's avatar Simon Marlow

Remove OldCmm, convert backends to consume new Cmm

This removes the OldCmm data type and the CmmCvt pass that converts
new Cmm to OldCmm.  The backends (NCGs, LLVM and C) have all been
converted to consume new Cmm.

The main difference between the two data types is that conditional
branches in new Cmm have both true/false successors, whereas in OldCmm
the false case was a fallthrough.  To generate slightly better code we
occasionally need to invert a conditional to ensure that the
branch-not-taken becomes a fallthrough; this was previously done in
CmmCvt, and it is now done in CmmContFlowOpt.

We could go further and use the Hoopl Block representation for native
code, which would mean that we could use Hoopl's postorderDfs and
analyses for native code, but for now I've left it as is, using the
old ListGraph representation for native code.
parent 121768de
......@@ -8,8 +8,13 @@ module Cmm (
CmmDecl, GenCmmDecl(..),
CmmGraph, GenCmmGraph(..),
CmmBlock,
RawCmmDecl, RawCmmGroup,
Section(..), CmmStatics(..), CmmStatic(..),
-- ** Blocks containing lists
GenBasicBlock(..), blockId,
ListGraph(..), pprBBlock,
-- * Cmm graphs
CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,
......@@ -31,6 +36,7 @@ import SMRep
import CmmExpr
import UniqSupply
import Compiler.Hoopl
import Outputable
import Data.Word ( Word8 )
......@@ -50,6 +56,7 @@ type CmmProgram = [CmmGroup]
type GenCmmGroup d h g = [GenCmmDecl d h g]
type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) CmmGraph
-----------------------------------------------------------------------------
-- CmmDecl, GenCmmDecl
......@@ -62,7 +69,6 @@ type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
--
-- We expect there to be two main instances of this type:
-- (a) C--, i.e. populated with various C-- constructs
-- (Cmm and RawCmm in OldCmm.hs)
-- (b) Native code, populated with data/instructions
-- | A top-level chunk, abstracted over the type of the contents of
......@@ -87,6 +93,12 @@ data GenCmmDecl d h g
type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type RawCmmDecl
= GenCmmDecl
CmmStatics
(BlockEnv CmmStatics)
CmmGraph
-----------------------------------------------------------------------------
-- Graphs
-----------------------------------------------------------------------------
......@@ -177,3 +189,28 @@ data CmmStatics
CLabel -- Label of statics
[CmmStatic] -- The static data itself
-- -----------------------------------------------------------------------------
-- Basic blocks consisting of lists
-- These are used by the LLVM and NCG backends, when populating Cmm
-- with lists of instructions.
data GenBasicBlock i = BasicBlock BlockId [i]
-- | The branch block id is that of the first block in
-- the branch, which is that branch's entry point
blockId :: GenBasicBlock i -> BlockId
blockId (BasicBlock blk_id _ ) = blk_id
newtype ListGraph i = ListGraph [GenBasicBlock i]
instance Outputable instr => Outputable (ListGraph instr) where
ppr (ListGraph blocks) = vcat (map ppr blocks)
instance Outputable instr => Outputable (GenBasicBlock instr) where
ppr = pprBBlock
pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
......@@ -4,17 +4,18 @@
module CmmContFlowOpt
( cmmCfgOpts
, cmmCfgOptsProc
, removeUnreachableBlocksProc
, removeUnreachableBlocks
, replaceLabels
)
where
import Hoopl
import BlockId
import Cmm
import CmmUtils
import Maybes
import Hoopl
import Control.Monad
import Prelude hiding (succ, unzip, zip)
......@@ -136,9 +137,10 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
= (blocks, mapInsert b' dest shortcut_map)
-- replaceLabels will substitute dest for b' everywhere, later
-- non-calls: see if we can shortcut any of the successors.
-- non-calls: see if we can shortcut any of the successors,
-- and check whether we should invert the conditional
| Nothing <- callContinuation_maybe last
= ( mapInsert bid (blockJoinTail head shortcut_last) blocks
= ( mapInsert bid (blockJoinTail head swapcond_last) blocks
, shortcut_map )
| otherwise
......@@ -146,17 +148,38 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
where
(head, last) = blockSplitTail block
bid = entryLabel block
shortcut_last = mapSuccessors shortcut last
shortcut l =
case mapLookup l blocks of
Just b | Just dest <- canShortcut b -> dest
_otherwise -> l
where
shortcut l =
case mapLookup l blocks of
Just b | Just dest <- canShortcut b -> dest
_otherwise -> l
-- for a conditional, we invert the conditional if that
-- would make it more likely that the branch-not-taken case
-- becomes a fallthrough. This helps the native codegen a
-- little bit, and probably has no effect on LLVM. It's
-- convenient to do it here, where we have the information
-- about predecessors.
--
swapcond_last
| CmmCondBranch cond t f <- shortcut_last
, numPreds f > 1
, numPreds t == 1
, Just cond' <- maybeInvertCmmExpr cond
= CmmCondBranch cond' f t
| otherwise
= shortcut_last
shouldConcatWith b block
| okToDuplicate block = True -- short enough to duplicate
| num_preds b == 1 = True -- only one predecessor: go for it
| numPreds b == 1 = True -- only one predecessor: go for it
| otherwise = False
where num_preds bid = mapLookup bid backEdges `orElse` 0
numPreds bid = mapLookup bid backEdges `orElse` 0
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut block
......@@ -265,6 +288,10 @@ predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
--
-- Removing unreachable blocks
removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
removeUnreachableBlocksProc (CmmProc info lbl live g)
= CmmProc info lbl live (removeUnreachableBlocks g)
removeUnreachableBlocks :: CmmGraph -> CmmGraph
removeUnreachableBlocks g
| length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
......
{-# LANGUAGE GADTs #-}
-- ToDo: remove -fno-warn-incomplete-patterns
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmCvt
( cmmOfZgraph )
where
import BlockId
import Cmm
import CmmUtils
import qualified OldCmm as Old
import OldPprCmm ()
import Hoopl
import Data.Maybe
import Maybes
import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup
cmmOfZgraph tops = map mapTop tops
where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
add_hints args hints = zipWith Old.CmmHinted args hints
get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
arg_hints ++ repeat NoHint)
where (res_hints, arg_hints) = callishMachOpHints op
get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
= (res_hints, arg_hints)
cmm_target :: ForeignTarget -> Old.CmmCallTarget
cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc
get_ret :: ForeignTarget -> CmmReturnInfo
get_ret (PrimTarget _) = CmmMayReturn
get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret
ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
-- We catenated some blocks in the conversion process,
-- because of the CmmCondBranch -- the machine code does not have
-- 'jump here or there' instruction, but has 'jump if true' instruction.
-- As OldCmm has the same instruction, so we use it.
-- When we are doing this, we also catenate normal goto-s (it is for free).
-- Exactly, we catenate blocks with nonentry labes, that are
-- a) mentioned exactly once as a successor
-- b) any of 1) are a target of a goto
-- 2) are false branch target of a conditional jump
-- 3) are true branch target of a conditional jump, and
-- the false branch target is a successor of at least 2 blocks
-- and the condition can be inverted
-- The complicated rule 3) is here because we need to assign at most one
-- catenable block to a CmmCondBranch.
where preds :: BlockEnv [CmmNode O C]
preds = mapFold add mapEmpty $ toBlockMap g
where add block env = foldr (add' $ lastNode block) env (successors block)
add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
to_be_catenated :: BlockId -> Bool
to_be_catenated id | id == g_entry g = False
| Just [CmmBranch _] <- mapLookup id preds = True
| Just [CmmCondBranch _ _ f] <- mapLookup id preds
, f == id = True
| Just [CmmCondBranch e t f] <- mapLookup id preds
, t == id
, Just (_:_:_) <- mapLookup f preds
, Just _ <- maybeInvertCmmExpr e = True
to_be_catenated _ = False
convert_block block | to_be_catenated (entryLabel block) = Nothing
convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
middle node stmts = stmt : stmts
where stmt :: Old.CmmStmt
stmt = case node of
CmmComment s -> Old.CmmComment s
CmmAssign l r -> Old.CmmAssign l r
CmmStore l r -> Old.CmmStore l r
CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
CmmUnsafeForeignCall target ress args ->
Old.CmmCall (cmm_target target)
(add_hints ress res_hints)
(add_hints args arg_hints)
(get_ret target)
where
(res_hints, arg_hints) = get_hints target
last :: CmmNode O C -> () -> [Old.CmmStmt]
last node _ = stmts
where stmts :: [Old.CmmStmt]
stmts = case node of
CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
| otherwise -> [Old.CmmBranch tgt]
CmmCondBranch expr tid fid
| to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
| to_be_catenated tid
, Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
| otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
-- ToDo: STG Live
CmmCall e _ r _ _ _ -> [Old.CmmJump e r]
CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
Old.BasicBlock _ stmts -> stmts
where Just block = mapLookup bid $ toBlockMap g
......@@ -14,8 +14,7 @@ module CmmInfo (
#include "HsVersions.h"
import OldCmm as Old
import Cmm
import CmmUtils
import CLabel
import SMRep
......@@ -42,8 +41,8 @@ mkEmptyContInfoTable info_lbl
, cit_prof = NoProfilingInfo
, cit_srt = NoC_SRT }
cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup ()
-> IO (Stream IO Old.RawCmmGroup ())
cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
-> IO (Stream IO RawCmmGroup ())
cmmToRawCmm dflags cmms
= do { uniqs <- mkSplitUniqSupply 'i'
; let do_one uniqs cmm = do
......@@ -108,21 +107,13 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
--
case blocks of
ListGraph [] ->
-- No code; only the info table is significant
-- Use a zero place-holder in place of the
-- entry-label in the info table
return (top_decls ++
[mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++
rel_extra_bits)])
_nonempty ->
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
return (top_decls ++
[CmmProc mapEmpty entry_lbl live blocks,
mkDataLits Data info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
--
return (top_decls ++
[CmmProc mapEmpty entry_lbl live blocks,
mkDataLits Data info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
--
-- With tables-next-to-code, we can have many info tables,
......@@ -132,7 +123,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
--
| otherwise
= do
(top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
(top_declss, raw_infos) <-
unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
return (concat top_declss ++
[CmmProc (mapFromList raw_infos) entry_lbl live blocks])
......
......@@ -12,7 +12,8 @@
module CmmNode (
CmmNode(..), CmmFormal, CmmActual,
UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..),
UpdFrameOffset, Convention(..),
ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
CmmReturnInfo(..),
mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
......@@ -281,6 +282,17 @@ data ForeignTarget -- The target of a foreign call
CallishMachOp -- Which one
deriving Eq
foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints target
= ( res_hints ++ repeat NoHint
, arg_hints ++ repeat NoHint )
where
(res_hints, arg_hints) =
case target of
PrimTarget op -> callishMachOpHints op
ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
(res_hints, arg_hints)
--------------------------------------------------
-- Instances of register and slot users / definers
......
......@@ -8,14 +8,13 @@
module CmmOpt (
cmmMachOpFold,
cmmMachOpFoldM,
cmmLoopifyForC,
cmmMachOpFoldM
) where
#include "HsVersions.h"
import CmmUtils
import OldCmm
import Cmm
import DynFlags
import CLabel
......@@ -416,6 +415,7 @@ exactLog2 x_
except factorial, but what the hell.
-}
{-
cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl
-- XXX: revisit if we actually want to do this
-- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts
......@@ -434,6 +434,7 @@ cmmLoopifyForC dflags (CmmProc infos entry_lbl live
| otherwise = entry_lbl
cmmLoopifyForC _ top = top
-}
-- -----------------------------------------------------------------------------
-- Utils
......
......@@ -134,6 +134,8 @@ cpsTop hsc_env proc =
return $ if optLevel dflags >= 1
then map (cmmCfgOptsProc splitting_proc_points) gs
else gs
gs <- return (map removeUnreachableBlocksProc gs)
-- Note [unreachable blocks]
dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
return (cafEnv, gs)
......@@ -152,6 +154,8 @@ cpsTop hsc_env proc =
return $ if optLevel dflags >= 1
then cmmCfgOptsProc splitting_proc_points g
else g
g <- return (removeUnreachableBlocksProc g)
-- Note [unreachable blocks]
dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
return (cafEnv, [g])
......@@ -212,7 +216,15 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
-}
{- Note [unreachable blocks]
The control-flow optimiser sometimes leaves unreachable blocks behind
containing junk code. If these blocks make it into the native code
generator then they trigger a register allocator panic because they
refer to undefined LocalRegs, so we must eliminate any unreachable
blocks before passing the code onwards.
-}
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
......
......@@ -51,9 +51,8 @@ module CmmUtils(
-- * Operations that probably don't belong here
modifyGraph,
lastNode, replaceLastNode,
ofBlockMap, toBlockMap, insertBlock,
ofBlockList, toBlockList, bodyToBlockList,
ofBlockList, toBlockList, bodyToBlockList, toBlockListEntryFirst,
foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
analFwd, analBwd, analRewFwd, analRewBwd,
......@@ -424,6 +423,17 @@ insertBlock block map =
toBlockList :: CmmGraph -> [CmmBlock]
toBlockList g = mapElems $ toBlockMap g
-- | like 'toBlockList', but the entry block always comes first
toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
toBlockListEntryFirst g
| mapNull m = []
| otherwise = entry_block : others
where
m = toBlockMap g
entry_id = g_entry g
Just entry_block = mapLookup entry_id m
others = filter ((/= entry_id) . entryLabel) (mapElems m)
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
ofBlockList entry blocks = CmmGraph { g_entry = entry
, g_graph = GMany NothingO body NothingO }
......
This diff is collapsed.
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2006
--
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module OldCmmLint (
cmmLint, cmmLintTop
) where
import BlockId
import OldCmm
import Outputable
import OldPprCmm()
import FastString
import DynFlags
import Data.Maybe
-- -----------------------------------------------------------------------------
-- Exported entry points:
cmmLint :: (Outputable d, Outputable h)
=> DynFlags -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
cmmLintTop :: (Outputable d, Outputable h)
=> DynFlags -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLintTop dflags top = runCmmLint dflags (lintCmmDecl dflags) top
runCmmLint :: Outputable a
=> DynFlags -> (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
lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks))
= addLintInfo (text "in proc " <> ppr lbl) $
let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
in mapM_ (lintCmmBlock dflags labels) blocks
lintCmmDecl _ (CmmData {})
= return ()
lintCmmBlock :: DynFlags -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
lintCmmBlock dflags labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr id) $
mapM_ (lintCmmStmt dflags labels) stmts
-- -----------------------------------------------------------------------------
-- lintCmmExpr
-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.
lintCmmExpr :: DynFlags -> CmmExpr -> CmmLint CmmType
lintCmmExpr dflags (CmmLoad expr rep) = do
_ <- lintCmmExpr dflags 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 dflags expr@(CmmMachOp op args) = do
tys <- mapM (lintCmmExpr dflags) args
if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
then cmmCheckMachOp dflags op args tys
else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
lintCmmExpr dflags (CmmRegOff reg offset)
= lintCmmExpr dflags (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
where rep = typeWidth (cmmRegType dflags reg)
lintCmmExpr dflags expr =
return (cmmExprType dflags expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: DynFlags -> MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp dflags op [reg, lit] tys
cmmCheckMachOp dflags op _ tys
= 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 :: 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 dflags) /= 0
= cmmLintDubiousWordOffset e
_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
-}
lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint ()
lintCmmStmt dflags labels = lint
where lint (CmmNop) = return ()
lint (CmmComment {}) = return ()
lint stmt@(CmmAssign reg expr) = do
erep <- lintCmmExpr dflags expr
let reg_ty = cmmRegType dflags reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr stmt erep reg_ty
lint (CmmStore l r) = do
_ <- lintCmmExpr dflags l
_ <- lintCmmExpr dflags r
return ()
lint (CmmCall target _res args _) =
do lintTarget dflags labels target
mapM_ (lintCmmExpr dflags . hintlessCmm) args
lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond dflags e
lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches
erep <- lintCmmExpr dflags e
if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
text " :: " <> ppr erep)
lint (CmmJump e _) = lintCmmExpr dflags e >> return ()
lint (CmmReturn) = return ()
lint (CmmBranch id) = checkTarget id
checkTarget id = if setMember id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget :: DynFlags -> BlockSet -> CmmCallTarget -> CmmLint ()
lintTarget dflags _ (CmmCallee e _) = do _ <- lintCmmExpr dflags e
return ()
lintTarget _ _ (CmmPrim _ Nothing) = return ()
lintTarget dflags labels (CmmPrim _ (Just stmts))
= mapM_ (lintCmmStmt dflags labels) stmts
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 }
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)
cmmLintErr :: SDoc -> CmmLint a
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
cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr expr argsRep opExpectsRep
= cmmLintErr (text "in MachOp application: " $$
nest 2 (ppr expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep))
cmmLintAssignErr :: CmmStmt -> 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]))
{-
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$
nest 2 (ppr expr))
-}
-----------------------------------------------------------------------------
--
-- Old-style Cmm utilities.
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
module OldCmmUtils(