1 module CmmBuildInfoTables
2 ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
3 , setInfoTableSRT, setInfoTableStackMap
4 , TopSRT, emptySRT, srtToData
5 , finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls )
8 #include "HsVersions.h"
12 import qualified Prelude as P
19 import Cmm hiding (blockId)
33 import MkZipCfgCmm hiding (CmmAGraph, CmmBlock, CmmTopZ, CmmZ, CmmGraph)
44 import ZipCfg hiding (zip, unzip, last)
45 import qualified ZipCfg as G
49 ----------------------------------------------------------------
50 -- Building InfoTables
53 -----------------------------------------------------------------------
56 -- Given a block ID, we return a representation of the layout of the stack,
57 -- as suspended before entering that block.
58 -- (For a return site to a function call, the layout does not include the
59 -- parameter passing area (or the "return address" on the stack)).
60 -- If the element is `Nothing`, then it represents a word of the stack that
61 -- does not contain a live pointer.
62 -- If the element is `Just` a register, then it represents a live spill slot
63 -- for a pointer; we assume that a pointer is the size of a word.
64 -- The head of the list represents the young end of the stack where the infotable
65 -- pointer for the block `Bid` is stored.
66 -- The infotable pointer itself is not included in the list.
67 -- Call areas are also excluded from the list: besides the stuff in the update
68 -- frame (and the return infotable), call areas should never be live across
71 -- RTS Invariant: All pointers must be word-aligned because each bit in the bitmap
72 -- represents a word. Consequently, we have to be careful when we see a live slot
73 -- on the stack: if we have packed multiple sub-word values into a word,
74 -- we have to make sure that we only mark the entire word as a non-pointer.
76 -- Also, don't forget to stop at the old end of the stack (oldByte),
77 -- which may differ depending on whether there is an update frame.
78 live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg]
79 live_ptrs oldByte slotEnv areaMap bid =
80 pprTrace "live_ptrs for" (ppr bid <+> ppr youngByte <+> ppr liveSlots) $
81 reverse $ slotsToList youngByte liveSlots []
82 where slotsToList n [] results | n == oldByte = results -- at old end of stack frame
83 slotsToList n (s : _) _ | n == oldByte =
84 pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+>
85 ppr n <+> ppr liveSlots <+> ppr youngByte)
86 slotsToList n _ _ | n < oldByte =
87 panic "stack slots not allocated on word boundaries?"
88 slotsToList n l@((n', r, w) : rst) results =
89 if n == (n' + w) then -- slot's young byte is at n
90 ASSERT (not (isPtr r) ||
91 (n `mod` wORD_SIZE == 0 && w == wORD_SIZE)) -- ptrs must be aligned
92 slotsToList next (dropWhile (non_ptr_younger_than next) rst)
94 else slotsToList next (dropWhile (non_ptr_younger_than next) l)
96 where next = n - wORD_SIZE
97 stack_rep = if isPtr r then Just r else Nothing
98 slotsToList n [] results = slotsToList (n - wORD_SIZE) [] (Nothing : results)
99 non_ptr_younger_than next (n', r, w) =
101 ASSERT (not (isPtr r))
103 isPtr = isGcPtrType . localRegType
104 liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
105 (foldFM (\_ -> flip $ foldl add_slot) [] slots)
107 add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) =
108 if off == w && widthInBytes (typeWidth ty) == w then
109 (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst
110 else panic "live_ptrs: only part of a variable live at a proc point"
111 add_slot rst (CallArea Old, off, w) =
112 rst -- the update frame (or return infotable) should be live
113 -- would be nice to check that only that part of the callarea is live...
114 add_slot rst c@((CallArea _), _, _) =
116 -- JD: THIS ISN'T CURRENTLY A CORRECTNESS PROBLEM, BUT WE SHOULD REALLY
117 -- MAKE LIVENESS INFO AROUND CALLS MORE PRECISE -- FOR NOW, A 32-BIT
118 -- FLOAT PADS OUT TO 64 BITS, BUT WE ASSUME THE WHOLE PARAMETER-PASSING
119 -- AREA IS LIVE (WHICH IT ISN'T...). WE SHOULD JUST PUT THE LIVE AREAS
120 -- IN THE CALL NODES, WHICH SHOULD EVENTUALLY HAVE LIVE REGISTER AS WELL,
121 -- SO IT'S ALL GOING IN THE SAME DIRECTION.
122 -- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c)
123 slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
124 youngByte = expectJust "live_ptrs bid_pos" $ lookupFM areaMap (CallArea (Young bid))
126 -- Construct the stack maps for the given procedure.
127 setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables
128 setInfoTableStackMap _ _ t@(NoInfoTable _) = t
129 setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable info bid updfr_off) =
130 updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
131 setInfoTableStackMap slotEnv areaMap
132 t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))
134 case blockSetToList procpoints of
136 let oldByte = case infoTbl of
137 CmmInfoTable _ _ _ (ContInfo _ _) ->
138 case lookupBlockEnv blocks bid of
139 Just (Block _ (StackInfo {returnOff = Just n}) _) -> n
140 _ -> pprPanic "misformed graph at procpoint" (ppr g)
141 _ -> initUpdFrameOff -- entry to top-level function
142 stack_vars = live_ptrs oldByte slotEnv areaMap bid
143 in updInfo (const stack_vars) id t
144 _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
145 -- until we stop splitting the graphs at procpoints in the native path
146 setInfoTableStackMap _ _ _ = panic "unexpected case for setInfoTableStackMap"
148 setInfoTableStackMap slotEnv areaMap
149 (Just bid, p@(CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))) =
150 let oldByte = case infoTbl of
151 CmmInfoTable _ _ _ (ContInfo _ _) ->
152 case lookupBlockEnv blocks bid of
153 Just (Block _ (StackInfo {returnOff = Just n}) _) -> n
154 _ -> pprPanic "misformed graph at procpoint" (ppr g)
155 _ -> initUpdFrameOff -- entry to top-level function
156 stack_vars = live_ptrs oldByte slotEnv areaMap bid
157 in (Just bid, upd_info_tbl (const stack_vars) id p)
158 setInfoTableStackMap _ _ t@(_, CmmData {}) = t
159 setInfoTableStackMap _ _ _ = panic "bad args to setInfoTableStackMap"
163 -----------------------------------------------------------------------
166 -- WE NEED AN EXAMPLE HERE.
167 -- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN
168 -- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED
169 -- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT).
170 -- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY
171 -- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
172 -- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).
175 -----------------------------------------------------------------------
176 -- Finding the CAFs used by a procedure
178 type CAFSet = FiniteMap CLabel ()
179 type CAFEnv = BlockEnv CAFSet
181 -- First, an analysis to find live CAFs.
182 cafLattice :: DataflowLattice CAFSet
183 cafLattice = DataflowLattice "live cafs" emptyFM add True
184 where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new'
185 where new' = new `plusFM` old
187 cafTransfers :: BackwardTransfers Middle Last CAFSet
188 cafTransfers = BackwardTransfers first middle last
189 where first live _ = live
190 middle live m = pprTrace "cafmiddle" (ppr m) $ foldExpDeepMiddle addCaf m live
191 last env l = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
192 addCaf e set = case e of
193 CmmLit (CmmLabel c) -> add c set
194 CmmLit (CmmLabelOff c _) -> add c set
195 CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
197 add l s = pprTrace "CAF analysis saw label" (ppr l) $
199 pprTrace "has caf" (ppr l) $ addToFM s (cvtToClosureLbl l) ()
200 else (pprTrace "no cafs" (ppr l) $ s)
202 type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
203 cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv
204 cafAnal g = liftM zdfFpFacts (res :: CafFix ())
205 where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice
206 cafTransfers (fact_bot cafLattice) g
208 -----------------------------------------------------------------------
211 -- Description of the SRT for a given module.
212 -- Note that this SRT may grow as we greedily add new CAFs to it.
213 data TopSRT = TopSRT { lbl :: CLabel
214 , next_elt :: Int -- the next entry in the table
215 , rev_elts :: [CLabel]
216 , elt_map :: FiniteMap CLabel Int }
217 -- map: CLabel -> its last entry in the table
218 instance Outputable TopSRT where
219 ppr (TopSRT lbl next elts eltmap) =
220 text "TopSRT:" <+> ppr lbl <+> ppr next <+> ppr elts <+> ppr eltmap
222 emptySRT :: MonadUnique m => m TopSRT
224 do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
225 return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = emptyFM }
227 cafMember :: TopSRT -> CLabel -> Bool
228 cafMember srt lbl = elemFM lbl (elt_map srt)
230 cafOffset :: TopSRT -> CLabel -> Maybe Int
231 cafOffset srt lbl = lookupFM (elt_map srt) lbl
233 addCAF :: CLabel -> TopSRT -> TopSRT
235 srt { next_elt = last + 1
236 , rev_elts = caf : rev_elts srt
237 , elt_map = addToFM (elt_map srt) caf last }
238 where last = next_elt srt
240 srtToData :: TopSRT -> CmmZ
241 srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)]
242 where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
244 -- Once we have found the CAFs, we need to do two things:
245 -- 1. Build a table of all the CAFs used in the procedure.
246 -- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
248 -- When building the local view of the SRT, we first make sure that all the CAFs are
249 -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
250 -- we make sure they're all close enough to the bottom of the table that the
251 -- bitmap will be able to cover all of them.
252 buildSRTs :: TopSRT -> FiniteMap CLabel CAFSet -> CAFSet ->
253 FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
254 buildSRTs topSRT topCAFMap cafs =
255 -- This is surely the wrong way to get names, as in BlockId
256 do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
257 let liftCAF lbl () z = -- get CAFs for functions without static closures
258 case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
259 Nothing -> addToFM z lbl ()
260 sub_srt topSRT localCafs =
261 let cafs = keysFM (foldFM liftCAF emptyFM localCafs)
263 do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
264 return (topSRT, localSRTs)
265 in pprTrace "cafs" (ppr cafs) $
266 if length cafs > maxBmpSize then
267 mkSRT (foldl add_if_missing topSRT cafs)
268 else -- make sure all the cafs are near the bottom of the srt
269 mkSRT (add_if_too_far topSRT cafs)
270 add_if_missing srt caf =
271 if cafMember srt caf then srt else addCAF caf srt
272 -- If a CAF is more than maxBmpSize entries from the young end of the
273 -- SRT, then we add it to the SRT again.
274 -- (Note: Not in the SRT => infinitely far.)
275 add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
276 add srt (sortBy farthestFst cafs)
278 farthestFst x y = case (lookupFM m x, lookupFM m y) of
279 (Nothing, Nothing) -> EQ
280 (Nothing, Just _) -> LT
281 (Just _, Nothing) -> GT
282 (Just d, Just d') -> compare d' d
284 add srt@(TopSRT {next_elt = next}) (caf : rst) =
285 case cafOffset srt caf of
286 Just ix -> if next - ix > maxBmpSize then
287 add (addCAF caf srt) rst
289 Nothing -> add (addCAF caf srt) rst
290 (topSRT, subSRTs) <- sub_srt topSRT cafs
291 let (sub_tbls, blockSRTs) = subSRTs
292 return (topSRT, sub_tbls, blockSRTs)
294 -- Construct an SRT bitmap.
295 -- Adapted from simpleStg/SRT.lhs, which expects Id's.
296 procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] ->
297 FuelMonad (Maybe CmmTopZ, C_SRT)
298 procpointSRT top_srt top_table [] =
299 return (Nothing, NoC_SRT)
300 procpointSRT top_srt top_table entries =
301 do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
304 ints = map (expectJust "constructSRT" . lookupFM top_table) entries
305 sorted_ints = sortLe (<=) ints
306 offset = head sorted_ints
307 bitmap_entries = map (subtract offset) sorted_ints
308 len = P.last bitmap_entries + 1
309 bitmap = intsToBitmap len bitmap_entries
312 maxBmpSize = widthInBits wordWidth `div` 2
314 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
315 to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT)
316 to_SRT top_srt off len bmp
317 | len > maxBmpSize || bmp == [fromIntegral srt_escape]
318 = do id <- getUniqueM
319 let srt_desc_lbl = mkLargeSRTLabel id
320 tbl = CmmData RelocatableReadOnlyData $
321 CmmDataLabel srt_desc_lbl : map CmmStaticLit
322 ( cmmLabelOffW top_srt off
323 : mkWordCLit (fromIntegral len)
324 : map mkWordCLit bmp)
325 return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
327 = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
328 -- The fromIntegral converts to StgHalfWord
330 -- Gather CAF info for a procedure, but only if the procedure
331 -- doesn't have a static closure.
332 -- (If it has a static closure, it will already have an SRT to
333 -- keep its CAFs live.)
334 localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
335 localCAFInfo _ t@(CmmData _ _) = Nothing
336 localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) =
338 CmmInfoTable False _ _ _ ->
339 Just (cvtToClosureLbl top_l,
340 expectJust "maybeBindCAFs" $ lookupBlockEnv cafEnv entry)
343 -- Once we have the local CAF sets for some (possibly) mutually
344 -- recursive functions, we can create an environment mapping
345 -- each function to its set of CAFs. Note that a CAF may
346 -- be a reference to a function. If that function f does not have
347 -- a static closure, then we need to refer specifically
348 -- to the set of CAFs used by f. Of course, the set of CAFs
349 -- used by f must be included in the local CAF sets that are input to
350 -- this function. To minimize lookup time later, we return
351 -- the environment with every reference to f replaced by its set of CAFs.
352 -- To do this replacement efficiently, we gather strongly connected
353 -- components, then we sort the components in topological order.
354 mkTopCAFInfo :: [(CLabel, CAFSet)] -> FiniteMap CLabel CAFSet
355 mkTopCAFInfo localCAFs = foldl addToTop emptyFM g
356 where addToTop env (AcyclicSCC (l, cafset)) =
357 addToFM env l (flatten env cafset)
358 addToTop env (CyclicSCC nodes) =
359 let (lbls, cafsets) = unzip nodes
360 cafset = foldl plusFM emptyFM cafsets `delListFromFM` lbls
361 in foldl (\env l -> addToFM env l (flatten env cafset)) env lbls
362 flatten env cafset = foldFM (lookup env) emptyFM cafset
363 lookup env caf () cafset' =
364 case lookupFM env caf of Just cafs -> foldFM add cafset' cafs
365 Nothing -> add caf () cafset'
366 add caf () cafset' = addToFM cafset' caf ()
367 g = stronglyConnCompFromEdgedVertices
368 (map (\n@(l, cafs) -> (n, l, keysFM cafs)) localCAFs)
370 type StackLayout = [Maybe LocalReg]
372 -- Construct the SRTs for the given procedure.
373 setInfoTableSRT :: CAFEnv -> FiniteMap CLabel CAFSet -> TopSRT ->
374 CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
375 setInfoTableSRT cafEnv topCAFMap topSRT t@(ProcInfoTable p procpoints) =
376 case blockSetToList procpoints of
377 [bid] -> setSRT cafEnv topCAFMap topSRT t bid
378 _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
379 -- until we stop splitting the graphs at procpoints in the native path
380 setInfoTableSRT cafEnv topCAFMap topSRT t@(FloatingInfoTable info bid _) =
381 setSRT cafEnv topCAFMap topSRT t bid
382 setInfoTableSRT _ _ topSRT t@(NoInfoTable _) = return (topSRT, [t])
384 setSRT :: CAFEnv -> FiniteMap CLabel CAFSet -> TopSRT ->
385 CmmTopForInfoTables -> BlockId -> FuelMonad (TopSRT, [CmmTopForInfoTables])
386 setSRT cafEnv topCAFMap topSRT t bid =
387 do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap
388 (expectJust "sub_srt" $ lookupBlockEnv cafEnv bid)
389 let t' = updInfo id (const srt) t
391 Just tbl -> return (topSRT, [t', NoInfoTable tbl])
392 Nothing -> return (topSRT, [t'])
394 updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) ->
395 CmmTopForInfoTables -> CmmTopForInfoTables
396 updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints) =
397 ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints
398 updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) =
399 FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off
400 updInfo toVars toSrt (NoInfoTable _) = panic "can't update NoInfoTable"
401 updInfo _ _ _ = panic "unexpected arg to updInfo"
403 updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo
404 updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo))
405 = CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo')
406 where typeinfo' = case typeinfo of
407 t@(ConstrInfo _ _ _) -> t
408 (FunInfo c s a d e) -> FunInfo c (toSrt s) a d e
409 (ThunkInfo c s) -> ThunkInfo c (toSrt s)
410 (ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
411 (ContInfo v s) -> ContInfo (toVars v) (toSrt s)
412 updInfoTbl toVars toSrt t@(CmmInfo _ _ CmmNonInfoTable) = t
414 -- Lower the CmmTopForInfoTables type down to good old CmmTopZ
415 -- by emitting info tables as data where necessary.
416 finishInfoTables :: CmmTopForInfoTables -> IO [CmmTopZ]
417 finishInfoTables (NoInfoTable t) = return [t]
418 finishInfoTables (ProcInfoTable p _) = return [p]
419 finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
420 do uniq_supply <- mkSplitUniqSupply 'i'
421 return $ mkBareInfoTable (retPtLbl bid) (uniqFromSupply uniq_supply) infotbl
423 ----------------------------------------------------------------
424 -- Safe foreign calls:
425 -- Our analyses capture the dataflow facts at block boundaries, but we need
426 -- to extend the CAF and live-slot analyses to safe foreign calls as well,
427 -- which show up as middle nodes.
428 extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
429 extendEnvsForSafeForeignCalls cafEnv slotEnv g =
430 fold_blocks block (cafEnv, slotEnv) g
431 where block b@(Block _ _ t) z =
432 tail ( bt_last_in cafTransfers (lookupFn cafEnv) l
433 , bt_last_in liveSlotTransfers (lookupFn slotEnv) l)
435 where (head, last) = goto_end (G.unzip b)
436 l = case last of LastOther l -> l
437 LastExit -> panic "extendEnvs lastExit"
438 tail lives z (ZFirst _ _) = z
439 tail lives@(cafs, slots) (cafEnv, slotEnv)
440 (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) =
441 let slots' = removeLiveSlotDefs slots m
442 slotEnv' = extendBlockEnv slotEnv bid slots'
443 cafEnv' = extendBlockEnv cafEnv bid cafs
444 in tail (upd lives m) (cafEnv', slotEnv') h
445 tail lives z (ZHead h m) = tail (upd lives m) z h
446 lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k
447 upd (cafs, slots) m =
448 (bt_middle_in cafTransfers cafs m, bt_middle_in liveSlotTransfers slots m)
450 -- Safe foreign calls: We need to insert the code that suspends and resumes
451 -- the thread before and after a safe foreign call.
452 -- Why do we do this so late in the pipeline?
453 -- Because we need this code to appear without interrruption: you can't rely on the
454 -- value of the stack pointer between the call and resetting the thread state;
455 -- you need to have an infotable on the young end of the stack both when
456 -- suspending the thread and making the foreign call.
457 -- All of this is much easier if we insert the suspend and resume calls here.
459 -- At the same time, we prepare for the stages of the compiler that
460 -- build the proc points. We have to do this at the same time because
461 -- the safe foreign calls need special treatment with respect to infotables.
462 -- A safe foreign call needs an infotable even though it isn't
463 -- a procpoint. The following datatype captures the information
464 -- needed to generate the infotables along with the Cmm data and procedures.
466 data CmmTopForInfoTables
467 = NoInfoTable CmmTopZ -- must be CmmData
468 | ProcInfoTable CmmTopZ BlockSet -- CmmProc; argument is its set of procpoints
469 | FloatingInfoTable CmmInfo BlockId UpdFrameOffset
470 instance Outputable CmmTopForInfoTables where
471 ppr (NoInfoTable t) = text "NoInfoTable: " <+> ppr t
472 ppr (ProcInfoTable t bids) = text "ProcInfoTable: " <+> ppr t <+> ppr bids
473 ppr (FloatingInfoTable info bid upd) =
474 text "FloatingInfoTable: " <+> ppr info <+> ppr bid <+> ppr upd
476 -- The `safeState' record collects the info we update while lowering the
477 -- safe foreign calls in the graph.
478 data SafeState = State { s_blocks :: BlockEnv CmmBlock
479 , s_pps :: ProcPointSet
480 , s_safeCalls :: [CmmTopForInfoTables]}
482 lowerSafeForeignCalls
483 :: ProcPointSet -> [[CmmTopForInfoTables]] ->
484 CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
485 lowerSafeForeignCalls _ rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
486 lowerSafeForeignCalls procpoints rst
487 t@(CmmProc info l args g@(LGraph entry off blocks)) = do
488 let init = return $ State emptyBlockEnv emptyBlockSet []
489 let block b@(Block bid _ _) z = do
490 state@(State {s_pps = ppset, s_blocks = blocks}) <- z
491 let ppset' = if bid == entry then extendBlockSet ppset bid else ppset
492 state' = state { s_pps = ppset' }
493 if hasSafeForeignCall b
494 then lowerSafeCallBlock state' b
495 else return (state' { s_blocks = insertBlock b blocks })
496 State blocks' g_procpoints safeCalls <- fold_blocks block init g
497 return $ (ProcInfoTable (CmmProc info l args (LGraph entry off blocks')) g_procpoints
500 -- Check for foreign calls -- if none, then we can avoid copying the block.
501 hasSafeForeignCall :: CmmBlock -> Bool
502 hasSafeForeignCall (Block _ _ t) = tail t
503 where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) t) = True
504 tail (ZTail _ t) = tail t
505 tail (ZLast _) = False
507 -- Lower each safe call in the block, update the CAF and slot environments
508 -- to include each of those calls, and insert the new block in the blockEnv.
509 lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState
510 lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
511 where (head, last) = goto_end (G.unzip b)
512 tail s b@(ZBlock (ZFirst _ _) _) =
514 return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
515 tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) =
518 { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
520 (state'', t') <- lowerSafeForeignCall state' m t
521 tail (return state'') (ZBlock h t')
522 tail s (ZBlock (ZHead h m) t) = tail s (ZBlock h (ZTail m t))
525 -- Late in the code generator, we want to insert the code necessary
526 -- to lower a safe foreign call to a sequence of unsafe calls.
527 lowerSafeForeignCall ::
528 SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
529 lowerSafeForeignCall state m@(MidForeignCall (Safe infotable updfr) _ _ _) tail = do
530 let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
531 -- Both 'id' and 'new_base' are KindNonPtr because they're
532 -- RTS-only objects and are not subject to garbage collection
534 new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
535 let (caller_save, caller_load) = callerSaveVolatileRegs
536 load_tso <- newTemp gcWord -- TODO FIXME NOW
537 let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
538 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
539 suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
542 mkUnsafeCall (ForeignTarget suspendThread
543 (ForeignConvention CCallConv [AddrHint] [AddrHint]))
544 [id] [CmmReg (CmmGlobal BaseReg)]
545 resume = mkUnsafeCall (ForeignTarget resumeThread
546 (ForeignConvention CCallConv [AddrHint] [AddrHint]))
547 [new_base] [CmmReg (CmmLocal id)] <*>
548 -- Assign the result to BaseReg: we
549 -- might now have a different Capability!
550 mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
552 loadThreadState load_tso
553 Graph tail' blocks' <-
554 liftUniq (graphOfAGraph (suspend <*> mkMiddle m <*> resume <*> mkZTail tail))
555 return (state {s_blocks = s_blocks state `plusBlockEnv` blocks'}, tail')
556 lowerSafeForeignCall _ _ _ = panic "lowerSafeForeignCall was passed something else"