Generalize register sets and liveness calculations.

We would like to calculate register liveness for global registers as well as
local registers, so this patch generalizes the existing infrastructure to set
the stage.

compiler/cmm/CmmExpr.hs

+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module CmmExpr
     ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
     , CmmReg(..), cmmRegType
     , CmmLit(..), cmmLitType
     , LocalReg(..), localRegType
-    , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
+    , GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
     , VGcPtr(..), vgcFlag       -- Temporary!
-    , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
-    , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
-            , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
-            , regSetToList
+
+    , DefinerOfRegs, UserOfRegs
+    , foldRegsDefd, foldRegsUsed, filterRegsUsed
+    , foldLocalRegsDefd, foldLocalRegsUsed
+
+    , RegSet, LocalRegSet, GlobalRegSet
+    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
+    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
+    , regSetToList
     , regUsedIn
+    
     , Area(..)
     , module CmmMachOp
     , module CmmType
@@ -177,7 +185,7 @@ localRegType (LocalReg _ rep) = rep
 --    Register-use information for expressions and other types
 -----------------------------------------------------------------------------
 
--- | Sets of local registers
+-- | Sets of registers
 
 -- These are used for dataflow facts, and a common operation is taking
 -- the union of two RegSets and then asking whether the union is the
@@ -185,16 +193,19 @@ localRegType (LocalReg _ rep) = rep
 -- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
 -- Sets.
 
-type RegSet              =  Set LocalReg
-emptyRegSet             :: RegSet
-nullRegSet              :: RegSet -> Bool
-elemRegSet              :: LocalReg -> RegSet -> Bool
-extendRegSet            :: RegSet -> LocalReg -> RegSet
-deleteFromRegSet        :: RegSet -> LocalReg -> RegSet
-mkRegSet                :: [LocalReg] -> RegSet
-minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet
-sizeRegSet              :: RegSet -> Int
-regSetToList            :: RegSet -> [LocalReg]
+type RegSet r     = Set r
+type LocalRegSet  = RegSet LocalReg
+type GlobalRegSet = RegSet GlobalReg
+
+emptyRegSet             :: Ord r => RegSet r
+nullRegSet              :: Ord r => RegSet r -> Bool
+elemRegSet              :: Ord r => r -> RegSet r -> Bool
+extendRegSet            :: Ord r => RegSet r -> r -> RegSet r
+deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r
+mkRegSet                :: Ord r => [r] -> RegSet r
+minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
+sizeRegSet              :: Ord r => RegSet r -> Int
+regSetToList            :: Ord r => RegSet r -> [r]
 
 emptyRegSet      = Set.empty
 nullRegSet       = Set.null
@@ -208,58 +219,75 @@ timesRegSet      = Set.intersection
 sizeRegSet       = Set.size
 regSetToList     = Set.toList
 
-class UserOfLocalRegs a where
-  foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
+class Ord r => UserOfRegs r a where
+  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b
+
+foldLocalRegsUsed :: UserOfRegs LocalReg a
+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+foldLocalRegsUsed = foldRegsUsed
 
-class DefinerOfLocalRegs a where
-  foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
+class Ord r => DefinerOfRegs r a where
+  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b
 
-filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
-filterRegsUsed p e =
-    foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
+foldLocalRegsDefd :: DefinerOfRegs LocalReg a
+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+foldLocalRegsDefd = foldRegsDefd
+
+filterRegsUsed :: UserOfRegs r e => DynFlags -> (r -> Bool) -> e -> RegSet r
+filterRegsUsed dflags p e =
+    foldRegsUsed dflags
+                 (\regs r -> if p r then extendRegSet regs r else regs)
                  emptyRegSet e
 
-instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where
-    foldRegsUsed f z (Just x) = foldRegsUsed f z x
-    foldRegsUsed _ z Nothing = z
+instance UserOfRegs LocalReg CmmReg where
+    foldRegsUsed _ f z (CmmLocal reg) = f z reg
+    foldRegsUsed _ _ z (CmmGlobal _)  = z
+
+instance DefinerOfRegs LocalReg CmmReg where
+    foldRegsDefd _ f z (CmmLocal reg) = f z reg
+    foldRegsDefd _ _ z (CmmGlobal _)  = z
 
