Define callerSaves for all platforms

This means that we now generate the same code whatever platform we are
on, which should help avoid changes on one platform breaking the build
on another.

It's also another step towards full cross-compilation.

12 files changed, 217 insertions, 229 deletions

diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 5aca286001..d8c76f4d79 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -915,7 +915,7 @@ lowerSafeForeignCall dflags block
     -- RTS-only objects and are not subject to garbage collection
     id <- newTemp bWord
     new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
-    let (caller_save, caller_load) = callerSaveVolatileRegs
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
     load_tso <- newTemp gcWord
     load_stack <- newTemp gcWord
     let suspend = saveThreadState dflags <*>
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index e86374b264..f6cbb5c52c 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -95,7 +95,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
 
        ----------- Sink and inline assignments *after* stack layout ------------
        g <- {-# SCC "sink2" #-}
-            condPass Opt_CmmSink cmmSink g
+            condPass Opt_CmmSink (cmmSink dflags) g
                      Opt_D_dump_cmmz_rewrite "Sink assignments (2)"
 
        ------------- CAF analysis ----------------------------------------------
diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs
index 2a6091d46f..a5b7602078 100644
--- a/compiler/cmm/CmmRewriteAssignments.hs
+++ b/compiler/cmm/CmmRewriteAssignments.hs
@@ -44,7 +44,7 @@ rewriteAssignments platform g = do
   g'  <- annotateUsage g
   g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
                                      analRewFwd assignmentLattice
-                                                assignmentTransfer
+                                                (assignmentTransfer platform)
                                                 (assignmentRewrite `thenFwdRw` machOpFoldRewrite platform)
   return (modifyGraph eraseRegUsage g'')
 
@@ -309,7 +309,8 @@ invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
 -- optimize; we need an algorithmic change to prevent us from having to
 -- traverse the /entire/ map continually.
 
-middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap
+middleAssignment :: Platform -> WithRegUsage CmmNode O O -> AssignmentMap
+                 -> AssignmentMap
 
 -- Algorithm for annotated assignments:
 --  1. Delete any sinking assignments that were used by this instruction
@@ -317,7 +318,7 @@ middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap
 --     the correct optimization policy.
 --  3. Look for all assignments that reference that register and
 --     invalidate them.
-middleAssignment n@(AssignLocal r e usage) assign
+middleAssignment _ n@(AssignLocal r e usage) assign
     = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
       where add m = addToUFM m r
                   $ case usage of
@@ -337,18 +338,18 @@ middleAssignment n@(AssignLocal r e usage) assign
 -- 1. Delete any sinking assignments that were used by this instruction
 -- 2. Look for all assignments that reference this register and
 --    invalidate them.
-middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
+middleAssignment _ (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
     = invalidateUsersOf reg . deleteSinks n $ assign
 
 -- Algorithm for unannotated assignments of *local* registers: do
 -- nothing (it's a reload, so no state should have changed)
-middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign
+middleAssignment _ (Plain (CmmAssign (CmmLocal _) _)) assign = assign
 
 -- Algorithm for stores:
 --  1. Delete any sinking assignments that were used by this instruction
 --  2. Look for all assignments that load from memory locations that
 --     were clobbered by this store and invalidate them.
-middleAssignment (Plain n@(CmmStore lhs rhs)) assign
+middleAssignment _ (Plain n@(CmmStore lhs rhs)) assign
     = let m = deleteSinks n assign
       in foldUFM_Directly f m m -- [foldUFM performance]
       where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize
@@ -370,16 +371,16 @@ middleAssignment (Plain n@(CmmStore lhs rhs)) assign
 -- This is kind of expensive. (One way to optimize this might be to
 -- store extra information about expressions that allow this and other
 -- checks to be done cheaply.)
-middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign
+middleAssignment platform (Plain n@(CmmUnsafeForeignCall{})) assign
     = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
     where deleteCallerSaves m = foldUFM_Directly f m m
           f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
           f _ _ m = m
-          g (CmmReg (CmmGlobal r)) _      | callerSaves r = True
-          g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True
+          g (CmmReg (CmmGlobal r)) _      | callerSaves platform r = True
+          g (CmmRegOff (CmmGlobal r) _) _ | callerSaves platform r = True
           g _ b = b
 
-middleAssignment (Plain (CmmComment {})) assign
+middleAssignment _ (Plain (CmmComment {})) assign
     = assign
 
 -- Assumptions:
@@ -462,8 +463,12 @@ invalidateVolatile k m = mapUFM p m
                   exp _ = False
         p _ = NeverOptimize -- probably shouldn't happen with AlwaysSink
 
-assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap
-assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment)
+assignmentTransfer :: Platform
+                   -> FwdTransfer (WithRegUsage CmmNode) AssignmentMap
+assignmentTransfer platform
+    = mkFTransfer3 (flip const)
+                   (middleAssignment platform)
+                   ((mkFactBase assignmentLattice .) . lastAssignment)
 
 -- Note [Soundness of inlining]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index b72a740234..71ed4f09f8 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -11,6 +11,7 @@ import CmmLive
 import CmmUtils
 import Hoopl
 
+import DynFlags
 import UniqFM
 -- import PprCmm ()
 -- import Outputable
@@ -99,8 +100,8 @@ type Assignment = (LocalReg, CmmExpr, AbsMem)
   -- Assignment caches AbsMem, an abstraction of the memory read by
   -- the RHS of the assignment.
 
-cmmSink :: CmmGraph -> CmmGraph
-cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
+cmmSink :: DynFlags -> CmmGraph -> CmmGraph
+cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
   where
   liveness = cmmLiveness graph
   getLive l = mapFindWithDefault Set.empty l liveness
@@ -128,8 +129,8 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
       ann_middles = annotate live_middle (blockToList middle)
 
       -- Now sink and inline in this block
-      (middle', assigs) = walk ann_middles (mapFindWithDefault [] lbl sunk)
-      (final_last, assigs') = tryToInline live last assigs
+      (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
+      (final_last, assigs') = tryToInline dflags live last assigs
 
       -- We cannot sink into join points (successors with more than
       -- one predecessor), so identify the join points and the set
@@ -149,11 +150,11 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
            _ -> False
 
       -- Now, drop any assignments that we will not sink any further.
-      (dropped_last, assigs'') = dropAssignments drop_if init_live_sets assigs'
+      (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'
 
       drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
           where
-            should_drop =  a `conflicts` final_last
+            should_drop =  conflicts dflags a final_last
                         || {- not (isTiny rhs) && -} live_in_multi live_sets r
                         || r `Set.member` live_in_joins
 
@@ -168,7 +169,7 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
       final_middle = foldl blockSnoc middle' dropped_last
 
       sunk' = mapUnion sunk $
-                 mapFromList [ (l, filterAssignments (getLive l) assigs'')
+                 mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')
                              | l <- succs ]
 
 {-
@@ -201,14 +202,14 @@ findJoinPoints blocks = mapFilter (>1) succ_counts
 -- filter the list of assignments to remove any assignments that
 -- are not live in a continuation.
 --
-filterAssignments :: RegSet -> [Assignment] -> [Assignment]
-filterAssignments live assigs = reverse (go assigs [])
+filterAssignments :: DynFlags -> RegSet -> [Assignment] -> [Assignment]
+filterAssignments dflags live assigs = reverse (go assigs [])
   where go []             kept = kept
         go (a@(r,_,_):as) kept | needed    = go as (a:kept)
                                | otherwise = go as kept
            where
               needed = r `Set.member` live
-                       || any (a `conflicts`) (map toNode kept)
+                       || any (conflicts dflags a) (map toNode kept)
                        --  Note that we must keep assignments that are
                        -- referred to by other assignments we have
                        -- already kept.
@@ -217,7 +218,8 @@ filterAssignments live assigs = reverse (go assigs [])
 -- Walk through the nodes of a block, sinking and inlining assignments
 -- as we go.
 
-walk :: [(RegSet, CmmNode O O)]         -- nodes of the block, annotated with
+walk :: DynFlags
+     -> [(RegSet, CmmNode O O)]         -- nodes of the block, annotated with
                                         -- the set of registers live *after*
                                         -- this node.
 
@@ -230,7 +232,7 @@ walk :: [(RegSet, CmmNode O O)]         -- nodes of the block, annotated with
         , [Assignment]                  -- Assignments to sink further
         )
 
-walk nodes assigs = go nodes emptyBlock assigs
+walk dflags nodes assigs = go nodes emptyBlock assigs
  where
    go []               block as = (block, as)
    go ((live,node):ns) block as
@@ -238,9 +240,9 @@ walk nodes assigs = go nodes emptyBlock assigs
     | Just a <- shouldSink node1 = go ns block (a : as1)
     | otherwise                  = go ns block' as'
     where
-      (node1, as1) = tryToInline live node as
+      (node1, as1) = tryToInline dflags live node as
 
-      (dropped, as') = dropAssignmentsSimple (`conflicts` node1) as1
+      (dropped, as') = dropAssignmentsSimple dflags (\a -> conflicts dflags a node1) as1
       block' = foldl blockSnoc block dropped `blockSnoc` node1
 
 --
@@ -276,13 +278,13 @@ shouldDiscard node live
 toNode :: Assignment -> CmmNode O O
 toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
 
-dropAssignmentsSimple :: (Assignment -> Bool) -> [Assignment]
+dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> [Assignment]
                       -> ([CmmNode O O], [Assignment])
-dropAssignmentsSimple f = dropAssignments (\a _ -> (f a, ())) ()
+dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()
 
-dropAssignments :: (Assignment -> s -> (Bool, s)) -> s -> [Assignment]
+dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> [Assignment]
                 -> ([CmmNode O O], [Assignment])
-dropAssignments should_drop state assigs
+dropAssignments dflags should_drop state assigs
  = (dropped, reverse kept)
  where
    (dropped,kept) = go state assigs [] []
@@ -293,14 +295,15 @@ dropAssignments should_drop state assigs
       | otherwise = go state' rest dropped (assig:kept)
       where
         (dropit, state') = should_drop assig state
-        conflict = dropit || any (assig `conflicts`) dropped
+        conflict = dropit || any (conflicts dflags assig) dropped
 
 
 -- -----------------------------------------------------------------------------
 -- Try to inline assignments into a node.
 
 tryToInline
-   :: RegSet                    -- set of registers live after this
+   :: DynFlags
+   -> RegSet                    -- set of registers live after this
                                 -- node.  We cannot inline anything
                                 -- that is live after the node, unless
                                 -- it is small enough to duplicate.
@@ -311,7 +314,7 @@ tryToInline
       , [Assignment]            -- Remaining assignments
       )
 
-tryToInline live node assigs = go usages node [] assigs
+tryToInline dflags live node assigs = go usages node [] assigs
  where
   usages :: UniqFM Int
   usages = foldRegsUsed addUsage emptyUFM node
@@ -331,7 +334,7 @@ tryToInline live node assigs = go usages node [] assigs
         can_inline =
             not (l `elemRegSet` live)
          && not (skipped `regsUsedIn` rhs)  -- Note [dependent assignments]
-         && okToInline rhs node
+         && okToInline dflags rhs node
          && lookupUFM usages l == Just 1
 
         usages' = foldRegsUsed addUsage usages rhs
@@ -385,9 +388,9 @@ regsUsedIn ls e = wrapRecExpf f e False
 -- ought to be able to handle it properly, but currently neither PprC
 -- nor the NCG can do it.  See Note [Register parameter passing]
 -- See also StgCmmForeign:load_args_into_temps.
-okToInline :: CmmExpr -> CmmNode e x -> Bool
-okToInline expr CmmUnsafeForeignCall{} = not (anyCallerSavesRegs expr)
-okToInline _ _ = True
+okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+okToInline dflags expr CmmUnsafeForeignCall{} = not (anyCallerSavesRegs dflags expr)
+okToInline _ _ _ = True
 
 -- -----------------------------------------------------------------------------
 
@@ -396,8 +399,8 @@ okToInline _ _ = True
 --
 -- We only sink "r = G" assignments right now, so conflicts is very simple:
 --
-conflicts :: Assignment -> CmmNode O x -> Bool
-(r, rhs, addr) `conflicts` node
+conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool
+conflicts dflags (r, rhs, addr) node
 
   -- (1) an assignment to a register conflicts with a use of the register
   | CmmAssign reg  _ <- node, reg `regUsedIn` rhs                 = True
@@ -413,7 +416,7 @@ conflicts :: Assignment -> CmmNode O x -> Bool
 
   -- (4) assignments that read caller-saves GlobalRegs conflict with a
   -- foreign call.  See Note [foreign calls clobber GlobalRegs].
-  | CmmUnsafeForeignCall{} <- node, anyCallerSavesRegs rhs        = True
+  | CmmUnsafeForeignCall{} <- node, anyCallerSavesRegs dflags rhs = True
 
   -- (5) foreign calls clobber memory, but not heap/stack memory
   | CmmUnsafeForeignCall{} <- node, AnyMem <- addr                = True
@@ -425,9 +428,10 @@ conflicts :: Assignment -> CmmNode O x -> Bool
   | otherwise = False
 
 
-anyCallerSavesRegs :: CmmExpr -> Bool
-anyCallerSavesRegs e = wrapRecExpf f e False
-  where f (CmmReg (CmmGlobal r)) _ | callerSaves r = True
+anyCallerSavesRegs :: DynFlags -> CmmExpr -> Bool
+anyCallerSavesRegs dflags e = wrapRecExpf f e False
+  where f (CmmReg (CmmGlobal r)) _
+         | callerSaves (targetPlatform dflags) r = True
         f _ z = z
 
 -- An abstraction of memory read or written.
diff --git a/compiler/codeGen/CallerSaves.hs b/compiler/codeGen/CallerSaves.hs
new file mode 100644
index 0000000000..babee9e36e
--- /dev/null
+++ b/compiler/codeGen/CallerSaves.hs
@@ -0,0 +1,51 @@
+
+module CallerSaves (callerSaves) where
+
+import CmmExpr
+import Platform
+
+-- | Returns 'True' if this global register is stored in a caller-saves
+-- machine register.
+
+callerSaves :: Platform -> GlobalReg -> Bool
+#define MACHREGS_NO_REGS 0
+callerSaves (Platform { platformArch = ArchX86 }) = platformCallerSaves
+  where
+#define MACHREGS_i386 1
+#include "../../includes/CallerSaves.part.hs"
+#undef MACHREGS_i386
+callerSaves (Platform { platformArch = ArchX86_64 }) = platformCallerSaves
+  where
+#define MACHREGS_x86_64 1
+#include "../../includes/CallerSaves.part.hs"
+#undef MACHREGS_x86_64
+callerSaves (Platform { platformArch = ppcArch, platformOS = OSDarwin })
+ | ppcArch `elem` [ArchPPC, ArchPPC_64] = platformCallerSaves
+  where
+#define MACHREGS_powerpc 1
+#define MACHREGS_darwin 1
+#include "../../includes/CallerSaves.part.hs"
+#undef MACHREGS_powerpc
+#undef MACHREGS_darwin
+callerSaves (Platform { platformArch = ppcArch })
+ | ppcArch `elem` [ArchPPC, ArchPPC_64] = platformCallerSaves
+  where
+#define MACHREGS_powerpc 1
+#include "../../includes/CallerSaves.part.hs"
+#undef MACHREGS_powerpc
+callerSaves (Platform { platformArch = ArchSPARC }) = platformCallerSaves
+  where
+#define MACHREGS_sparc 1
+#include "../../includes/CallerSaves.part.hs"
+#undef MACHREGS_sparc
+callerSaves (Platform { platformArch = ArchARM {} }) = platformCallerSaves
+  where
+#define MACHREGS_arm 1
+#include "../../includes/CallerSaves.part.hs"
+#undef MACHREGS_arm
+callerSaves _ = platformCallerSaves
+  where
+#undef MACHREGS_NO_REGS
+#define MACHREGS_NO_REGS 1
+#include "../../includes/CallerSaves.part.hs"
+
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index 4a83d86592..a37245ea01 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -125,21 +125,23 @@ emitForeignCall'
         -> Code
 emitForeignCall' safety results target args vols _srt ret
   | not (playSafe safety) = do
+    dflags <- getDynFlags
     temp_args <- load_args_into_temps args
-    let (caller_save, caller_load) = callerSaveVolatileRegs vols
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols
     let caller_load' = if ret == CmmNeverReturns then [] else caller_load
     stmtsC caller_save
     stmtC (CmmCall target results temp_args ret)
     stmtsC caller_load'
 
   | otherwise = do
+    dflags <- getDynFlags
     -- Both 'id' and 'new_base' are GCKindNonPtr because they're
     -- RTS only objects and are not subject to garbage collection
     id <- newTemp bWord
     new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
     temp_args <- load_args_into_temps args
     temp_target <- load_target_into_temp target
-    let (caller_save, caller_load) = callerSaveVolatileRegs vols
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols
     emitSaveThreadState
     stmtsC caller_save
     -- The CmmUnsafe arguments are only correct because this part
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index b7acc1c54c..d64aaa87e3 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -48,6 +48,7 @@ module CgUtils (
 #include "../includes/stg/HaskellMachRegs.h"
 
 import BlockId
+import CallerSaves
 import CgMonad
 import TyCon
 import DataCon
@@ -260,11 +261,12 @@ emitRtsCallGen
    -> Maybe [GlobalReg]
    -> Code
 emitRtsCallGen res pkg fun args vols = do
+  dflags <- getDynFlags
+  let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols
   stmtsC caller_save
   stmtC (CmmCall target res args CmmMayReturn)
   stmtsC caller_load
   where
-    (caller_save, caller_load) = callerSaveVolatileRegs vols
     target   = CmmCallee fun_expr CCallConv
     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 
@@ -281,9 +283,12 @@ emitRtsCallGen res pkg fun args vols = do
 --  * Regs.h claims that BaseReg should be saved last and loaded first
 --    * This might not have been tickled before since BaseReg is callee save
 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
-callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
-callerSaveVolatileRegs vols = (caller_save, caller_load)
+callerSaveVolatileRegs :: DynFlags -> Maybe [GlobalReg]
+                       -> ([CmmStmt], [CmmStmt])
+callerSaveVolatileRegs dflags vols = (caller_save, caller_load)
   where
+    platform = targetPlatform dflags
+
     caller_save = foldr ($!) [] (map callerSaveGlobalReg    regs_to_save)
     caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
 
@@ -301,102 +306,19 @@ callerSaveVolatileRegs vols = (caller_save, caller_load)
              ++ [ LongReg    n | n <- [0..mAX_Long_REG] ]
 
     callerSaveGlobalReg reg next
-        | callerSaves reg =
+        | callerSaves platform reg =
                 CmmStore (get_GlobalReg_addr reg)
                          (CmmReg (CmmGlobal reg)) : next
         | otherwise = next
 
     callerRestoreGlobalReg reg next
-        | callerSaves reg =
+        | callerSaves platform reg =
                 CmmAssign (CmmGlobal reg)
                           (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
                         : next
         | otherwise = next
 
 
--- | Returns @True@ if this global register is stored in a caller-saves
--- machine register.
-
-callerSaves :: GlobalReg -> Bool
-
-#ifdef CALLER_SAVES_Base
-callerSaves BaseReg             = True
-#endif
-#ifdef CALLER_SAVES_R1
-callerSaves (VanillaReg 1 _)    = True
-#endif
-#ifdef CALLER_SAVES_R2
-callerSaves (VanillaReg 2 _)    = True
-#endif
-#ifdef CALLER_SAVES_R3
-callerSaves (VanillaReg 3 _)    = True
-#endif
-#ifdef CALLER_SAVES_R4
-callerSaves (VanillaReg 4 _)    = True
-#endif
-#ifdef CALLER_SAVES_R5
-callerSaves (VanillaReg 5 _)    = True
-#endif
-#ifdef CALLER_SAVES_R6
-callerSaves (VanillaReg 6 _)    = True
-#endif
-#ifdef CALLER_SAVES_R7
-callerSaves (VanillaReg 7 _)    = True
-#endif
-#ifdef CALLER_SAVES_R8
-callerSaves (VanillaReg 8 _)    = True
-#endif
-#ifdef CALLER_SAVES_R9
-callerSaves (VanillaReg 9 _)    = True
-#endif
-#ifdef CALLER_SAVES_R10
-callerSaves (VanillaReg 10 _)   = True
-#endif
-#ifdef CALLER_SAVES_F1
-callerSaves (FloatReg 1)        = True
-#endif
-#ifdef CALLER_SAVES_F2
-callerSaves (FloatReg 2)        = True
-#endif
-#ifdef CALLER_SAVES_F3
-callerSaves (FloatReg 3)        = True
-#endif
-#ifdef CALLER_SAVES_F4
-callerSaves (FloatReg 4)        = True
-#endif
-#ifdef CALLER_SAVES_D1
-callerSaves (DoubleReg 1)       = True
-#endif
-#ifdef CALLER_SAVES_D2
-callerSaves (DoubleReg 2)       = True
-#endif
-#ifdef CALLER_SAVES_L1
-callerSaves (LongReg 1)         = True
-#endif
-#ifdef CALLER_SAVES_Sp
-callerSaves Sp                  = True
-#endif
-#ifdef CALLER_SAVES_SpLim
-callerSaves SpLim               = True
-#endif
-#ifdef CALLER_SAVES_Hp
-callerSaves Hp                  = True
-#endif
-#ifdef CALLER_SAVES_HpLim
-callerSaves HpLim               = True
-#endif
-#ifdef CALLER_SAVES_CCCS
-callerSaves CCCS                = True
-#endif
-#ifdef CALLER_SAVES_CurrentTSO
-callerSaves CurrentTSO          = True
-#endif
-#ifdef CALLER_SAVES_CurrentNursery
-callerSaves CurrentNursery      = True
-#endif
-callerSaves _                   = False
-
-
 -- -----------------------------------------------------------------------------
 -- Information about global registers
 
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 3976dee6f8..5a717bbc65 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -207,7 +207,8 @@ emitForeignCall
         -> FCode ReturnKind
 emitForeignCall safety results target args _ret
   | not (playSafe safety) = do
-    let (caller_save, caller_load) = callerSaveVolatileRegs
+    dflags <- getDynFlags
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
     emit caller_save
     emit $ mkUnsafeCall target results args
     emit caller_load
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index caecff923b..af2b0203ec 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -57,6 +57,7 @@ import StgCmmClosure
 import Cmm
 import BlockId
 import MkGraph
+import CallerSaves
 import CLabel
 import CmmUtils
 
@@ -200,7 +201,9 @@ emitRtsCallGen
    -> Bool -- True <=> CmmSafe call
    -> FCode ()
 emitRtsCallGen res pkg fun args _vols safe
-  = do { updfr_off <- getUpdFrameOff
+  = do { dflags <- getDynFlags
+       ; updfr_off <- getUpdFrameOff
+       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
        ; emit caller_save
        ; call updfr_off
        ; emit caller_load }
@@ -213,7 +216,6 @@ emitRtsCallGen res pkg fun args _vols safe
                          (ForeignConvention CCallConv arg_hints res_hints)) res' args'
     (args', arg_hints) = unzip args
     (res',  res_hints) = unzip res
-    (caller_save, caller_load) = callerSaveVolatileRegs
     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 
 
@@ -247,9 +249,11 @@ emitRtsCallGen res pkg fun args _vols safe
 -- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across
 -- unsafe foreign calls in rewriteAssignments, but this is strictly
 -- temporary.
-callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
-callerSaveVolatileRegs = (caller_save, caller_load)
+callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
+callerSaveVolatileRegs dflags = (caller_save, caller_load)
   where
+    platform = targetPlatform dflags
+
     caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)
     caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
 
@@ -257,7 +261,7 @@ callerSaveVolatileRegs = (caller_save, caller_load)
 		    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
 		  , BaseReg ]
 
-    regs_to_save = filter callerSaves system_regs
+    regs_to_save = filter (callerSaves platform) system_regs
 
     callerSaveGlobalReg reg
 	= mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg))
@@ -295,89 +299,6 @@ get_Regtable_addr_from_offset _rep offset =
 #endif
 
 
--- | Returns 'True' if this global register is stored in a caller-saves
--- machine register.
-
-callerSaves :: GlobalReg -> Bool
-
-#ifdef CALLER_SAVES_Base
-callerSaves BaseReg		= True
-#endif
-#ifdef CALLER_SAVES_R1
-callerSaves (VanillaReg 1 _)	= True
-#endif
-#ifdef CALLER_SAVES_R2
-callerSaves (VanillaReg 2 _)	= True
-#endif
-#ifdef CALLER_SAVES_R3
-callerSaves (VanillaReg 3 _)	= True
-#endif
-#ifdef CALLER_SAVES_R4
-callerSaves (VanillaReg 4 _)	= True
-#endif
-#ifdef CALLER_SAVES_R5
-callerSaves (VanillaReg 5 _)	= True
-#endif
-#ifdef CALLER_SAVES_R6
-callerSaves (VanillaReg 6 _)	= True
-#endif
-#ifdef CALLER_SAVES_R7
-callerSaves (VanillaReg 7 _)	= True
-#endif
-#ifdef CALLER_SAVES_R8
-callerSaves (VanillaReg 8 _)	= True
-#endif
-#ifdef CALLER_SAVES_R9
-callerSaves (VanillaReg 9 _)	= True
-#endif
-#ifdef CALLER_SAVES_R10
-callerSaves (VanillaReg 10 _)	= True
-#endif
-#ifdef CALLER_SAVES_F1
-callerSaves (FloatReg 1)	= True
-#endif
-#ifdef CALLER_SAVES_F2
-callerSaves (FloatReg 2)	= True
-#endif
-#ifdef CALLER_SAVES_F3
-callerSaves (FloatReg 3)	= True
-#endif
-#ifdef CALLER_SAVES_F4
-callerSaves (FloatReg 4)	= True
-#endif
-#ifdef CALLER_SAVES_D1
-callerSaves (DoubleReg 1)	= True
-#endif
-#ifdef CALLER_SAVES_D2
-callerSaves (DoubleReg 2)	= True
-#endif
-#ifdef CALLER_SAVES_L1
-callerSaves (LongReg 1)		= True
-#endif
-#ifdef CALLER_SAVES_Sp
-callerSaves Sp			= True
-#endif
-#ifdef CALLER_SAVES_SpLim
-callerSaves SpLim		= True
-#endif
-#ifdef CALLER_SAVES_Hp
-callerSaves Hp			= True
-#endif
-#ifdef CALLER_SAVES_HpLim
-callerSaves HpLim		= True
-#endif
-#ifdef CALLER_SAVES_CCCS
-callerSaves CCCS                = True
-#endif
-#ifdef CALLER_SAVES_CurrentTSO
-callerSaves CurrentTSO		= True
-#endif
-#ifdef CALLER_SAVES_CurrentNursery
-callerSaves CurrentNursery	= True
-#endif
-callerSaves _			= False
-
-
 -- -----------------------------------------------------------------------------
 -- Information about global registers
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index ec91e23e0c..9eaa0ef1de 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -200,6 +200,7 @@ Library
         PprCmmDecl
         PprCmmExpr
         Bitmap
+        CallerSaves
         CgBindery
         CgCallConv
         CgCase
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 0bd1bb70ce..25152a9c65 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -222,7 +222,7 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn
     let arguments = argVars' ++ (alignVal:isVolVal)
         call = Expr $ Call StdCall fptr arguments []
         stmts = stmts1 `appOL` stmts2 `appOL` stmts3
-                `appOL` trashStmts `snocOL` call
+                `appOL` trashStmts (getDflags env) `snocOL` call
     return (env2, stmts, top1 ++ top2)
   
   where
@@ -297,7 +297,7 @@ genCall env target res args ret = do
                 | ret == CmmNeverReturns = unitOL $ Unreachable
                 | otherwise              = nilOL
 
-    let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
+    let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env)
 
     -- make the actual call
     case retTy of
@@ -1276,13 +1276,13 @@ funEpilogue _ _ = do
 -- before the call by assigning the 'undef' value to them. The ones we
 -- need are restored from the Cmm local var and the ones we don't need
 -- are fine to be trashed.
-trashStmts :: LlvmStatements
-trashStmts = concatOL $ map trashReg activeStgRegs
+trashStmts :: DynFlags -> LlvmStatements
+trashStmts dflags = concatOL $ map trashReg activeStgRegs
     where trashReg r =
             let reg   = lmGlobalRegVar r
                 ty    = (pLower . getVarType) reg
                 trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
-            in case callerSaves r of
+            in case callerSaves (targetPlatform dflags) r of
                       True  -> trash
                       False -> nilOL
 
diff --git a/includes/CallerSaves.part.hs b/includes/CallerSaves.part.hs
new file mode 100644
index 0000000000..f045b647bf
--- /dev/null
+++ b/includes/CallerSaves.part.hs
@@ -0,0 +1,81 @@
+
+#include <stg/MachRegs.h>
+
+    platformCallerSaves :: GlobalReg -> Bool
+#ifdef CALLER_SAVES_Base
+    platformCallerSaves BaseReg     = True
+#endif
+#ifdef CALLER_SAVES_R1
+    platformCallerSaves (VanillaReg 1 _)    = True
+#endif
+#ifdef CALLER_SAVES_R2
+    platformCallerSaves (VanillaReg 2 _)    = True
+#endif
+#ifdef CALLER_SAVES_R3
+    platformCallerSaves (VanillaReg 3 _)    = True
+#endif
+#ifdef CALLER_SAVES_R4
+    platformCallerSaves (VanillaReg 4 _)    = True
+#endif
+#ifdef CALLER_SAVES_R5
+    platformCallerSaves (VanillaReg 5 _)    = True
+#endif
+#ifdef CALLER_SAVES_R6
+    platformCallerSaves (VanillaReg 6 _)    = True
+#endif
+#ifdef CALLER_SAVES_R7
+    platformCallerSaves (VanillaReg 7 _)    = True
+#endif
+#ifdef CALLER_SAVES_R8
+    platformCallerSaves (VanillaReg 8 _)    = True
+#endif
+#ifdef CALLER_SAVES_R9
+    platformCallerSaves (VanillaReg 9 _)    = True
+#endif
+#ifdef CALLER_SAVES_R10
+    platformCallerSaves (VanillaReg 10 _)   = True
+#endif
+#ifdef CALLER_SAVES_F1
+    platformCallerSaves (FloatReg 1)    = True
+#endif
+#ifdef CALLER_SAVES_F2
+    platformCallerSaves (FloatReg 2)    = True
+#endif
+#ifdef CALLER_SAVES_F3
+    platformCallerSaves (FloatReg 3)    = True
+#endif
+#ifdef CALLER_SAVES_F4
+    platformCallerSaves (FloatReg 4)    = True
+#endif
+#ifdef CALLER_SAVES_D1
+    platformCallerSaves (DoubleReg 1)   = True
+#endif
+#ifdef CALLER_SAVES_D2
+    platformCallerSaves (DoubleReg 2)   = True
+#endif
+#ifdef CALLER_SAVES_L1
+    platformCallerSaves (LongReg 1)     = True
+#endif
+#ifdef CALLER_SAVES_Sp
+    platformCallerSaves Sp          = True
+#endif
+#ifdef CALLER_SAVES_SpLim
+    platformCallerSaves SpLim       = True
+#endif
+#ifdef CALLER_SAVES_Hp
+    platformCallerSaves Hp          = True
+#endif
+#ifdef CALLER_SAVES_HpLim
+    platformCallerSaves HpLim       = True
+#endif
+#ifdef CALLER_SAVES_CCCS
+    platformCallerSaves CCCS                = True
+#endif
+#ifdef CALLER_SAVES_CurrentTSO
+    platformCallerSaves CurrentTSO      = True
+#endif
+#ifdef CALLER_SAVES_CurrentNursery
+    platformCallerSaves CurrentNursery  = True
+#endif
+    platformCallerSaves _           = False
+