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 (CmmDataLabel (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                    CmmDataLabel 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 s p t typeinfo)
 401   = CmmInfoTable 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"