-instance UserOfLocalRegs CmmReg where
-    foldRegsUsed f z (CmmLocal reg) = f z reg
-    foldRegsUsed _ z (CmmGlobal _)  = z
+instance UserOfRegs GlobalReg CmmReg where
+    foldRegsUsed _ _ z (CmmLocal _)    = z
+    foldRegsUsed _ f z (CmmGlobal reg) = f z reg
 
-instance DefinerOfLocalRegs CmmReg where
-    foldRegsDefd f z (CmmLocal reg) = f z reg
-    foldRegsDefd _ z (CmmGlobal _)  = z
+instance DefinerOfRegs GlobalReg CmmReg where
+    foldRegsDefd _ _ z (CmmLocal _)    = z
+    foldRegsDefd _ f z (CmmGlobal reg) = f z reg
 
-instance UserOfLocalRegs LocalReg where
-    foldRegsUsed f z r = f z r
+instance Ord r => UserOfRegs r r where
+    foldRegsUsed _ f z r = f z r
 
-instance DefinerOfLocalRegs LocalReg where
-    foldRegsDefd f z r = f z r
+instance Ord r => DefinerOfRegs r r where
+    foldRegsDefd _ f z r = f z r
 
-instance UserOfLocalRegs RegSet where
-    foldRegsUsed f = Set.fold (flip f)
+instance Ord r => UserOfRegs r (RegSet r) where
+    foldRegsUsed _ f = Set.fold (flip f)
 
-instance UserOfLocalRegs CmmExpr where
-  foldRegsUsed f z e = expr z e
+instance UserOfRegs r CmmReg => UserOfRegs r CmmExpr where
+  foldRegsUsed dflags f z e = expr z e
     where expr z (CmmLit _)          = z
-          expr z (CmmLoad addr _)    = foldRegsUsed f z addr
-          expr z (CmmReg r)          = foldRegsUsed f z r
-          expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
-          expr z (CmmRegOff r _)     = foldRegsUsed f z r
+          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr
+          expr z (CmmReg r)          = foldRegsUsed dflags f z r
+          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
+          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r
           expr z (CmmStackSlot _ _)  = z
 
-instance UserOfLocalRegs a => UserOfLocalRegs [a] where
-  foldRegsUsed _ set [] = set
-  foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
+instance UserOfRegs r a => UserOfRegs r (Maybe a) where
+    foldRegsUsed dflags f z (Just x) = foldRegsUsed dflags f z x
+    foldRegsUsed _      _ z Nothing = z
 
-instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
-  foldRegsDefd _ set [] = set
-  foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
+instance UserOfRegs r a => UserOfRegs r [a] where
+  foldRegsUsed _      _ set [] = set
+  foldRegsUsed dflags f set (x:xs) = foldRegsUsed dflags f (foldRegsUsed dflags f set x) xs
 
-instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
-  foldRegsDefd _ set Nothing  = set
-  foldRegsDefd f set (Just x) = foldRegsDefd f set x
+instance DefinerOfRegs r a => DefinerOfRegs r [a] where
+  foldRegsDefd _      _ set [] = set
+  foldRegsDefd dflags f set (x:xs) = foldRegsDefd dflags f (foldRegsDefd dflags f set x) xs
+
+instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where
+  foldRegsDefd _      _ set Nothing  = set
+  foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x
 
 -----------------------------------------------------------------------------
 -- Another reg utility
@@ -424,3 +452,10 @@ globalRegType dflags Hp                = gcWord dflags
                                             -- The initialiser for all
                                             -- dynamically allocated closures
 globalRegType dflags _                 = bWord dflags
+
+isArgReg :: GlobalReg -> Bool
+isArgReg (VanillaReg {}) = True
+isArgReg (FloatReg {})   = True
+isArgReg (DoubleReg {})  = True
+isArgReg (LongReg {})    = True
+isArgReg _               = False

compiler/cmm/CmmLayoutStack.hs

@@ -111,9 +111,9 @@ cmmLayoutStack dflags procpoints entry_args
 
     -- We need liveness info.  We could do removeDeadAssignments at
     -- the same time, but it buys nothing over doing cmmSink later,
-    -- and costs a lot more than just cmmLiveness.
+    -- and costs a lot more than just cmmLocalLiveness.
     -- (graph, liveness) <- removeDeadAssignments graph0
-    let (graph, liveness) = (graph0, cmmLiveness graph0)
+    let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0)
 
     -- pprTrace "liveness" (ppr liveness) $ return ()
     let blocks = postorderDfs graph
