compiler/cmm/CmmBuildInfoTables.hs

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