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