Commit 176ba0ff authored by Simon Marlow's avatar Simon Marlow

Lower safe foreign calls separately from stack layout

parent 65256948
...@@ -117,8 +117,10 @@ cmmLayoutStack procpoints entry_args ...@@ -117,8 +117,10 @@ cmmLayoutStack procpoints entry_args
layout procpoints liveness entry entry_args layout procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks rec_stackmaps rec_high_sp blocks
new_blocks' <- liftUniq $ mapM lowerSafeForeignCall new_blocks
pprTrace ("Sp HWM") (ppr final_high_sp) $ pprTrace ("Sp HWM") (ppr final_high_sp) $
return (ofBlockList entry new_blocks, final_stackmaps) return (ofBlockList entry new_blocks', final_stackmaps)
...@@ -177,15 +179,16 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks ...@@ -177,15 +179,16 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
-- a proc point, we must save the live variables, adjust Sp, and -- a proc point, we must save the live variables, adjust Sp, and
-- construct the StackMaps for each of the successor blocks. -- construct the StackMaps for each of the successor blocks.
-- See handleLastNode for details. -- See handleLastNode for details.
(middle2, sp_off, middle3, last1, fixup_blocks, out) (middle2, sp_off, last1, fixup_blocks, out)
<- handleLastNode procpoints liveness cont_info <- handleLastNode procpoints liveness cont_info
acc_stackmaps stack1 last0 acc_stackmaps stack1 last0
pprTrace "layout(out)" (ppr out) $ return ()
-- our block: -- our block:
-- middle1 -- the original middle nodes -- middle1 -- the original middle nodes
-- middle2 -- live variable saves from handleLastNode -- middle2 -- live variable saves from handleLastNode
-- Sp = Sp + sp_off -- Sp adjustment goes here -- Sp = Sp + sp_off -- Sp adjustment goes here
-- middle3 -- some more middle nodes from handleLastNode
-- last1 -- the last node -- last1 -- the last node
-- --
let middle_pre = blockToList $ foldl blockSnoc middle1 middle2 let middle_pre = blockToList $ foldl blockSnoc middle1 middle2
...@@ -198,15 +201,13 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks ...@@ -198,15 +201,13 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
-- check. -- check.
final_blocks = manifestSp final_stackmaps stack0 sp0 sp_high entry0 final_blocks = manifestSp final_stackmaps stack0 sp0 sp_high entry0
middle_pre sp_off middle3 last1 fixup_blocks middle_pre sp_off last1 fixup_blocks
stackmaps' = mapUnion acc_stackmaps out acc_stackmaps' = mapUnion acc_stackmaps out
hwm' = maximum (acc_hwm : (sp0 - sp_off) : map sm_sp (mapElems out)) hwm' = maximum (acc_hwm : (sp0 - sp_off) : map sm_sp (mapElems out))
pprTrace "layout(wibble)" (ppr out) $ return () go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
go bs stackmaps' hwm' (final_blocks ++ acc_blocks)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
...@@ -214,9 +215,8 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks ...@@ -214,9 +215,8 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp. The -- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp. The
-- block looks like this: -- block looks like this:
-- --
-- middle_pre -- some middle nodes -- middle_pre -- the middle nodes
-- Sp = Sp + sp_off -- Sp adjustment goes here -- Sp = Sp + sp_off -- Sp adjustment goes here
-- middle_post -- some more middle nodes, after the Sp adjustment
-- last -- the last node -- last -- the last node
-- --
-- And we have some extra blocks too (that don't contain Sp adjustments) -- And we have some extra blocks too (that don't contain Sp adjustments)
...@@ -230,16 +230,15 @@ manifestSp ...@@ -230,16 +230,15 @@ manifestSp
-> ByteOff -- Sp on entry to the block -> ByteOff -- Sp on entry to the block
-> ByteOff -- SpHigh -> ByteOff -- SpHigh
-> CmmNode C O -- first node -> CmmNode C O -- first node
-> [CmmNode O O] -- middle_pre -> [CmmNode O O] -- middle
-> ByteOff -- sp_off -> ByteOff -- sp_off
-> [CmmNode O O] -- middle_post
-> CmmNode O C -- last node -> CmmNode O C -- last node
-> [CmmBlock] -- new blocks -> [CmmBlock] -- new blocks
-> [CmmBlock] -- final blocks with Sp manifest -> [CmmBlock] -- final blocks with Sp manifest
manifestSp stackmaps stack0 sp0 sp_high manifestSp stackmaps stack0 sp0 sp_high
first middle_pre sp_off middle_post last fixup_blocks first middle_pre sp_off last fixup_blocks
= blockJoin first final_middle final_last : fixup_blocks' = final_block : fixup_blocks'
where where
area_off = getAreaOff stackmaps area_off = getAreaOff stackmaps
...@@ -247,16 +246,15 @@ manifestSp stackmaps stack0 sp0 sp_high ...@@ -247,16 +246,15 @@ manifestSp stackmaps stack0 sp0 sp_high
adj_pre_sp = mapExpDeep (areaToSp sp0 sp_high area_off) adj_pre_sp = mapExpDeep (areaToSp sp0 sp_high area_off)
adj_post_sp = mapExpDeep (areaToSp (sp0 - sp_off) sp_high area_off) adj_post_sp = mapExpDeep (areaToSp (sp0 - sp_off) sp_high area_off)
middle_pre' = maybeAddSpAdj sp_off $ final_middle = maybeAddSpAdj sp_off $
blockFromList $ blockFromList $
map adj_pre_sp $ map adj_pre_sp $
elimStackStores stack0 stackmaps area_off $ elimStackStores stack0 stackmaps area_off $
middle_pre middle_pre
middle_post' = map adj_post_sp middle_post final_last = optStackCheck (adj_post_sp last)
final_middle = foldl blockSnoc middle_pre' middle_post' final_block = blockJoin first final_middle final_last
final_last = optStackCheck (adj_post_sp last)
fixup_blocks' = map (blockMapNodes3 (id, adj_post_sp, id)) fixup_blocks fixup_blocks' = map (blockMapNodes3 (id, adj_post_sp, id)) fixup_blocks
...@@ -371,7 +369,6 @@ handleLastNode ...@@ -371,7 +369,6 @@ handleLastNode
-> UniqSM -> UniqSM
( [CmmNode O O] -- nodes to go *before* the Sp adjustment ( [CmmNode O O] -- nodes to go *before* the Sp adjustment
, ByteOff -- amount to adjust Sp , ByteOff -- amount to adjust Sp
, [CmmNode O O] -- nodes to go *after* the Sp adjustment
, CmmNode O C -- new last node , CmmNode O C -- new last node
, [CmmBlock] -- new blocks , [CmmBlock] -- new blocks
, BlockEnv StackMap -- stackmaps for the continuations , BlockEnv StackMap -- stackmaps for the continuations
...@@ -385,18 +382,15 @@ handleLastNode procpoints liveness cont_info stackmaps ...@@ -385,18 +382,15 @@ handleLastNode procpoints liveness cont_info stackmaps
-- is cml_args, after popping any other junk from the stack. -- is cml_args, after popping any other junk from the stack.
CmmCall{ cml_cont = Nothing, .. } -> do CmmCall{ cml_cont = Nothing, .. } -> do
let sp_off = sp0 - cml_args let sp_off = sp0 - cml_args
return ([], sp_off, [], last, [], mapEmpty) return ([], sp_off, last, [], mapEmpty)
-- At each CmmCall with a continuation: -- At each CmmCall with a continuation:
CmmCall{ cml_cont = Just cont_lbl, .. } -> CmmCall{ cml_cont = Just cont_lbl, .. } ->
lastCall cont_lbl [] cml_args cml_ret_args cml_ret_off lastCall cont_lbl [] cml_args cml_ret_args cml_ret_off
CmmForeignCall{ succ = cont_lbl, .. } -> do CmmForeignCall{ succ = cont_lbl, .. } -> do
(mids, spoff, _, last', blocks, stackmap') <- lastCall cont_lbl res wORD_SIZE wORD_SIZE (sm_ret_off stack0)
lastCall cont_lbl res wORD_SIZE wORD_SIZE (sm_ret_off stack0)
-- one word each for args and results: the return address -- one word each for args and results: the return address
(extra_mids, last'') <- lowerSafeForeignCall last'
return (mids, spoff, extra_mids, last'', blocks, stackmap')
CmmBranch{..} -> handleProcPoints CmmBranch{..} -> handleProcPoints
CmmCondBranch{..} -> handleProcPoints CmmCondBranch{..} -> handleProcPoints
...@@ -407,7 +401,6 @@ handleLastNode procpoints liveness cont_info stackmaps ...@@ -407,7 +401,6 @@ handleLastNode procpoints liveness cont_info stackmaps
-> UniqSM -> UniqSM
( [CmmNode O O] ( [CmmNode O O]
, ByteOff , ByteOff
, [CmmNode O O]
, CmmNode O C , CmmNode O C
, [CmmBlock] , [CmmBlock]
, BlockEnv StackMap , BlockEnv StackMap
...@@ -420,7 +413,6 @@ handleLastNode procpoints liveness cont_info stackmaps ...@@ -420,7 +413,6 @@ handleLastNode procpoints liveness cont_info stackmaps
= =
return ( fixupStack stack0 cont_stack return ( fixupStack stack0 cont_stack
, sp0 - sm_sp cont_stack , sp0 - sm_sp cont_stack
, []
, last , last
, [] , []
, stackmaps ) , stackmaps )
...@@ -463,7 +455,6 @@ handleLastNode procpoints liveness cont_info stackmaps ...@@ -463,7 +455,6 @@ handleLastNode procpoints liveness cont_info stackmaps
-- --
return ( assigs return ( assigs
, sp_off , sp_off
, []
, last , last
, [] -- no new blocks , [] -- no new blocks
, mapSingleton cont_lbl cont_stack ) , mapSingleton cont_lbl cont_stack )
...@@ -471,7 +462,6 @@ handleLastNode procpoints liveness cont_info stackmaps ...@@ -471,7 +462,6 @@ handleLastNode procpoints liveness cont_info stackmaps
handleProcPoints :: UniqSM ( [CmmNode O O] handleProcPoints :: UniqSM ( [CmmNode O O]
, ByteOff , ByteOff
, [CmmNode O O]
, CmmNode O C , CmmNode O C
, [CmmBlock] , [CmmBlock]
, BlockEnv StackMap ) , BlockEnv StackMap )
...@@ -488,7 +478,6 @@ handleLastNode procpoints liveness cont_info stackmaps ...@@ -488,7 +478,6 @@ handleLastNode procpoints liveness cont_info stackmaps
fix_lbl l = mapLookup l lbl_map `orElse` l fix_lbl l = mapLookup l lbl_map `orElse` l
return ( [] return ( []
, 0 , 0
, []
, mapSuccessors fix_lbl last , mapSuccessors fix_lbl last
, concat [ blk | (_,_,_,blk) <- pps ] , concat [ blk | (_,_,_,blk) <- pps ]
, mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] ) , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
...@@ -765,10 +754,10 @@ Note the copyOut, which saves the results in the places that L1 is ...@@ -765,10 +754,10 @@ Note the copyOut, which saves the results in the places that L1 is
expecting them (see Note {safe foreign call convention]). expecting them (see Note {safe foreign call convention]).
-} -}
lowerSafeForeignCall :: CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall :: CmmNode O C -> UniqSM ([CmmNode O O], CmmNode O C) lowerSafeForeignCall block
lowerSafeForeignCall CmmForeignCall { .. } = | (entry, middle, CmmForeignCall { .. }) <- blockSplit block
do let = do
-- Both 'id' and 'new_base' are KindNonPtr because they're -- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection -- RTS-only objects and are not subject to garbage collection
id <- newTemp bWord id <- newTemp bWord
...@@ -807,11 +796,12 @@ lowerSafeForeignCall CmmForeignCall { .. } = ...@@ -807,11 +796,12 @@ lowerSafeForeignCall CmmForeignCall { .. } =
mkLast jump mkLast jump
case toBlockList graph' of case toBlockList graph' of
[one] -> let (_, middle, last) = blockSplit one [one] -> let (_, middle', last) = blockSplit one
in return (blockToList middle, last) in return (blockJoin entry (middle `blockAppend` middle') last)
_ -> panic "lowerSafeForeignCall0" _ -> panic "lowerSafeForeignCall0"
lowerSafeForeignCall _ = panic "lowerSafeForeignCall1" -- Block doesn't end in a safe foreign call:
| otherwise = return block
foreignLbl :: FastString -> CmmExpr foreignLbl :: FastString -> CmmExpr
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment