Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

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.
  • Loading branch information...
commit 46b5c197f9f2c8ed012251289400fbc7189b1acb 1 parent f917eeb
@igfoo igfoo authored
View
2  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 <*>
View
2  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 ----------------------------------------------
View
29 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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View
66 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.
View
51 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"
+
View
6 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
View
98 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
View
3  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
View
97 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
View
1  compiler/ghc.cabal.in
@@ -200,6 +200,7 @@ Library
PprCmmDecl
PprCmmExpr
Bitmap
+ CallerSaves
CgBindery
CgCallConv
CgCase
View
10 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
View
81 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
+
Please sign in to comment.
Something went wrong with that request. Please try again.