update to current master againwip/T13904

21 files changed, 90 insertions, 43 deletions

diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
index 6771e4ecb9..634e61cb13 100644
--- a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
@@ -21,6 +21,8 @@ module RegAlloc.Graph.ArchBase (
         bound,
         squeese
 ) where
+import GhcPrelude
+
 import UniqSet
 import UniqFM
 import Unique
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
index 439899071a..0472e4cf09 100644
--- a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
@@ -14,9 +14,14 @@ module RegAlloc.Graph.ArchX86 (
         worst,
         squeese,
 ) where
+
+import GhcPrelude
+
 import RegAlloc.Graph.ArchBase  (Reg(..), RegSub(..), RegClass(..))
 import UniqSet
 
+import qualified Data.Array as A
+
 
 -- | Determine the class of a register
 classOfReg :: Reg -> RegClass
@@ -57,18 +62,28 @@ regName :: Reg -> Maybe String
 regName reg
  = case reg of
         Reg ClassG32 i
-         | i <= 7-> Just $ [ "eax", "ebx", "ecx", "edx"
-                           , "ebp", "esi", "edi", "esp" ] !! i
+         | i <= 7 ->
+           let names = A.listArray (0,8)
+                       [ "eax", "ebx", "ecx", "edx"
+                       , "ebp", "esi", "edi", "esp" ]
+           in Just $ names A.! i
 
         RegSub SubL16 (Reg ClassG32 i)
-         | i <= 7 -> Just $ [ "ax", "bx", "cx", "dx"
-                            , "bp", "si", "di", "sp"] !! i
+         | i <= 7 ->
+           let names = A.listArray (0,8)
+                       [ "ax", "bx", "cx", "dx"
+                       , "bp", "si", "di", "sp"]
+           in Just $ names A.! i
 
         RegSub SubL8  (Reg ClassG32 i)
-         | i <= 3 -> Just $ [ "al", "bl", "cl", "dl"] !! i
+         | i <= 3 ->
+           let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"]
+           in Just $ names A.! i
 
         RegSub SubL8H (Reg ClassG32 i)
-         | i <= 3 -> Just $ [ "ah", "bh", "ch", "dh"] !! i
+         | i <= 3 ->
+           let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"]
+           in Just $ names A.! i
 
         _         -> Nothing
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
index 7e8047f29f..5ca2412c73 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -3,6 +3,8 @@ module RegAlloc.Graph.Coalesce (
         regCoalesce,
         slurpJoinMovs
 ) where
+import GhcPrelude
+
 import RegAlloc.Liveness
 import Instruction
 import Reg
@@ -14,8 +16,6 @@ import UniqFM
 import UniqSet
 import UniqSupply
 
-import Data.List
-
 
 -- | Do register coalescing on this top level thing
 --
@@ -62,7 +62,7 @@ sinkReg fm r
 
 -- | Slurp out mov instructions that only serve to join live ranges.
 --
---   During a mov, if the source reg dies and the destiation reg is
+--   During a mov, if the source reg dies and the destination reg is
 --   born then we can rename the two regs to the same thing and
 --   eliminate the move.
 slurpJoinMovs
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index 08538453f7..4c17d930ea 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -4,6 +4,8 @@
 module RegAlloc.Graph.Main (
         regAlloc
 ) where
+import GhcPrelude
+
 import qualified GraphColor as Color
 import RegAlloc.Liveness
 import RegAlloc.Graph.Spill
@@ -25,7 +27,6 @@ import UniqSet
 import UniqSupply
 import Util (seqList)
 
-import Data.List
 import Data.Maybe
 import Control.Monad
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index 0014ab6fed..bce24bdd3c 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -7,6 +7,8 @@ module RegAlloc.Graph.Spill (
         SpillStats(..),
         accSpillSL
 ) where
+import GhcPrelude
+
 import RegAlloc.Liveness
 import Instruction
 import Reg
@@ -34,7 +36,7 @@ import qualified Data.IntSet    as IntSet
 --   TODO: See if we can split some of the live ranges instead of just globally
 --         spilling the virtual reg. This might make the spill cleaner's job easier.
 --
---   TODO: On CISCy x86 and x86_64 we don't nessesarally have to add a mov instruction
+--   TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction
 --         when making spills. If an instr is using a spilled virtual we may be able to
 --         address the spill slot directly.
 --
@@ -111,8 +113,8 @@ regSpill_top platform regSlotMap cmm
                 -- after we've done a successful allocation.
                 let liveSlotsOnEntry' :: BlockMap IntSet
                     liveSlotsOnEntry'
-                        = mapFoldWithKey patchLiveSlot
-                                         liveSlotsOnEntry liveVRegsOnEntry
+                        = mapFoldlWithKey patchLiveSlot
+                                          liveSlotsOnEntry liveVRegsOnEntry
 
                 let info'
                         = LiveInfo static firstId
