compiler/cmm/CmmBuildInfoTables.hs

   1 module CmmBuildInfoTables
   2     ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
   3     , setInfoTableSRT, setInfoTableStackMap
   4     , TopSRT, emptySRT, srtToData
   5     , finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls )
   6 where
   7
   8 #include "HsVersions.h"
   9
  10 import Constants
  11 import Digraph
  12 import qualified Prelude as P
  13 import Prelude
  14 import Util (sortLe)
  15
  16 import BlockId
  17 import Bitmap
  18 import CLabel
  19 import Cmm hiding (blockId)
  20 import CmmExpr
  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 List (sortBy)
  31 import Maybes
  32 import MkZipCfg
  33 import MkZipCfgCmm hiding (CmmAGraph, CmmBlock, CmmTopZ, CmmZ, CmmGraph)
  34 import Monad
  35 import Name
  36 import Outputable
  37 import Panic
  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, off, w) =
 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 c@((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 info bid updfr_off) =
 130   updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
 131 setInfoTableStackMap slotEnv areaMap
 132      t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))
 133                       procpoints) =
 134   case blockSetToList procpoints of
 135     [bid] ->
 136       let oldByte = case infoTbl of
 137                          CmmInfoTable _ _ _ (ContInfo _ _) ->
 138                            case lookupBlockEnv blocks bid of
 139                               Just (Block _ (StackInfo {returnOff = Just n}) _) -> n
 140                               _ -> pprPanic "misformed graph at procpoint" (ppr g)
 141                          _ -> initUpdFrameOff -- entry to top-level function
 142           stack_vars = live_ptrs oldByte slotEnv areaMap bid
 143       in updInfo (const stack_vars) id t
 144     _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
 145            -- until we stop splitting the graphs at procpoints in the native path
 146 setInfoTableStackMap _ _ _ = panic "unexpected case for setInfoTableStackMap"
 147 {-
 148 setInfoTableStackMap slotEnv areaMap
 149       (Just bid, p@(CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))) =
 150   let oldByte = case infoTbl of
 151                      CmmInfoTable _ _ _ (ContInfo _ _) ->
 152                        case lookupBlockEnv blocks bid of
 153                           Just (Block _ (StackInfo {returnOff = Just n}) _) -> n
 154                           _ -> pprPanic "misformed graph at procpoint" (ppr g)
 155                      _ -> initUpdFrameOff -- entry to top-level function
 156       stack_vars = live_ptrs oldByte slotEnv areaMap bid
 157   in (Just bid, upd_info_tbl (const stack_vars) id p)
 158 setInfoTableStackMap _ _ t@(_, CmmData {}) = t
 159 setInfoTableStackMap _ _ _ = panic "bad args to setInfoTableStackMap"
 160 -}
 161
 162
 163 -----------------------------------------------------------------------
 164 -- SRTs
 165
 166 -- WE NEED AN EXAMPLE HERE.
 167 -- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN
 168 -- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED
 169 -- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT).
 170 -- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY
 171 -- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
 172 -- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).
 173
 174
 175 -----------------------------------------------------------------------
 176 -- Finding the CAFs used by a procedure
 177
 178 type CAFSet = FiniteMap CLabel ()
 179 type CAFEnv = BlockEnv CAFSet
 180
 181 -- First, an analysis to find live CAFs.
 182 cafLattice :: DataflowLattice CAFSet
 183 cafLattice = DataflowLattice "live cafs" emptyFM add True
 184   where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new'
 185           where new' = new `plusFM` old
 186
 187 cafTransfers :: BackwardTransfers Middle Last CAFSet
 188 cafTransfers = BackwardTransfers first middle last
 189     where first  live _ = live
 190           middle live m = pprTrace "cafmiddle" (ppr m) $ foldExpDeepMiddle addCaf m live
 191           last   env  l = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
 192           addCaf e set = case e of
 193                  CmmLit (CmmLabel c)              -> add c set
 194                  CmmLit (CmmLabelOff c _)         -> add c set
 195                  CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
 196                  _ -> set
 197           add l s = pprTrace "CAF analysis saw label" (ppr l) $
 198                      if hasCAF l then
 199                        pprTrace "has caf" (ppr l) $ addToFM s (cvtToClosureLbl l) ()
 200                      else (pprTrace "no cafs" (ppr l) $ s)
 201
 202 type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
 203 cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv
 204 cafAnal g = liftM zdfFpFacts (res :: CafFix ())
 205   where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice
 206                             cafTransfers (fact_bot cafLattice) g
 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  :: FiniteMap 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 = emptyFM }
 226
 227 cafMember :: TopSRT -> CLabel -> Bool
 228 cafMember srt lbl = elemFM lbl (elt_map srt)
 229
 230 cafOffset :: TopSRT -> CLabel -> Maybe Int
 231 cafOffset srt lbl = lookupFM (elt_map srt) lbl
 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  = addToFM (elt_map srt) caf last }
 238     where last  = next_elt srt
 239
 240 srtToData :: TopSRT -> CmmZ
 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 -> FiniteMap CLabel CAFSet -> CAFSet ->
 253              FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
 254 buildSRTs topSRT topCAFMap cafs =
 255   -- This is surely the wrong way to get names, as in BlockId
 256   do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
 257      let liftCAF lbl () z = -- get CAFs for functions without static closures
 258            case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
 259                                           Nothing   -> addToFM z lbl ()
 260          sub_srt topSRT localCafs =
 261            let cafs = keysFM (foldFM liftCAF emptyFM localCafs)
 262                mkSRT topSRT =
 263                  do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
 264                     return (topSRT, localSRTs)
 265            in pprTrace "cafs" (ppr cafs) $
 266               if length cafs > maxBmpSize then
 267                 mkSRT (foldl add_if_missing topSRT cafs)
 268               else -- make sure all the cafs are near the bottom of the srt
 269                 mkSRT (add_if_too_far topSRT cafs)
 270          add_if_missing srt caf =
 271            if cafMember srt caf then srt else addCAF caf srt
 272          -- If a CAF is more than maxBmpSize entries from the young end of the
 273          -- SRT, then we add it to the SRT again.
 274          -- (Note: Not in the SRT => infinitely far.)
 275          add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
 276            add srt (sortBy farthestFst cafs)
 277              where
 278                farthestFst x y = case (lookupFM m x, lookupFM m y) of
 279                                    (Nothing, Nothing) -> EQ
 280                                    (Nothing, Just _)  -> LT
 281                                    (Just _,  Nothing) -> GT
 282                                    (Just d, Just d')  -> compare d' d
 283                add srt [] = srt
 284                add srt@(TopSRT {next_elt = next}) (caf : rst) =
 285                  case cafOffset srt caf of
 286                    Just ix -> if next - ix > maxBmpSize then
 287                                 add (addCAF caf srt) rst
 288                               else srt
 289                    Nothing -> add (addCAF caf srt) rst
 290      (topSRT, subSRTs) <- sub_srt topSRT cafs
 291      let (sub_tbls, blockSRTs) = subSRTs
 292      return (topSRT, sub_tbls, blockSRTs)
 293
 294 -- Construct an SRT bitmap.
 295 -- Adapted from simpleStg/SRT.lhs, which expects Id's.
 296 procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] ->
 297                 FuelMonad (Maybe CmmTopZ, C_SRT)
 298 procpointSRT top_srt top_table [] =
 299  return (Nothing, NoC_SRT)
 300 procpointSRT top_srt top_table entries =
 301  do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
 302     return (top, srt)
 303   where
 304     ints = map (expectJust "constructSRT" . lookupFM top_table) entries
 305     sorted_ints = sortLe (<=) ints
 306     offset = head sorted_ints
 307     bitmap_entries = map (subtract offset) sorted_ints
 308     len = P.last bitmap_entries + 1
 309     bitmap = intsToBitmap len bitmap_entries
 310
 311 maxBmpSize :: Int
 312 maxBmpSize = widthInBits wordWidth `div` 2
 313
 314 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
 315 to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT)
 316 to_SRT top_srt off len bmp
 317   | len > maxBmpSize || bmp == [fromIntegral srt_escape]
 318   = do id <- getUniqueM
 319        let srt_desc_lbl = mkLargeSRTLabel id
 320            tbl = CmmData RelocatableReadOnlyData $
 321                    CmmDataLabel srt_desc_lbl : map CmmStaticLit
 322                      ( cmmLabelOffW top_srt off
 323                      : mkWordCLit (fromIntegral len)
 324                      : map mkWordCLit bmp)
 325        return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
 326   | otherwise
 327   = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
 328         -- The fromIntegral converts to StgHalfWord
 329
 330 -- Gather CAF info for a procedure, but only if the procedure
 331 -- doesn't have a static closure.
 332 -- (If it has a static closure, it will already have an SRT to
 333 --  keep its CAFs live.)
 334 localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
 335 localCAFInfo _    t@(CmmData _ _) = Nothing
 336 localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) =
 337   case infoTbl of
 338     CmmInfoTable False _ _ _ ->
 339       Just (cvtToClosureLbl top_l,
 340             expectJust "maybeBindCAFs" $ lookupBlockEnv cafEnv entry)
 341     _ -> Nothing
 342
 343 -- Once we have the local CAF sets for some (possibly) mutually
 344 -- recursive functions, we can create an environment mapping
 345 -- each function to its set of CAFs. Note that a CAF may
 346 -- be a reference to a function. If that function f does not have
 347 -- a static closure, then we need to refer specifically
 348 -- to the set of CAFs used by f. Of course, the set of CAFs
 349 -- used by f must be included in the local CAF sets that are input to
 350 -- this function. To minimize lookup time later, we return
 351 -- the environment with every reference to f replaced by its set of CAFs.
 352 -- To do this replacement efficiently, we gather strongly connected
 353 -- components, then we sort the components in topological order.
 354 mkTopCAFInfo :: [(CLabel, CAFSet)] -> FiniteMap CLabel CAFSet
 355 mkTopCAFInfo localCAFs = foldl addToTop emptyFM g
 356   where addToTop env (AcyclicSCC (l, cafset)) =
 357           addToFM env l (flatten env cafset)
 358         addToTop env (CyclicSCC nodes) =
 359           let (lbls, cafsets) = unzip nodes
 360               cafset  = foldl plusFM  emptyFM cafsets `delListFromFM` lbls
 361           in foldl (\env l -> addToFM env l (flatten env cafset)) env lbls
 362         flatten env cafset = foldFM (lookup env) emptyFM cafset
 363         lookup env caf () cafset' =
 364           case lookupFM env caf of Just cafs -> foldFM add cafset' cafs
 365                                    Nothing -> add caf () cafset'
 366         add caf () cafset' = addToFM cafset' caf ()
 367         g = stronglyConnCompFromEdgedVertices
 368               (map (\n@(l, cafs) -> (n, l, keysFM cafs)) localCAFs)
 369
 370 type StackLayout = [Maybe LocalReg]
 371
 372 -- Construct the SRTs for the given procedure.
 373 setInfoTableSRT :: CAFEnv -> FiniteMap CLabel CAFSet -> TopSRT ->
 374                    CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
 375 setInfoTableSRT cafEnv topCAFMap topSRT t@(ProcInfoTable p procpoints) =
 376   case blockSetToList procpoints of
 377     [bid] -> setSRT cafEnv topCAFMap topSRT t bid
 378     _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
 379            -- until we stop splitting the graphs at procpoints in the native path
 380 setInfoTableSRT cafEnv topCAFMap topSRT t@(FloatingInfoTable info bid _) =
 381   setSRT cafEnv topCAFMap topSRT t bid
 382 setInfoTableSRT _ _ topSRT t@(NoInfoTable _) = return (topSRT, [t])
 383
 384 setSRT :: CAFEnv -> FiniteMap CLabel CAFSet -> TopSRT ->
 385           CmmTopForInfoTables -> BlockId -> FuelMonad (TopSRT, [CmmTopForInfoTables])
 386 setSRT cafEnv topCAFMap topSRT t bid =
 387   do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap
 388                                   (expectJust "sub_srt" $ lookupBlockEnv cafEnv bid)
 389      let t' = updInfo id (const srt) t
 390      case cafTable of
 391        Just tbl -> return (topSRT, [t', NoInfoTable tbl])
 392        Nothing  -> return (topSRT, [t'])
 393
 394 updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) ->
 395            CmmTopForInfoTables -> CmmTopForInfoTables
 396 updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints) =
 397   ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints
 398 updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) =
 399   FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off
 400 updInfo toVars toSrt (NoInfoTable _) = panic "can't update NoInfoTable"
 401 updInfo _ _ _ = panic "unexpected arg to updInfo"
 402
 403 updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo
 404 updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo))
 405   = CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo')
 406     where typeinfo' = case typeinfo of
 407             t@(ConstrInfo _ _ _)    -> t
 408             (FunInfo    c s a d e)  -> FunInfo c (toSrt s) a d e
 409             (ThunkInfo  c s)        -> ThunkInfo c (toSrt s)
 410             (ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
 411             (ContInfo v s)          -> ContInfo (toVars v) (toSrt s)
 412 updInfoTbl toVars toSrt t@(CmmInfo _ _ CmmNonInfoTable) = t
 413
 414 -- Lower the CmmTopForInfoTables type down to good old CmmTopZ
 415 -- by emitting info tables as data where necessary.
 416 finishInfoTables :: CmmTopForInfoTables -> IO [CmmTopZ]
 417 finishInfoTables (NoInfoTable t) = return [t]
 418 finishInfoTables (ProcInfoTable p _) = return [p]
 419 finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
 420   do uniq_supply <- mkSplitUniqSupply 'i'
 421      return $ mkBareInfoTable (retPtLbl bid) (uniqFromSupply uniq_supply) infotbl
 422
 423 ----------------------------------------------------------------
 424 -- Safe foreign calls:
 425 -- Our analyses capture the dataflow facts at block boundaries, but we need
 426 -- to extend the CAF and live-slot analyses to safe foreign calls as well,
 427 -- which show up as middle nodes.
 428 extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
 429 extendEnvsForSafeForeignCalls cafEnv slotEnv g =
 430   fold_blocks block (cafEnv, slotEnv) g
 431     where block b@(Block _ _ t) z =
 432             tail ( bt_last_in cafTransfers      (lookupFn cafEnv)  l
 433                  , bt_last_in liveSlotTransfers (lookupFn slotEnv) l)
 434                  z head
 435              where (head, last) = goto_end (G.unzip b)
 436                    l = case last of LastOther l -> l
 437                                     LastExit -> panic "extendEnvs lastExit"
 438           tail lives z (ZFirst _ _) = z
 439           tail lives@(cafs, slots) (cafEnv, slotEnv)
 440                (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) =
 441             let slots'   = removeLiveSlotDefs slots m
 442                 slotEnv' = extendBlockEnv slotEnv bid slots'
 443                 cafEnv'  = extendBlockEnv cafEnv  bid cafs
 444             in  tail (upd lives m) (cafEnv', slotEnv') h
 445           tail lives z (ZHead h m) = tail (upd lives m) z h
 446           lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k
 447           upd (cafs, slots) m =
 448             (bt_middle_in cafTransfers cafs m, bt_middle_in liveSlotTransfers slots m)
 449
 450 -- Safe foreign calls: We need to insert the code that suspends and resumes
 451 -- the thread before and after a safe foreign call.
 452 -- Why do we do this so late in the pipeline?
 453 -- Because we need this code to appear without interrruption: you can't rely on the
 454 -- value of the stack pointer between the call and resetting the thread state;
 455 -- you need to have an infotable on the young end of the stack both when
 456 -- suspending the thread and making the foreign call.
 457 -- All of this is much easier if we insert the suspend and resume calls here.
 458
 459 -- At the same time, we prepare for the stages of the compiler that
 460 -- build the proc points. We have to do this at the same time because
 461 -- the safe foreign calls need special treatment with respect to infotables.
 462 -- A safe foreign call needs an infotable even though it isn't
 463 -- a procpoint. The following datatype captures the information
 464 -- needed to generate the infotables along with the Cmm data and procedures.
 465
 466 data CmmTopForInfoTables
 467   = NoInfoTable       CmmTopZ  -- must be CmmData
 468   | ProcInfoTable     CmmTopZ BlockSet -- CmmProc; argument is its set of procpoints
 469   | FloatingInfoTable CmmInfo BlockId UpdFrameOffset
 470 instance Outputable CmmTopForInfoTables where
 471   ppr (NoInfoTable t) = text "NoInfoTable: " <+> ppr t
 472   ppr (ProcInfoTable t bids) = text "ProcInfoTable: " <+> ppr t <+> ppr bids
 473   ppr (FloatingInfoTable info bid upd) =
 474     text "FloatingInfoTable: " <+> ppr info <+> ppr bid <+> ppr upd
 475
 476 -- The `safeState' record collects the info we update while lowering the
 477 -- safe foreign calls in the graph.
 478 data SafeState = State { s_blocks    :: BlockEnv CmmBlock
 479                        , s_pps       :: ProcPointSet
 480                        , s_safeCalls :: [CmmTopForInfoTables]}
 481
 482 lowerSafeForeignCalls
 483   :: ProcPointSet ->           [[CmmTopForInfoTables]] ->
 484           CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
 485 lowerSafeForeignCalls _ rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
 486 lowerSafeForeignCalls procpoints rst
 487                       t@(CmmProc info l args g@(LGraph entry off blocks)) = do
 488   let init = return $ State emptyBlockEnv emptyBlockSet []
 489   let block b@(Block bid _ _) z = do
 490         state@(State {s_pps = ppset, s_blocks = blocks}) <- z
 491         let ppset' = if bid == entry then extendBlockSet ppset bid else ppset
 492             state' = state { s_pps = ppset' }
 493         if hasSafeForeignCall b
 494          then lowerSafeCallBlock state' b
 495          else return (state' { s_blocks = insertBlock b blocks })
 496   State blocks' g_procpoints safeCalls <- fold_blocks block init g
 497   return $ (ProcInfoTable (CmmProc info l args (LGraph entry off blocks')) g_procpoints
 498                : safeCalls) : rst
 499
 500 -- Check for foreign calls -- if none, then we can avoid copying the block.
 501 hasSafeForeignCall :: CmmBlock -> Bool
 502 hasSafeForeignCall (Block _ _ t) = tail t
 503   where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) t) = True
 504         tail (ZTail _ t) = tail t
 505         tail (ZLast _)   = False
 506
 507 -- Lower each safe call in the block, update the CAF and slot environments
 508 -- to include each of those calls, and insert the new block in the blockEnv.
 509 lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState
 510 lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
 511   where (head, last) = goto_end (G.unzip b)
 512         tail s b@(ZBlock (ZFirst _ _) _) =
 513           do state <- s
 514              return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
 515         tail  s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) =
 516           do state <- s
 517              let state' = state
 518                    { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
 519                                      s_safeCalls state }
 520              (state'', t') <- lowerSafeForeignCall state' m t
 521              tail (return state'') (ZBlock h t')
 522         tail s (ZBlock (ZHead h m) t) = tail s (ZBlock h (ZTail m t))
 523
 524
 525 -- Late in the code generator, we want to insert the code necessary
 526 -- to lower a safe foreign call to a sequence of unsafe calls.
 527 lowerSafeForeignCall ::
 528   SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
 529 lowerSafeForeignCall state m@(MidForeignCall (Safe infotable updfr) _ _ _) tail = do
 530     let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
 531     -- Both 'id' and 'new_base' are KindNonPtr because they're
 532     -- RTS-only objects and are not subject to garbage collection
 533     id <- newTemp bWord
 534     new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
 535     let (caller_save, caller_load) = callerSaveVolatileRegs
 536     load_tso <- newTemp gcWord -- TODO FIXME NOW
 537     let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
 538         resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
 539         suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
 540                   saveThreadState <*>
 541                   caller_save <*>
 542                   mkUnsafeCall (ForeignTarget suspendThread
 543                                   (ForeignConvention CCallConv [AddrHint] [AddrHint]))
 544                     [id] [CmmReg (CmmGlobal BaseReg)]
 545         resume = mkUnsafeCall (ForeignTarget resumeThread
 546                                   (ForeignConvention CCallConv [AddrHint] [AddrHint]))
 547                     [new_base] [CmmReg (CmmLocal id)] <*>
 548                  -- Assign the result to BaseReg: we
 549                  -- might now have a different Capability!
 550                  mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
 551                  caller_load <*>
 552                  loadThreadState load_tso
 553     Graph tail' blocks' <-
 554       liftUniq (graphOfAGraph (suspend <*> mkMiddle m <*> resume <*> mkZTail tail))
 555     return (state {s_blocks = s_blocks state `plusBlockEnv` blocks'}, tail')
 556 lowerSafeForeignCall _ _ _ = panic "lowerSafeForeignCall was passed something else"