diff options
| -rw-r--r-- | compiler/cmm/CmmLint.hs | 27 | ||||
| -rw-r--r-- | compiler/cmm/OldCmmLint.hs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/CgMonad.lhs | 46 |
3 files changed, 29 insertions, 48 deletions
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index fea23e6632..1625307c2b 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -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 diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index 96fbf97666..cc7e2cd8d6 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -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) diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index f907f85071..dff54f3bf5 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -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 |