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