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