More CPP removal: pprDynamicLinkerAsmLabel in CLabel
[ghc.git] / compiler / cmm / CmmBuildInfoTables.hs
1 {-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
2 -- Norman likes local bindings
3 -- If this module lives on I'd like to get rid of this flag in due course
4
5 -- Todo: remove
6
7 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
8 module CmmBuildInfoTables
9 ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
10 , setInfoTableSRT, setInfoTableStackMap
11 , TopSRT, emptySRT, srtToData
12 , bundleCAFs
13 , lowerSafeForeignCalls
14 , cafTransfers, liveSlotTransfers
15 , mkLiveness )
16 where
17
18 #include "HsVersions.h"
19
20 -- These should not be imported here!
21 import StgCmmForeign
22 import StgCmmUtils
23
24 import Constants
25 import Digraph
26 import qualified Prelude as P
27 import Prelude hiding (succ)
28 import Util (sortLe)
29
30 import BlockId
31 import Bitmap
32 import CLabel
33 import Cmm
34 import CmmUtils
35 import CmmStackLayout
36 import Module
37 import FastString
38 import ForeignCall
39 import IdInfo
40 import Data.List
41 import Maybes
42 import MkGraph as M
43 import Control.Monad
44 import Name
45 import OptimizationFuel
46 import Outputable
47 import Platform
48 import SMRep
49 import UniqSupply
50
51 import Compiler.Hoopl
52
53 import Data.Map (Map)
54 import qualified Data.Map as Map
55 import qualified FiniteMap as Map
56
57 ----------------------------------------------------------------
58 -- Building InfoTables
59
60
61 -----------------------------------------------------------------------
62 -- Stack Maps
63
64 -- Given a block ID, we return a representation of the layout of the stack,
65 -- as suspended before entering that block.
66 -- (For a return site to a function call, the layout does not include the
67 -- parameter passing area (or the "return address" on the stack)).
68 -- If the element is `Nothing`, then it represents a word of the stack that
69 -- does not contain a live pointer.
70 -- If the element is `Just` a register, then it represents a live spill slot
71 -- for a pointer; we assume that a pointer is the size of a word.
72 -- The head of the list represents the young end of the stack where the infotable
73 -- pointer for the block `Bid` is stored.
74 -- The infotable pointer itself is not included in the list.
75 -- Call areas are also excluded from the list: besides the stuff in the update
76 -- frame (and the return infotable), call areas should never be live across
77 -- function calls.
78
79 -- RTS Invariant: All pointers must be word-aligned because each bit in the bitmap
80 -- represents a word. Consequently, we have to be careful when we see a live slot
81 -- on the stack: if we have packed multiple sub-word values into a word,
82 -- we have to make sure that we only mark the entire word as a non-pointer.
83
84 -- Also, don't forget to stop at the old end of the stack (oldByte),
85 -- which may differ depending on whether there is an update frame.
86
87 type RegSlotInfo
88 = ( Int -- Offset from oldest byte of Old area
89 , LocalReg -- The register
90 , Int) -- Width of the register
91
92 live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> StackLayout
93 live_ptrs oldByte slotEnv areaMap bid =
94 -- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
95 -- ppr liveSlots) $
96 -- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
97 res
98 where
99 res = mkLiveness (reverse $ slotsToList youngByte liveSlots [])
100
101 slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg]
102 -- n starts at youngByte and is decremented down to oldByte
103 -- Returns a list, one element per word, with
104 -- (Just r) meaning 'pointer register r is saved here',
105 -- Nothing meaning 'non-pointer or empty'
106
107 slotsToList n [] results | n == oldByte = results -- at old end of stack frame
108
109 slotsToList n (s : _) _ | n == oldByte =
110 pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+>
111 ppr n <+> ppr liveSlots <+> ppr youngByte)
112
113 slotsToList n _ _ | n < oldByte =
114 panic "stack slots not allocated on word boundaries?"
115
116 slotsToList n l@((n', r, w) : rst) results =
117 if n == (n' + w) then -- slot's young byte is at n
118 ASSERT (not (isPtr r) ||
119 (n `mod` wORD_SIZE == 0 && w == wORD_SIZE)) -- ptrs must be aligned
120 slotsToList next (dropWhile (non_ptr_younger_than next) rst)
121 (stack_rep : results)
122 else slotsToList next (dropWhile (non_ptr_younger_than next) l)
123 (Nothing : results)
124 where next = n - wORD_SIZE
125 stack_rep = if isPtr r then Just r else Nothing
126
127 slotsToList n [] results = slotsToList (n - wORD_SIZE) [] (Nothing : results)
128
129 non_ptr_younger_than next (n', r, w) =
130 n' + w > next &&
131 ASSERT (not (isPtr r))
132 True
133 isPtr = isGcPtrType . localRegType
134
135 liveSlots :: [RegSlotInfo]
136 liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
137 (Map.foldRightWithKey (\_ -> flip $ foldl add_slot) [] slots)
138
139 add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo]
140 add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) =
141 if off == w && widthInBytes (typeWidth ty) == w then
142 (expectJust "add_slot" (Map.lookup a areaMap), r, w) : rst
143 else panic "live_ptrs: only part of a variable live at a proc point"
144 add_slot rst (CallArea Old, _, _) =
145 rst -- the update frame (or return infotable) should be live
146 -- would be nice to check that only that part of the callarea is live...
147 add_slot rst ((CallArea _), _, _) =
148 rst
149 -- JD: THIS ISN'T CURRENTLY A CORRECTNESS PROBLEM, BUT WE SHOULD REALLY
150 -- MAKE LIVENESS INFO AROUND CALLS MORE PRECISE -- FOR NOW, A 32-BIT
151 -- FLOAT PADS OUT TO 64 BITS, BUT WE ASSUME THE WHOLE PARAMETER-PASSING
152 -- AREA IS LIVE (WHICH IT ISN'T...). WE SHOULD JUST PUT THE LIVE AREAS
153 -- IN THE CALL NODES, WHICH SHOULD EVENTUALLY HAVE LIVE REGISTER AS WELL,
154 -- SO IT'S ALL GOING IN THE SAME DIRECTION.
155 -- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c)
156
157 slots :: SubAreaSet -- The SubAreaSet for 'bid'
158 slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv
159 youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
160
161 -- Construct the stack maps for a procedure _if_ it needs an infotable.
162 -- When wouldn't a procedure need an infotable? If it is a procpoint that
163 -- is not the successor of a call.
164 setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmDecl -> CmmDecl
165 setInfoTableStackMap slotEnv areaMap
166 t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _
167 (CmmGraph {g_entry = eid}))
168 = updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
169 setInfoTableStackMap _ _ t = t
170
171
172
173 -----------------------------------------------------------------------
174 -- SRTs
175
176 -- WE NEED AN EXAMPLE HERE.
177 -- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN
178 -- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED
179 -- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT).
180 -- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY
181 -- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
182 -- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).
183
184
185 -----------------------------------------------------------------------
186 -- Finding the CAFs used by a procedure
187
188 type CAFSet = Map CLabel ()
189 type CAFEnv = BlockEnv CAFSet
190
191 -- First, an analysis to find live CAFs.
192 cafLattice :: DataflowLattice CAFSet
193 cafLattice = DataflowLattice "live cafs" Map.empty add
194 where add _ (OldFact old) (NewFact new) = case old `Map.union` new of
195 new' -> (changeIf $ Map.size new' > Map.size old, new')
196
197 cafTransfers :: Platform -> BwdTransfer CmmNode CAFSet
198 cafTransfers platform = mkBTransfer3 first middle last
199 where first _ live = live
200 middle m live = foldExpDeep addCaf m live
201 last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
202 addCaf e set = case e of
203 CmmLit (CmmLabel c) -> add c set
204 CmmLit (CmmLabelOff c _) -> add c set
205 CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
206 _ -> set
207 add l s = if hasCAF l then Map.insert (toClosureLbl platform l) () s
208 else s
209
210 cafAnal :: Platform -> CmmGraph -> FuelUniqSM CAFEnv
211 cafAnal platform g
212 = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice (cafTransfers platform)
213
214 -----------------------------------------------------------------------
215 -- Building the SRTs
216
217 -- Description of the SRT for a given module.
218 -- Note that this SRT may grow as we greedily add new CAFs to it.
219 data TopSRT = TopSRT { lbl :: CLabel
220 , next_elt :: Int -- the next entry in the table
221 , rev_elts :: [CLabel]
222 , elt_map :: Map CLabel Int }
223 -- map: CLabel -> its last entry in the table
224 instance PlatformOutputable TopSRT where
225 pprPlatform platform (TopSRT lbl next elts eltmap) =
226 text "TopSRT:" <+> pprPlatform platform lbl
227 <+> ppr next
228 <+> pprPlatform platform elts
229 <+> pprPlatform platform eltmap
230
231 emptySRT :: MonadUnique m => m TopSRT
232 emptySRT =
233 do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
234 return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
235
236 cafMember :: TopSRT -> CLabel -> Bool
237 cafMember srt lbl = Map.member lbl (elt_map srt)
238
239 cafOffset :: TopSRT -> CLabel -> Maybe Int
240 cafOffset srt lbl = Map.lookup lbl (elt_map srt)
241
242 addCAF :: CLabel -> TopSRT -> TopSRT
243 addCAF caf srt =
244 srt { next_elt = last + 1
245 , rev_elts = caf : rev_elts srt
246 , elt_map = Map.insert caf last (elt_map srt) }
247 where last = next_elt srt
248
249 srtToData :: TopSRT -> CmmGroup
250 srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
251 where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
252
253 -- Once we have found the CAFs, we need to do two things:
254 -- 1. Build a table of all the CAFs used in the procedure.
255 -- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
256 --
257 -- When building the local view of the SRT, we first make sure that all the CAFs are
258 -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
259 -- we make sure they're all close enough to the bottom of the table that the
260 -- bitmap will be able to cover all of them.
261 buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
262 FuelUniqSM (TopSRT, Maybe CmmDecl, C_SRT)
263 buildSRTs topSRT topCAFMap cafs =
264 do let liftCAF lbl () z = -- get CAFs for functions without static closures
265 case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs
266 Nothing -> Map.insert lbl () z
267 -- For each label referring to a function f without a static closure,
268 -- replace it with the CAFs that are reachable from f.
269 sub_srt topSRT localCafs =
270 let cafs = Map.keys (Map.foldRightWithKey liftCAF Map.empty localCafs)
271 mkSRT topSRT =
272 do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
273 return (topSRT, localSRTs)
274 in if length cafs > maxBmpSize then
275 mkSRT (foldl add_if_missing topSRT cafs)
276 else -- make sure all the cafs are near the bottom of the srt
277 mkSRT (add_if_too_far topSRT cafs)
278 add_if_missing srt caf =
279 if cafMember srt caf then srt else addCAF caf srt
280 -- If a CAF is more than maxBmpSize entries from the young end of the
281 -- SRT, then we add it to the SRT again.
282 -- (Note: Not in the SRT => infinitely far.)
283 add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
284 add srt (sortBy farthestFst cafs)
285 where
286 farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
287 (Nothing, Nothing) -> EQ
288 (Nothing, Just _) -> LT
289 (Just _, Nothing) -> GT
290 (Just d, Just d') -> compare d' d
291 add srt [] = srt
292 add srt@(TopSRT {next_elt = next}) (caf : rst) =
293 case cafOffset srt caf of
294 Just ix -> if next - ix > maxBmpSize then
295 add (addCAF caf srt) rst
296 else srt
297 Nothing -> add (addCAF caf srt) rst
298 (topSRT, subSRTs) <- sub_srt topSRT cafs
299 let (sub_tbls, blockSRTs) = subSRTs
300 return (topSRT, sub_tbls, blockSRTs)
301
302 -- Construct an SRT bitmap.
303 -- Adapted from simpleStg/SRT.lhs, which expects Id's.
304 procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
305 FuelUniqSM (Maybe CmmDecl, C_SRT)
306 procpointSRT _ _ [] =
307 return (Nothing, NoC_SRT)
308 procpointSRT top_srt top_table entries =
309 do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
310 return (top, srt)
311 where
312 ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
313 sorted_ints = sortLe (<=) ints
314 offset = head sorted_ints
315 bitmap_entries = map (subtract offset) sorted_ints
316 len = P.last bitmap_entries + 1
317 bitmap = intsToBitmap len bitmap_entries
318
319 maxBmpSize :: Int
320 maxBmpSize = widthInBits wordWidth `div` 2
321
322 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
323 to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmDecl, C_SRT)
324 to_SRT top_srt off len bmp
325 | len > maxBmpSize || bmp == [fromIntegral srt_escape]
326 = do id <- getUniqueM
327 let srt_desc_lbl = mkLargeSRTLabel id
328 tbl = CmmData RelocatableReadOnlyData $
329 Statics srt_desc_lbl $ map CmmStaticLit
330 ( cmmLabelOffW top_srt off
331 : mkWordCLit (fromIntegral len)
332 : map mkWordCLit bmp)
333 return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
334 | otherwise
335 = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
336 -- The fromIntegral converts to StgHalfWord
337
338 -- Gather CAF info for a procedure, but only if the procedure
339 -- doesn't have a static closure.
340 -- (If it has a static closure, it will already have an SRT to
341 -- keep its CAFs live.)
342 -- Any procedure referring to a non-static CAF c must keep live
343 -- any CAF that is reachable from c.
344 localCAFInfo :: Platform -> CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet)
345 localCAFInfo _ _ (CmmData _ _) = Nothing
346 localCAFInfo platform cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
347 case info_tbl top_info of
348 CmmInfoTable { cit_rep = rep }
349 | not (isStaticRep rep)
350 -> Just (toClosureLbl platform top_l,
351 expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
352 _ -> Nothing
353
354 -- Once we have the local CAF sets for some (possibly) mutually
355 -- recursive functions, we can create an environment mapping
356 -- each function to its set of CAFs. Note that a CAF may
357 -- be a reference to a function. If that function f does not have
358 -- a static closure, then we need to refer specifically
359 -- to the set of CAFs used by f. Of course, the set of CAFs
360 -- used by f must be included in the local CAF sets that are input to
361 -- this function. To minimize lookup time later, we return
362 -- the environment with every reference to f replaced by its set of CAFs.
363 -- To do this replacement efficiently, we gather strongly connected
364 -- components, then we sort the components in topological order.
365 mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet
366 mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
367 where addToTop env (AcyclicSCC (l, cafset)) =
368 Map.insert l (flatten env cafset) env
369 addToTop env (CyclicSCC nodes) =
370 let (lbls, cafsets) = unzip nodes
371 cafset = lbls `Map.deleteList` foldl Map.union Map.empty cafsets
372 in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
373 flatten env cafset = Map.foldRightWithKey (lookup env) Map.empty cafset
374 lookup env caf () cafset' =
375 case Map.lookup caf env of Just cafs -> Map.foldRightWithKey add cafset' cafs
376 Nothing -> add caf () cafset'
377 add caf () cafset' = Map.insert caf () cafset'
378 g = stronglyConnCompFromEdgedVertices
379 (map (\n@(l, cafs) -> (n, l, Map.keys cafs)) localCAFs)
380
381 -- Bundle the CAFs used at a procpoint.
382 bundleCAFs :: CAFEnv -> CmmDecl -> (CAFSet, CmmDecl)
383 bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
384 (expectJust "bundleCAFs" (mapLookup entry cafEnv), t)
385 bundleCAFs _ t = (Map.empty, t)
386
387 -- Construct the SRTs for the given procedure.
388 setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) ->
389 FuelUniqSM (TopSRT, [CmmDecl])
390 setInfoTableSRT topCAFMap topSRT (cafs, t) =
391 setSRT cafs topCAFMap topSRT t
392
393 setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
394 CmmDecl -> FuelUniqSM (TopSRT, [CmmDecl])
395 setSRT cafs topCAFMap topSRT t =
396 do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
397 let t' = updInfo id (const srt) t
398 case cafTable of
399 Just tbl -> return (topSRT, [t', tbl])
400 Nothing -> return (topSRT, [t'])
401
402 type StackLayout = Liveness
403
404 updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
405 updInfo toVars toSrt (CmmProc top_info top_l g) =
406 CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
407 updInfo _ _ t = t
408
409 updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
410 updInfoTbl toVars toSrt info_tbl@(CmmInfoTable {})
411 = info_tbl { cit_srt = toSrt (cit_srt info_tbl)
412 , cit_rep = case cit_rep info_tbl of
413 StackRep ls -> StackRep (toVars ls)
414 other -> other }
415 updInfoTbl _ _ t@CmmNonInfoTable = t
416
417 ----------------------------------------------------------------
418 -- Safe foreign calls: We need to insert the code that suspends and resumes
419 -- the thread before and after a safe foreign call.
420 -- Why do we do this so late in the pipeline?
421 -- Because we need this code to appear without interrruption: you can't rely on the
422 -- value of the stack pointer between the call and resetting the thread state;
423 -- you need to have an infotable on the young end of the stack both when
424 -- suspending the thread and making the foreign call.
425 -- All of this is much easier if we insert the suspend and resume calls here.
426
427 -- At the same time, we prepare for the stages of the compiler that
428 -- build the proc points. We have to do this at the same time because
429 -- the safe foreign calls need special treatment with respect to infotables.
430 -- A safe foreign call needs an infotable even though it isn't
431 -- a procpoint. The following datatype captures the information
432 -- needed to generate the infotables along with the Cmm data and procedures.
433
434 -- JD: Why not do this while splitting procedures?
435 lowerSafeForeignCalls :: AreaMap -> CmmDecl -> FuelUniqSM CmmDecl
436 lowerSafeForeignCalls _ t@(CmmData _ _) = return t
437 lowerSafeForeignCalls areaMap (CmmProc info l g@(CmmGraph {g_entry=entry})) = do
438 let block b mblocks = mblocks >>= lowerSafeCallBlock entry areaMap b
439 blocks <- foldGraphBlocks block (return mapEmpty) g
440 return $ CmmProc info l (ofBlockMap entry blocks)
441
442 -- If the block ends with a safe call in the block, lower it to an unsafe
443 -- call (with appropriate saves and restores before and after).
444 lowerSafeCallBlock :: BlockId -> AreaMap -> CmmBlock -> BlockEnv CmmBlock
445 -> FuelUniqSM (BlockEnv CmmBlock)
446 lowerSafeCallBlock entry areaMap b blocks =
447 case blockToNodeList b of
448 (JustC (CmmEntry id), m, JustC l@(CmmForeignCall {})) -> lowerSafeForeignCall entry areaMap blocks id m l
449 _ -> return $ insertBlock b blocks
450
451 -- Late in the code generator, we want to insert the code necessary
452 -- to lower a safe foreign call to a sequence of unsafe calls.
453 lowerSafeForeignCall :: BlockId -> AreaMap -> BlockEnv CmmBlock -> BlockId -> [CmmNode O O] -> CmmNode O C
454 -> FuelUniqSM (BlockEnv CmmBlock)
455 lowerSafeForeignCall entry areaMap blocks bid m
456 (CmmForeignCall {tgt=tgt, res=rs, args=as, succ=succ, updfr = updfr_off, intrbl = intrbl}) =
457 do let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
458 -- Both 'id' and 'new_base' are KindNonPtr because they're
459 -- RTS-only objects and are not subject to garbage collection
460 id <- newTemp bWord
461 new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
462 let (caller_save, caller_load) = callerSaveVolatileRegs
463 load_tso <- newTemp gcWord -- TODO FIXME NOW
464 load_stack <- newTemp gcWord -- TODO FIXME NOW
465 let (<**>) = (M.<*>)
466 let suspendThread = foreignLbl "suspendThread"
467 resumeThread = foreignLbl "resumeThread"
468 foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit name)))
469 suspend = saveThreadState <**>
470 caller_save <**>
471 mkUnsafeCall (ForeignTarget suspendThread
472 (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
473 [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum intrbl)) wordWidth)]
474 midCall = mkUnsafeCall tgt rs as
475 resume = mkUnsafeCall (ForeignTarget resumeThread
476 (ForeignConvention CCallConv [AddrHint] [AddrHint]))
477 [new_base] [CmmReg (CmmLocal id)] <**>
478 -- Assign the result to BaseReg: we
479 -- might now have a different Capability!
480 mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <**>
481 caller_load <**>
482 loadThreadState load_tso load_stack
483 -- We have to save the return value on the stack because its next use
484 -- may appear in a different procedure due to procpoint splitting...
485 saveRetVals = foldl (<**>) emptyAGraph $ map (M.mkMiddle . spill) rs
486 spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
487 regSlot r@(LocalReg _ _) = CmmRegOff (CmmGlobal Sp) (sp_off - offset)
488 where offset = w + expectJust "lowerForeign" (Map.lookup (RegSlot r) areaMap)
489 sp_off = wORD_SIZE + expectJust "lowerForeign" (Map.lookup (CallArea area) areaMap)
490 area = if succ == entry then Old else Young succ
491 w = widthInBytes $ typeWidth $ localRegType r
492 -- Note: The successor must be a procpoint, and we have already split,
493 -- so we use a jump, not a branch.
494 succLbl = CmmLit (CmmLabel (infoTblLbl succ))
495 jump = CmmCall { cml_target = succLbl, cml_cont = Nothing
496 , cml_args = widthInBytes wordWidth ,cml_ret_args = 0
497 , cml_ret_off = updfr_off}
498 graph' <- liftUniq $ labelAGraph bid $ catAGraphs (map M.mkMiddle m) <**>
499 suspend <**> midCall <**>
500 resume <**> saveRetVals <**> M.mkLast jump
501 return $ blocks `mapUnion` toBlockMap graph'
502 lowerSafeForeignCall _ _ _ _ _ _ = panic "lowerSafeForeignCall was passed something else"
503