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