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