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