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