#if __GLASGOW_HASKELL__ >= 611
#endif
module CmmBuildInfoTables
( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
, setInfoTableSRT, setInfoTableStackMap
, TopSRT, emptySRT, srtToData
, bundleCAFs
, finishInfoTables, lowerSafeForeignCalls
, cafTransfers, liveSlotTransfers
, extendEnvWithSafeForeignCalls, 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 Module
import FastString
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
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
type RegSlotInfo
= ( Int
, LocalReg
, Int)
live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg]
live_ptrs oldByte slotEnv areaMap bid =
res
where res = reverse $ slotsToList youngByte liveSlots []
slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg]
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 :: [RegSlotInfo]
liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
(Map.foldRightWithKey (\_ -> flip $ foldl add_slot) [] slots)
add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo]
add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) =
if off == w && widthInBytes (typeWidth ty) == w then
(expectJust "add_slot" (Map.lookup a areaMap), 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 :: SubAreaSet
slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
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 = Map CLabel ()
type CAFEnv = BlockEnv CAFSet
cafLattice :: DataflowLattice CAFSet
cafLattice = DataflowLattice "live cafs" Map.empty add False
where add new old = if Map.size new' > Map.size old
then aTx new'
else noTx new'
where new' = new `Map.union` 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 Map.insert (cvtToClosureLbl l) () s 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 :: Map 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 = Map.empty }
cafMember :: TopSRT -> CLabel -> Bool
cafMember srt lbl = Map.member lbl (elt_map srt)
cafOffset :: TopSRT -> CLabel -> Maybe Int
cafOffset srt lbl = Map.lookup lbl (elt_map srt)
addCAF :: CLabel -> TopSRT -> TopSRT
addCAF caf srt =
srt { next_elt = last + 1
, rev_elts = caf : rev_elts srt
, elt_map = Map.insert caf last (elt_map srt) }
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 -> Map CLabel CAFSet -> CAFSet ->
FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
buildSRTs topSRT topCAFMap cafs =
do let liftCAF lbl () z =
case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs
Nothing -> Map.insert lbl () z
sub_srt topSRT localCafs =
let cafs = Map.keys (Map.foldRightWithKey liftCAF Map.empty 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 (Map.lookup x m, Map.lookup y m) 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 -> Map 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" . flip Map.lookup 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)] -> Map CLabel CAFSet
mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
where addToTop env (AcyclicSCC (l, cafset)) =
Map.insert l (flatten env cafset) env
addToTop env (CyclicSCC nodes) =
let (lbls, cafsets) = unzip nodes
cafset = lbls `Map.deleteList` foldl Map.union Map.empty cafsets
in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
flatten env cafset = Map.foldRightWithKey (lookup env) Map.empty cafset
lookup env caf () cafset' =
case Map.lookup caf env of Just cafs -> Map.foldRightWithKey add cafset' cafs
Nothing -> add caf () cafset'
add caf () cafset' = Map.insert caf () cafset'
g = stronglyConnCompFromEdgedVertices
(map (\n@(l, cafs) -> (n, l, Map.keys 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 _) = (Map.empty, t)
setInfoTableSRT :: Map 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 -> Map 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
extendEnvWithSafeForeignCalls ::
BackwardTransfers Middle Last a -> BlockEnv a -> CmmGraph -> BlockEnv a
extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g
where block b z =
tail (bt_last_in transfers l (lookup env)) 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 fact env (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
tail (mid m fact) (extendBlockEnv env bid fact) h
tail fact env (ZHead h m) = tail (mid m fact) env h
lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k
mid = bt_middle_in transfers
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 (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "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"