+#if __GLASGOW_HASKELL__ >= 611
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+#endif
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
module CmmBuildInfoTables
( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
, setInfoTableSRT, setInfoTableStackMap
, TopSRT, emptySRT, srtToData
, bundleCAFs
- , finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls )
+ , finishInfoTables, lowerSafeForeignCalls
+ , cafTransfers, liveSlotTransfers
+ , extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls )
where
#include "HsVersions.h"
-- Also, don't forget to stop at the old end of the stack (oldByte),
-- which may differ depending on whether there is an update frame.
+
+type RegSlotInfo
+ = ( Int -- Offset from oldest byte of Old area
+ , LocalReg -- The register
+ , Int) -- Width of the register
+
live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg]
live_ptrs oldByte slotEnv areaMap bid =
- -- pprTrace "live_ptrs for" (ppr bid <+> ppr youngByte <+> ppr liveSlots) $
- reverse $ slotsToList youngByte liveSlots []
- where slotsToList n [] results | n == oldByte = results -- at old end of stack frame
+ -- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
+ -- ppr liveSlots) $
+ -- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
+ res
+ where res = reverse $ slotsToList youngByte liveSlots []
+
+ slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg]
+ -- n starts at youngByte and is decremented down to oldByte
+ -- Returns a list, one element per word, with
+ -- (Just r) meaning 'pointer register r is saved here',
+ -- Nothing meaning 'non-pointer or empty'
+
+ slotsToList n [] results | n == oldByte = results -- at old end of stack frame
+
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 -- slot's young byte is at n
ASSERT (not (isPtr r) ||
(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)
(foldFM (\_ -> 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" (lookupFM areaMap a), r, w) : rst
-- IN THE CALL NODES, WHICH SHOULD EVENTUALLY HAVE LIVE REGISTER AS WELL,
-- SO IT'S ALL GOING IN THE SAME DIRECTION.
-- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c)
+
+ slots :: SubAreaSet -- The SubAreaSet for 'bid'
slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
youngByte = expectJust "live_ptrs bid_pos" $ lookupFM areaMap (CallArea (Young bid))
do let liftCAF lbl () z = -- get CAFs for functions without static closures
case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
Nothing -> addToFM z lbl ()
+ -- For each label referring to a function f without a static closure,
+ -- replace it with the CAFs that are reachable from f.
sub_srt topSRT localCafs =
let cafs = keysFM (foldFM liftCAF emptyFM localCafs)
mkSRT topSRT =
-- doesn't have a static closure.
-- (If it has a static closure, it will already have an SRT to
-- keep its CAFs live.)
--- Any procedure referring to a non-static CAF c must keep live the
+-- Any procedure referring to a non-static CAF c must keep live
-- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing
bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables)
bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
case blockSetToList procpoints of
- [bid] -> (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
+ [bid] -> (expectJust "bundleCAFs" (lookupBlockEnv cafEnv bid), t)
_ -> panic "setInfoTableStackMap: unexpect number of procpoints"
-- until we stop splitting the graphs at procpoints in the native path
bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
-- Our analyses capture the dataflow facts at block boundaries, but we need
-- to extend the CAF and live-slot analyses to safe foreign calls as well,
-- which show up as middle nodes.
+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
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) =
+ 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 :
projects / ghc-hetmet.git / blobdiff