compiler/cmm/CmmBuildInfoTables.hs

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