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