Remove (most of) the FiniteMap wrapper

We still have
    insertList, insertListWith, deleteList
which aren't in Data.Map, and
    foldRightWithKey
which works around the fold(r)WithKey addition and deprecation.

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index ef93a47..072d011 100644 (file)
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -5,7 +5,7 @@
 Module
 ~~~~~~~~~~
 Simply the name of a module, represented as a FastString.
 Module
 ~~~~~~~~~~
 Simply the name of a module, represented as a FastString.

-These are Uniquable, hence we can build FiniteMaps with Modules as
+These are Uniquable, hence we can build Maps with Modules as

 the keys.
 
 \begin{code}
 the keys.
 
 \begin{code}

@@ -60,7 +60,7 @@ module Module
        lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
        moduleEnvKeys, moduleEnvElts, moduleEnvToList,
         unitModuleEnv, isEmptyModuleEnv,
        lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
        moduleEnvKeys, moduleEnvElts, moduleEnvToList,
         unitModuleEnv, isEmptyModuleEnv,

-        foldModuleEnv, extendModuleEnv_C, filterModuleEnv,
+        foldModuleEnv, extendModuleEnvWith, filterModuleEnv,

 
        -- * ModuleName mappings
        ModuleNameEnv,
 
        -- * ModuleName mappings
        ModuleNameEnv,

@@ -76,13 +76,15 @@ import Config
 import Outputable
 import qualified Pretty
 import Unique
 import Outputable
 import qualified Pretty
 import Unique

-import FiniteMap

 import UniqFM
 import FastString
 import Binary
 import Util
 
 import Data.Data
 import UniqFM
 import FastString
 import Binary
 import Util
 
 import Data.Data

+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map

 import System.FilePath
 \end{code}
 
 import System.FilePath
 \end{code}
 

@@ -370,76 +372,76 @@ mainPackageId        = fsToPackageId (fsLit "main")
 
 \begin{code}
 -- | A map keyed off of 'Module's
 
 \begin{code}
 -- | A map keyed off of 'Module's

-newtype ModuleEnv elt = ModuleEnv (FiniteMap Module elt)
+newtype ModuleEnv elt = ModuleEnv (Map Module elt)

 
 filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
 
 filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a

-filterModuleEnv f (ModuleEnv e) = ModuleEnv (filterFM f e)
+filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey f e)

 
 elemModuleEnv :: Module -> ModuleEnv a -> Bool
 
 elemModuleEnv :: Module -> ModuleEnv a -> Bool

-elemModuleEnv m (ModuleEnv e) = elemFM m e
+elemModuleEnv m (ModuleEnv e) = Map.member m e

 
 extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
 
 extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a

-extendModuleEnv (ModuleEnv e) m x = ModuleEnv (addToFM e m x)
+extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert m x e)

 
 

-extendModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
-extendModuleEnv_C f (ModuleEnv e) m x = ModuleEnv (addToFM_C f e m x)
+extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
+extendModuleEnvWith f (ModuleEnv e) m x = ModuleEnv (Map.insertWith f m x e)

 
 extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
 
 extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a

-extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (addListToFM e xs)
+extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (Map.insertList xs e)

 
 extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
                       -> ModuleEnv a
 
 extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
                       -> ModuleEnv a

-extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (addListToFM_C f e xs)
+extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (Map.insertListWith f xs e)

 
 plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
 
 plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a

-plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM_C f e1 e2)
+plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.unionWith f e1 e2)

 
 delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
 
 delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a

-delModuleEnvList (ModuleEnv e) ms = ModuleEnv (delListFromFM e ms)
+delModuleEnvList (ModuleEnv e) ms = ModuleEnv (Map.deleteList ms e)

 
 delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
 
 delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a

-delModuleEnv (ModuleEnv e) m = ModuleEnv (delFromFM e m)
+delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete m e)

 
 plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
 
 plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a

-plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM e1 e2)
+plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)

 
 lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
 
 lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a

-lookupModuleEnv (ModuleEnv e) m = lookupFM e m
+lookupModuleEnv (ModuleEnv e) m = Map.lookup m e

 
 lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
 
 lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a

-lookupWithDefaultModuleEnv (ModuleEnv e) x m = lookupWithDefaultFM e x m
+lookupWithDefaultModuleEnv (ModuleEnv e) x m = Map.findWithDefault x m e

 
 mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
 
 mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b

-mapModuleEnv f (ModuleEnv e) = ModuleEnv (mapFM (\_ v -> f v) e)
+mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)

 
 mkModuleEnv :: [(Module, a)] -> ModuleEnv a
 
 mkModuleEnv :: [(Module, a)] -> ModuleEnv a

-mkModuleEnv xs = ModuleEnv (listToFM xs)
+mkModuleEnv xs = ModuleEnv (Map.fromList xs)

 
 emptyModuleEnv :: ModuleEnv a
 
 emptyModuleEnv :: ModuleEnv a

-emptyModuleEnv = ModuleEnv emptyFM
+emptyModuleEnv = ModuleEnv Map.empty

 
 moduleEnvKeys :: ModuleEnv a -> [Module]
 
 moduleEnvKeys :: ModuleEnv a -> [Module]

-moduleEnvKeys (ModuleEnv e) = keysFM e
+moduleEnvKeys (ModuleEnv e) = Map.keys e

 
 moduleEnvElts :: ModuleEnv a -> [a]
 
 moduleEnvElts :: ModuleEnv a -> [a]

-moduleEnvElts (ModuleEnv e) = eltsFM e
+moduleEnvElts (ModuleEnv e) = Map.elems e

 
 moduleEnvToList :: ModuleEnv a -> [(Module, a)]
 
 moduleEnvToList :: ModuleEnv a -> [(Module, a)]

-moduleEnvToList (ModuleEnv e) = fmToList e
+moduleEnvToList (ModuleEnv e) = Map.toList e

 
 unitModuleEnv :: Module -> a -> ModuleEnv a
 
 unitModuleEnv :: Module -> a -> ModuleEnv a

-unitModuleEnv m x = ModuleEnv (unitFM m x)
+unitModuleEnv m x = ModuleEnv (Map.singleton m x)

 
 isEmptyModuleEnv :: ModuleEnv a -> Bool
 
 isEmptyModuleEnv :: ModuleEnv a -> Bool

-isEmptyModuleEnv (ModuleEnv e) = isEmptyFM e
+isEmptyModuleEnv (ModuleEnv e) = Map.null e

 
 foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
 
 foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b

-foldModuleEnv f x (ModuleEnv e) = foldFM (\_ v -> f v) x e
+foldModuleEnv f x (ModuleEnv e) = Map.foldRightWithKey (\_ v -> f v) x e

 \end{code}
 
 \begin{code}
 -- | A set of 'Module's
 \end{code}
 
 \begin{code}
 -- | A set of 'Module's

-type ModuleSet = FiniteMap Module ()
+type ModuleSet = Map Module ()

 
 mkModuleSet    :: [Module] -> ModuleSet
 extendModuleSet :: ModuleSet -> Module -> ModuleSet
 
 mkModuleSet    :: [Module] -> ModuleSet
 extendModuleSet :: ModuleSet -> Module -> ModuleSet

@@ -447,11 +449,11 @@ emptyModuleSet  :: ModuleSet
 moduleSetElts   :: ModuleSet -> [Module]
 elemModuleSet   :: Module -> ModuleSet -> Bool
 
 moduleSetElts   :: ModuleSet -> [Module]
 elemModuleSet   :: Module -> ModuleSet -> Bool
 

-emptyModuleSet    = emptyFM
-mkModuleSet ms    = listToFM [(m,()) | m <- ms ]
-extendModuleSet s m = addToFM s m ()
-moduleSetElts     = keysFM
-elemModuleSet     = elemFM
+emptyModuleSet    = Map.empty
+mkModuleSet ms    = Map.fromList [(m,()) | m <- ms ]
+extendModuleSet s m = Map.insert m () s
+moduleSetElts     = Map.keys
+elemModuleSet     = Map.member

 \end{code}
 
 A ModuleName has a Unique, so we can build mappings of these using
 \end{code}
 
 A ModuleName has a Unique, so we can build mappings of these using

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 0ba8cc0..0e87c6c 100644 (file)
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -33,7 +33,6 @@ import CmmTx
 import DFMonad
 import Module
 import FastString
 import DFMonad
 import Module
 import FastString

-import FiniteMap

 import ForeignCall
 import IdInfo
 import Data.List
 import ForeignCall
 import IdInfo
 import Data.List

@@ -54,6 +53,10 @@ import qualified ZipCfg as G
 import ZipCfgCmmRep
 import ZipDataflow
 
 import ZipCfgCmmRep
 import ZipDataflow
 

+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
+

 ----------------------------------------------------------------
 -- Building InfoTables
 
 ----------------------------------------------------------------
 -- Building InfoTables
 

@@ -133,12 +136,12 @@ live_ptrs oldByte slotEnv areaMap bid =
 
         liveSlots :: [RegSlotInfo]
         liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
 
         liveSlots :: [RegSlotInfo]
         liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)

-                           (foldFM (\_ -> flip $ foldl add_slot) [] slots)
+                           (Map.foldRightWithKey (\_ -> flip $ foldl add_slot) [] slots)

                     
         add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo]
         add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) = 
           if off == w && widthInBytes (typeWidth ty) == w then
                     
         add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo]
         add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) = 
           if off == w && widthInBytes (typeWidth ty) == w then

-            (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst
+            (expectJust "add_slot" (Map.lookup a areaMap), r, w) : rst

           else panic "live_ptrs: only part of a variable live at a proc point"
         add_slot rst (CallArea Old, _, _) =
           rst -- the update frame (or return infotable) should be live
           else panic "live_ptrs: only part of a variable live at a proc point"
         add_slot rst (CallArea Old, _, _) =
           rst -- the update frame (or return infotable) should be live

@@ -155,7 +158,7 @@ live_ptrs oldByte slotEnv areaMap bid =
 
         slots :: SubAreaSet     -- The SubAreaSet for 'bid'
         slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
 
         slots :: SubAreaSet     -- The SubAreaSet for 'bid'
         slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid

-        youngByte = expectJust "live_ptrs bid_pos" $ lookupFM areaMap (CallArea (Young bid))
+        youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap

 
 -- Construct the stack maps for the given procedure.
 setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables 
 
 -- Construct the stack maps for the given procedure.
 setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables 

@@ -187,14 +190,16 @@ setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap"
 -----------------------------------------------------------------------
 -- Finding the CAFs used by a procedure
 
 -----------------------------------------------------------------------
 -- Finding the CAFs used by a procedure
 

-type CAFSet = FiniteMap CLabel ()
+type CAFSet = Map CLabel ()

 type CAFEnv = BlockEnv CAFSet
 
 -- First, an analysis to find live CAFs.
 cafLattice :: DataflowLattice CAFSet
 type CAFEnv = BlockEnv CAFSet
 
 -- First, an analysis to find live CAFs.
 cafLattice :: DataflowLattice CAFSet

-cafLattice = DataflowLattice "live cafs" emptyFM add False
-  where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new'
-          where new' = new `plusFM` old
+cafLattice = DataflowLattice "live cafs" Map.empty add False
+  where add new old = if Map.size new' > Map.size old
+                      then aTx new'
+                      else noTx new'
+          where new' = new `Map.union` old

 
 cafTransfers :: BackwardTransfers Middle Last CAFSet
 cafTransfers = BackwardTransfers first middle last
 
 cafTransfers :: BackwardTransfers Middle Last CAFSet
 cafTransfers = BackwardTransfers first middle last

@@ -206,7 +211,7 @@ cafTransfers = BackwardTransfers first middle last
                CmmLit (CmmLabelOff c _)         -> add c set
                CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
                _ -> set
                CmmLit (CmmLabelOff c _)         -> add c set
                CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
                _ -> set

-        add l s = if hasCAF l then addToFM s (cvtToClosureLbl l) () else s
+        add l s = if hasCAF l then Map.insert (cvtToClosureLbl l) () s else s

 
 type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
 cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv
 
 type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
 cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv

@@ -222,7 +227,7 @@ cafAnal g = liftM zdfFpFacts (res :: CafFix ())
 data TopSRT = TopSRT { lbl      :: CLabel
                      , next_elt :: Int -- the next entry in the table
                      , rev_elts :: [CLabel]
 data TopSRT = TopSRT { lbl      :: CLabel
                      , next_elt :: Int -- the next entry in the table
                      , rev_elts :: [CLabel]

-                     , elt_map  :: FiniteMap CLabel Int }
+                     , elt_map  :: Map CLabel Int }

                         -- map: CLabel -> its last entry in the table
 instance Outputable TopSRT where
   ppr (TopSRT lbl next elts eltmap) =
                         -- map: CLabel -> its last entry in the table
 instance Outputable TopSRT where
   ppr (TopSRT lbl next elts eltmap) =

@@ -231,19 +236,19 @@ instance Outputable TopSRT where
 emptySRT :: MonadUnique m => m TopSRT
 emptySRT =
   do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
 emptySRT :: MonadUnique m => m TopSRT
 emptySRT =
   do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs

-     return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = emptyFM }
+     return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }

 
 cafMember :: TopSRT -> CLabel -> Bool
 
 cafMember :: TopSRT -> CLabel -> Bool

-cafMember srt lbl = elemFM lbl (elt_map srt)
+cafMember srt lbl = Map.member lbl (elt_map srt)

 
 cafOffset :: TopSRT -> CLabel -> Maybe Int
 
 cafOffset :: TopSRT -> CLabel -> Maybe Int

-cafOffset srt lbl = lookupFM (elt_map srt) lbl
+cafOffset srt lbl = Map.lookup lbl (elt_map srt)

 
 addCAF :: CLabel -> TopSRT -> TopSRT
 addCAF caf srt =
   srt { next_elt = last + 1
       , rev_elts = caf : rev_elts srt
 
 addCAF :: CLabel -> TopSRT -> TopSRT
 addCAF caf srt =
   srt { next_elt = last + 1
       , rev_elts = caf : rev_elts srt

-      , elt_map  = addToFM (elt_map srt) caf last }
+      , elt_map  = Map.insert caf last (elt_map srt) }

     where last  = next_elt srt
 
 srtToData :: TopSRT -> CmmZ
     where last  = next_elt srt
 
 srtToData :: TopSRT -> CmmZ

@@ -258,16 +263,16 @@ srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : t
 -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
 -- we make sure they're all close enough to the bottom of the table that the
 -- bitmap will be able to cover all of them.
 -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
 -- we make sure they're all close enough to the bottom of the table that the
 -- bitmap will be able to cover all of them.

-buildSRTs :: TopSRT -> FiniteMap CLabel CAFSet -> CAFSet ->
+buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->

              FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
 buildSRTs topSRT topCAFMap cafs =
   do let liftCAF lbl () z = -- get CAFs for functions without static closures
              FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
 buildSRTs topSRT topCAFMap cafs =
   do let liftCAF lbl () z = -- get CAFs for functions without static closures

-           case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
-                                          Nothing   -> addToFM z lbl ()
+           case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs
+                                            Nothing   -> Map.insert lbl () z

          -- For each label referring to a function f without a static closure,
          -- replace it with the CAFs that are reachable from f.
          sub_srt topSRT localCafs =
          -- For each label referring to a function f without a static closure,
          -- replace it with the CAFs that are reachable from f.
          sub_srt topSRT localCafs =

-           let cafs = keysFM (foldFM liftCAF emptyFM localCafs)
+           let cafs = Map.keys (Map.foldRightWithKey liftCAF Map.empty localCafs)

                mkSRT topSRT =
                  do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
                     return (topSRT, localSRTs)
                mkSRT topSRT =
                  do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
                     return (topSRT, localSRTs)

