compiler/cmm/CmmBuildInfoTables.hs

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