[commit: ghc] wip/T10137: Make SwitchTargets type abstract (f83791f)

git at git.haskell.org git at git.haskell.org
Wed Mar 4 21:02:29 UTC 2015


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T10137
Link       : http://ghc.haskell.org/trac/ghc/changeset/f83791f8f3ca05b970f45ad84194c76de0a1407d/ghc

>---------------------------------------------------------------

commit f83791f8f3ca05b970f45ad84194c76de0a1407d
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.


>---------------------------------------------------------------

f83791f8f3ca05b970f45ad84194c76de0a1407d
 compiler/cmm/CmmCommonBlockElim.hs      |  9 ++------
 compiler/cmm/CmmNode.hs                 | 37 ++++++++++++++++++++++++++-------
 compiler/cmm/CmmParse.y                 |  2 +-
 compiler/codeGen/StgCmmUtils.hs         |  4 +++-
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 14 +++++--------
 5 files changed, 40 insertions(+), 26 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/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 84b297a..4f286f5 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1326,7 +1326,7 @@ doSwitch mb_range scrut arms deflt
 
         expr <- scrut
         -- ToDo: check for out of range and jump to default if necessary
-        emit $ mkSwitch expr (dflt_entry, table)
+        emit $ mkSwitch expr (mkSwitchTargets dflt_entry table)
    where
         emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
         emitArm (ints,Left blockid) = return [ (fromIntegral i,blockid) | i <- ints ]
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