@@ -283,7 +288,7 @@ buildSRTs topSRT topCAFMap cafs =
          add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
            add srt (sortBy farthestFst cafs)
              where
          add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
            add srt (sortBy farthestFst cafs)
              where

-               farthestFst x y = case (lookupFM m x, lookupFM m y) of
+               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of

                                    (Nothing, Nothing) -> EQ
                                    (Nothing, Just _)  -> LT
                                    (Just _,  Nothing) -> GT
                                    (Nothing, Nothing) -> EQ
                                    (Nothing, Just _)  -> LT
                                    (Just _,  Nothing) -> GT

@@ -301,7 +306,7 @@ buildSRTs topSRT topCAFMap cafs =
 
 -- Construct an SRT bitmap.
 -- Adapted from simpleStg/SRT.lhs, which expects Id's.
 
 -- Construct an SRT bitmap.
 -- Adapted from simpleStg/SRT.lhs, which expects Id's.

-procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] ->
+procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->

                 FuelMonad (Maybe CmmTopZ, C_SRT)
 procpointSRT _ _ [] =
  return (Nothing, NoC_SRT)
                 FuelMonad (Maybe CmmTopZ, C_SRT)
 procpointSRT _ _ [] =
  return (Nothing, NoC_SRT)

@@ -309,7 +314,7 @@ procpointSRT top_srt top_table entries =
  do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
     return (top, srt)
   where
  do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
     return (top, srt)
   where

-    ints = map (expectJust "constructSRT" . lookupFM top_table) entries
+    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries

     sorted_ints = sortLe (<=) ints
     offset = head sorted_ints
     bitmap_entries = map (subtract offset) sorted_ints
     sorted_ints = sortLe (<=) ints
     offset = head sorted_ints
     bitmap_entries = map (subtract offset) sorted_ints

@@ -361,21 +366,21 @@ localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _))
 -- the environment with every reference to f replaced by its set of CAFs.
 -- To do this replacement efficiently, we gather strongly connected
 -- components, then we sort the components in topological order.
 -- the environment with every reference to f replaced by its set of CAFs.
 -- To do this replacement efficiently, we gather strongly connected
 -- components, then we sort the components in topological order.

-mkTopCAFInfo :: [(CLabel, CAFSet)] -> FiniteMap CLabel CAFSet
-mkTopCAFInfo localCAFs = foldl addToTop emptyFM g
+mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet
+mkTopCAFInfo localCAFs = foldl addToTop Map.empty g

   where addToTop env (AcyclicSCC (l, cafset)) =
   where addToTop env (AcyclicSCC (l, cafset)) =

-          addToFM env l (flatten env cafset)
+          Map.insert l (flatten env cafset) env

         addToTop env (CyclicSCC nodes) =
           let (lbls, cafsets) = unzip nodes
         addToTop env (CyclicSCC nodes) =
           let (lbls, cafsets) = unzip nodes

-              cafset  = foldl plusFM  emptyFM cafsets `delListFromFM` lbls
-          in foldl (\env l -> addToFM env l (flatten env cafset)) env lbls
-        flatten env cafset = foldFM (lookup env) emptyFM cafset
+              cafset  = lbls `Map.deleteList` foldl Map.union Map.empty cafsets
+          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
+        flatten env cafset = Map.foldRightWithKey (lookup env) Map.empty cafset

         lookup env caf () cafset' =
         lookup env caf () cafset' =

-          case lookupFM env caf of Just cafs -> foldFM add cafset' cafs
-                                   Nothing -> add caf () cafset'
-        add caf () cafset' = addToFM cafset' caf ()
+          case Map.lookup caf env of Just cafs -> Map.foldRightWithKey add cafset' cafs
+                                     Nothing -> add caf () cafset'
+        add caf () cafset' = Map.insert caf () cafset'

         g = stronglyConnCompFromEdgedVertices
         g = stronglyConnCompFromEdgedVertices

-              (map (\n@(l, cafs) -> (n, l, keysFM cafs)) localCAFs)
+              (map (\n@(l, cafs) -> (n, l, Map.keys cafs)) localCAFs)

 
 type StackLayout = [Maybe LocalReg]
 
 
 type StackLayout = [Maybe LocalReg]
 

@@ -388,10 +393,10 @@ bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
              -- until we stop splitting the graphs at procpoints in the native path
 bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
   (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
              -- until we stop splitting the graphs at procpoints in the native path
 bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
   (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)

-bundleCAFs _ t@(NoInfoTable _) = (emptyFM, t)
+bundleCAFs _ t@(NoInfoTable _) = (Map.empty, t)

 
 -- Construct the SRTs for the given procedure.
 
 -- Construct the SRTs for the given procedure.

-setInfoTableSRT :: FiniteMap CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) ->
+setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) ->

                    FuelMonad (TopSRT, [CmmTopForInfoTables])
 setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) =
   case blockSetToList procpoints of
                    FuelMonad (TopSRT, [CmmTopForInfoTables])
 setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) =
   case blockSetToList procpoints of

@@ -402,7 +407,7 @@ setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) =
   setSRT cafs topCAFMap topSRT t
 setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])
 
   setSRT cafs topCAFMap topSRT t
 setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])
 

-setSRT :: CAFSet -> FiniteMap CLabel CAFSet -> TopSRT ->
+setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->

           CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
 setSRT cafs topCAFMap topSRT t =
   do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
           CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
 setSRT cafs topCAFMap topSRT t =
   do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index fa568af..d74da69 100644 (file)
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -24,10 +24,11 @@ import ZipCfgCmmRep
 
 import DynFlags
 import ErrUtils
 
 import DynFlags
 import ErrUtils

-import FiniteMap

 import HscTypes
 import Data.Maybe
 import Control.Monad
 import HscTypes
 import Data.Maybe
 import Control.Monad

+import Data.Map (Map)
+import qualified Data.Map as Map

 import Outputable
 import StaticFlags
 
 import Outputable
 import StaticFlags
 

@@ -73,7 +74,7 @@ global to one compiler session.
 cpsTop :: HscEnv -> CmmTopZ ->
           IO ([(CLabel, CAFSet)],
               [(CAFSet, CmmTopForInfoTables)])
 cpsTop :: HscEnv -> CmmTopZ ->
           IO ([(CLabel, CAFSet)],
               [(CAFSet, CmmTopForInfoTables)])

-cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)])
+cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)])

 cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
     do 
        dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
 cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
     do 
        dump Opt_D_dump_cmmz "Pre Proc Points Added"  g

@@ -172,7 +173,7 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
 -- This probably belongs in CmmBuildInfoTables?
 -- We're just finishing the job here: once we know what CAFs are defined
 -- in non-static closures, we can build the SRTs.
 -- This probably belongs in CmmBuildInfoTables?
 -- We're just finishing the job here: once we know what CAFs are defined
 -- in non-static closures, we can build the SRTs.

-toTops :: HscEnv -> FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
+toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]])

                  -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
 
 toTops hsc_env topCAFEnv (topSRT, tops) gs =
                  -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
 
 toTops hsc_env topCAFEnv (topSRT, tops) gs =

diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 39099f1..8a5bab1 100644 (file)
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -49,13 +49,13 @@ import BlockId
 import CLabel
 import Constants
 import FastString
 import CLabel
 import Constants
 import FastString

-import FiniteMap

 import Outputable
 import Unique
 import UniqSet
 
 import Data.Word
 import Data.Int
 import Outputable
 import Unique
 import UniqSet
 
 import Data.Word
 import Data.Int

+import Data.Map (Map)

 
 -----------------------------------------------------------------------------
 --             CmmExpr
 
 -----------------------------------------------------------------------------
 --             CmmExpr

@@ -117,9 +117,9 @@ necessarily at the young end of the Old area.
 End of note -}
 
 type SubArea    = (Area, Int, Int) -- area, offset, width
 End of note -}
 
 type SubArea    = (Area, Int, Int) -- area, offset, width

-type SubAreaSet = FiniteMap Area [SubArea]
+type SubAreaSet = Map Area [SubArea]

 
 

-type AreaMap    = FiniteMap Area Int
+type AreaMap    = Map Area Int

      -- Byte offset of the oldest byte of the Area, 
      -- relative to the oldest byte of the Old Area
 
      -- Byte offset of the oldest byte of the Area, 
      -- relative to the oldest byte of the Old Area
 

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 13f6421..c972ad5 100644 (file)
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -15,7 +15,6 @@ import CmmInfo
 import CmmLiveZ
 import CmmTx
 import DFMonad
 import CmmLiveZ
 import CmmTx
 import DFMonad

-import FiniteMap

 import Data.List (sortBy)
 import Maybes
 import MkZipCfg
 import Data.List (sortBy)
 import Maybes
 import MkZipCfg

@@ -28,6 +27,8 @@ import ZipCfg
 import ZipCfgCmmRep
 import ZipDataflow
 
 import ZipCfgCmmRep
 import ZipDataflow
 

+import qualified Data.Map as Map
+

 -- Compute a minimal set of proc points for a control-flow graph.
 
 -- Determine a protocol for each proc point (which live variables will
 -- Compute a minimal set of proc points for a control-flow graph.
 
 -- Determine a protocol for each proc point (which live variables will

@@ -399,9 +400,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap
      graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
      -- Build a map from proc point BlockId to labels for their new procedures
      -- Due to common blockification, we may overestimate the set of procpoints.
      graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
      -- Build a map from proc point BlockId to labels for their new procedures
      -- Due to common blockification, we may overestimate the set of procpoints.

-     let add_label map pp = return $ addToFM map pp lbl
+     let add_label map pp = return $ Map.insert pp lbl map

            where lbl = if pp == entry then entry_label else blockLbl pp
            where lbl = if pp == entry then entry_label else blockLbl pp

-     procLabels <- foldM add_label emptyFM
+     procLabels <- foldM add_label Map.empty

                          (filter (elemBlockEnv blocks) (blockSetToList procPoints))
      -- For each procpoint, we need to know the SP offset on entry.
      -- If the procpoint is:
                          (filter (elemBlockEnv blocks) (blockSetToList procPoints))
      -- For each procpoint, we need to know the SP offset on entry.
      -- If the procpoint is:

@@ -434,7 +435,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
                         add_if_pp ti (add_if_pp fi rst)
                       LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl)
                       _ -> rst
                         add_if_pp ti (add_if_pp fi rst)
                       LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl)
                       _ -> rst

-                  add_if_pp id rst = case lookupFM procLabels id of
+                  add_if_pp id rst = case Map.lookup id procLabels of

                                        Just x -> (id, x) : rst
                                        Nothing -> rst
               (jumpEnv, jumpBlocks) <-
                                        Just x -> (id, x) : rst
                                        Nothing -> rst
               (jumpEnv, jumpBlocks) <-

@@ -456,14 +457,14 @@ splitAtProcPoints entry_label callPPs procPoints procMap
              CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g)
            else
              CmmProc emptyContInfoTable lbl [] (replacePPIds g)
              CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g)
            else
              CmmProc emptyContInfoTable lbl [] (replacePPIds g)

-           where lbl = expectJust "pp label" $ lookupFM procLabels bid
+           where lbl = expectJust "pp label" $ Map.lookup bid procLabels

          to_proc (bid, g) =
            CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)
          to_proc (bid, g) =
            CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)

-             where lbl = expectJust "pp label" $ lookupFM procLabels bid
+             where lbl = expectJust "pp label" $ Map.lookup bid procLabels

          -- References to procpoint IDs can now be replaced with the infotable's label
          replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g)
            where repl e@(CmmLit (CmmBlock bid)) =
          -- References to procpoint IDs can now be replaced with the infotable's label
          replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g)
            where repl e@(CmmLit (CmmBlock bid)) =

-                   case lookupFM procLabels bid of
+                   case Map.lookup bid procLabels of

                      Just l  -> CmmLit (CmmLabel (entryLblToInfoLbl l))
                      Nothing -> e
                  repl e = e
                      Just l  -> CmmLit (CmmLabel (entryLblToInfoLbl l))
                      Nothing -> e
                  repl e = e

diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index dedb6b0..06204ef 100644 (file)
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -18,7 +18,6 @@ import CmmExpr
 import CmmProcPointZ
 import CmmTx
 import DFMonad
 import CmmProcPointZ
 import CmmTx
 import DFMonad

-import FiniteMap

 import Maybes
 import MkZipCfg
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
 import Maybes
 import MkZipCfg
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph)

@@ -30,6 +29,10 @@ import ZipCfg as Z
 import ZipCfgCmmRep
 import ZipDataflow
 
 import ZipCfgCmmRep
 import ZipDataflow
 

+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
+

 ------------------------------------------------------------------------
 --                    Stack Layout                                    --
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 --                    Stack Layout                                    --
 ------------------------------------------------------------------------

@@ -63,14 +66,14 @@ import ZipDataflow
 -- a single slot, on insertion.
 
 slotLattice :: DataflowLattice SubAreaSet
 -- a single slot, on insertion.
 
 slotLattice :: DataflowLattice SubAreaSet

-slotLattice = DataflowLattice "live slots" emptyFM add False
-  where add new old = case foldFM addArea (False, old) new of
+slotLattice = DataflowLattice "live slots" Map.empty add False
+  where add new old = case Map.foldRightWithKey addArea (False, old) new of

                         (True,  x) -> aTx  x
                         (False, x) -> noTx x
         addArea a newSlots z = foldr (addSlot a) z newSlots
         addSlot a slot (changed, map) =
                         (True,  x) -> aTx  x
                         (False, x) -> noTx x
         addArea a newSlots z = foldr (addSlot a) z newSlots
         addSlot a slot (changed, map) =

-          let (c, live) = liveGen slot $ lookupWithDefaultFM map [] a
-          in (c || changed, addToFM map a live)
+          let (c, live) = liveGen slot $ Map.findWithDefault [] a map
+          in (c || changed, Map.insert a live map)

 
 type SlotEnv   = BlockEnv SubAreaSet
   -- The sub-areas live on entry to the block
 
 type SlotEnv   = BlockEnv SubAreaSet
   -- The sub-areas live on entry to the block

@@ -122,17 +125,17 @@ liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $
 liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
 liveSlotTransfers =
   BackwardTransfers first liveInSlots liveLastIn
 liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
 liveSlotTransfers =
   BackwardTransfers first liveInSlots liveLastIn

-    where first id live = delFromFM live (CallArea (Young id))
+    where first id live = Map.delete (CallArea (Young id)) live

 
 -- Slot sets: adding slots, removing slots, and checking for membership.
 liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet 
 addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet
 elemSlot            :: SubAreaSet -> SubArea -> Bool
 
 -- Slot sets: adding slots, removing slots, and checking for membership.
 liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet 
 addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet
 elemSlot            :: SubAreaSet -> SubArea -> Bool

-liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a)
+liftToArea a f map = Map.insert a (f (Map.findWithDefault [] a map)) map

 addSlot    live (a, i, w) = liftToArea a (snd . liveGen  (a, i, w)) live
 removeSlot live (a, i, w) = liftToArea a       (liveKill (a, i, w)) live
 elemSlot   live (a, i, w) =
 addSlot    live (a, i, w) = liftToArea a (snd . liveGen  (a, i, w)) live
 removeSlot live (a, i, w) = liftToArea a       (liveKill (a, i, w)) live
 elemSlot   live (a, i, w) =

-  not $ fst $ liveGen  (a, i, w) (lookupWithDefaultFM live [] a)
+  not $ fst $ liveGen  (a, i, w) (Map.findWithDefault [] a live)

 
 removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
 removeLiveSlotDefs = foldSlotsDefd removeSlot
 
 removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
 removeLiveSlotDefs = foldSlotsDefd removeSlot

@@ -163,7 +166,7 @@ liveLastOut env l =
   where out = joinOuts slotLattice env l
         add_area _ n live | n == 0 = live
         add_area a n live =
   where out = joinOuts slotLattice env l
         add_area _ n live | n == 0 = live
         add_area a n live =