@@ -132,7 +132,7 @@ cmmLayoutStack dflags procpoints entry_args
 
 layout :: DynFlags
        -> BlockSet                      -- proc points
-       -> BlockEnv CmmLive              -- liveness
+       -> BlockEnv CmmLocalLive         -- liveness
        -> BlockId                       -- entry
        -> ByteOff                       -- stack args on entry
 
@@ -319,7 +319,7 @@ getStackLoc (Young l) n stackmaps =
 -- extra code that goes *after* the Sp adjustment.
 
 handleLastNode
-   :: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff
+   :: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
    -> BlockEnv StackMap -> StackMap
    -> Block CmmNode O O
    -> CmmNode O C
@@ -499,7 +499,7 @@ fixupStack old_stack new_stack = concatMap move new_locs
 setupStackFrame
              :: DynFlags
              -> BlockId                 -- label of continuation
-             -> BlockEnv CmmLive        -- liveness
+             -> BlockEnv CmmLocalLive   -- liveness
              -> ByteOff      -- updfr
              -> ByteOff      -- bytes of return values on stack
              -> StackMap     -- current StackMap
@@ -602,7 +602,7 @@ futureContinuation middle = foldBlockNodesB f middle Nothing
 -- on the stack and return the new StackMap and the assignments to do
 -- the saving.
 --
-allocate :: DynFlags -> ByteOff -> RegSet -> StackMap
+allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
          -> (StackMap, [CmmNode O O])
 allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
                                               , sm_regs = regs0 }

compiler/cmm/CmmLint.hs

@@ -32,10 +32,10 @@ import Data.Maybe
 
 cmmLint :: (Outputable d, Outputable h)
         => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
-cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops
+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
 
 cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
-cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g
+cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
 
 runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
 runCmmLint dflags l p =
@@ -46,18 +46,19 @@ runCmmLint dflags l p =
                              nest 2 (ppr p)])
      Right _  -> Nothing
 
-lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
-lintCmmDecl (CmmProc _ lbl g)
-  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g
-lintCmmDecl (CmmData {})
+lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
+lintCmmDecl dflags (CmmProc _ lbl _ g)
+  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
+lintCmmDecl _ (CmmData {})
   = return ()
 
 
-lintCmmGraph :: CmmGraph -> CmmLint ()
-lintCmmGraph g = cmmLiveness g `seq` mapM_ (lintCmmBlock labels) blocks
-                 -- cmmLiveness throws an error if there are registers
-                 -- live on entry to the graph (i.e. undefined
-                 -- variables)
+lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
+lintCmmGraph dflags g =
+    cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks
+    -- cmmLiveness throws an error if there are registers
+    -- live on entry to the graph (i.e. undefined
+    -- variables)
   where
        blocks = toBlockList g
        labels = setFromList (map entryLabel blocks)

compiler/cmm/CmmLive.hs

+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 
 module CmmLive
-    ( CmmLive
-    , cmmLiveness
+    ( CmmLocalLive
+    , CmmGlobalLive
+    , cmmLocalLiveness
+    , cmmGlobalLiveness
     , liveLattice
     , noLiveOnEntry, xferLive, gen, kill, gen_kill
     , removeDeadAssignments
@@ -12,6 +16,7 @@ module CmmLive
 where
 
 import UniqSupply
+import DynFlags
 import BlockId
 import Cmm
 import CmmUtils
@@ -26,10 +31,14 @@ import Outputable
 -----------------------------------------------------------------------------
 
 -- | The variables live on entry to a block
-type CmmLive = RegSet
+type CmmLive r = RegSet r
+type CmmLocalLive = CmmLive LocalReg
+type CmmGlobalLive = CmmLive GlobalReg
 
 -- | The dataflow lattice
-liveLattice :: DataflowLattice CmmLive
+liveLattice :: Ord r => DataflowLattice (CmmLive r)
+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}
+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}
 liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
     where add _ (OldFact old) (NewFact new) =
                (changeIf $ sizeRegSet join > sizeRegSet old, join)
@@ -37,58 +46,73 @@ liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
 
 
 -- | A mapping from block labels to the variables live on entry
-type BlockEntryLiveness = BlockEnv CmmLive
+type BlockEntryLiveness r = BlockEnv (CmmLive r)
 
 -----------------------------------------------------------------------------
 -- | Calculated liveness info for a CmmGraph
 -----------------------------------------------------------------------------
 
