module CmmBuildInfoTables
( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
, setInfoTableSRT, setInfoTableStackMap
, TopSRT, emptySRT, srtToData
, bundleCAFs
, finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls )
where
#include "HsVersions.h"
import Constants
import Digraph
import qualified Prelude as P
import Prelude
import Util (sortLe)
import BlockId
import Bitmap
import CLabel
import Cmm hiding (blockId)
import CmmInfo
import CmmProcPointZ
import CmmStackLayout
import CmmTx
import DFMonad
import FastString
import FiniteMap
import ForeignCall
import IdInfo
import Data.List
import Maybes
import MkZipCfg
import MkZipCfgCmm hiding (CmmAGraph, CmmBlock, CmmTopZ, CmmZ, CmmGraph)
import Control.Monad
import Name
import Outputable
import SMRep
import StgCmmClosure
import StgCmmForeign
import StgCmmUtils
import UniqSupply
import ZipCfg hiding (zip, unzip, last)
import qualified ZipCfg as G
import ZipCfgCmmRep
import ZipDataflow
live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg]
live_ptrs oldByte slotEnv areaMap bid =
reverse $ slotsToList youngByte liveSlots []
where slotsToList n [] results | n == oldByte = results
slotsToList n (s : _) _ | n == oldByte =
pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+>
ppr n <+> ppr liveSlots <+> ppr youngByte)
slotsToList n _ _ | n < oldByte =
panic "stack slots not allocated on word boundaries?"
slotsToList n l@((n', r, w) : rst) results =
if n == (n' + w) then
ASSERT (not (isPtr r) ||
(n `mod` wORD_SIZE == 0 && w == wORD_SIZE))
slotsToList next (dropWhile (non_ptr_younger_than next) rst)
(stack_rep : results)
else slotsToList next (dropWhile (non_ptr_younger_than next) l)
(Nothing : results)
where next = n wORD_SIZE
stack_rep = if isPtr r then Just r else Nothing
slotsToList n [] results = slotsToList (n wORD_SIZE) [] (Nothing : results)
non_ptr_younger_than next (n', r, w) =
n' + w > next &&
ASSERT (not (isPtr r))
True
isPtr = isGcPtrType . localRegType
liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
(foldFM (\_ -> flip $ foldl add_slot) [] slots)
add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) =
if off == w && widthInBytes (typeWidth ty) == w then
(expectJust "add_slot" (lookupFM areaMap a), r, w) : rst
else panic "live_ptrs: only part of a variable live at a proc point"
add_slot rst (CallArea Old, _, _) =
rst
add_slot rst ((CallArea _), _, _) =
rst
slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
youngByte = expectJust "live_ptrs bid_pos" $ lookupFM areaMap (CallArea (Young bid))
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables
setInfoTableStackMap _ _ t@(NoInfoTable _) = t
setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) =
updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
setInfoTableStackMap slotEnv areaMap
t@(ProcInfoTable (CmmProc (CmmInfo _ _ _) _ _ ((_, Just updfr_off), _)) procpoints) =
case blockSetToList procpoints of
[bid] -> updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
_ -> panic "setInfoTableStackMap: unexpected number of procpoints"
setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" (ppr t)
type CAFSet = FiniteMap CLabel ()
type CAFEnv = BlockEnv CAFSet
cafLattice :: DataflowLattice CAFSet
cafLattice = DataflowLattice "live cafs" emptyFM add False
where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new'
where new' = new `plusFM` old
cafTransfers :: BackwardTransfers Middle Last CAFSet
cafTransfers = BackwardTransfers first middle last
where first _ live = live
middle m live = foldExpDeepMiddle addCaf m live
last l env = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
addCaf e set = case e of
CmmLit (CmmLabel c) -> add c set
CmmLit (CmmLabelOff c _) -> add c set
CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
_ -> set
add l s = if hasCAF l then addToFM s (cvtToClosureLbl l) () else s
type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv
cafAnal g = liftM zdfFpFacts (res :: CafFix ())
where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice
cafTransfers (fact_bot cafLattice) g
data TopSRT = TopSRT { lbl :: CLabel
, next_elt :: Int
, rev_elts :: [CLabel]
, elt_map :: FiniteMap CLabel Int }
instance Outputable TopSRT where
ppr (TopSRT lbl next elts eltmap) =
text "TopSRT:" <+> ppr lbl <+> ppr next <+> ppr elts <+> ppr eltmap
emptySRT :: MonadUnique m => m TopSRT
emptySRT =
do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = emptyFM }
cafMember :: TopSRT -> CLabel -> Bool
cafMember srt lbl = elemFM lbl (elt_map srt)
cafOffset :: TopSRT -> CLabel -> Maybe Int
cafOffset srt lbl = lookupFM (elt_map srt) lbl
addCAF :: CLabel -> TopSRT -> TopSRT
addCAF caf srt =
srt { next_elt = last + 1
, rev_elts = caf : rev_elts srt
, elt_map = addToFM (elt_map srt) caf last }
where last = next_elt srt
srtToData :: TopSRT -> CmmZ
srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)]
where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
buildSRTs :: TopSRT -> FiniteMap CLabel CAFSet -> CAFSet ->
FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
buildSRTs topSRT topCAFMap cafs =
do let liftCAF lbl () z =
case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
Nothing -> addToFM z lbl ()
sub_srt topSRT localCafs =
let cafs = keysFM (foldFM liftCAF emptyFM localCafs)
mkSRT topSRT =
do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
return (topSRT, localSRTs)
in if length cafs > maxBmpSize then
mkSRT (foldl add_if_missing topSRT cafs)
else
mkSRT (add_if_too_far topSRT cafs)
add_if_missing srt caf =
if cafMember srt caf then srt else addCAF caf srt
add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
add srt (sortBy farthestFst cafs)
where
farthestFst x y = case (lookupFM m x, lookupFM m y) of
(Nothing, Nothing) -> EQ
(Nothing, Just _) -> LT
(Just _, Nothing) -> GT
(Just d, Just d') -> compare d' d
add srt [] = srt
add srt@(TopSRT {next_elt = next}) (caf : rst) =
case cafOffset srt caf of
Just ix -> if next ix > maxBmpSize then
add (addCAF caf srt) rst
else srt
Nothing -> add (addCAF caf srt) rst
(topSRT, subSRTs) <- sub_srt topSRT cafs
let (sub_tbls, blockSRTs) = subSRTs
return (topSRT, sub_tbls, blockSRTs)
procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] ->
FuelMonad (Maybe CmmTopZ, C_SRT)
procpointSRT _ _ [] =
return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries =
do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
return (top, srt)
where
ints = map (expectJust "constructSRT" . lookupFM top_table) entries
sorted_ints = sortLe (<=) ints
offset = head sorted_ints
bitmap_entries = map (subtract offset) sorted_ints
len = P.last bitmap_entries + 1
bitmap = intsToBitmap len bitmap_entries
maxBmpSize :: Int
maxBmpSize = widthInBits wordWidth `div` 2
to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT)
to_SRT top_srt off len bmp
| len > maxBmpSize || bmp == [fromIntegral srt_escape]
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
CmmDataLabel srt_desc_lbl : map CmmStaticLit
( cmmLabelOffW top_srt off
: mkWordCLit (fromIntegral len)
: map mkWordCLit bmp)
return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
| otherwise
= return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing
localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) =
case infoTbl of
CmmInfoTable False _ _ _ ->
Just (cvtToClosureLbl top_l,
expectJust "maybeBindCAFs" $ lookupBlockEnv cafEnv entry)
_ -> Nothing
mkTopCAFInfo :: [(CLabel, CAFSet)] -> FiniteMap CLabel CAFSet
mkTopCAFInfo localCAFs = foldl addToTop emptyFM g
where addToTop env (AcyclicSCC (l, cafset)) =
addToFM env l (flatten env cafset)
addToTop env (CyclicSCC nodes) =
let (lbls, cafsets) = unzip nodes
cafset = foldl plusFM emptyFM cafsets `delListFromFM` lbls
in foldl (\env l -> addToFM env l (flatten env cafset)) env lbls
flatten env cafset = foldFM (lookup env) emptyFM cafset
lookup env caf () cafset' =
case lookupFM env caf of Just cafs -> foldFM add cafset' cafs
Nothing -> add caf () cafset'
add caf () cafset' = addToFM cafset' caf ()
g = stronglyConnCompFromEdgedVertices
(map (\n@(l, cafs) -> (n, l, keysFM cafs)) localCAFs)
type StackLayout = [Maybe LocalReg]
bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables)
bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
case blockSetToList procpoints of
[bid] -> (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
_ -> panic "setInfoTableStackMap: unexpect number of procpoints"
bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
(expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
bundleCAFs _ t@(NoInfoTable _) = (emptyFM, t)
setInfoTableSRT :: FiniteMap CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) ->
FuelMonad (TopSRT, [CmmTopForInfoTables])
setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) =
case blockSetToList procpoints of
[_] -> setSRT cafs topCAFMap topSRT t
_ -> panic "setInfoTableStackMap: unexpect number of procpoints"
setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) =
setSRT cafs topCAFMap topSRT t
setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])
setSRT :: CAFSet -> FiniteMap CLabel CAFSet -> TopSRT ->
CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
setSRT cafs topCAFMap topSRT t =
do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
let t' = updInfo id (const srt) t
case cafTable of
Just tbl -> return (topSRT, [t', NoInfoTable tbl])
Nothing -> return (topSRT, [t'])
updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) ->
CmmTopForInfoTables -> CmmTopForInfoTables
updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints) =
ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints
updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) =
FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off
updInfo _ _ (NoInfoTable _) = panic "can't update NoInfoTable"
updInfo _ _ _ = panic "unexpected arg to updInfo"
updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo
updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo))
= CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo')
where typeinfo' = case typeinfo of
t@(ConstrInfo _ _ _) -> t
(FunInfo c s a d e) -> FunInfo c (toSrt s) a d e
(ThunkInfo c s) -> ThunkInfo c (toSrt s)
(ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
(ContInfo v s) -> ContInfo (toVars v) (toSrt s)
updInfoTbl _ _ t@(CmmInfo _ _ CmmNonInfoTable) = t
finishInfoTables :: CmmTopForInfoTables -> IO [CmmTopZ]
finishInfoTables (NoInfoTable t) = return [t]
finishInfoTables (ProcInfoTable p _) = return [p]
finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
do uniq_supply <- mkSplitUniqSupply 'i'
return $ mkBareInfoTable (retPtLbl bid) (uniqFromSupply uniq_supply) infotbl
extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
extendEnvsForSafeForeignCalls cafEnv slotEnv g =
fold_blocks block (cafEnv, slotEnv) g
where block b z =
tail ( bt_last_in cafTransfers l (lookupFn cafEnv)
, bt_last_in liveSlotTransfers l (lookupFn slotEnv))
z head
where (head, last) = goto_end (G.unzip b)
l = case last of LastOther l -> l
LastExit -> panic "extendEnvs lastExit"
tail _ z (ZFirst _) = z
tail lives@(cafs, slots) (cafEnv, slotEnv)
(ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
let slots' = removeLiveSlotDefs slots m
slotEnv' = extendBlockEnv slotEnv bid slots'
cafEnv' = extendBlockEnv cafEnv bid cafs
in tail (upd lives m) (cafEnv', slotEnv') h
tail lives z (ZHead h m) = tail (upd lives m) z h
lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k
upd (cafs, slots) m =
(bt_middle_in cafTransfers m cafs, bt_middle_in liveSlotTransfers m slots)
data CmmTopForInfoTables
= NoInfoTable CmmTopZ
| ProcInfoTable CmmTopZ BlockSet
| FloatingInfoTable CmmInfo BlockId UpdFrameOffset
instance Outputable CmmTopForInfoTables where
ppr (NoInfoTable t) = text "NoInfoTable: " <+> ppr t
ppr (ProcInfoTable t bids) = text "ProcInfoTable: " <+> ppr t <+> ppr bids
ppr (FloatingInfoTable info bid upd) =
text "FloatingInfoTable: " <+> ppr info <+> ppr bid <+> ppr upd
data SafeState = State { s_blocks :: BlockEnv CmmBlock
, s_pps :: ProcPointSet
, s_safeCalls :: [CmmTopForInfoTables]}
lowerSafeForeignCalls
:: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do
let init = return $ State emptyBlockEnv emptyBlockSet []
let block b@(Block bid _) z = do
state@(State {s_pps = ppset, s_blocks = blocks}) <- z
let ppset' = if bid == entry then extendBlockSet ppset bid else ppset
state' = state { s_pps = ppset' }
if hasSafeForeignCall b
then lowerSafeCallBlock state' b
else return (state' { s_blocks = insertBlock b blocks })
State blocks' g_procpoints safeCalls <- fold_blocks block init g
let proc = (CmmProc info l args (off, LGraph entry blocks'))
procTable = case off of
(_, Just _) -> [ProcInfoTable proc g_procpoints]
_ -> [NoInfoTable proc]
return $ safeCalls : procTable : rst
hasSafeForeignCall :: CmmBlock -> Bool
hasSafeForeignCall (Block _ t) = tail t
where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True
tail (ZTail _ t) = tail t
tail (ZLast _) = False
lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState
lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
where (head, last) = goto_end (G.unzip b)
tail s b@(ZBlock (ZFirst _) _) =
do state <- s
return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) =
do state <- s
let state' = state
{ s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
s_safeCalls state }
(state'', t') <- lowerSafeForeignCall state' m t
tail (return state'') (ZBlock h t')
tail s (ZBlock (ZHead h m) t) = tail s (ZBlock h (ZTail m t))
lowerSafeForeignCall ::
SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
id <- newTemp bWord
new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
let (caller_save, caller_load) = callerSaveVolatileRegs
load_tso <- newTemp gcWord
let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
saveThreadState <*>
caller_save <*>
mkUnsafeCall (ForeignTarget suspendThread
(ForeignConvention CCallConv [AddrHint] [AddrHint]))
[id] [CmmReg (CmmGlobal BaseReg)]
resume = mkUnsafeCall (ForeignTarget resumeThread
(ForeignConvention CCallConv [AddrHint] [AddrHint]))
[new_base] [CmmReg (CmmLocal id)] <*>
mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
caller_load <*>
loadThreadState load_tso
Graph tail' blocks' <-
liftUniq (graphOfAGraph (suspend <*> mkMiddle m <*> resume <*> mkZTail tail))
return (state {s_blocks = s_blocks state `plusBlockEnv` blocks'}, tail')
lowerSafeForeignCall _ _ _ = panic "lowerSafeForeignCall was passed something else"