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