module CmmLayoutStack (
cmmLayoutStack, setInfoTableStackMap
) where
import StgCmmUtils ( callerSaveVolatileRegs )
import StgCmmForeign ( saveThreadState, loadThreadState )
import BasicTypes
import Cmm
import CmmInfo
import BlockId
import CLabel
import CmmUtils
import MkGraph
import ForeignCall
import CmmLive
import CmmProcPoint
import SMRep
import Hoopl
import UniqSupply
import Maybes
import UniqFM
import Util
import DynFlags
import FastString
import Outputable hiding ( isEmpty )
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
import Data.Bits
import Data.List (nub)
import Control.Monad (liftM)
#if __GLASGOW_HASKELL__ >= 709
import Prelude hiding ((<*>))
#endif
#include "HsVersions.h"
type StackLoc = ByteOff
data StackMap = StackMap
{ sm_sp :: StackLoc
, sm_args :: ByteOff
, sm_ret_off :: ByteOff
, sm_regs :: UniqFM (LocalReg,StackLoc)
}
instance Outputable StackMap where
ppr StackMap{..} =
text "Sp = " <> int sm_sp $$
text "sm_args = " <> int sm_args $$
text "sm_ret_off = " <> int sm_ret_off $$
text "sm_regs = " <> ppr (eltsUFM sm_regs)
cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
-> UniqSM (CmmGraph, BlockEnv StackMap)
cmmLayoutStack dflags procpoints entry_args
graph0@(CmmGraph { g_entry = entry })
= do
let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0)
blocks = postorderDfs graph
(final_stackmaps, _final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
layout dflags procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks
new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks
return (ofBlockList entry new_blocks', final_stackmaps)
layout :: DynFlags
-> BlockSet
-> BlockEnv CmmLocalLive
-> BlockId
-> ByteOff
-> BlockEnv StackMap
-> ByteOff
-> [CmmBlock]
-> UniqSM
( BlockEnv StackMap
, ByteOff
, [CmmBlock]
)
layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks
= go blocks init_stackmap entry_args []
where
(updfr, cont_info) = collectContInfo blocks
init_stackmap = mapSingleton entry StackMap{ sm_sp = entry_args
, sm_args = entry_args
, sm_ret_off = updfr
, sm_regs = emptyUFM
}
go [] acc_stackmaps acc_hwm acc_blocks
= return (acc_stackmaps, acc_hwm, acc_blocks)
go (b0 : bs) acc_stackmaps acc_hwm acc_blocks
= do
let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0
let stack0@StackMap { sm_sp = sp0 }
= mapFindWithDefault
(pprPanic "no stack map for" (ppr entry_lbl))
entry_lbl acc_stackmaps
let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0
let middle1 = if entry_lbl `setMember` procpoints
then foldr blockCons middle0 (insertReloads stack0)
else middle0
(middle2, sp_off, last1, fixup_blocks, out)
<- handleLastNode dflags procpoints liveness cont_info
acc_stackmaps stack1 tscope middle0 last0
let middle_pre = blockToList $ foldl blockSnoc middle1 middle2
final_blocks = manifestSp dflags final_stackmaps stack0 sp0 final_sp_high entry0
middle_pre sp_off last1 fixup_blocks
acc_stackmaps' = mapUnion acc_stackmaps out
this_sp_hwm | isGcJump last0 = 0
| otherwise = sp0 sp_off
hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))
go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
isGcJump :: CmmNode O C -> Bool
isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })
= l == GCFun || l == GCEnter1
isGcJump _something_else = False
collectContInfo :: [CmmBlock] -> (ByteOff, BlockEnv ByteOff)
collectContInfo blocks
= (maximum ret_offs, mapFromList (catMaybes mb_argss))
where
(mb_argss, ret_offs) = mapAndUnzip get_cont blocks
get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
get_cont b =
case lastNode b of
CmmCall { cml_cont = Just l, .. }
-> (Just (l, cml_ret_args), cml_ret_off)
CmmForeignCall { .. }
-> (Just (succ, ret_args), ret_off)
_other -> (Nothing, 0)
procMiddle :: BlockEnv StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle stackmaps node sm
= case node of
CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
-> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }
where loc = getStackLoc area off stackmaps
CmmAssign (CmmLocal r) _other
-> sm { sm_regs = delFromUFM (sm_regs sm) r }
_other
-> sm
getStackLoc :: Area -> ByteOff -> BlockEnv StackMap -> StackLoc
getStackLoc Old n _ = n
getStackLoc (Young l) n stackmaps =
case mapLookup l stackmaps of
Nothing -> pprPanic "getStackLoc" (ppr l)
Just sm -> sm_sp sm sm_args sm + n
handleLastNode
:: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
-> BlockEnv StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, BlockEnv StackMap
)
handleLastNode dflags procpoints liveness cont_info stackmaps
stack0@StackMap { sm_sp = sp0 } tscp middle last
= case last of
CmmCall{ cml_cont = Nothing, .. } -> do
let sp_off = sp0 cml_args
return ([], sp_off, last, [], mapEmpty)
CmmCall{ cml_cont = Just cont_lbl, .. } ->
return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
CmmForeignCall{ succ = cont_lbl, .. } -> do
return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
CmmBranch {} -> handleBranches
CmmCondBranch {} -> handleBranches
CmmSwitch {} -> handleBranches
where
lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
-> ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, BlockEnv StackMap
)
lastCall lbl cml_args cml_ret_args cml_ret_off
= ( assignments
, spOffsetForCall sp0 cont_stack cml_args
, last
, []
, mapSingleton lbl cont_stack )
where
(assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off
prepareStack lbl cml_ret_args cml_ret_off
| Just cont_stack <- mapLookup lbl stackmaps
= (fixupStack stack0 cont_stack, cont_stack)
| otherwise
= (save_assignments, new_cont_stack)
where
(new_cont_stack, save_assignments)
= setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
handleBranches :: UniqSM ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, BlockEnv StackMap )
handleBranches
| Just l <- futureContinuation middle
, (nub $ filter (`setMember` procpoints) $ successors last) == [l]
= do
let cont_args = mapFindWithDefault 0 l cont_info
(assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)
out = mapFromList [ (l', cont_stack)
| l' <- successors last ]
return ( assigs
, spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
, last
, []
, out)
| otherwise = do
pps <- mapM handleBranch (successors last)
let lbl_map :: LabelMap Label
lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
fix_lbl l = mapFindWithDefault l l lbl_map
return ( []
, 0
, mapSuccessors fix_lbl last
, concat [ blk | (_,_,_,blk) <- pps ]
, mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch l
| Just stack2 <- mapLookup l stackmaps
= do
let assigs = fixupStack stack0 stack2
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
return (l, tmp_lbl, stack2, block)
| l `setMember` procpoints
= do
let cont_args = mapFindWithDefault 0 l cont_info
(stack2, assigs) =
setupStackFrame dflags l liveness (sm_ret_off stack0)
cont_args stack0
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
return (l, tmp_lbl, stack2, block)
| otherwise = return (l, l, stack1, [])
where live = mapFindWithDefault (panic "handleBranch") l liveness
stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }
is_live (r,_) = r `elemRegSet` live
makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
-> CmmTickScope -> [CmmNode O O]
-> UniqSM (Label, [CmmBlock])
makeFixupBlock dflags sp0 l stack tscope assigs
| null assigs && sp0 == sm_sp stack = return (l, [])
| otherwise = do
tmp_lbl <- liftM mkBlockId $ getUniqueM
let sp_off = sp0 sm_sp stack
block = blockJoin (CmmEntry tmp_lbl tscope)
(maybeAddSpAdj dflags sp_off (blockFromList assigs))
(CmmBranch l)
return (tmp_lbl, [block])
spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
spOffsetForCall current_sp cont_stack args
= current_sp (sm_sp cont_stack sm_args cont_stack + args)
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack old_stack new_stack = concatMap move new_locs
where
old_map = sm_regs old_stack
new_locs = stackSlotRegs new_stack
move (r,n)
| Just (_,m) <- lookupUFM old_map r, n == m = []
| otherwise = [CmmStore (CmmStackSlot Old n)
(CmmReg (CmmLocal r))]
setupStackFrame
:: DynFlags
-> BlockId
-> BlockEnv CmmLocalLive
-> ByteOff
-> ByteOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame dflags lbl liveness updfr_off ret_args stack0
= (cont_stack, assignments)
where
live = mapFindWithDefault Set.empty lbl liveness
(stack1, assignments) = allocate dflags updfr_off live stack0
cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args
, sm_args = ret_args
, sm_ret_off = updfr_off
}
futureContinuation :: Block CmmNode O O -> Maybe BlockId
futureContinuation middle = foldBlockNodesB f middle Nothing
where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _
= Just l
f _ r = r
allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
-> (StackMap, [CmmNode O O])
allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
, sm_regs = regs0 }
=
let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)
regs1 = filterUFM (\(r,_) -> elemRegSet r live) regs0
in
let stack = reverse $ Array.elems $
accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
ret_words ++ live_words
where ret_words =
[ (x, Occupied)
| x <- [ 1 .. toWords dflags ret_off] ]
live_words =
[ (toWords dflags x, Occupied)
| (r,off) <- eltsUFM regs1,
let w = localRegBytes dflags r,
x <- [ off, off wORD_SIZE dflags .. off w + 1] ]
in
let
save slot ([], stack, n, assigs, regs)
= ([], slot:stack, plusW dflags n 1, assigs, regs)
save slot (to_save, stack, n, assigs, regs)
= case slot of
Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
Empty
| Just (stack', r, to_save') <-
select_save to_save (slot:stack)
-> let assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
n' = plusW dflags n 1
in
(to_save', stack', n', assig : assigs, (r,(r,n')):regs)
| otherwise
-> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
select_save :: [LocalReg] -> [StackSlot]
-> Maybe ([StackSlot], LocalReg, [LocalReg])
select_save regs stack = go regs []
where go [] _no_fit = Nothing
go (r:rs) no_fit
| Just rest <- dropEmpty words stack
= Just (replicate words Occupied ++ rest, r, rs++no_fit)
| otherwise
= go rs (r:no_fit)
where words = localRegWords dflags r
(still_to_save, save_stack, n, save_assigs, save_regs)
= foldr save (to_save, [], 0, [], []) stack
(push_sp, push_assigs, push_regs)
= foldr push (n, [], []) still_to_save
where
push r (n, assigs, regs)
= (n', assig : assigs, (r,(r,n')) : regs)
where
n' = n + localRegBytes dflags r
assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
trim_sp
| not (null push_regs) = push_sp
| otherwise
= plusW dflags n ( length (takeWhile isEmpty save_stack))
final_regs = regs1 `addListToUFM` push_regs
`addListToUFM` save_regs
in
if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
if (trim_sp .&. (wORD_SIZE dflags 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
, push_assigs ++ save_assigs )
manifestSp
:: DynFlags
-> BlockEnv StackMap
-> StackMap
-> ByteOff
-> ByteOff
-> CmmNode C O
-> [CmmNode O O]
-> ByteOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp dflags stackmaps stack0 sp0 sp_high
first middle_pre sp_off last fixup_blocks
= final_block : fixup_blocks'
where
area_off = getAreaOff stackmaps
adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off)
adj_post_sp = mapExpDeep (areaToSp dflags (sp0 sp_off) sp_high area_off)
add_unwind_info block
| debugLevel dflags > 0 = CmmUnwind Sp sp_unwind : block
| otherwise = block
sp_unwind = CmmRegOff (CmmGlobal Sp) (sp0 wORD_SIZE dflags)
final_middle = maybeAddSpAdj dflags sp_off $
blockFromList $
add_unwind_info $
map adj_pre_sp $
elimStackStores stack0 stackmaps area_off $
middle_pre
final_last = optStackCheck (adj_post_sp last)
final_block = blockJoin first final_middle final_last
fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc)
getAreaOff _ Old = 0
getAreaOff stackmaps (Young l) =
case mapLookup l stackmaps of
Just sm -> sm_sp sm sm_args sm
Nothing -> pprPanic "getAreaOff" (ppr l)
maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj _ 0 block = block
maybeAddSpAdj dflags sp_off block
= block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
= cmmOffset dflags (CmmReg spReg) (sp_old area_off area n)
areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
= mkIntExpr dflags sp_hwm
areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)
| falseStackCheck args
= zeroExpr dflags
areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)
| falseStackCheck args
= mkIntExpr dflags 1
areaToSp _ _ _ _ other = other
falseStackCheck :: [CmmExpr] -> Bool
falseStackCheck [ CmmMachOp (MO_Sub _)
[ CmmRegOff (CmmGlobal Sp) x_off
, CmmLit (CmmInt y_lit _)]
, CmmReg (CmmGlobal SpLim)]
= fromIntegral x_off >= y_lit
falseStackCheck _ = False
optStackCheck :: CmmNode O C -> CmmNode O C
optStackCheck n =
case n of
CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false
CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true
other -> other
elimStackStores :: StackMap
-> BlockEnv StackMap
-> (Area -> ByteOff)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores stackmap stackmaps area_off nodes
= go stackmap nodes
where
go _stackmap [] = []
go stackmap (n:ns)
= case n of
CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
| Just (_,off) <- lookupUFM (sm_regs stackmap) r
, area_off area + m == off
-> go stackmap ns
_otherwise
-> n : go (procMiddle stackmaps n stackmap) ns
setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness lbl) }
fix_info _ other = other
get_liveness :: BlockId -> Liveness
get_liveness lbl
= case mapLookup lbl stackmaps of
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
Just sm -> stackMapToLiveness dflags sm
setInfoTableStackMap _ _ d = d
stackMapToLiveness :: DynFlags -> StackMap -> Liveness
stackMapToLiveness dflags StackMap{..} =
reverse $ Array.elems $
accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
toWords dflags (sm_sp sm_args)) live_words
where
live_words = [ (toWords dflags off, False)
| (r,off) <- eltsUFM sm_regs, isGcPtrType (localRegType r) ]
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall dflags block
| (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
= do
id <- newTemp (bWord dflags)
new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
let (caller_save, caller_load) = callerSaveVolatileRegs dflags
load_stack <- newTemp (gcWord dflags)
tso <- newTemp (gcWord dflags)
cn <- newTemp (bWord dflags)
bdfree <- newTemp (bWord dflags)
bdstart <- newTemp (bWord dflags)
let suspend = saveThreadState dflags tso cn <*>
caller_save <*>
mkMiddle (callSuspendThread dflags id intrbl)
midCall = mkUnsafeCall tgt res args
resume = mkMiddle (callResumeThread new_base id) <*>
mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
caller_load <*>
loadThreadState dflags tso load_stack cn bdfree bdstart
(_, regs, copyout) =
copyOutOflow dflags NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res)
ret_off []
jump = CmmCall { cml_target = entryCode dflags $
CmmLoad (CmmReg spReg) (bWord dflags)
, cml_cont = Just succ
, cml_args_regs = regs
, cml_args = widthInBytes (wordWidth dflags)
, cml_ret_args = ret_args
, cml_ret_off = ret_off }
graph' <- lgraphOfAGraph ( suspend <*>
midCall <*>
resume <*>
copyout <*>
mkLast jump, tscp)
case toBlockList graph' of
[one] -> let (_, middle', last) = blockSplit one
in return (blockJoin entry (middle `blockAppend` middle') last)
_ -> panic "lowerSafeForeignCall0"
| otherwise = return block
foreignLbl :: FastString -> CmmExpr
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
newTemp :: CmmType -> UniqSM LocalReg
newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread dflags id intrbl =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread"))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
[id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "resumeThread"))
(ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))
[new_base] [CmmReg (CmmLocal id)]
plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
plusW dflags b w = b + w * wORD_SIZE dflags
data StackSlot = Occupied | Empty
instance Outputable StackSlot where
ppr Occupied = text "XXX"
ppr Empty = text "---"
dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty 0 ss = Just ss
dropEmpty n (Empty : ss) = dropEmpty (n1) ss
dropEmpty _ _ = Nothing
isEmpty :: StackSlot -> Bool
isEmpty Empty = True
isEmpty _ = False
localRegBytes :: DynFlags -> LocalReg -> ByteOff
localRegBytes dflags r
= roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
localRegWords :: DynFlags -> LocalReg -> WordOff
localRegWords dflags = toWords dflags . localRegBytes dflags
toWords :: DynFlags -> ByteOff -> WordOff
toWords dflags x = x `quot` wORD_SIZE dflags
insertReloads :: StackMap -> [CmmNode O O]
insertReloads stackmap =
[ CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot Old sp)
(localRegType r))
| (r,sp) <- stackSlotRegs stackmap
]
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs sm = eltsUFM (sm_regs sm)