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