compiler/cmm/CmmBuildInfoTables.hs

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