-          addToFM live a $ snd $ liveGen (a, n, n) $ lookupWithDefaultFM live [] a
+          Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live

 
 -- The liveness analysis must be precise: otherwise, we won't know if a definition
 -- should really kill a live-out stack slot.
 
 -- The liveness analysis must be precise: otherwise, we won't know if a definition
 -- should really kill a live-out stack slot.

@@ -174,7 +177,7 @@ liveLastOut env l =
 -- every time, I provide a function to fold over the nodes, which should be a
 -- reasonably efficient approach for the implementations we envision.
 -- Of course, it will probably be much easier to program if we just return a list...
 -- every time, I provide a function to fold over the nodes, which should be a
 -- reasonably efficient approach for the implementations we envision.
 -- Of course, it will probably be much easier to program if we just return a list...

-type Set x = FiniteMap x ()
+type Set x = Map x ()

 data IGraphBuilder n =
   Builder { foldNodes     :: forall z. SubArea -> (n -> z -> z) -> z -> z
           , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
 data IGraphBuilder n =
   Builder { foldNodes     :: forall z. SubArea -> (n -> z -> z) -> z -> z
           , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]

@@ -184,8 +187,8 @@ areaBuilder :: IGraphBuilder Area
 areaBuilder = Builder fold words
   where fold (a, _, _) f z = f a z
         words areaSize areaMap a =
 areaBuilder = Builder fold words
   where fold (a, _, _) f z = f a z
         words areaSize areaMap a =

-          case lookupFM areaMap a of
-            Just addr -> [addr .. addr + (lookupFM areaSize a `orElse`
+          case Map.lookup a areaMap of
+            Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse`

                                           pprPanic "wordsOccupied: unknown area" (ppr a))]
             Nothing   -> []
 
                                           pprPanic "wordsOccupied: unknown area" (ppr a))]
             Nothing   -> []
 

@@ -195,10 +198,10 @@ areaBuilder = Builder fold words
 -- Now, we can build the interference graph.
 -- The usual story: a definition interferes with all live outs and all other
 -- definitions.
 -- Now, we can build the interference graph.
 -- The usual story: a definition interferes with all live outs and all other
 -- definitions.

-type IGraph x = FiniteMap x (Set x)
+type IGraph x = Map x (Set x)

 type IGPair x = (IGraph x, IGraphBuilder x)
 igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x
 type IGPair x = (IGraph x, IGraphBuilder x)
 igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x

-igraph builder env g = foldr interfere emptyFM (postorder_dfs g)
+igraph builder env g = foldr interfere Map.empty (postorder_dfs g)

   where foldN = foldNodes builder
         interfere block igraph =
           let (h, l) = goto_end (unzip block)
   where foldN = foldNodes builder
         interfere block igraph =
           let (h, l) = goto_end (unzip block)

@@ -210,15 +213,15 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g)
               addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
               addDef (igraph, out) def@(a, _, _) =
                 (foldN def (addDefN out) igraph,
               addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
               addDef (igraph, out) def@(a, _, _) =
                 (foldN def (addDefN out) igraph,

-                 addToFM out a (snd $ liveGen def (lookupWithDefaultFM out [] a)))
+                 Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out)

               addDefN out n igraph =
                 let addEdgeNO o igraph = foldN o addEdgeNN igraph
                     addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph
               addDefN out n igraph =
                 let addEdgeNO o igraph = foldN o addEdgeNN igraph
                     addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph

-                    addEdgeNN' n n' igraph = addToFM igraph n (addToFM set n' ())
-                      where set = lookupWithDefaultFM igraph emptyFM n
-                in foldFM (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
+                    addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph
+                      where set = Map.findWithDefault Map.empty n igraph
+                in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out

               env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
               env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"

-          in heads h $ case l of LastExit    -> (igraph, emptyFM)
+          in heads h $ case l of LastExit    -> (igraph, Map.empty)

                                  LastOther l -> (addEdges igraph l $ liveLastOut env' l,
                                                  liveLastIn l env')
 
                                  LastOther l -> (addEdges igraph l $ liveLastOut env' l,
                                                  liveLastIn l env')
 

@@ -230,7 +233,7 @@ getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap
   -- used for (a) variable spill slots, and (b) parameter passing ares for calls
 getAreaSize entry_off g@(LGraph _ _) =
   fold_blocks (fold_fwd_block first add_regslots last)
   -- used for (a) variable spill slots, and (b) parameter passing ares for calls
 getAreaSize entry_off g@(LGraph _ _) =
   fold_blocks (fold_fwd_block first add_regslots last)

-              (unitFM (CallArea Old) entry_off) g
+              (Map.singleton (CallArea Old) entry_off) g

   where first _  z = z
         last l@(LastOther (LastCall _ Nothing args res _)) z =
           add_regslots l (add (add z area args) area res)
   where first _  z = z
         last l@(LastOther (LastCall _ Nothing args res _)) z =
           add_regslots l (add (add z area args) area res)

@@ -243,7 +246,7 @@ getAreaSize entry_off g@(LGraph _ _) =
         addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) =
           add z a $ widthInBytes $ typeWidth ty
         addSlot z _ = z
         addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) =
           add z a $ widthInBytes $ typeWidth ty
         addSlot z _ = z

-        add z a off = addToFM z a (max off (lookupWithDefaultFM z 0 a))
+        add z a off = Map.insert a (max off (Map.findWithDefault 0 a z)) z

        -- The 'max' is important.  Two calls, to f and g, might share a common
        -- continuation (and hence a common CallArea), but their number of overflow
        -- parameters might differ.
        -- The 'max' is important.  Two calls, to f and g, might share a common
        -- continuation (and hence a common CallArea), but their number of overflow
        -- parameters might differ.

@@ -252,19 +255,19 @@ getAreaSize entry_off g@(LGraph _ _) =
 -- Find the Stack slots occupied by the subarea's conflicts
 conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
 conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
 -- Find the Stack slots occupied by the subarea's conflicts
 conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
 conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =

-  foldNodes subarea foldNode emptyFM
-  where foldNode n set = foldFM conflict set $ lookupWithDefaultFM ig emptyFM n
+  foldNodes subarea foldNode Map.empty
+  where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig

         conflict n' () set = liveInSlots areaMap n' set
         -- Add stack slots occupied by igraph node n
         liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
         conflict n' () set = liveInSlots areaMap n' set
         -- Add stack slots occupied by igraph node n
         liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)

-        setAdd w s = addToFM s w ()
+        setAdd w s = Map.insert w () s

 
 -- Find any open space on the stack, starting from the offset.
 -- If the area is a CallArea or a spill slot for a pointer, then it must
 -- be word-aligned.
 freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
 freeSlotFrom ig areaSize offset areaMap area =
 
 -- Find any open space on the stack, starting from the offset.
 -- If the area is a CallArea or a spill slot for a pointer, then it must
 -- be word-aligned.
 freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
 freeSlotFrom ig areaSize offset areaMap area =

-  let size = lookupFM areaSize area `orElse` 0
+  let size = Map.lookup area areaSize `orElse` 0

       conflicts = conflictSlots ig areaSize areaMap (area, size, size)
       -- CallAreas and Ptrs need to be word-aligned (round up!)
       align = case area of CallArea _                                -> align'
       conflicts = conflictSlots ig areaSize areaMap (area, size, size)
       -- CallAreas and Ptrs need to be word-aligned (round up!)
       align = case area of CallArea _                                -> align'

@@ -274,7 +277,7 @@ freeSlotFrom ig areaSize offset areaMap area =
       -- Find a space big enough to hold the area
       findSpace curr 0 = curr
       findSpace curr cnt = -- part of target slot, # of bytes left to check
       -- Find a space big enough to hold the area
       findSpace curr 0 = curr
       findSpace curr cnt = -- part of target slot, # of bytes left to check

-        if elemFM curr conflicts then
+        if Map.member curr conflicts then

           findSpace (align (curr + size)) size -- try the next (possibly) open space
         else findSpace (curr - 1) (cnt - 1)
   in findSpace (align (offset + size)) size
           findSpace (align (curr + size)) size -- try the next (possibly) open space
         else findSpace (curr - 1) (cnt - 1)
   in findSpace (align (offset + size)) size

@@ -282,8 +285,8 @@ freeSlotFrom ig areaSize offset areaMap area =
 -- Find an open space on the stack, and assign it to the area.
 allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
 allocSlotFrom ig areaSize from areaMap area =
 -- Find an open space on the stack, and assign it to the area.
 allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
 allocSlotFrom ig areaSize from areaMap area =

-  if elemFM area areaMap then areaMap
-  else addToFM areaMap area $ freeSlotFrom ig areaSize from areaMap area
+  if Map.member area areaMap then areaMap
+  else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap

 
 -- | Greedy stack layout.
 -- Compute liveness, build the interference graph, and allocate slots for the areas.
 
 -- | Greedy stack layout.
 -- Compute liveness, build the interference graph, and allocate slots for the areas.

@@ -319,7 +322,7 @@ layout procPoints env entry_off g =
       -- Find the slots that are live-in to a block tail
       live_in (ZTail m l) = liveInSlots m (live_in l)
       live_in (ZLast (LastOther l)) = liveLastIn l env'
       -- Find the slots that are live-in to a block tail
       live_in (ZTail m l) = liveInSlots m (live_in l)
       live_in (ZLast (LastOther l)) = liveLastIn l env'

-      live_in (ZLast LastExit) = emptyFM 
+      live_in (ZLast LastExit) = Map.empty 

 
       -- Find the youngest live stack slot that has already been allocated
       youngest_live :: AreaMap            -- Already allocated
 
       -- Find the youngest live stack slot that has already been allocated
       youngest_live :: AreaMap            -- Already allocated

@@ -327,17 +330,17 @@ layout procPoints env entry_off g =
                    -> ByteOff     -- Offset of the youngest byte of any 
                                   --    already-allocated, live sub-area
       youngest_live areaMap live = fold_subareas young_slot live 0
                    -> ByteOff     -- Offset of the youngest byte of any 
                                   --    already-allocated, live sub-area
       youngest_live areaMap live = fold_subareas young_slot live 0

-        where young_slot (a, o, _) z = case lookupFM areaMap a of
+        where young_slot (a, o, _) z = case Map.lookup a areaMap of

                                          Just top -> max z $ top + o
                                          Nothing  -> z
                                          Just top -> max z $ top + o
                                          Nothing  -> z

-              fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m
+              fold_subareas f m z = Map.foldRightWithKey (\_ s z -> foldr f z s) z m

 
       -- Allocate space for spill slots and call areas
       allocVarSlot = allocSlotFrom ig areaSize 0
 
       -- Update the successor's incoming SP.
       setSuccSPs inSp bid areaMap =
 
       -- Allocate space for spill slots and call areas
       allocVarSlot = allocSlotFrom ig areaSize 0
 
       -- Update the successor's incoming SP.
       setSuccSPs inSp bid areaMap =

-        case (lookupFM areaMap area, lookupBlockEnv (lg_blocks g) bid) of
+        case (Map.lookup area areaMap, lookupBlockEnv (lg_blocks g) bid) of

           (Just _, _) -> areaMap -- succ already knows incoming SP
           (Nothing, Just (Block _ _)) ->
             if elemBlockSet bid procPoints then
           (Just _, _) -> areaMap -- succ already knows incoming SP
           (Nothing, Just (Block _ _)) ->
             if elemBlockSet bid procPoints then

@@ -347,18 +350,18 @@ layout procPoints env entry_off g =
                   start = young -- maybe wrong, but I don't understand
                                 -- why the preceding is necessary...
               in  allocSlotFrom ig areaSize start areaMap area
                   start = young -- maybe wrong, but I don't understand
                                 -- why the preceding is necessary...
               in  allocSlotFrom ig areaSize start areaMap area

-            else addToFM areaMap area inSp
+            else Map.insert area inSp areaMap

           (_, Nothing) -> panic "Block not found in cfg"
         where area = CallArea (Young bid)
 
       allocLast (Block id _) areaMap l =
         fold_succs (setSuccSPs inSp) l areaMap
           (_, Nothing) -> panic "Block not found in cfg"
         where area = CallArea (Young bid)
 
       allocLast (Block id _) areaMap l =
         fold_succs (setSuccSPs inSp) l areaMap

-        where inSp = expectJust "sp in" $ lookupFM areaMap (CallArea (Young id))
+        where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap

 
       allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
         let young     = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
             area      = CallArea (Young bid)
 
       allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
         let young     = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
             area      = CallArea (Young bid)

-            areaSize' = addToFM areaSize area (widthInBytes (typeWidth gcWord))
+            areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize

         in  allocSlotFrom ig areaSize' young areaMap area
       allocMidCall _ _ areaMap = areaMap
 
         in  allocSlotFrom ig areaSize' young areaMap area
       allocMidCall _ _ areaMap = areaMap
 

@@ -370,8 +373,8 @@ layout procPoints env entry_off g =
       layoutAreas areaMap b@(Block _ t) = layout areaMap t
         where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
               layout areaMap (ZLast l)   = allocLast b areaMap l
       layoutAreas areaMap b@(Block _ t) = layout areaMap t
         where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
               layout areaMap (ZLast l)   = allocLast b areaMap l

-      initMap = addToFM (addToFM emptyFM (CallArea Old) 0)
-                        (CallArea (Young (lg_entry g))) 0
+      initMap = Map.insert (CallArea (Young (lg_entry g))) 0
+                           (Map.insert (CallArea Old) 0 Map.empty)

       areaMap = foldl layoutAreas initMap (postorder_dfs g)
   in -- pprTrace "ProcPoints" (ppr procPoints) $
         -- pprTrace "Area SizeMap" (ppr areaSize) $
       areaMap = foldl layoutAreas initMap (postorder_dfs g)
   in -- pprTrace "ProcPoints" (ppr procPoints) $
         -- pprTrace "Area SizeMap" (ppr areaSize) $

@@ -392,7 +395,7 @@ manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Midd
 manifestSP areaMap entry_off g@(LGraph entry _blocks) =
   liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g)
   where slot a = -- pprTrace "slot" (ppr a) $
 manifestSP areaMap entry_off g@(LGraph entry _blocks) =
   liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g)
   where slot a = -- pprTrace "slot" (ppr a) $

-                   lookupFM areaMap a `orElse` panic "unallocated Area"
+                   Map.lookup a areaMap `orElse` panic "unallocated Area"

         slot' (Just id) = slot $ CallArea (Young id)
         slot' Nothing   = slot $ CallArea Old
         sp_high = maxSlot slot g
         slot' (Just id) = slot $ CallArea (Young id)
         slot' Nothing   = slot $ CallArea Old
         sp_high = maxSlot slot g

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 9f284c8..a36a356 100644 (file)
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -44,7 +44,6 @@ import ClosureInfo
 import DynFlags
 import Unique
 import UniqSet
 import DynFlags
 import Unique
 import UniqSet

-import FiniteMap

 import UniqFM
 import FastString
 import Outputable
 import UniqFM
 import FastString
 import Outputable

@@ -57,6 +56,8 @@ import Data.List
 import Data.Bits
 import Data.Char
 import System.IO
 import Data.Bits
 import Data.Char
 import System.IO

+import Data.Map (Map)
+import qualified Data.Map as Map

 import Data.Word
 
 import Data.Array.ST
 import Data.Word
 
 import Data.Array.ST

@@ -865,12 +866,12 @@ is_cish StdCallConv = True
 pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
 pprTempAndExternDecls stmts 
   = (vcat (map pprTempDecl (uniqSetToList temps)), 
 pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
 pprTempAndExternDecls stmts 
   = (vcat (map pprTempDecl (uniqSetToList temps)), 

-     vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)))
+     vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))

   where (temps, lbls) = runTE (mapM_ te_BB stmts)
 
 pprDataExterns :: [CmmStatic] -> SDoc
 pprDataExterns statics
   where (temps, lbls) = runTE (mapM_ te_BB stmts)
 
 pprDataExterns :: [CmmStatic] -> SDoc
 pprDataExterns statics

-  = vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls))
+  = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))

   where (_, lbls) = runTE (mapM_ te_Static statics)
 
 pprTempDecl :: LocalReg -> SDoc
   where (_, lbls) = runTE (mapM_ te_Static statics)
 
 pprTempDecl :: LocalReg -> SDoc

@@ -901,7 +902,7 @@ pprExternDecl in_srt lbl
         <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
         <> semi
 
         <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
         <> semi
 

-type TEState = (UniqSet LocalReg, FiniteMap CLabel ())
+type TEState = (UniqSet LocalReg, Map CLabel ())

 newtype TE a = TE { unTE :: TEState -> (a, TEState) }
 
 instance Monad TE where
 newtype TE a = TE { unTE :: TEState -> (a, TEState) }
 
 instance Monad TE where

@@ -909,13 +910,13 @@ instance Monad TE where
    return a    = TE $ \s -> (a, s)
 
 te_lbl :: CLabel -> TE ()
    return a    = TE $ \s -> (a, s)
 
 te_lbl :: CLabel -> TE ()

-te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, addToFM lbls lbl ()))
+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))

 
 te_temp :: LocalReg -> TE ()
 te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
 
 runTE :: TE () -> TEState
 
 te_temp :: LocalReg -> TE ()
 te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
 
 runTE :: TE () -> TEState

-runTE (TE m) = snd (m (emptyUniqSet, emptyFM))
+runTE (TE m) = snd (m (emptyUniqSet, Map.empty))

 
 te_Static :: CmmStatic -> TE ()
 te_Static (CmmStaticLit lit) = te_Lit lit
 
 te_Static :: CmmStatic -> TE ()
 te_Static (CmmStaticLit lit) = te_Lit lit

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index f32ce93..21ce13d 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -23,7 +23,6 @@ import FastString
 import HscTypes        
 import StaticFlags
 import TyCon
 import HscTypes        
 import StaticFlags
 import TyCon

-import FiniteMap

 import MonadUtils
 import Maybes
 
 import MonadUtils
 import Maybes
 

@@ -35,6 +34,8 @@ import Trace.Hpc.Util
 
 import BreakArray 
 import Data.HashTable   ( hashString )
 
 import BreakArray 
 import Data.HashTable   ( hashString )

+import Data.Map (Map)
+import qualified Data.Map as Map

 \end{code}
 
 
 \end{code}
 
 

@@ -76,8 +77,8 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
                       { fileName    = mkFastString orig_file2
                      , declPath     = []
                       , inScope      = emptyVarSet
                       { fileName    = mkFastString orig_file2
                      , declPath     = []
                       , inScope      = emptyVarSet

-                     , blackList    = listToFM [ (getSrcSpan (tyConName tyCon),()) 
-                                               | tyCon <- tyCons ]
+                     , blackList    = Map.fromList [ (getSrcSpan (tyConName tyCon),()) 
+                                                   | tyCon <- tyCons ]

                       })
                   (TT 
                      { tickBoxCount = 0
                       })
                   (TT 
                      { tickBoxCount = 0

@@ -574,7 +575,7 @@ data TickTransState = TT { tickBoxCount:: Int
 data TickTransEnv = TTE { fileName      :: FastString
                        , declPath     :: [String]
                         , inScope      :: VarSet
 data TickTransEnv = TTE { fileName      :: FastString
                        , declPath     :: [String]
                         , inScope      :: VarSet

-                       , blackList   :: FiniteMap SrcSpan ()
+                       , blackList   :: Map SrcSpan ()

                        }
 
 --     deriving Show
                        }
 
 --     deriving Show

@@ -658,7 +659,7 @@ bindLocals new_ids (TM m)
 
 isBlackListed :: SrcSpan -> TM Bool
 isBlackListed pos = TM $ \ env st -> 
 
 isBlackListed :: SrcSpan -> TM Bool
 isBlackListed pos = TM $ \ env st -> 

-             case lookupFM (blackList env) pos of
+             case Map.lookup pos (blackList env) of

                Nothing -> (False,noFVs,st)
                Just () -> (True,noFVs,st)
 
                Nothing -> (False,noFVs,st)
                Just () -> (True,noFVs,st)
 

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index d64a649..649b2f1 100644 (file)
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -42,9 +42,10 @@ import SrcLoc
 import Maybes
 import Util
 import Name
 import Maybes
 import Util
 import Name

-import FiniteMap

 import Outputable
 import FastString
 import Outputable
 import FastString

+
+import qualified Data.Map as Map

 \end{code}
 
 This function is a wrapper of @match@, it must be called from all the parts where 
 \end{code}
 
 This function is a wrapper of @match@, it must be called from all the parts where 

@@ -801,14 +802,14 @@ subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
 -- Each sub-list in the result has the same PatGroup
 -- See Note [Take care with pattern order]
 subGroup group 
 -- Each sub-list in the result has the same PatGroup
 -- See Note [Take care with pattern order]
 subGroup group 

-    = map reverse $ eltsFM $ foldl accumulate emptyFM group
+    = map reverse $ Map.elems $ foldl accumulate Map.empty group

   where
     accumulate pg_map (pg, eqn)
   where
     accumulate pg_map (pg, eqn)

-      = case lookupFM pg_map pg of
-          Just eqns -> addToFM pg_map pg (eqn:eqns)
-          Nothing   -> addToFM pg_map pg [eqn]
+      = case Map.lookup pg pg_map of
+          Just eqns -> Map.insert pg (eqn:eqns) pg_map
+          Nothing   -> Map.insert pg [eqn]      pg_map

 
 

-    -- pg_map :: FiniteMap a [EquationInfo]
+    -- pg_map :: Map a [EquationInfo]

     -- Equations seen so far in reverse order of appearance
 \end{code}
 
     -- Equations seen so far in reverse order of appearance
 \end{code}
 

diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index d5ffae1..0fa7c62 100644 (file)
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -23,7 +23,6 @@ import ByteCodeItbls
 
 import Name
 import NameSet
 
 import Name
 import NameSet

-import FiniteMap

 import Literal
 import TyCon
 import PrimOp
 import Literal
 import TyCon
 import PrimOp

@@ -42,6 +41,8 @@ import Data.Array.ST    ( castSTUArray )
 import Foreign
 import Data.Char        ( ord )
 import Data.List
 import Foreign
 import Data.Char        ( ord )
 import Data.List

+import Data.Map (Map)
+import qualified Data.Map as Map

 
 import GHC.Base         ( ByteArray#, MutableByteArray#, RealWorld )
 
 
 import GHC.Base         ( ByteArray#, MutableByteArray#, RealWorld )
 

@@ -128,19 +129,19 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
           | wORD_SIZE_IN_BITS == 64 = 4
           | wORD_SIZE_IN_BITS == 32 = 2
           | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
           | wORD_SIZE_IN_BITS == 64 = 4
           | wORD_SIZE_IN_BITS == 32 = 2
           | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"

-         label_env = mkLabelEnv emptyFM lableInitialOffset instrs
+         label_env = mkLabelEnv Map.empty lableInitialOffset instrs

 
 

-         mkLabelEnv :: FiniteMap Word16 Word -> Word -> [BCInstr]
-                    -> FiniteMap Word16 Word
+         mkLabelEnv :: Map Word16 Word -> Word -> [BCInstr]
+                    -> Map Word16 Word

          mkLabelEnv env _ [] = env
          mkLabelEnv env i_offset (i:is)
             = let new_env
          mkLabelEnv env _ [] = env
          mkLabelEnv env i_offset (i:is)
             = let new_env

-                     = case i of LABEL n -> addToFM env n i_offset ; _ -> env
+                     = case i of LABEL n -> Map.insert n i_offset env ; _ -> env

               in  mkLabelEnv new_env (i_offset + instrSize16s i) is
 
          findLabel :: Word16 -> Word
          findLabel lab
               in  mkLabelEnv new_env (i_offset + instrSize16s i) is
 
          findLabel :: Word16 -> Word
          findLabel lab

-            = case lookupFM label_env lab of
+            = case Map.lookup lab label_env of

                  Just bco_offset -> bco_offset
                  Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab)
      in
                  Just bco_offset -> bco_offset
                  Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab)
      in

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 90931cc..9330c71 100644 (file)
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -19,7 +19,6 @@ import Outputable
 import Name
 import MkId
 import Id
 import Name
 import MkId
 import Id

-import FiniteMap

 import ForeignCall
 import HscTypes
 import CoreUtils
 import ForeignCall
 import HscTypes
 import CoreUtils

@@ -62,6 +61,10 @@ import Data.Maybe
 import Module 
 import IdInfo 
 
 import Module 
 import IdInfo 
 

+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
+

 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module 
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module 
 

@@ -127,13 +130,13 @@ type Sequel = Word16 -- back off to this depth before ENTER
 
 -- Maps Ids to the offset from the stack _base_ so we don't have
 -- to mess with it after each push/pop.
 
 -- Maps Ids to the offset from the stack _base_ so we don't have
 -- to mess with it after each push/pop.

-type BCEnv = FiniteMap Id Word16 -- To find vars on the stack
+type BCEnv = Map Id Word16 -- To find vars on the stack

 
 {-
 ppBCEnv :: BCEnv -> SDoc
 ppBCEnv p
    = text "begin-env"
 
 {-
 ppBCEnv :: BCEnv -> SDoc
 ppBCEnv p
    = text "begin-env"

-     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
+     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))

      $$ text "end-env"
      where
         pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var)
      $$ text "end-env"
      where
         pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var)

@@ -277,7 +280,7 @@ schemeR_wrk fvs nm original_body (args, body)
 
          szsw_args = map (fromIntegral . idSizeW) all_args
          szw_args  = sum szsw_args
 
          szsw_args = map (fromIntegral . idSizeW) all_args
          szw_args  = sum szsw_args

-         p_init    = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
+         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))

 
         -- make the arg bitmap
         bits = argBits (reverse (map idCgRep all_args))
 
         -- make the arg bitmap
         bits = argBits (reverse (map idCgRep all_args))

@@ -314,7 +317,7 @@ getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
 
 getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
 getOffSet d env id 
 
 getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
 getOffSet d env id 

-   = case lookupBCEnv_maybe env id of
+   = case lookupBCEnv_maybe id env of

         Nothing     -> Nothing 
         Just offset -> Just (id, d - offset)
 
         Nothing     -> Nothing 
         Just offset -> Just (id, d - offset)
 

@@ -329,7 +332,7 @@ fvsToEnv :: BCEnv -> VarSet -> [Id]
 -- it, have to agree about this layout
 fvsToEnv p fvs = [v | v <- varSetElems fvs, 
                      isId v,           -- Could be a type variable
 -- it, have to agree about this layout
 fvsToEnv p fvs = [v | v <- varSetElems fvs, 
                      isId v,           -- Could be a type variable

-                     v `elemFM` p]
+                     v `Map.member` p]

 
 -- -----------------------------------------------------------------------------
 -- schemeE
 
 -- -----------------------------------------------------------------------------
 -- schemeE

@@ -389,7 +392,7 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
        -- saturatred constructor application.
        -- Just allocate the constructor and carry on
         alloc_code <- mkConAppCode d s p data_con args_r_to_l
        -- saturatred constructor application.
        -- Just allocate the constructor and carry on
         alloc_code <- mkConAppCode d s p data_con args_r_to_l

-        body_code <- schemeE (d+1) s (addToFM p x d) body
+        body_code <- schemeE (d+1) s (Map.insert x d p) body

         return (alloc_code `appOL` body_code)
 
 -- General case for let.  Generates correct, if inefficient, code in
         return (alloc_code `appOL` body_code)
 
 -- General case for let.  Generates correct, if inefficient, code in

@@ -411,7 +414,7 @@ schemeE d s p (AnnLet binds (_,body))
          -- are ptrs, so all have size 1.  d' and p' reflect the stack
          -- after the closures have been allocated in the heap (but not
          -- filled in), and pointers to them parked on the stack.
          -- are ptrs, so all have size 1.  d' and p' reflect the stack
          -- after the closures have been allocated in the heap (but not
          -- filled in), and pointers to them parked on the stack.

-         p'    = addListToFM p (zipE xs (mkStackOffsets d (genericReplicate n_binds 1)))
+         p'    = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p

          d'    = d + n_binds
          zipE  = zipEqual "schemeE"
 
          d'    = d + n_binds
          zipE  = zipEqual "schemeE"
 

@@ -802,7 +805,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 
         -- Env in which to compile the alts, not including
         -- any vars bound by the alts themselves
 
         -- Env in which to compile the alts, not including
         -- any vars bound by the alts themselves

-        p_alts = addToFM p bndr (d_bndr - 1)
+        p_alts = Map.insert bndr (d_bndr - 1) p

 
        bndr_ty = idType bndr
         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
 
        bndr_ty = idType bndr
         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple

@@ -826,9 +829,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                 bind_sizes   = ptr_sizes ++ nptrs_sizes
                 size         = sum ptr_sizes + sum nptrs_sizes
                 -- the UNPACK instruction unpacks in reverse order...
                 bind_sizes   = ptr_sizes ++ nptrs_sizes
                 size         = sum ptr_sizes + sum nptrs_sizes
                 -- the UNPACK instruction unpacks in reverse order...

-                p' = addListToFM p_alts 
+                p' = Map.insertList

                        (zip (reverse (ptrs ++ nptrs))
                          (mkStackOffsets d_alts (reverse bind_sizes)))
                        (zip (reverse (ptrs ++ nptrs))
                          (mkStackOffsets d_alts (reverse bind_sizes)))

+                        p_alts 

             in do
              MASSERT(isAlgCase)
             rhs_code <- schemeE (d_alts+size) s p' rhs
             in do
              MASSERT(isAlgCase)
             rhs_code <- schemeE (d_alts+size) s p' rhs

@@ -877,7 +881,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
        bitmap = intsToReverseBitmap bitmap_size'{-size-}
                         (sortLe (<=) (filter (< bitmap_size') rel_slots))
          where
        bitmap = intsToReverseBitmap bitmap_size'{-size-}
                         (sortLe (<=) (filter (< bitmap_size') rel_slots))
          where

-         binds = fmToList p
+         binds = Map.toList p

          rel_slots = map fromIntegral $ concat (map spread binds)
          spread (id, offset)
                | isFollowableArg (idCgRep id) = [ rel_offset ]
          rel_slots = map fromIntegral $ concat (map spread binds)
          spread (id, offset)
                | isFollowableArg (idCgRep id) = [ rel_offset ]

@@ -1206,7 +1210,7 @@ pushAtom d p (AnnVar v)
    | Just primop <- isPrimOpId_maybe v
    = return (unitOL (PUSH_PRIMOP primop), 1)
 
    | Just primop <- isPrimOpId_maybe v
    = return (unitOL (PUSH_PRIMOP primop), 1)
 

-   | Just d_v <- lookupBCEnv_maybe p v  -- v is a local variable
+   | Just d_v <- lookupBCEnv_maybe v p  -- v is a local variable

    = let l = d - d_v + sz - 2
      in return (toOL (genericReplicate sz (PUSH_L l)), sz)
         -- d - d_v                 the number of words between the TOS 
    = let l = d - d_v + sz - 2
      in return (toOL (genericReplicate sz (PUSH_L l)), sz)
         -- d - d_v                 the number of words between the TOS 

@@ -1420,8 +1424,8 @@ instance Outputable Discr where
    ppr NoDiscr    = text "DEF"
 
 
    ppr NoDiscr    = text "DEF"
 
 

-lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Word16
-lookupBCEnv_maybe = lookupFM
+lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16
+lookupBCEnv_maybe = Map.lookup

 
 idSizeW :: Id -> Int
 idSizeW id = cgRepSizeW (typeCgRep (idType id))
 
 idSizeW :: Id -> Int
 idSizeW id = cgRepSizeW (typeCgRep (idType id))

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index d53d247..66a4576 100644 (file)
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -51,7 +51,6 @@ import ErrUtils
 import SrcLoc
 import qualified Maybes
 import UniqSet
 import SrcLoc
 import qualified Maybes
 import UniqSet

-import FiniteMap

 import Constants
 import FastString
 import Config          ( cProjectVersion )
 import Constants
 import FastString
 import Config          ( cProjectVersion )

@@ -62,6 +61,7 @@ import Control.Monad
 import Data.Char
 import Data.IORef
 import Data.List
 import Data.Char
 import Data.IORef
 import Data.List

+import qualified Data.Map as Map

 import Foreign
 import Control.Concurrent.MVar
 
 import Foreign
 import Control.Concurrent.MVar
 

@@ -1001,7 +1001,7 @@ linkPackages' dflags new_pks pls = do
        | Just pkg_cfg <- lookupPackage pkg_map new_pkg
        = do {  -- Link dependents first
                pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
        | Just pkg_cfg <- lookupPackage pkg_map new_pkg
        = do {  -- Link dependents first
                pkgs' <- link pkgs [ Maybes.expectJust "link_one" $

-                                    lookupFM ipid_map ipid
+                                    Map.lookup ipid ipid_map

                                   | ipid <- depends pkg_cfg ]
                -- Now link the package itself
             ; linkPackage dflags pkg_cfg
                                   | ipid <- depends pkg_cfg ]
                -- Now link the package itself
             ; linkPackage dflags pkg_cfg

diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index 84a6474..a1bcbb4 100644 (file)
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -31,7 +31,6 @@ import Module
 import UniqFM
 import FastString
 import UniqSupply
 import UniqFM
 import FastString
 import UniqSupply

-import FiniteMap

 import BasicTypes
 import SrcLoc
 import MkId
 import BasicTypes
 import SrcLoc
 import MkId

@@ -40,6 +39,7 @@ import Outputable
 import Exception     ( evaluate )
 
 import Data.IORef    ( atomicModifyIORef, readIORef )
 import Exception     ( evaluate )
 
 import Data.IORef    ( atomicModifyIORef, readIORef )

+import qualified Data.Map as Map

 \end{code}
 
 
 \end{code}
 
 

@@ -176,14 +176,14 @@ newIPName occ_name_ip =
        ipcache = nsIPs name_cache
         key = occ_name_ip  -- Ensures that ?x and %x get distinct Names
     in
        ipcache = nsIPs name_cache
         key = occ_name_ip  -- Ensures that ?x and %x get distinct Names
     in

-    case lookupFM ipcache key of
+    case Map.lookup key ipcache of

       Just name_ip -> (name_cache, name_ip)
       Nothing      -> (new_ns, name_ip)
          where
            (us', us1)  = splitUniqSupply (nsUniqs name_cache)
            uniq        = uniqFromSupply us1
            name_ip     = mapIPName (mkIPName uniq) occ_name_ip
       Just name_ip -> (name_cache, name_ip)
       Nothing      -> (new_ns, name_ip)
          where
            (us', us1)  = splitUniqSupply (nsUniqs name_cache)
            uniq        = uniqFromSupply us1
            name_ip     = mapIPName (mkIPName uniq) occ_name_ip

-           new_ipcache = addToFM ipcache key name_ip
+           new_ipcache = Map.insert key name_ip ipcache

            new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
 \end{code}
 
            new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
 \end{code}
 

@@ -220,9 +220,9 @@ extendOrigNameCache nc name
 
 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 extendNameCache nc mod occ name
 
 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 extendNameCache nc mod occ name

-  = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
+  = extendModuleEnvWith combine nc mod (unitOccEnv occ name)

   where
   where

-    combine occ_env _ = extendOccEnv occ_env occ name
+    combine _ occ_env = extendOccEnv occ_env occ name

 
 getNameCache :: TcRnIf a b NameCache
 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
 
 getNameCache :: TcRnIf a b NameCache
 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 

@@ -254,7 +254,7 @@ initNameCache :: UniqSupply -> [Name] -> NameCache
 initNameCache us names
   = NameCache { nsUniqs = us,
                nsNames = initOrigNames names,
 initNameCache us names
   = NameCache { nsUniqs = us,
                nsNames = initOrigNames names,

-               nsIPs   = emptyFM }
+               nsIPs   = Map.empty }

 
 initOrigNames :: [Name] -> OrigNameCache
 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 
 initOrigNames :: [Name] -> OrigNameCache
 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index fa9e0ec..68c6cf1 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -87,7 +87,6 @@ import BasicTypes       hiding ( SuccessFlag(..) )
 import UniqFM
 import Unique
 import Util             hiding ( eqListBy )
 import UniqFM
 import Unique
 import Util             hiding ( eqListBy )

-import FiniteMap

 import FastString
 import Maybes
 import ListSetOps
 import FastString
 import Maybes
 import ListSetOps

@@ -97,6 +96,8 @@ import Bag
 
 import Control.Monad
 import Data.List
 
 import Control.Monad
 import Data.List

+import Data.Map (Map)
+import qualified Data.Map as Map

 import Data.IORef
 import System.FilePath
 \end{code}
 import Data.IORef
 import System.FilePath
 \end{code}

@@ -523,7 +524,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                         -- wiki/Commentary/Compiler/RecompilationAvoidance
 
    -- put the declarations in a canonical order, sorted by OccName
                         -- wiki/Commentary/Compiler/RecompilationAvoidance
 
    -- put the declarations in a canonical order, sorted by OccName

-   let sorted_decls = eltsFM $ listToFM $
+   let sorted_decls = Map.elems $ Map.fromList $

                           [(ifName d, e) | e@(_, d) <- decls_w_hashes]
 
    -- the ABI hash depends on:
                           [(ifName d, e) | e@(_, d) <- decls_w_hashes]
 
    -- the ABI hash depends on:

@@ -860,10 +861,10 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
         | otherwise
         = case nameModule_maybe name of
              Nothing  -> pprPanic "mkUsageInfo: internal name?" (ppr name)
         | otherwise
         = case nameModule_maybe name of
              Nothing  -> pprPanic "mkUsageInfo: internal name?" (ppr name)

-             Just mod -> -- We use this fiddly lambda function rather than
-                         -- (++) as the argument to extendModuleEnv_C to
+             Just mod -> -- This lambda function is really just a
+                         -- specialised (++); originally came about to

                          -- avoid quadratic behaviour (trac #2680)
                          -- avoid quadratic behaviour (trac #2680)

-                         extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
+                         extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]

                   where occ = nameOccName name
     
     -- We want to create a Usage for a home module if 
                   where occ = nameOccName name
     
     -- We want to create a Usage for a home module if 

@@ -897,7 +898,7 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
                       usg_mod_name = moduleName mod,
                      usg_mod_hash = mod_hash,
                      usg_exports  = export_hash,
                       usg_mod_name = moduleName mod,
                      usg_mod_hash = mod_hash,
                      usg_exports  = export_hash,

-                     usg_entities = fmToList ent_hashs }
+                     usg_entities = Map.toList ent_hashs }

       where
        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
                -- In one-shot mode, the interfaces for home-package 
       where
        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
                -- In one-shot mode, the interfaces for home-package 

@@ -914,13 +915,13 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
 
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
 

-       -- Making a FiniteMap here ensures that (a) we remove duplicates
+       -- Making a Map here ensures that (a) we remove duplicates

         -- when we have usages on several subordinates of a single parent,
         -- and (b) that the usages emerge in a canonical order, which
         -- when we have usages on several subordinates of a single parent,
         -- and (b) that the usages emerge in a canonical order, which

-        -- is why we use FiniteMap rather than OccEnv: FiniteMap works
+        -- is why we use Map rather than OccEnv: Map works

         -- using Ord on the OccNames, which is a lexicographic ordering.
         -- using Ord on the OccNames, which is a lexicographic ordering.

-       ent_hashs :: FiniteMap OccName Fingerprint
-        ent_hashs = listToFM (map lookup_occ used_occs)
+       ent_hashs :: Map OccName Fingerprint
+        ent_hashs = Map.fromList (map lookup_occ used_occs)

         
         lookup_occ occ = 
             case hash_env occ of
         
         lookup_occ occ = 
             case hash_env occ of

@@ -960,10 +961,10 @@ mkIfaceExports :: [AvailInfo]
                -> [(Module, [GenAvailInfo OccName])]
                   -- Group by module and sort by occurrence
 mkIfaceExports exports
                -> [(Module, [GenAvailInfo OccName])]
                   -- Group by module and sort by occurrence
 mkIfaceExports exports

-  = [ (mod, eltsFM avails)
+  = [ (mod, Map.elems avails)

     | (mod, avails) <- sortBy (stableModuleCmp `on` fst)
                               (moduleEnvToList groupFM)
     | (mod, avails) <- sortBy (stableModuleCmp `on` fst)
                               (moduleEnvToList groupFM)

-                       -- NB. the fmToList is in a random order,
+                       -- NB. the Map.toList is in a random order,

                        -- because Ord Module is not a predictable
                        -- ordering.  Hence we perform a final sort
                        -- using the stable Module ordering.
                        -- because Ord Module is not a predictable
                        -- ordering.  Hence we perform a final sort
                        -- using the stable Module ordering.

@@ -971,20 +972,21 @@ mkIfaceExports exports
   where
        -- Group by the module where the exported entities are defined
        -- (which may not be the same for all Names in an Avail)
   where
        -- Group by the module where the exported entities are defined
        -- (which may not be the same for all Names in an Avail)

-       -- Deliberately use FiniteMap rather than UniqFM so we
+       -- Deliberately use Map rather than UniqFM so we

        -- get a canonical ordering
        -- get a canonical ordering

-    groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+    groupFM :: ModuleEnv (Map FastString (GenAvailInfo OccName))

     groupFM = foldl add emptyModuleEnv exports
 
     groupFM = foldl add emptyModuleEnv exports
 

-    add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+    add_one :: ModuleEnv (Map FastString (GenAvailInfo OccName))

            -> Module -> GenAvailInfo OccName
            -> Module -> GenAvailInfo OccName

-           -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+           -> ModuleEnv (Map FastString (GenAvailInfo OccName))

     add_one env mod avail 
     add_one env mod avail 

-      =  extendModuleEnv_C plusFM env mod 
-               (unitFM (occNameFS (availName avail)) avail)
+      -- XXX Is there a need to flip Map.union here?
+      =  extendModuleEnvWith (flip Map.union) env mod 
+               (Map.singleton (occNameFS (availName avail)) avail)

 
        -- NB: we should not get T(X) and T(Y) in the export list
 
        -- NB: we should not get T(X) and T(Y) in the export list

-       --     else the plusFM will simply discard one!  They
+       --     else the Map.union will simply discard one!  They

        --     should have been combined by now.
     add env (Avail n)
       = ASSERT( isExternalName n ) 
        --     should have been combined by now.
     add env (Avail n)
       = ASSERT( isExternalName n ) 

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c9ac5f9..47d9f6d 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -88,7 +88,6 @@ import Util
 import Maybes           ( orElse )
 import SrcLoc
 import FastString
 import Maybes           ( orElse )
 import SrcLoc
 import FastString

-import FiniteMap

 import Outputable
 import Foreign.C       ( CInt )
 import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
 import Outputable
 import Foreign.C       ( CInt )
 import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )

@@ -99,6 +98,8 @@ import Control.Monad    ( when )
 
 import Data.Char
 import Data.List
 
 import Data.Char
 import Data.List

+import Data.Map (Map)
+import qualified Data.Map as Map

 import System.FilePath
 import System.IO        ( stderr, hPutChar )
 
 import System.FilePath
 import System.IO        ( stderr, hPutChar )
 

@@ -488,7 +489,7 @@ data DynFlags = DynFlags {
   -- These have to be IORefs, because the defaultCleanupHandler needs to
   -- know what to clean when an exception happens
   filesToClean          :: IORef [FilePath],
   -- These have to be IORefs, because the defaultCleanupHandler needs to
   -- know what to clean when an exception happens
   filesToClean          :: IORef [FilePath],

-  dirsToClean           :: IORef (FiniteMap FilePath FilePath),
+  dirsToClean           :: IORef (Map FilePath FilePath),

 
   -- hsc dynamic flags
   flags                 :: [DynFlag],
 
   -- hsc dynamic flags
   flags                 :: [DynFlag],

@@ -612,7 +613,7 @@ initDynFlags dflags = do
  -- someday these will be dynamic flags
  ways <- readIORef v_Ways
  refFilesToClean <- newIORef []
  -- someday these will be dynamic flags
  ways <- readIORef v_Ways
  refFilesToClean <- newIORef []

- refDirsToClean <- newIORef emptyFM
+ refDirsToClean <- newIORef Map.empty

  return dflags{
         ways            = ways,
         buildTag        = mkBuildTag (filter (not . wayRTSOnly) ways),
  return dflags{
         ways            = ways,
         buildTag        = mkBuildTag (filter (not . wayRTSOnly) ways),

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 92345c7..c3aa832 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -286,7 +286,6 @@ import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
 import Annotations
 import Module
 import UniqFM
 import Annotations
 import Module
 import UniqFM

-import FiniteMap

 import Panic
 import Digraph
 import Bag             ( unitBag, listToBag, emptyBag, isEmptyBag )
 import Panic
 import Digraph
 import Bag             ( unitBag, listToBag, emptyBag, isEmptyBag )

@@ -303,6 +302,9 @@ import Lexer
 import System.Directory ( getModificationTime, doesFileExist,
                           getCurrentDirectory )
 import Data.Maybe
 import System.Directory ( getModificationTime, doesFileExist,
                           getCurrentDirectory )
 import Data.Maybe

+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map

 import Data.List
 import qualified Data.List as List
 import Data.Typeable    ( Typeable )
 import Data.List
 import qualified Data.List as List
 import Data.Typeable    ( Typeable )

@@ -1827,14 +1829,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l
     numbered_summaries = zip summaries [1..]
 
     lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
     numbered_summaries = zip summaries [1..]
 
     lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode

-    lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
+    lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map

 
     lookup_key :: HscSource -> ModuleName -> Maybe Int
     lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
 
     node_map :: NodeMap SummaryNode
 
     lookup_key :: HscSource -> ModuleName -> Maybe Int
     lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
 
     node_map :: NodeMap SummaryNode

-    node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
-                        | node@(s, _, _) <- nodes ]
+    node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
+                            | node@(s, _, _) <- nodes ]

 
     -- We use integers as the keys for the SCC algorithm
     nodes :: [SummaryNode]
 
     -- We use integers as the keys for the SCC algorithm
     nodes :: [SummaryNode]

@@ -1870,16 +1872,16 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l
 
 
 type NodeKey   = (ModuleName, HscSource)  -- The nodes of the graph are 
 
 
 type NodeKey   = (ModuleName, HscSource)  -- The nodes of the graph are 

-type NodeMap a = FiniteMap NodeKey a     -- keyed by (mod, src_file_type) pairs
+type NodeMap a = Map NodeKey a   -- keyed by (mod, src_file_type) pairs

 
 msKey :: ModSummary -> NodeKey
 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
 
 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
 
 msKey :: ModSummary -> NodeKey
 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
 
 mkNodeMap :: [ModSummary] -> NodeMap ModSummary

-mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]

        
 nodeMapElts :: NodeMap a -> [a]
        
 nodeMapElts :: NodeMap a -> [a]

-nodeMapElts = eltsFM
+nodeMapElts = Map.elems

 
 -- | If there are {-# SOURCE #-} imports between strongly connected
 -- components in the topological sort, then those imports can
 
 -- | If there are {-# SOURCE #-} imports between strongly connected
 -- components in the topological sort, then those imports can

@@ -1984,7 +1986,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
                        -- for those mentioned in the visited set
        loop [] done      = return (concat (nodeMapElts done))
        loop ((wanted_mod, is_boot) : ss) done 
                        -- for those mentioned in the visited set
        loop [] done      = return (concat (nodeMapElts done))
        loop ((wanted_mod, is_boot) : ss) done 

-         | Just summs <- lookupFM done key
+         | Just summs <- Map.lookup key done

          = if isSingleton summs then
                loop ss done
            else
          = if isSingleton summs then
                loop ss done
            else

@@ -1995,13 +1997,15 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
                                        Nothing excl_mods
                case mb_s of
                    Nothing -> loop ss done
                                        Nothing excl_mods
                case mb_s of
                    Nothing -> loop ss done

-                   Just s  -> loop (msDeps s ++ ss) (addToFM done key [s])
+                   Just s  -> loop (msDeps s ++ ss) (Map.insert key [s] done)

          where
            key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
 
          where
            key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
 

+-- XXX Does the (++) here need to be flipped?

 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]

-mkRootMap summaries = addListToFM_C (++) emptyFM 
-                       [ (msKey s, [s]) | s <- summaries ]
+mkRootMap summaries = Map.insertListWith (flip (++))
+                                         [ (msKey s, [s]) | s <- summaries ]
+                                         Map.empty

 
 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
 -- (msDeps s) returns the dependencies of the ModSummary s.
 
 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
 -- (msDeps s) returns the dependencies of the ModSummary s.

@@ -2146,7 +2150,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
   | wanted_mod `elem` excl_mods
   = return Nothing
 
   | wanted_mod `elem` excl_mods
   = return Nothing
 

-  | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
+  | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map

   = do         -- Find its new timestamp; all the 
                -- ModSummaries in the old map have valid ml_hs_files
        let location = ms_location old_summary
   = do         -- Find its new timestamp; all the 
                -- ModSummaries in the old map have valid ml_hs_files
        let location = ms_location old_summary

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 5c41f68..bc9c9ee 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -140,7 +140,6 @@ import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase )
 import BasicTypes      ( IPName, defaultFixity, WarningTxt(..) )
 import OptimizationFuel        ( OptFuelState )
 import IfaceSyn
 import BasicTypes      ( IPName, defaultFixity, WarningTxt(..) )
 import OptimizationFuel        ( OptFuelState )
 import IfaceSyn

-import FiniteMap       ( FiniteMap )

 import CoreSyn         ( CoreRule )
 import Maybes          ( orElse, expectJust, catMaybes )
 import Outputable
 import CoreSyn         ( CoreRule )
 import Maybes          ( orElse, expectJust, catMaybes )
 import Outputable

@@ -162,6 +161,7 @@ import System.Time  ( ClockTime )
 import Data.IORef
 import Data.Array       ( Array, array )
 import Data.List
 import Data.IORef
 import Data.Array       ( Array, array )
 import Data.List

+import Data.Map (Map)

 import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
 \end{code}
 import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
 \end{code}

@@ -1851,7 +1851,7 @@ data NameCache
 type OrigNameCache   = ModuleEnv (OccEnv Name)
 
 -- | Module-local cache of implicit parameter 'OccName's given 'Name's
 type OrigNameCache   = ModuleEnv (OccEnv Name)
 
 -- | Module-local cache of implicit parameter 'OccName's given 'Name's

-type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name)
+type OrigIParamCache = Map (IPName OccName) (IPName Name)

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 06cd573..a940f99 100644 (file)
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -41,7 +41,6 @@ import StaticFlags
 import Config          ( cProjectVersion )
 import Name            ( Name, nameModule_maybe )
 import UniqFM
 import Config          ( cProjectVersion )
 import Name            ( Name, nameModule_maybe )
 import UniqFM

-import FiniteMap

 import Module
 import Util
 import Panic
 import Module
 import Util
 import Panic

@@ -60,6 +59,9 @@ import System.Directory
 import System.FilePath
 import Control.Monad
 import Data.List as List
 import System.FilePath
 import Control.Monad
 import Data.List as List

+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map

 import qualified Data.Set as Set
 
 -- ---------------------------------------------------------------------------
 import qualified Data.Set as Set
 
 -- ---------------------------------------------------------------------------

@@ -126,9 +128,9 @@ data PackageState = PackageState {
 -- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig'
 type PackageConfigMap = UniqFM PackageConfig
 
 -- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig'
 type PackageConfigMap = UniqFM PackageConfig
 

-type InstalledPackageIdMap = FiniteMap InstalledPackageId PackageId
+type InstalledPackageIdMap = Map InstalledPackageId PackageId

 
 

-type InstalledPackageIndex = FiniteMap InstalledPackageId PackageConfig
+type InstalledPackageIndex = Map InstalledPackageId PackageConfig

 
 emptyPackageConfigMap :: PackageConfigMap
 emptyPackageConfigMap = emptyUFM
 
 emptyPackageConfigMap :: PackageConfigMap
 emptyPackageConfigMap = emptyUFM

@@ -331,7 +333,7 @@ selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
 selectPackages matches pkgs unusable
   = let
         (ps,rest) = partition matches pkgs
 selectPackages matches pkgs unusable
   = let
         (ps,rest) = partition matches pkgs

-        reasons = [ (p, lookupFM unusable (installedPackageId p))
+        reasons = [ (p, Map.lookup (installedPackageId p) unusable)

                   | p <- ps ]
     in
     if all (isJust.snd) reasons
                   | p <- ps ]
     in
     if all (isJust.snd) reasons

@@ -493,7 +495,7 @@ data UnusablePackageReason
   | MissingDependencies [InstalledPackageId]
   | ShadowedBy InstalledPackageId
 
   | MissingDependencies [InstalledPackageId]
   | ShadowedBy InstalledPackageId
 

-type UnusablePackages = FiniteMap InstalledPackageId UnusablePackageReason
+type UnusablePackages = Map InstalledPackageId UnusablePackageReason

 
 pprReason :: SDoc -> UnusablePackageReason -> SDoc
 pprReason pref reason = case reason of
 
 pprReason :: SDoc -> UnusablePackageReason -> SDoc
 pprReason pref reason = case reason of

@@ -507,7 +509,7 @@ pprReason pref reason = case reason of
       pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)
 
 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
       pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)
 
 reportUnusable :: DynFlags -> UnusablePackages -> IO ()

-reportUnusable dflags pkgs = mapM_ report (fmToList pkgs)
+reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)

   where
     report (ipid, reason) =
        debugTraceMsg dflags 2 $
   where
     report (ipid, reason) =
        debugTraceMsg dflags 2 $

@@ -524,17 +526,18 @@ reportUnusable dflags pkgs = mapM_ report (fmToList pkgs)
 -- satisfied until no more can be added.
 --
 findBroken :: [PackageConfig] -> UnusablePackages
 -- satisfied until no more can be added.
 --
 findBroken :: [PackageConfig] -> UnusablePackages

-findBroken pkgs = go [] emptyFM pkgs
+findBroken pkgs = go [] Map.empty pkgs

  where
    go avail ipids not_avail =
      case partitionWith (depsAvailable ipids) not_avail of
         ([], not_avail) ->
  where
    go avail ipids not_avail =
      case partitionWith (depsAvailable ipids) not_avail of
         ([], not_avail) ->

-            listToFM [ (installedPackageId p, MissingDependencies deps)
-                     | (p,deps) <- not_avail ]
+            Map.fromList [ (installedPackageId p, MissingDependencies deps)
+                         | (p,deps) <- not_avail ]

         (new_avail, not_avail) ->
             go (new_avail ++ avail) new_ipids (map fst not_avail)
         (new_avail, not_avail) ->
             go (new_avail ++ avail) new_ipids (map fst not_avail)

-            where new_ipids = addListToFM ipids
+            where new_ipids = Map.insertList

                                 [ (installedPackageId p, p) | p <- new_avail ]
                                 [ (installedPackageId p, p) | p <- new_avail ]

+                                ipids

 
    depsAvailable :: InstalledPackageIndex
                  -> PackageConfig
 
    depsAvailable :: InstalledPackageIndex
                  -> PackageConfig

@@ -542,7 +545,7 @@ findBroken pkgs = go [] emptyFM pkgs
    depsAvailable ipids pkg
         | null dangling = Left pkg
         | otherwise     = Right (pkg, dangling)
    depsAvailable ipids pkg
         | null dangling = Left pkg
         | otherwise     = Right (pkg, dangling)

-        where dangling = filter (not . (`elemFM` ipids)) (depends pkg)
+        where dangling = filter (not . (`Map.member` ipids)) (depends pkg)

 
 -- -----------------------------------------------------------------------------
 -- Eliminate shadowed packages, giving the user some feedback
 
 -- -----------------------------------------------------------------------------
 -- Eliminate shadowed packages, giving the user some feedback

@@ -554,7 +557,7 @@ findBroken pkgs = go [] emptyFM pkgs
 shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
 shadowPackages pkgs preferred
  = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
 shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
 shadowPackages pkgs preferred
  = let (shadowed,_) = foldl check ([],emptyUFM) pkgs

-   in  listToFM shadowed
+   in  Map.fromList shadowed

  where
  check (shadowed,pkgmap) pkg
       | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
  where
  check (shadowed,pkgmap) pkg
       | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)

@@ -574,7 +577,7 @@ shadowPackages pkgs preferred
 -- -----------------------------------------------------------------------------
 
 ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
 -- -----------------------------------------------------------------------------
 
 ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages

-ignorePackages flags pkgs = listToFM (concatMap doit flags)
+ignorePackages flags pkgs = Map.fromList (concatMap doit flags)

   where
   doit (IgnorePackage str) =
      case partition (matchingStr str) pkgs of
   where
   doit (IgnorePackage str) =
      case partition (matchingStr str) pkgs of

@@ -590,13 +593,13 @@ ignorePackages flags pkgs = listToFM (concatMap doit flags)
 depClosure :: InstalledPackageIndex
            -> [InstalledPackageId]
            -> [InstalledPackageId]
 depClosure :: InstalledPackageIndex
            -> [InstalledPackageId]
            -> [InstalledPackageId]

-depClosure index ipids = closure emptyFM ipids
+depClosure index ipids = closure Map.empty ipids

   where
   where

-   closure set [] = keysFM set
+   closure set [] = Map.keys set

    closure set (ipid : ipids)
    closure set (ipid : ipids)

-     | ipid `elemFM` set = closure set ipids
-     | Just p <- lookupFM index ipid = closure (addToFM set ipid p) 
-                                               (depends p ++ ipids)
+     | ipid `Map.member` set = closure set ipids
+     | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) 
+                                                 (depends p ++ ipids)

      | otherwise = closure set ipids
 
 -- -----------------------------------------------------------------------------
      | otherwise = closure set ipids
 
 -- -----------------------------------------------------------------------------

@@ -673,7 +676,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
                   where pid = installedPackageId p
           -- XXX this is just a variant of nub
 
                   where pid = installedPackageId p
           -- XXX this is just a variant of nub
 

-      ipid_map = listToFM [ (installedPackageId p, p) | p <- pkgs0 ]
+      ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]

 
       ipid_selected = depClosure ipid_map [ InstalledPackageId i
                                           | ExposePackageId i <- flags ]
 
       ipid_selected = depClosure ipid_map [ InstalledPackageId i
                                           | ExposePackageId i <- flags ]

@@ -686,9 +689,9 @@ mkPackageState dflags pkgs0 preload0 this_package = do
 
       ignored  = ignorePackages ignore_flags pkgs0_unique
 
 
       ignored  = ignorePackages ignore_flags pkgs0_unique
 

-      pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0_unique
+      pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique

       broken   = findBroken pkgs0'
       broken   = findBroken pkgs0'

-      unusable = shadowed `plusFM` ignored `plusFM` broken
+      unusable = shadowed `Map.union` ignored `Map.union` broken

 
   reportUnusable dflags unusable
 
 
   reportUnusable dflags unusable
 

@@ -697,7 +700,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
   -- (-package, -hide-package, -ignore-package, -hide-all-packages).
   --
   pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
   -- (-package, -hide-package, -ignore-package, -hide-all-packages).
   --
   pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags

-  let pkgs2 = filter (not . (`elemFM` unusable) . installedPackageId) pkgs1
+  let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1

 
   -- Here we build up a set of the packages mentioned in -package
   -- flags on the command line; these are called the "preload"
 
   -- Here we build up a set of the packages mentioned in -package
   -- flags on the command line; these are called the "preload"

@@ -719,12 +722,12 @@ mkPackageState dflags pkgs0 preload0 this_package = do
 
   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
 
 
   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
 

-      ipid_map = listToFM [ (installedPackageId p, packageConfigId p)
-                          | p <- pkgs4 ]
+      ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
+                              | p <- pkgs4 ]

 
       lookupIPID ipid@(InstalledPackageId str)
 
       lookupIPID ipid@(InstalledPackageId str)

-         | Just pid <- lookupFM ipid_map ipid = return pid
-         | otherwise                          = missingPackageErr str
+         | Just pid <- Map.lookup ipid ipid_map = return pid
+         | otherwise                            = missingPackageErr str

 
   preload2 <- mapM lookupIPID preload1
 
 
   preload2 <- mapM lookupIPID preload1
 

@@ -890,7 +893,7 @@ getPreloadPackagesAnd dflags pkgids =
 -- Takes a list of packages, and returns the list with dependencies included,
 -- in reverse dependency order (a package appears before those it depends on).
 closeDeps :: PackageConfigMap
 -- Takes a list of packages, and returns the list with dependencies included,
 -- in reverse dependency order (a package appears before those it depends on).
 closeDeps :: PackageConfigMap

-          -> FiniteMap InstalledPackageId PackageId
+          -> Map InstalledPackageId PackageId

           -> [(PackageId, Maybe PackageId)]
           -> IO [PackageId]
 closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
           -> [(PackageId, Maybe PackageId)]
           -> IO [PackageId]
 closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)

@@ -901,14 +904,14 @@ throwErr m = case m of
                Succeeded r -> return r
 
 closeDepsErr :: PackageConfigMap
                Succeeded r -> return r
 
 closeDepsErr :: PackageConfigMap

-             -> FiniteMap InstalledPackageId PackageId
+             -> Map InstalledPackageId PackageId

              -> [(PackageId,Maybe PackageId)]
              -> MaybeErr Message [PackageId]
 closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
 
 -- internal helper
 add_package :: PackageConfigMap 
              -> [(PackageId,Maybe PackageId)]
              -> MaybeErr Message [PackageId]
 closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
 
 -- internal helper
 add_package :: PackageConfigMap 

-            -> FiniteMap InstalledPackageId PackageId
+            -> Map InstalledPackageId PackageId

             -> [PackageId]
             -> (PackageId,Maybe PackageId)
             -> MaybeErr Message [PackageId]
             -> [PackageId]
             -> (PackageId,Maybe PackageId)
             -> MaybeErr Message [PackageId]

@@ -924,7 +927,7 @@ add_package pkg_db ipid_map ps (p, mb_parent)
           return (p : ps')
           where
             add_package_ipid ps ipid@(InstalledPackageId str)
           return (p : ps')
           where
             add_package_ipid ps ipid@(InstalledPackageId str)

-              | Just pid <- lookupFM ipid_map ipid
+              | Just pid <- Map.lookup ipid ipid_map

               = add_package pkg_db ipid_map ps (pid, Just p)
               | otherwise
               = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
               = add_package pkg_db ipid_map ps (pid, Just p)
               | otherwise
               = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 12b73d3..1693aa0 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -45,7 +45,6 @@ import ErrUtils
 import Panic
 import Util
 import DynFlags
 import Panic
 import Util
 import DynFlags

-import FiniteMap

 
 import Exception
 import Data.IORef
 
 import Exception
 import Data.IORef

@@ -58,6 +57,7 @@ import System.IO.Error as IO
 import System.Directory
 import Data.Char
 import Data.List
 import System.Directory
 import Data.Char
 import Data.List

+import qualified Data.Map as Map

 
 #ifndef mingw32_HOST_OS
 import qualified System.Posix.Internals
 
 #ifndef mingw32_HOST_OS
 import qualified System.Posix.Internals

@@ -472,8 +472,8 @@ cleanTempDirs dflags
    = unless (dopt Opt_KeepTmpFiles dflags)
    $ do let ref = dirsToClean dflags
         ds <- readIORef ref
    = unless (dopt Opt_KeepTmpFiles dflags)
    $ do let ref = dirsToClean dflags
         ds <- readIORef ref

-        removeTmpDirs dflags (eltsFM ds)
-        writeIORef ref emptyFM
+        removeTmpDirs dflags (Map.elems ds)
+        writeIORef ref Map.empty

 
 cleanTempFiles :: DynFlags -> IO ()
 cleanTempFiles dflags
 
 cleanTempFiles :: DynFlags -> IO ()
 cleanTempFiles dflags

@@ -515,7 +515,7 @@ getTempDir :: DynFlags -> IO FilePath
 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
   = do let ref = dirsToClean dflags
        mapping <- readIORef ref
 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
   = do let ref = dirsToClean dflags
        mapping <- readIORef ref

-       case lookupFM mapping tmp_dir of
+       case Map.lookup tmp_dir mapping of

            Nothing ->
                do x <- getProcessID
                   let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
            Nothing ->
                do x <- getProcessID
                   let prefix = tmp_dir </> "ghc" ++ show x ++ "_"

@@ -524,7 +524,7 @@ getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
                       mkTempDir x
                        = let dirname = prefix ++ show x
                          in do createDirectory dirname
                       mkTempDir x
                        = let dirname = prefix ++ show x
                          in do createDirectory dirname

-                               let mapping' = addToFM mapping tmp_dir dirname
+                               let mapping' = Map.insert tmp_dir dirname mapping

                                writeIORef ref mapping'
                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
                                return dirname
                                writeIORef ref mapping'
                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
                                return dirname

diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 4cba23b..84568d9 100644 (file)
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -33,7 +33,6 @@ import RdrName
 import Outputable
 import Maybes
 import SrcLoc
 import Outputable
 import Maybes
 import SrcLoc

-import FiniteMap

 import ErrUtils
 import Util
 import FastString
 import ErrUtils
 import Util
 import FastString

@@ -42,6 +41,8 @@ import Data.List        ( partition, (\\), delete )
 import qualified Data.Set as Set
 import System.IO
 import Control.Monad
 import qualified Data.Set as Set
 import System.IO
 import Control.Monad

+import Data.Map (Map)
+import qualified Data.Map as Map

 \end{code}
 
 
 \end{code}
 
 

@@ -1256,7 +1257,7 @@ findImportUsage :: [LImportDecl Name]
                -> [RdrName]
                 -> [ImportDeclUsage]
 
                -> [RdrName]
                 -> [ImportDeclUsage]
 

-type ImportMap = FiniteMap SrcLoc [AvailInfo]
+type ImportMap = Map SrcLoc [AvailInfo]

   -- The intermediate data struture records, for each import 
   -- declaration, what stuff brought into scope by that 
   -- declaration is actually used in the module.
   -- The intermediate data struture records, for each import 
   -- declaration, what stuff brought into scope by that 
   -- declaration is actually used in the module.

@@ -1271,12 +1272,12 @@ findImportUsage imports rdr_env rdrs
   = map unused_decl imports
   where
     import_usage :: ImportMap
   = map unused_decl imports
   where
     import_usage :: ImportMap

-    import_usage = foldr add_rdr emptyFM rdrs
+    import_usage = foldr add_rdr Map.empty rdrs

 
     unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
       = (decl, nubAvails used_avails, unused_imps)
       where
 
     unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
       = (decl, nubAvails used_avails, unused_imps)
       where

-        used_avails = lookupFM import_usage (srcSpanStart loc) `orElse` []
+        used_avails = Map.lookup (srcSpanStart loc) import_usage `orElse` []

        used_names = availsToNameSet used_avails
                                      
        unused_imps = case imps of
        used_names = availsToNameSet used_avails
                                      
        unused_imps = case imps of

@@ -1296,9 +1297,9 @@ findImportUsage imports rdr_env rdrs
 
     add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap
     add_imp gre (ImpSpec { is_decl = imp_decl_spec }) iu
 
     add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap
     add_imp gre (ImpSpec { is_decl = imp_decl_spec }) iu

-      = addToFM_C add iu decl_loc [avail]
+      = Map.insertWith add decl_loc [avail] iu

       where
       where

-       add avails _ = avail : avails
+       add _ avails = avail : avails -- add is really just a specialised (++)

         decl_loc = srcSpanStart (is_dloc imp_decl_spec)
        name     = gre_name gre
        avail    = case gre_par gre of
         decl_loc = srcSpanStart (is_dloc imp_decl_spec)
        name     = gre_name gre
        avail    = case gre_par gre of

diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 7f43ce5..00dedff 100644 (file)
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -79,12 +79,13 @@ import Bag
 import Maybes
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )
 import Maybes
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )

-import FiniteMap

 
 import Util            ( split )
 import Data.List       ( intersperse )
 import Data.Dynamic
 import Data.IORef
 
 import Util            ( split )
 import Data.List       ( intersperse )
 import Data.Dynamic
 import Data.IORef

+import Data.Map (Map)
+import qualified Data.Map as Map

 import Data.Word
 import Control.Monad
 
 import Data.Word
 import Control.Monad
 

@@ -559,7 +560,7 @@ data SimplCount
                                -- recent history reasonably efficiently
      }
 
                                -- recent history reasonably efficiently
      }
 

-type TickCounts = FiniteMap Tick Int
+type TickCounts = Map Tick Int

 
 simplCountN :: SimplCount -> Int
 simplCountN (VerySimplCount n)         = n
 
 simplCountN :: SimplCount -> Int
 simplCountN (VerySimplCount n)         = n

@@ -569,7 +570,7 @@ zeroSimplCount dflags
                -- This is where we decide whether to do
                -- the VerySimpl version or the full-stats version
   | dopt Opt_D_dump_simpl_stats dflags
                -- This is where we decide whether to do
                -- the VerySimpl version or the full-stats version
   | dopt Opt_D_dump_simpl_stats dflags

-  = SimplCount {ticks = 0, details = emptyFM,
+  = SimplCount {ticks = 0, details = Map.empty,

                 n_log = 0, log1 = [], log2 = []}
   | otherwise
   = VerySimplCount 0
                 n_log = 0, log1 = [], log2 = []}
   | otherwise
   = VerySimplCount 0

@@ -590,19 +591,19 @@ doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 =
 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
 
 
 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
 
 

--- Don't use plusFM_C because that's lazy, and we want to 
+-- Don't use Map.unionWith because that's lazy, and we want to 

 -- be pretty strict here!
 addTick :: TickCounts -> Tick -> TickCounts
 -- be pretty strict here!
 addTick :: TickCounts -> Tick -> TickCounts

-addTick fm tick = case lookupFM fm tick of
-                       Nothing -> addToFM fm tick 1
-                       Just n  -> n1 `seq` addToFM fm tick n1
+addTick fm tick = case Map.lookup tick fm of
+                       Nothing -> Map.insert tick 1 fm
+                       Just n  -> n1 `seq` Map.insert tick n1 fm

                                where
                                   n1 = n+1
 
 
 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
               sc2@(SimplCount { ticks = tks2, details = dts2 })
                                where
                                   n1 = n+1
 
 
 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
               sc2@(SimplCount { ticks = tks2, details = dts2 })

-  = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
+  = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }

   where
        -- A hackish way of getting recent log info
     log_base | null (log1 sc2) = sc1   -- Nothing at all in sc2
   where
        -- A hackish way of getting recent log info
     log_base | null (log1 sc2) = sc1   -- Nothing at all in sc2

@@ -617,7 +618,7 @@ pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
          blankLine,
 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
          blankLine,

-         pprTickCounts (fmToList dts),
+         pprTickCounts (Map.toList dts),

          if verboseSimplStats then
                vcat [blankLine,
                      ptext (sLit "Log (most recent first)"),
          if verboseSimplStats then
                vcat [blankLine,
                      ptext (sLit "Log (most recent first)"),

diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs
index 08bb1ec..73ffba5 100644 (file)
--- a/compiler/simplCore/SAT.lhs
+++ b/compiler/simplCore/SAT.lhs
@@ -123,7 +123,7 @@ emptyIdSATInfo :: IdSATInfo
 emptyIdSATInfo = emptyUFM
 
 {-
 emptyIdSATInfo = emptyUFM
 
 {-

-pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (fmToList id_sat_info))
+pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))

   where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)
 -}
 
   where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)
 -}
 

diff --git a/compiler/simplStg/StgStats.lhs b/compiler/simplStg/StgStats.lhs
index 25c988d..74a4fc3 100644 (file)
--- a/compiler/simplStg/StgStats.lhs
+++ b/compiler/simplStg/StgStats.lhs
@@ -34,8 +34,10 @@ module StgStats ( showStgStats ) where
 
 import StgSyn
 
 
 import StgSyn
 

-import FiniteMap       ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap )

 import Id (Id)
 import Id (Id)

+
+import Data.Map (Map)
+import qualified Data.Map as Map

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -54,24 +56,24 @@ data CounterType
   deriving (Eq, Ord)
 
 type Count     = Int
   deriving (Eq, Ord)
 
 type Count     = Int

-type StatEnv   = FiniteMap CounterType Count
+type StatEnv   = Map CounterType Count

 \end{code}
 
 \begin{code}
 emptySE        :: StatEnv
 \end{code}
 
 \begin{code}
 emptySE        :: StatEnv

-emptySE        = emptyFM
+emptySE        = Map.empty

 
 combineSE :: StatEnv -> StatEnv -> StatEnv
 
 combineSE :: StatEnv -> StatEnv -> StatEnv

-combineSE = plusFM_C (+)
+combineSE = Map.unionWith (+)

 
 combineSEs :: [StatEnv] -> StatEnv
 combineSEs = foldr combineSE emptySE
 
 countOne :: CounterType -> StatEnv
 
 combineSEs :: [StatEnv] -> StatEnv
 combineSEs = foldr combineSE emptySE
 
 countOne :: CounterType -> StatEnv

-countOne c = unitFM c 1
+countOne c = Map.singleton c 1

 
 countN :: CounterType -> Int -> StatEnv
 
 countN :: CounterType -> Int -> StatEnv

-countN = unitFM
+countN = Map.singleton

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -85,7 +87,7 @@ showStgStats :: [StgBinding] -> String
 
 showStgStats prog
   = "STG Statistics:\n\n"
 
 showStgStats prog
   = "STG Statistics:\n\n"

-    ++ concat (map showc (fmToList (gatherStgStats prog)))
+    ++ concat (map showc (Map.toList (gatherStgStats prog)))

   where
     showc (x,n) = (showString (s x) . shows n) "\n"
 
   where
     showc (x,n) = (showString (s x) . shows n) "\n"
 

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index f18c8f9..2d0b383 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -21,7 +21,6 @@ import CoreFVs                ( exprFreeVars, exprsFreeVars, idFreeVars )
 import UniqSupply      ( UniqSupply, UniqSM, initUs_, MonadUnique(..) )
 import Name
 import MkId            ( voidArgId, realWorldPrimId )
 import UniqSupply      ( UniqSupply, UniqSM, initUs_, MonadUnique(..) )
 import Name
 import MkId            ( voidArgId, realWorldPrimId )

-import FiniteMap

 import Maybes          ( catMaybes, isJust )
 import BasicTypes      ( isNeverActive, inlinePragmaActivation )
 import Bag
 import Maybes          ( catMaybes, isJust )
 import BasicTypes      ( isNeverActive, inlinePragmaActivation )
 import Bag

@@ -29,6 +28,9 @@ import Util
 import Outputable
 import FastString
 
 import Outputable
 import FastString
 

+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -1321,12 +1323,12 @@ emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyVarEnv }
 type CallDetails  = IdEnv CallInfoSet
 newtype CallKey   = CallKey [Maybe Type]                       -- Nothing => unconstrained type argument
 
 type CallDetails  = IdEnv CallInfoSet
 newtype CallKey   = CallKey [Maybe Type]                       -- Nothing => unconstrained type argument
 

--- CallInfo uses a FiniteMap, thereby ensuring that
+-- CallInfo uses a Map, thereby ensuring that

 -- we record only one call instance for any key
 --
 -- The list of types and dictionaries is guaranteed to
 -- match the type of f
 -- we record only one call instance for any key
 --
 -- The list of types and dictionaries is guaranteed to
 -- match the type of f

-type CallInfoSet = FiniteMap CallKey ([DictExpr], VarSet)
+type CallInfoSet = Map CallKey ([DictExpr], VarSet)

                        -- Range is dict args and the vars of the whole
                        -- call (including tyvars)
                        -- [*not* include the main id itself, of course]
                        -- Range is dict args and the vars of the whole
                        -- call (including tyvars)
                        -- [*not* include the main id itself, of course]

@@ -1350,7 +1352,7 @@ instance Ord CallKey where
                  cmp (Just t1) (Just t2) = tcCmpType t1 t2
 
 unionCalls :: CallDetails -> CallDetails -> CallDetails
                  cmp (Just t1) (Just t2) = tcCmpType t1 t2
 
 unionCalls :: CallDetails -> CallDetails -> CallDetails

-unionCalls c1 c2 = plusVarEnv_C plusFM c1 c2
+unionCalls c1 c2 = plusVarEnv_C Map.union c1 c2

 
 -- plusCalls :: UsageDetails -> CallDetails -> UsageDetails
 -- plusCalls uds call_ds = uds { ud_calls = ud_calls uds `unionCalls` call_ds }
 
 -- plusCalls :: UsageDetails -> CallDetails -> UsageDetails
 -- plusCalls uds call_ds = uds { ud_calls = ud_calls uds `unionCalls` call_ds }

@@ -1359,13 +1361,13 @@ callDetailsFVs :: CallDetails -> VarSet
 callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls
 
 callInfoFVs :: CallInfoSet -> VarSet
 callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls
 
 callInfoFVs :: CallInfoSet -> VarSet

-callInfoFVs call_info = foldFM (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info
+callInfoFVs call_info = Map.foldRightWithKey (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info

 
 ------------------------------------------------------------                   
 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
 singleCall id tys dicts 
   = MkUD {ud_binds = emptyBag, 
 
 ------------------------------------------------------------                   
 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
 singleCall id tys dicts 
   = MkUD {ud_binds = emptyBag, 

-         ud_calls = unitVarEnv id (unitFM (CallKey tys) (dicts, call_fvs)) }
+         ud_calls = unitVarEnv id (Map.singleton (CallKey tys) (dicts, call_fvs)) }

   where
     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
     tys_fvs  = tyVarsOfTypes (catMaybes tys)
   where
     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
     tys_fvs  = tyVarsOfTypes (catMaybes tys)

@@ -1539,7 +1541,7 @@ callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
     uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn }
     calls_for_me = case lookupVarEnv orig_calls fn of
                        Nothing -> []
     uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn }
     calls_for_me = case lookupVarEnv orig_calls fn of
                        Nothing -> []

-                       Just cs -> filter_dfuns (fmToList cs)
+                       Just cs -> filter_dfuns (Map.toList cs)

 
     dep_set = foldlBag go (unitVarSet fn) orig_dbs
     go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set
 
     dep_set = foldlBag go (unitVarSet fn) orig_dbs
     go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set

@@ -1576,7 +1578,7 @@ deleteCallsMentioning bs calls
   = mapVarEnv filter_calls calls
   where
     filter_calls :: CallInfoSet -> CallInfoSet
   = mapVarEnv filter_calls calls
   where
     filter_calls :: CallInfoSet -> CallInfoSet

-    filter_calls = filterFM (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))
+    filter_calls = Map.filterWithKey (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))

 
 deleteCallsFor :: [Id] -> CallDetails -> CallDetails
 -- Remove calls *for* bs
 
 deleteCallsFor :: [Id] -> CallDetails -> CallDetails
 -- Remove calls *for* bs

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 36f78cb..8855fdc 100644 (file)
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -15,11 +15,12 @@ import Module
 import SrcLoc
 import Outputable
 import UniqFM
 import SrcLoc
 import Outputable
 import UniqFM

-import FiniteMap

 import FastString
 
 import Maybes
 import Control.Monad
 import FastString
 
 import Maybes
 import Control.Monad

+import Data.Map (Map)
+import qualified Data.Map as Map

 \end{code}
 
 
 \end{code}
 
 

@@ -70,10 +71,10 @@ instance Ord ModulePair where
 
 -- Sets of module pairs
 --
 
 -- Sets of module pairs
 --

-type ModulePairSet = FiniteMap ModulePair ()
+type ModulePairSet = Map ModulePair ()

 
 listToSet :: [ModulePair] -> ModulePairSet
 
 listToSet :: [ModulePair] -> ModulePairSet

-listToSet l = listToFM (zip l (repeat ()))
+listToSet l = Map.fromList (zip l (repeat ()))

 
 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
 checkFamInstConsistency famInstMods directlyImpMods
 
 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
 checkFamInstConsistency famInstMods directlyImpMods

@@ -101,7 +102,7 @@ checkFamInstConsistency famInstMods directlyImpMods
                 -- instances of okPairs are consistent
             ; criticalPairs = listToSet $ allPairs famInstMods
                 -- all pairs that we need to consider
                 -- instances of okPairs are consistent
             ; criticalPairs = listToSet $ allPairs famInstMods
                 -- all pairs that we need to consider

-             ; toCheckPairs  = keysFM $ criticalPairs `minusFM` okPairs
+             ; toCheckPairs  = Map.keys $ criticalPairs `Map.difference` okPairs

                 -- the difference gives us the pairs we need to check now
             }
 
                 -- the difference gives us the pairs we need to check now
             }
 

diff --git a/compiler/typecheck/TcSimplify.lhs-old b/compiler/typecheck/TcSimplify.lhs-old
index c9b5736..274c14d 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs-old
+++ b/compiler/typecheck/TcSimplify.lhs-old
@@ -2490,7 +2490,7 @@ pprAvails (Avails imp avails)
   = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty)
         , nest 2 $ braces $ 
           vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)]
   = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty)
         , nest 2 $ braces $ 
           vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)]

-               | (inst,avail) <- fmToList avails ]]
+               | (inst,avail) <- Map.toList avails ]]

 
 instance Outputable AvailHow where
     ppr = pprAvail
 
 instance Outputable AvailHow where
     ppr = pprAvail

@@ -2504,10 +2504,10 @@ pprAvail (Rhs rhs bs)   = sep [text "Rhs" <+> ppr bs,
 
 -------------------------
 extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv
 
 -------------------------
 extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv

-extendAvailEnv env inst avail = addToFM env inst avail
+extendAvailEnv env inst avail = Map.insert inst avail env

 
 findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow
 
 findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow

-findAvailEnv env wanted = lookupFM env wanted
+findAvailEnv env wanted = Map.lookup wanted env

        -- NB 1: the Ord instance of Inst compares by the class/type info
        --  *not* by unique.  So
        --      d1::C Int ==  d2::C Int
        -- NB 1: the Ord instance of Inst compares by the class/type info
        --  *not* by unique.  So
        --      d1::C Int ==  d2::C Int

@@ -2528,7 +2528,7 @@ extendAvails avails@(Avails imp env) inst avail
        ; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) }
 
 availsInsts :: Avails -> [Inst]
        ; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) }
 
 availsInsts :: Avails -> [Inst]

-availsInsts (Avails _ avails) = keysFM avails
+availsInsts (Avails _ avails) = Map.keys avails

 
 availsImproved :: Avails -> ImprovementDone
 availsImproved (Avails imp _) = imp
 
 availsImproved :: Avails -> ImprovementDone
 availsImproved (Avails imp _) = imp

@@ -2566,12 +2566,12 @@ extractResults (Avails _ avails) wanteds
       | isEqInst w
       = go binds bound_dicts (w:irreds) done' ws
 
       | isEqInst w
       = go binds bound_dicts (w:irreds) done' ws
 

-      | Just done_ids@(done_id : rest_done_ids) <- lookupFM done w
+      | Just done_ids@(done_id : rest_done_ids) <- Map.lookup w done

       = if w_id `elem` done_ids then
           go binds bound_dicts irreds done ws
        else
           go (add_bind (nlHsVar done_id)) bound_dicts irreds
       = if w_id `elem` done_ids then
           go binds bound_dicts irreds done ws
        else
           go (add_bind (nlHsVar done_id)) bound_dicts irreds

-             (addToFM done w (done_id : w_id : rest_done_ids)) ws
+             (Map.insert w (done_id : w_id : rest_done_ids) done) ws

 
       | otherwise      -- Not yet done
       = case findAvailEnv avails w of
 
       | otherwise      -- Not yet done
       = case findAvailEnv avails w of

@@ -2582,14 +2582,14 @@ extractResults (Avails _ avails) wanteds
 
          Just (Rhs rhs ws') -> go (add_bind rhs) (w:bound_dicts) irreds done' (ws' ++ ws)
 
 
          Just (Rhs rhs ws') -> go (add_bind rhs) (w:bound_dicts) irreds done' (ws' ++ ws)
 

-         Just (Given g) -> go binds' bound_dicts irreds (addToFM done w [g_id]) ws 
+         Just (Given g) -> go binds' bound_dicts irreds (Map.insert w [g_id] done) ws 

                where
                  g_id = instToId g
                  binds' | w_id == g_id = binds
                         | otherwise    = add_bind (nlHsVar g_id)
       where
        w_id  = instToId w      
                where
                  g_id = instToId g
                  binds' | w_id == g_id = binds
                         | otherwise    = add_bind (nlHsVar g_id)
       where
        w_id  = instToId w      

-       done' = addToFM done w [w_id]
+       done' = Map.insert w [w_id] done

        add_bind rhs = addInstToDictBind binds w rhs
 \end{code}
 
        add_bind rhs = addInstToDictBind binds w rhs
 \end{code}
 

diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs
index 28c9620..ca91811 100644 (file)
--- a/compiler/utils/FiniteMap.lhs
+++ b/compiler/utils/FiniteMap.lhs
@@ -1,207 +1,33 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The AQUA Project, Glasgow University, 1994-1998
-%
-
-``Finite maps'' are the heart of the compiler's lookup-tables/environments
-and its implementation of sets. Important stuff!
-
-The implementation uses @Data.Map@ from the containers package, which
-is both maintained and faster than the past implementation (see commit log).
-
-The orinigal interface is being kept around. It maps directly to Data.Map,
-only ``Data.Map.union'' is left-biased and ``plusFM'' right-biased and
-``addToFM\_C'' and ``Data.Map.insertWith'' differ in the order of
-arguments of combining function.

 
 \begin{code}
 module FiniteMap (
 
 \begin{code}
 module FiniteMap (

-        -- * Mappings keyed from arbitrary types
-        FiniteMap,   -- abstract data type
-
-        -- ** Manipulating those mappings
-        emptyFM, unitFM, listToFM,
-
-        addToFM,
-        addToFM_C,
-        addListToFM,
-        addListToFM_C,
-        delFromFM,
-        delListFromFM,
-
-        plusFM,
-        plusFM_C,
-        minusFM,
-        foldFM,
-
-        intersectFM,
-        intersectFM_C,
-        mapFM, filterFM,
-
-        sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
-
-        fmToList, keysFM, eltsFM,
-
-        bagToFM
+        insertList,
+        insertListWith,
+        deleteList,
+        foldRightWithKey

     ) where
 
     ) where
 

-import Bag ( Bag, foldrBag )
-import Outputable
-
-import qualified Data.Map as M
-
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection{The signature of the module}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
--- BUILDING
-emptyFM     :: FiniteMap key elt
-unitFM      :: key -> elt -> FiniteMap key elt
--- | In the case of duplicates keys, the last item is taken
-listToFM    :: (Ord key) => [(key,elt)] -> FiniteMap key elt
--- | In the case of duplicate keys, who knows which item is taken
-bagToFM     :: (Ord key) => Bag (key,elt) -> FiniteMap key elt
-
--- ADDING AND DELETING
-
--- | Throws away any previous binding
-addToFM     :: (Ord key)
-            => FiniteMap key elt -> key -> elt -> FiniteMap key elt
--- | Throws away any previous binding, items are added left-to-right
-addListToFM :: (Ord key)
-            => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
-
--- | Combines added item with previous item, if any --
--- if the key is present, ``addToFM_C f`` inserts
--- ``(key, f old_value new_value)''
-addToFM_C       :: (Ord key) => (elt -> elt -> elt)
-                           -> FiniteMap key elt -> key -> elt
-                           -> FiniteMap key elt
--- | Combines added item with previous item, if any, items are added left-to-right
-addListToFM_C   :: (Ord key) => (elt -> elt -> elt)
-                           -> FiniteMap key elt -> [(key,elt)]
-                           -> FiniteMap key elt
-
--- | Deletion doesn't complain if you try to delete something which isn't there
-delFromFM       :: (Ord key)
-                => FiniteMap key elt -> key   -> FiniteMap key elt
--- | Deletion doesn't complain if you try to delete something which isn't there
-delListFromFM   :: (Ord key)
-                => FiniteMap key elt -> [key] -> FiniteMap key elt
+import Data.Map (Map)
+import qualified Data.Map as Map

 
 

--- COMBINING
+insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt
+insertList xs m = foldl (\m (k, v) -> Map.insert k v m) m xs

 
 

--- | Bindings in right argument shadow those in the left
-plusFM          :: (Ord key)
-                => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+insertListWith :: Ord key
+               => (elt -> elt -> elt)
+               -> [(key,elt)]
+               -> Map key elt
+               -> Map key elt
+insertListWith f xs m0 = foldl (\m (k, v) -> Map.insertWith f k v m) m0 xs

 
 

--- | Combines bindings for the same thing with the given function, 
--- bindings in right argument shadow those in the left
-plusFM_C        :: (Ord key)
-                => (elt -> elt -> elt)
-                -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+deleteList :: Ord key => [key] -> Map key elt -> Map key elt
+deleteList ks m = foldl (flip Map.delete) m ks

 
 

--- | Deletes from the left argument any bindings in the right argument
-minusFM         :: (Ord key)
-                => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
-intersectFM     :: (Ord key)
-                => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
--- | Combines bindings for the same thing in the two maps with the given function
-intersectFM_C   :: (Ord key)
-                => (elt1 -> elt2 -> elt3)
-                -> FiniteMap key elt1 -> FiniteMap key elt2
-                -> FiniteMap key elt3
-
--- MAPPING, FOLDING, FILTERING
-foldFM          :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
-mapFM           :: (key -> elt1 -> elt2)
-                -> FiniteMap key elt1 -> FiniteMap key elt2
-filterFM        :: (Ord key)
-                => (key -> elt -> Bool)
-                -> FiniteMap key elt -> FiniteMap key elt
-
--- INTERROGATING
-sizeFM                  :: FiniteMap key elt -> Int
-isEmptyFM               :: FiniteMap key elt -> Bool
-
-elemFM                  :: (Ord key)
-                        => key -> FiniteMap key elt -> Bool
-lookupFM                :: (Ord key)
-                        => FiniteMap key elt -> key -> Maybe elt
--- | Supplies a "default" element in return for an unmapped key
-lookupWithDefaultFM     :: (Ord key)
-                        => FiniteMap key elt -> elt -> key -> elt
-
--- LISTIFYING
-fmToList        :: FiniteMap key elt -> [(key,elt)]
-keysFM          :: FiniteMap key elt -> [key]
-eltsFM          :: FiniteMap key elt -> [elt]
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection{Implementation using ``Data.Map''}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-newtype FiniteMap key elt = FM (M.Map key elt)
-
-emptyFM = FM M.empty
-unitFM k v = FM (M.singleton k v)
-listToFM l = FM (M.fromList l)
-
-addToFM (FM m) k v = FM (M.insert k v m)
--- Arguments of combining function of M.insertWith and addToFM_C are flipped.
-addToFM_C f (FM m) k v = FM (M.insertWith (flip f) k v m)
-addListToFM = foldl (\m (k, v) -> addToFM m k v)
-addListToFM_C f = foldl (\m (k, v) -> addToFM_C f m k v)
-delFromFM (FM m) k = FM (M.delete k m)
-delListFromFM = foldl delFromFM
-
--- M.union is left-biased, plusFM should be right-biased.
-plusFM (FM x) (FM y) = FM (M.union y x)
-plusFM_C f (FM x) (FM y) = FM (M.unionWith f x y)
-minusFM (FM x) (FM y) = FM (M.difference x y)
-#if MIN_VERSION_containers(0,4,0)
-foldFM k z (FM m) = M.foldrWithKey k z m
+foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a
+#if (MIN_VERSION_containers(0,4,0))
+foldRightWithKey = Map.foldrWithKey

 #else
 #else

-foldFM k z (FM m) = M.foldWithKey k z m
+foldRightWithKey = Map.foldWithKey

 #endif
 #endif

-
-intersectFM (FM x) (FM y) = FM (M.intersection x y)
-intersectFM_C f (FM x) (FM y) = FM (M.intersectionWith f x y)
-mapFM f (FM m) = FM (M.mapWithKey f m)
-filterFM p (FM m) = FM (M.filterWithKey p m)
-
-sizeFM (FM m) = M.size m
-isEmptyFM (FM m) = M.null m
-elemFM k (FM m) = M.member k m
-lookupFM (FM m) k = M.lookup k m
-lookupWithDefaultFM (FM m) v k = M.findWithDefault v k m
-
-fmToList (FM m) = M.toList m
-keysFM (FM m) = M.keys m
-eltsFM (FM m) = M.elems m
-
-bagToFM = foldrBag (\(k,v) m -> addToFM m k v) emptyFM
-

 \end{code}
 
 \end{code}
 

-%************************************************************************
-%*                                                                      *
-\subsection{Output-ery}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where
-    ppr fm = ppr (fmToList fm)
-\end{code}

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 7a643d7..73c6bd3 100644 (file)
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -75,6 +75,8 @@ import Pretty         ( Doc, Mode(..) )
 import Panic
 
 import Data.Char
 import Panic
 
 import Data.Char

+import Data.Map (Map)
+import qualified Data.Map as M

 import Data.Word
 import System.IO       ( Handle, stderr, stdout, hFlush )
 import System.FilePath
 import Data.Word
 import System.IO       ( Handle, stderr, stdout, hFlush )
 import System.FilePath

@@ -564,6 +566,9 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e)
 instance Outputable FastString where
     ppr fs = ftext fs          -- Prints an unadorned string,
                                -- no double quotes or anything
 instance Outputable FastString where
     ppr fs = ftext fs          -- Prints an unadorned string,
                                -- no double quotes or anything

+
+instance (Outputable key, Outputable elt) => Outputable (Map key elt) where
+    ppr m = ppr (M.toList m)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************