Permalink
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...
1 parent f917eeb commit 46b5c197f9f2c8ed012251289400fbc7189b1acb @igfoo igfoo committed Aug 7, 2012
@@ -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 <*>
@@ -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 ----------------------------------------------
@@ -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,15 +309,16 @@ 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
-- 2. Add the assignment to our list of valid local assignments with
-- 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
@@ -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,17 +232,17 @@ 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
| shouldDiscard node live = go ns block as
| 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.
@@ -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"
+
@@ -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
Oops, something went wrong.

0 comments on commit 46b5c19

Please sign in to comment.