-cmmLiveness :: CmmGraph -> BlockEntryLiveness
-cmmLiveness graph =
-  check $ dataflowAnalBwd graph [] $ analBwd liveLattice xferLive
+cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
+cmmLocalLiveness dflags graph =
+  check $ dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags)
   where entry = g_entry graph
         check facts = noLiveOnEntry entry
                         (expectJust "check" $ mapLookup entry facts) facts
 
+cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg
+cmmGlobalLiveness dflags graph =
+  dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags)
+
 -- | On entry to the procedure, there had better not be any LocalReg's live-in.
-noLiveOnEntry :: BlockId -> CmmLive -> a -> a
+noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
 noLiveOnEntry bid in_fact x =
   if nullRegSet in_fact then x
   else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
 
 -- | The transfer equations use the traditional 'gen' and 'kill'
 -- notations, which should be familiar from the Dragon Book.
-gen  :: UserOfLocalRegs a    => a -> RegSet -> RegSet
-gen  a live = foldRegsUsed extendRegSet      live a
-kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
-kill a live = foldRegsDefd deleteFromRegSet live a
+gen  :: UserOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r
+{-# INLINE gen #-}
+gen dflags a live = foldRegsUsed dflags extendRegSet live a
+
+kill :: DefinerOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r
+{-# INLINE kill #-}
+kill dflags a live = foldRegsDefd dflags deleteFromRegSet live a
 
-gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a)
-          => a -> CmmLive -> CmmLive
-gen_kill a = gen a . kill a
+gen_kill :: (DefinerOfRegs r a, UserOfRegs r a)
+          => DynFlags -> a -> CmmLive r -> CmmLive r
+{-# INLINE gen_kill #-}
+gen_kill dflags a = gen dflags a . kill dflags a
 
 -- | The transfer function
-xferLive :: BwdTransfer CmmNode CmmLive
-xferLive = mkBTransfer3 fst mid lst
+xferLive :: forall r . ( UserOfRegs    r (CmmNode O O)
+                       , DefinerOfRegs r (CmmNode O O)
+                       , UserOfRegs    r (CmmNode O C)
+                       , DefinerOfRegs r (CmmNode O C))
+         => DynFlags -> BwdTransfer CmmNode (CmmLive r)
+{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive LocalReg) #-}
+{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive GlobalReg) #-}
+xferLive dflags = mkBTransfer3 fst mid lst
   where fst _ f = f
-        mid :: CmmNode O O -> CmmLive -> CmmLive
-        mid n f = gen_kill n f
-        lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
-        lst n f = gen_kill n $ joinOutFacts liveLattice n f
+        mid :: CmmNode O O -> CmmLive r -> CmmLive r
+        mid n f = gen_kill dflags n f
+        lst :: CmmNode O C -> FactBase (CmmLive r) -> CmmLive r
+        lst n f = gen_kill dflags n $ joinOutFacts liveLattice n f
 
 -----------------------------------------------------------------------------
 -- Removing assignments to dead variables
 -----------------------------------------------------------------------------
 
-removeDeadAssignments :: CmmGraph -> UniqSM (CmmGraph, BlockEnv CmmLive)
-removeDeadAssignments g =
-   dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites
+removeDeadAssignments :: DynFlags -> CmmGraph
+                      -> UniqSM (CmmGraph, BlockEnv CmmLocalLive)
+removeDeadAssignments dflags g =
+   dataflowPassBwd g [] $ analRewBwd liveLattice (xferLive dflags) rewrites
    where rewrites = mkBRewrite3 nothing middle nothing
          -- SDM: no need for deepBwdRw here, we only rewrite to empty
          -- Beware: deepBwdRw with one polymorphic function seems more
          -- reasonable here, but GHC panics while compiling, see bug
          -- #4045.
-         middle :: CmmNode O O -> Fact O CmmLive -> CmmReplGraph O O
+         middle :: CmmNode O O -> Fact O CmmLocalLive -> CmmReplGraph O O
          middle (CmmAssign (CmmLocal reg') _) live
                  | not (reg' `elemRegSet` live)
                  = return $ Just emptyGraph
@@ -99,5 +123,5 @@ removeDeadAssignments g =
                  = return $ Just emptyGraph
          middle _ _ = return Nothing
 
-         nothing :: CmmNode e x -> Fact x CmmLive -> CmmReplGraph e x
+         nothing :: CmmNode e x -> Fact x CmmLocalLive -> CmmReplGraph e x
          nothing _ _ = return Nothing

compiler/cmm/CmmNode.hs

 -- CmmNode type for representation using Hoopl graphs.
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS -fno-warn-tabs #-}
 -- The above warning supression flag is a temporary kludge.
@@ -16,7 +18,9 @@ module CmmNode (
      mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
   ) where
 
+import CodeGen.Platform
 import CmmExpr
+import DynFlags
 import FastString
 import ForeignCall
 import SMRep
@@ -280,8 +284,8 @@ data ForeignTarget        -- The target of a foreign call
 --------------------------------------------------
 -- Instances of register and slot users / definers
 
-instance UserOfLocalRegs (CmmNode e x) where
-  foldRegsUsed f z n = case n of
+instance UserOfRegs LocalReg (CmmNode e x) where
+  foldRegsUsed dflags f z n = case n of
     CmmAssign _ expr -> fold f z expr
     CmmStore addr rval -> fold f (fold f z addr) rval
     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
@@ -291,24 +295,58 @@ instance UserOfLocalRegs (CmmNode e x) where
     CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
     _ -> z
     where fold :: forall a b.
-                       UserOfLocalRegs a =>
+                       UserOfRegs LocalReg a =>
                        (b -> LocalReg -> b) -> b -> a -> b
-          fold f z n = foldRegsUsed f z n
+          fold f z n = foldRegsUsed dflags f z n
 
-instance UserOfLocalRegs ForeignTarget where
-  foldRegsUsed _f z (PrimTarget _)      = z
-  foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
+instance UserOfRegs GlobalReg (CmmNode e x) where
+  foldRegsUsed dflags f z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+    CmmCondBranch expr _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b.
+                       UserOfRegs GlobalReg a =>
+                       (b -> GlobalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsUsed dflags f z n
 
-instance DefinerOfLocalRegs (CmmNode e x) where
-  foldRegsDefd f z n = case n of
+instance UserOfRegs r CmmExpr => UserOfRegs r ForeignTarget where
+  foldRegsUsed _      _ z (PrimTarget _)      = z
+  foldRegsUsed dflags f z (ForeignTarget e _) = foldRegsUsed dflags f z e
+
+instance DefinerOfRegs LocalReg (CmmNode e x) where
+  foldRegsDefd dflags f z n = case n of
     CmmAssign lhs _ -> fold f z lhs
     CmmUnsafeForeignCall _ fs _ -> fold f z fs
     CmmForeignCall {res=res} -> fold f z res
     _ -> z
     where fold :: forall a b.
-                   DefinerOfLocalRegs a =>
+                   DefinerOfRegs LocalReg a =>
                    (b -> LocalReg -> b) -> b -> a -> b
-          fold f z n = foldRegsDefd f z n
+          fold f z n = foldRegsDefd dflags f z n
+
+instance DefinerOfRegs GlobalReg (CmmNode e x) where
+  foldRegsDefd dflags f z n = case n of
+    CmmAssign lhs _ -> fold f z lhs
+    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
+    CmmCall {} -> fold f z activeRegs
+    CmmForeignCall {tgt=tgt} -> fold f z (foreignTargetRegs tgt)
+    _ -> z
+    where fold :: forall a b.
+                   DefinerOfRegs GlobalReg a =>
+                   (b -> GlobalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsDefd dflags f z n
+
+          platform = targetPlatform dflags
+          activeRegs = activeStgRegs platform
+          activeCallerSavesRegs = filter (callerSaves platform) activeRegs
+
+          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
+          foreignTargetRegs _ = activeCallerSavesRegs
 
 
 -----------------------------------

compiler/cmm/CmmRewriteAssignments.hs

@@ -42,11 +42,11 @@ rewriteAssignments dflags g = do
   -- first perform usage analysis and bake this information into the
   -- graph (backwards transform), and then do a forwards transform
   -- to actually perform inlining and sinking.
-  g'  <- annotateUsage g
+  g'  <- annotateUsage dflags g
   g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
                                      analRewFwd assignmentLattice
                                                 (assignmentTransfer dflags)
-                                                (assignmentRewrite `thenFwdRw` machOpFoldRewrite dflags)
+                                                (assignmentRewrite dflags `thenFwdRw` machOpFoldRewrite dflags)
   return (modifyGraph eraseRegUsage g'')
 
 ----------------------------------------------------------------
@@ -159,13 +159,13 @@ data WithRegUsage n e x where
     Plain       :: n e x -> WithRegUsage n e x
     AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
 
-instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where
-    foldRegsUsed f z (Plain n) = foldRegsUsed f z n
-    foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e
+instance UserOfRegs LocalReg (n e x) => UserOfRegs LocalReg (WithRegUsage n e x) where
+    foldRegsUsed dflags f z (Plain n) = foldRegsUsed dflags f z n
+    foldRegsUsed dflags f z (AssignLocal _ e _) = foldRegsUsed dflags f z e
 
-instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where
-    foldRegsDefd f z (Plain n) = foldRegsDefd f z n
-    foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r
+instance DefinerOfRegs LocalReg (n e x) => DefinerOfRegs LocalReg (WithRegUsage n e x) where
+    foldRegsDefd dflags f z (Plain n) = foldRegsDefd dflags f z n
+    foldRegsDefd dflags f z (AssignLocal r _ _) = foldRegsDefd dflags f z r
 
 instance NonLocal n => NonLocal (WithRegUsage n) where
     entryLabel (Plain n) = entryLabel n
@@ -190,8 +190,8 @@ usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f)
 
 -- We reuse the names 'gen' and 'kill', although we're doing something
 -- slightly different from the Dragon Book
-usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap
-usageTransfer = mkBTransfer3 first middle last
+usageTransfer :: DynFlags -> BwdTransfer (WithRegUsage CmmNode) UsageMap
+usageTransfer dflags = mkBTransfer3 first middle last
     where first _ f = f
           middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap
           middle n f = gen_kill n f
@@ -209,9 +209,9 @@ usageTransfer = mkBTransfer3 first middle last
           gen_kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap
           gen_kill a = gen a . kill a
           gen :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap
-          gen  a f = foldRegsUsed increaseUsage f a
+          gen  a f = foldLocalRegsUsed dflags increaseUsage f a
           kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap
-          kill a f = foldRegsDefd delFromUFM f a
+          kill a f = foldLocalRegsDefd dflags delFromUFM f a
           increaseUsage f r = addToUFM_C combine f r SingleUse
             where combine _ _ = ManyUse
 
@@ -228,11 +228,11 @@ usageRewrite = mkBRewrite3 first middle last
           last   _ _ = return Nothing
 
 type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
-annotateUsage :: CmmGraph -> UniqSM (CmmGraphWithRegUsage)
-annotateUsage vanilla_g =
+annotateUsage :: DynFlags -> CmmGraph -> UniqSM (CmmGraphWithRegUsage)
+annotateUsage dflags vanilla_g =
     let g = modifyGraph liftRegUsage vanilla_g
     in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
-                                   analRewBwd usageLattice usageTransfer usageRewrite
+                                   analRewBwd usageLattice (usageTransfer dflags) usageRewrite
 
 ----------------------------------------------------------------
 --- Assignment tracking
@@ -286,8 +286,8 @@ assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUF
 
 -- Deletes sinks from assignment map, because /this/ is the place
 -- where it will be sunk to.
-deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap
-deleteSinks n m = foldRegsUsed (adjustUFM f) m n
+deleteSinks :: UserOfRegs LocalReg n => DynFlags -> n -> AssignmentMap -> AssignmentMap
+deleteSinks dflags n m = foldLocalRegsUsed dflags (adjustUFM f) m n
   where f (AlwaysSink _) = NeverOptimize
         f old = old
 
@@ -319,8 +319,8 @@ middleAssignment :: DynFlags -> WithRegUsage CmmNode O O -> AssignmentMap
 --     the correct optimization policy.
 --  3. Look for all assignments that reference that register and
 --     invalidate them.
-middleAssignment _ n@(AssignLocal r e usage) assign
-    = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
+middleAssignment dflags n@(AssignLocal r e usage) assign
+    = invalidateUsersOf (CmmLocal r) . add . deleteSinks dflags n $ assign
       where add m = addToUFM m r
                   $ case usage of
                         SingleUse -> AlwaysInline e
@@ -339,8 +339,8 @@ middleAssignment _ n@(AssignLocal r e usage) assign
 -- 1. Delete any sinking assignments that were used by this instruction