@@ -129,10 +131,9 @@ regSpill_top platform regSlotMap cmm
         -- then record the fact that these slots are now live in those blocks
         -- in the given slotmap.
         patchLiveSlot
-                :: BlockId -> RegSet
-                -> BlockMap IntSet -> BlockMap IntSet
+                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
 
-        patchLiveSlot blockId regsLive slotMap
+        patchLiveSlot slotMap blockId regsLive
          = let
                 -- Slots that are already recorded as being live.
                 curSlotsLive    = fromMaybe IntSet.empty
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index faef4037c2..50001d7334 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -28,6 +28,8 @@
 module RegAlloc.Graph.SpillClean (
         cleanSpills
 ) where
+import GhcPrelude
+
 import RegAlloc.Liveness
 import Instruction
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index 9811f1a64b..f603b609df 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -13,6 +13,8 @@ module RegAlloc.Graph.SpillCost (
 
         lifeMapFromSpillCostInfo
 ) where
+import GhcPrelude
+
 import RegAlloc.Liveness
 import Instruction
 import RegClass
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
index 71956025b0..487e3ee03a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -16,6 +16,8 @@ module RegAlloc.Graph.Stats (
 
 #include "nativeGen/NCG.h"
 
+import GhcPrelude
+
 import qualified GraphColor as Color
 import RegAlloc.Liveness
 import RegAlloc.Graph.Spill
@@ -32,9 +34,6 @@ import UniqFM
 import UniqSet
 import State
 
-import Data.List
-
-
 -- | Holds interesting statistics from the register allocator.
 data RegAllocStats statics instr
 
@@ -265,8 +264,8 @@ pprStatsConflict stats
         $$ text "\n")
 
 
--- | For every vreg, dump it's how many conflicts it has and its lifetime
---      good for making a scatter plot.
+-- | For every vreg, dump how many conflicts it has, and its lifetime.
+--      Good for making a scatter plot.
 pprStatsLifeConflict
         :: [RegAllocStats statics instr]
         -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
@@ -277,10 +276,10 @@ pprStatsLifeConflict stats graph
                 $ foldl' plusSpillCostInfo zeroSpillCostInfo
                 $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
 
