[commit: ghc] wip/T10137: Make SwitchTargets type abstract (82ca17b)
git at git.haskell.org
git at git.haskell.org
Wed Mar 4 20:31:11 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T10137
Link : http://ghc.haskell.org/trac/ghc/changeset/82ca17bb3679963903f8633a0b3a43141b85172b/ghc
>---------------------------------------------------------------
commit 82ca17bb3679963903f8633a0b3a43141b85172b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Mar 4 21:32:52 2015 +0100
Make SwitchTargets type abstract
so that less code has to be touched when it is changed.
>---------------------------------------------------------------
82ca17bb3679963903f8633a0b3a43141b85172b
compiler/cmm/CmmCommonBlockElim.hs | 9 ++------
compiler/cmm/CmmNode.hs | 37 ++++++++++++++++++++++++++-------
compiler/codeGen/StgCmmUtils.hs | 4 +++-
compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 14 +++++--------
4 files changed, 39 insertions(+), 25 deletions(-)
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 234b729..6174929 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -203,15 +203,10 @@ eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
c1 == c2 && eqBid t1 t2 && eqBid f1 f2
eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
-eqLastWith eqBid (CmmSwitch e1 (mbdef1, bs1)) (CmmSwitch e2 (mbdef2, bs2)) =
- e1 == e2 && eqMaybeWith eqBid mbdef1 mbdef2 && eqMapWith eqBid bs1 bs2
+eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
+ e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
eqLastWith _ _ _ = False
-eqMapWith :: Eq k => (a -> b -> Bool) -> M.Map k a -> M.Map k b -> Bool
-eqMapWith eltEq m1 m2 =
- all (\((k1,v1), (k2,v2)) -> k1 == k2 && v1 `eltEq` v2) $
- List.zip (M.toList m1) (M.toList m2)
-
eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
eqMaybeWith _ Nothing Nothing = True
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index e6daa18..a3edc3f 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -22,8 +22,9 @@ module CmmNode (
-- * Switch
SwitchTargets,
+ mkSwitchTargets, switchTargetsCases, switchTargetsDefault,
mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,
- switchTargetsToList,
+ switchTargetsToList, eqSwitchTargetWith,
) where
import CodeGen.Platform
@@ -696,13 +697,25 @@ combineTickScopes s1 s2
-- See Note [Switch Table]
-type SwitchTargets = (Maybe Label, M.Map Integer Label)
+data SwitchTargets =
+ SwitchTargets (Maybe Label) (M.Map Integer Label)
+ deriving Eq
+
+mkSwitchTargets :: Maybe Label -> M.Map Integer Label -> SwitchTargets
+mkSwitchTargets = SwitchTargets
mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets
-mapSwitchTargets f (mbdef, branches) = (fmap f mbdef, fmap f branches)
+mapSwitchTargets f (SwitchTargets mbdef branches)
+ = SwitchTargets (fmap f mbdef) (fmap f branches)
+
+switchTargetsCases :: SwitchTargets -> [(Integer, Label)]
+switchTargetsCases (SwitchTargets _ branches) = M.toList branches
+
+switchTargetsDefault :: SwitchTargets -> Maybe Label
+switchTargetsDefault (SwitchTargets mbdef _) = mbdef
switchTargetsToTable :: SwitchTargets -> [Maybe Label]
-switchTargetsToTable (mbdef, branches)
+switchTargetsToTable (SwitchTargets mbdef branches)
| min < 0 = pprPanic "mapSwitchTargets" empty
| otherwise = [ labelFor i | i <- [0..max] ]
where
@@ -712,19 +725,27 @@ switchTargetsToTable (mbdef, branches)
Nothing -> mbdef
switchTargetsToList :: SwitchTargets -> [Label]
-switchTargetsToList (mbdef, branches) = maybeToList mbdef ++ M.elems branches
+switchTargetsToList (SwitchTargets mbdef branches) = maybeToList mbdef ++ M.elems branches
-- | Groups cases with equal targets, suitable for pretty-printing to a
-- c-like switch statement with fall-through semantics.
switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)
-switchTargetsFallThrough (mbdef, branches) = (groups, mbdef)
+switchTargetsFallThrough (SwitchTargets mbdef branches) = (groups, mbdef)
where
groups = map (\xs -> (map fst xs, snd (head xs))) $
groupBy ((==) `on` snd) $
M.toList branches
-
-
+eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool
+eqSwitchTargetWith eq (SwitchTargets mbdef1 ids1) (SwitchTargets mbdef2 ids2) =
+ goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2)
+ where
+ goMB Nothing Nothing = True
+ goMB (Just l1) (Just l2) = l1 `eq` l2
+ goMB _ _ = False
+ goList [] [] = True
+ goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2
+ goList _ _ = False
-- Note [SwitchTargets]:
-- ~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 2ad794e..4935c7f 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -550,7 +550,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
, i <= real_hi_tag
]
dflags <- getDynFlags
- return (mkSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) (Nothing, arms))
+ return $ mkSwitch
+ (cmmOffset dflags tag_expr (- real_lo_tag))
+ (mkSwitchTargets Nothing arms)
-- if we can knock off a bunch of default cases with one if, then do so
| Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 230c64f..9049214 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -32,7 +32,6 @@ import Unique
import Data.List ( nub )
import Data.Maybe ( catMaybes )
-import qualified Data.Map as M
type Atomic = Bool
type LlvmStatements = OrdList LlvmStatement
@@ -825,19 +824,16 @@ For a real example of this, see ./rts/StgStdThunks.cmm
-- | Switch branch
---
--- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
--- However, they may be defined one day, so we better document this behaviour.
genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
-genSwitch cond (mbdef, ids) = do
+genSwitch cond ids = do
(vc, stmts, top) <- exprToVar cond
let ty = getVarType vc
- let pairs = M.toList ids
- let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
+ let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
+ | (ix, b) <- switchTargetsCases ids ]
-- out of range is undefined, so let's just branch to first label
- let defLbl | Just l <- mbdef = blockIdToLlvm l
- | otherwise = snd (head labels)
+ let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
+ | otherwise = snd (head labels)
let s1 = Switch vc defLbl labels
return $ (stmts `snocOL` s1, top)
More information about the ghc-commits
mailing list