From 98acdf083c119b018f25097593668a816dc68068 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Thu, 23 Feb 2012 19:57:57 +0000 Subject: Add a Word add-with-carry primop No special-casing in any NCGs yet --- compiler/cmm/CmmOpt.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'compiler/cmm/CmmOpt.hs') diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index ae715a9eb7..8066c60157 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -61,7 +61,7 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = stmt m (CmmStore e1 e2) = expr (expr m e1) e2 stmt m (CmmCall c _ as _) = f (actuals m as) c where f m (CmmCallee e _) = expr m e - f m (CmmPrim _) = m + f m (CmmPrim _ _) = m stmt m (CmmBranch b) = b:m stmt m (CmmCondBranch e b) = b:(expr m e) stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e @@ -269,7 +269,7 @@ inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e inlineStmt u a (CmmCall target regs es ret) = CmmCall (infn target) regs es' ret where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv - infn (CmmPrim p) = CmmPrim p + infn (CmmPrim p m) = CmmPrim p m es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d -- cgit v1.2.1 From 2304a36272531fd20f163b6f378e417dc351aa25 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Mon, 27 Feb 2012 22:03:39 +0000 Subject: Fix the unregisterised build; fixes #5901 --- compiler/cmm/CmmOpt.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'compiler/cmm/CmmOpt.hs') diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 8066c60157..e4ad450069 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -61,7 +61,8 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = stmt m (CmmStore e1 e2) = expr (expr m e1) e2 stmt m (CmmCall c _ as _) = f (actuals m as) c where f m (CmmCallee e _) = expr m e - f m (CmmPrim _ _) = m + f m (CmmPrim _ Nothing) = m + f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts stmt m (CmmBranch b) = b:m stmt m (CmmCondBranch e b) = b:(expr m e) stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e @@ -269,7 +270,7 @@ inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e inlineStmt u a (CmmCall target regs es ret) = CmmCall (infn target) regs es' ret where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv - infn (CmmPrim p m) = CmmPrim p m + infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts) es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d -- cgit v1.2.1 From ab50c9c527d19f4df7ee6742b6d79c855d57c9b8 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 12 Jun 2012 18:52:05 +0100 Subject: Pass DynFlags down to showSDoc --- compiler/cmm/CmmOpt.hs | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) (limited to 'compiler/cmm/CmmOpt.hs') diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index e4ad450069..d2f0058668 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -20,6 +20,7 @@ import OldCmm import OldPprCmm import CmmNode (wrapRecExp) import CmmUtils +import DynFlags import StaticFlags import UniqFM @@ -147,46 +148,47 @@ countUses :: UserOfLocalRegs a => a -> UniqFM Int countUses a = foldRegsUsed (\m r -> addToUFM m r (count m r + 1)) emptyUFM a where count m r = lookupWithDefaultUFM m (0::Int) r -cmmMiniInline :: Platform -> [CmmBasicBlock] -> [CmmBasicBlock] -cmmMiniInline platform blocks = map do_inline blocks +cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock] +cmmMiniInline dflags blocks = map do_inline blocks where do_inline (BasicBlock id stmts) - = BasicBlock id (cmmMiniInlineStmts platform (countUses blocks) stmts) + = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts) -cmmMiniInlineStmts :: Platform -> UniqFM Int -> [CmmStmt] -> [CmmStmt] -cmmMiniInlineStmts _ _ [] = [] -cmmMiniInlineStmts platform uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) +cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt] +cmmMiniInlineStmts _ _ [] = [] +cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) -- not used: just discard this assignment | Nothing <- lookupUFM uses u - = cmmMiniInlineStmts platform uses stmts + = cmmMiniInlineStmts dflags uses stmts -- used (literal): try to inline at all the use sites | Just n <- lookupUFM uses u, isLit expr = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $ + ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $ case lookForInlineLit u expr stmts of (m, stmts') - | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts' + | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' | otherwise -> - stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts' + stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts' -- used (foldable to literal): try to inline at all the use sites | Just n <- lookupUFM uses u, e@(CmmLit _) <- wrapRecExp foldExp expr = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $ + ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $ case lookForInlineLit u e stmts of (m, stmts') - | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts' + | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' | otherwise -> - stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts' + stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts' -- used once (non-literal): try to inline at the use site | Just 1 <- lookupUFM uses u, Just stmts' <- lookForInline u expr stmts = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $ - cmmMiniInlineStmts platform uses stmts' + ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $ + cmmMiniInlineStmts dflags uses stmts' where + platform = targetPlatform dflags foldExp (CmmMachOp op args) = cmmMachOpFold platform op args foldExp e = e -- cgit v1.2.1 From 0f1c5b1eda3c780498667607975d5121384a9095 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 20 Jun 2012 17:19:22 +0100 Subject: Remove some more redundant Platform arguments --- compiler/cmm/CmmOpt.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'compiler/cmm/CmmOpt.hs') diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index d2f0058668..8cc18fc1ca 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -163,7 +163,7 @@ cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) -- used (literal): try to inline at all the use sites | Just n <- lookupUFM uses u, isLit expr = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $ + ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ case lookForInlineLit u expr stmts of (m, stmts') | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' @@ -174,7 +174,7 @@ cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) | Just n <- lookupUFM uses u, e@(CmmLit _) <- wrapRecExp foldExp expr = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $ + ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ case lookForInlineLit u e stmts of (m, stmts') | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' @@ -185,7 +185,7 @@ cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) | Just 1 <- lookupUFM uses u, Just stmts' <- lookForInline u expr stmts = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $ + ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ cmmMiniInlineStmts dflags uses stmts' where platform = targetPlatform dflags -- cgit v1.2.1