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