-        scatter = map   (\r ->  let lifetime    = case lookupUFM lifeMap r of
-                                                        Just (_, l)     -> l
-                                                        Nothing         -> 0
-                                    Just node   = Color.lookupNode graph r
+        scatter = map   (\r ->  let lifetime  = case lookupUFM lifeMap r of
+                                                      Just (_, l) -> l
+                                                      Nothing     -> 0
+                                    Just node = Color.lookupNode graph r
                                 in parens $ hcat $ punctuate (text ", ")
                                         [ doubleQuotes $ ppr $ Color.nodeId node
                                         , ppr $ sizeUniqSet (Color.nodeConflicts node)
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
index 204de846ae..7774985dce 100644
--- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -8,6 +8,8 @@ where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import RegClass
 import Reg
 
diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs
index d4f124e297..1172870729 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Base.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs
@@ -17,6 +17,8 @@ module RegAlloc.Linear.Base (
 
 where
 
+import GhcPrelude
+
 import RegAlloc.Linear.StackMap
 import RegAlloc.Liveness
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
index 9933f5bb49..b4e79432d8 100644
--- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
@@ -9,6 +9,8 @@ module RegAlloc.Linear.FreeRegs (
 
 where
 
+import GhcPrelude
+
 import Reg
 import RegClass
 
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index c262b2b059..89f496c409 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -9,6 +9,8 @@
 --
 module RegAlloc.Linear.JoinToTargets (joinToTargets) where
 
+import GhcPrelude
+
 import RegAlloc.Linear.State
 import RegAlloc.Linear.Base
 import RegAlloc.Linear.FreeRegs
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 2ba682ad17..6171d8d20d 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -102,6 +102,8 @@ module RegAlloc.Linear.Main (
 #include "HsVersions.h"
 
 
+import GhcPrelude
+
 import RegAlloc.Linear.State
 import RegAlloc.Linear.Base
 import RegAlloc.Linear.StackMap
@@ -496,7 +498,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
     -- debugging
 {-    freeregs <- getFreeRegsR
     assig    <- getAssigR
-    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform }) trace "genRaInsn"
+    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn"
         (ppr instr
                 $$ text "r_dying      = " <+> ppr r_dying
                 $$ text "w_dying      = " <+> ppr w_dying
@@ -807,27 +809,29 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
 
           -- case (3): we need to push something out to free up a register
          [] ->
-           do   let keep' = map getUnique keep
+           do   let inRegOrBoth (InReg _) = True
+                    inRegOrBoth (InBoth _ _) = True
+                    inRegOrBoth _ = False
+                let candidates' =
+                      flip delListFromUFM keep $
+                      filterUFM inRegOrBoth $
+                      assig
+                      -- This is non-deterministic but we do not
+                      -- currently support deterministic code-generation.
+                      -- See Note [Unique Determinism and code generation]
+                let candidates = nonDetUFMToList candidates'
 
                 -- the vregs we could kick out that are already in a slot
                 let candidates_inBoth
                         = [ (temp, reg, mem)
-                          | (temp, InBoth reg mem) <- nonDetUFMToList assig
-                          -- This is non-deterministic but we do not
-                          -- currently support deterministic code-generation.
-                          -- See Note [Unique Determinism and code generation]
-                          , temp `notElem` keep'
+                          | (temp, InBoth reg mem) <- candidates
                           , targetClassOfRealReg platform reg == classOfVirtualReg r ]
 
                 -- the vregs we could kick out that are only in a reg
                 --      this would require writing the reg to a new slot before using it.
                 let candidates_inReg
                         = [ (temp, reg)
-                          | (temp, InReg reg) <- nonDetUFMToList assig
-                          -- This is non-deterministic but we do not
-                          -- currently support deterministic code-generation.
-                          -- See Note [Unique Determinism and code generation]
-                          , temp `notElem` keep'
+                          | (temp, InReg reg) <- candidates
                           , targetClassOfRealReg platform reg == classOfVirtualReg r ]
 
                 let result
diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
index 5d369249c7..581548212a 100644
--- a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
@@ -2,6 +2,8 @@
 module RegAlloc.Linear.PPC.FreeRegs
 where
 
+import GhcPrelude
+
 import PPC.Regs
 import RegClass
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
index db4d6ba376..653b2707c9 100644
--- a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
@@ -3,6 +3,8 @@
 module RegAlloc.Linear.SPARC.FreeRegs
 where
 
+import GhcPrelude
+
 import SPARC.Regs
 import RegClass
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
index 748fb98c30..95819c6fb3 100644
--- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
@@ -20,6 +20,8 @@ module RegAlloc.Linear.StackMap (
 
 where
 
+import GhcPrelude
+
 import DynFlags
 import UniqFM
 import Unique
diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
index 8b17d3ab88..6554188f41 100644
--- a/compiler/nativeGen/RegAlloc/Linear/State.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -31,6 +31,8 @@ module RegAlloc.Linear.State (
 )
 where
 
+import GhcPrelude
+
 import RegAlloc.Linear.Stats
 import RegAlloc.Linear.StackMap
 import RegAlloc.Linear.Base
diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
index 71dedaeb55..74f3c834d0 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
@@ -6,6 +6,8 @@ module RegAlloc.Linear.Stats (
 
 where
 
+import GhcPrelude
+
 import RegAlloc.Linear.Base
 import RegAlloc.Liveness
 import Instruction
@@ -13,7 +15,6 @@ import Instruction
 import UniqFM
 import Outputable
 
-import Data.List
 import State
 
 -- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
index ae4aa53254..65a566d1c3 100644
--- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
@@ -3,6 +3,8 @@
 module RegAlloc.Linear.X86.FreeRegs
 where
 
+import GhcPrelude
+
 import X86.Regs
 import RegClass
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
index 5a7f71e3f0..713b053356 100644
--- a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
@@ -3,6 +3,8 @@
 module RegAlloc.Linear.X86_64.FreeRegs
 where
 
+import GhcPrelude
+
 import X86.Regs
 import RegClass
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index e66139786b..9d93564317 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -35,6 +35,8 @@ module RegAlloc.Liveness (
         regLiveness,
         natCmmTopToLive
   ) where
+import GhcPrelude
+
 import Reg
 import Instruction
 
@@ -145,10 +147,10 @@ instance Instruction instr => Instruction (InstrSR instr) where
         mkJumpInstr target      = map Instr (mkJumpInstr target)
 
         mkStackAllocInstr platform amount =
-             Instr (mkStackAllocInstr platform amount)
+             Instr <$> mkStackAllocInstr platform amount
 
         mkStackDeallocInstr platform amount =
-             Instr (mkStackDeallocInstr platform amount)
+             Instr <$> mkStackDeallocInstr platform amount
 
 
 -- | An instruction with liveness information.
@@ -812,7 +814,7 @@ computeLiveness
 computeLiveness platform sccs
  = case checkIsReverseDependent sccs of
         Nothing         -> livenessSCCs platform mapEmpty [] sccs
-        Just bad        -> pprPanic "RegAlloc.Liveness.computeLivenss"
+        Just bad        -> pprPanic "RegAlloc.Liveness.computeLiveness"
                                 (vcat   [ text "SCCs aren't in reverse dependent order"
                                         , text "bad blockId" <+> ppr bad
                                         , ppr sccs])
@@ -1006,5 +1008,3 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
             r_dying_br  = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
                                              live_branch_only)
                           -- See Note [Unique Determinism and code generation]
-
-