Commit 32d652e4 authored by Simon Marlow's avatar Simon Marlow

merge fixes

parent d96f7a27
......@@ -169,7 +169,32 @@ lintCmmLast labels node = case node of
text "switch scrutinee is not a word: " <>
pprPlatform platform e <>
text " :: " <> ppr erep)
(pprPlatform platform expr))
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 :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond expr
= cmmLintErr (\platform -> hang (text "expression is not a conditional:") 2
(pprPlatform platform expr))
-- -----------------------------------------------------------------------------
-- CmmLint monad
......
......@@ -143,8 +143,8 @@ lintCmmStmt platform labels = lint
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
text " :: " <> ppr erep)
lint (CmmJump e args) = lintCmmExpr platform e >> mapM_ (lintCmmExpr platform . hintlessCmm) args
lint (CmmReturn ress) = mapM_ (lintCmmExpr platform . hintlessCmm) ress
lint (CmmJump e _) = lintCmmExpr platform 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)
......
......@@ -385,30 +385,12 @@ instance Monad FCode where
{-# INLINE thenFC #-}
{-# INLINE returnFC #-}
<<<<<<< HEAD
\begin{code}
initC :: IO CgState
initC = do { uniqs <- mkSplitUniqSupply 'c'
; return (initCgState uniqs) }
runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
||||||| merged common ancestors
\begin{code}
initC :: DynFlags -> Module -> FCode a -> IO a
initC dflags mod (FCode code)
= do { uniqs <- mkSplitUniqSupply 'c'
; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
(res, _) -> return res
}
=======
initC :: DynFlags -> Module -> FCode a -> IO a
initC dflags mod (FCode code) = do
uniqs <- mkSplitUniqSupply 'c'
case code (initCgInfoDown dflags mod) (initCgState uniqs) of
(res, _) -> return res
>>>>>>> origin/master
returnFC :: a -> FCode a
returnFC val = FCode $ \_ state -> (val, state)
......@@ -726,45 +708,19 @@ emitDecl decl = do
state <- getState
setState $ state { cgs_tops = cgs_tops state `snocOL` decl }
<<<<<<< HEAD
emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
emitProc info lbl [] blocks
= do { let proc_block = CmmProc info lbl (ListGraph blocks)
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
||||||| merged common ancestors
emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
emitProc info lbl [] blocks
= do { let proc_block = CmmProc info lbl (ListGraph blocks)
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
=======
emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
emitProc info lbl [] blocks = do
let proc_block = CmmProc info lbl (ListGraph blocks)
state <- getState
setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block }
>>>>>>> origin/master
emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
-- Emit a procedure whose body is the specified code; no info table
emitSimpleProc :: CLabel -> Code -> Code
<<<<<<< HEAD
emitSimpleProc lbl code
= do { stmts <- getCgStmts code
; blks <- cgStmtsToBlocks stmts
; emitProc CmmNonInfoTable lbl [] blks }
||||||| merged common ancestors
emitSimpleProc lbl code
= do { stmts <- getCgStmts code
; blks <- cgStmtsToBlocks stmts
; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
=======
emitSimpleProc lbl code = do
stmts <- getCgStmts code
blks <- cgStmtsToBlocks stmts
emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks
>>>>>>> origin/master
emitProc CmmNonInfoTable lbl [] blks
-- Get all the CmmTops (there should be no stmts)
-- Return a single Cmm which may be split from other Cmms by
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment