CmmBuildInfoTables.hs 28.1 KB
Newer Older
Ian Lynagh's avatar
Ian Lynagh committed
1
#if __GLASGOW_HASKELL__ >= 611
2
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
Ian Lynagh's avatar
Ian Lynagh committed
3
#endif
4 5 6
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
7
module CmmBuildInfoTables
8
    ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
9 10
    , setInfoTableSRT, setInfoTableStackMap
    , TopSRT, emptySRT, srtToData
11
    , bundleCAFs
12 13 14
    , finishInfoTables, lowerSafeForeignCalls
    , cafTransfers, liveSlotTransfers
    , extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls )
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
where

#include "HsVersions.h"

import Constants
import Digraph
import qualified Prelude as P
import Prelude
import Util (sortLe)

import BlockId
import Bitmap
import CLabel
import Cmm hiding (blockId)
import CmmInfo
import CmmProcPointZ
import CmmStackLayout
import CmmTx
import DFMonad
34
import Module
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
35 36 37
import FastString
import ForeignCall
import IdInfo
Ian Lynagh's avatar
Ian Lynagh committed
38
import Data.List
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
39 40 41
import Maybes
import MkZipCfg
import MkZipCfgCmm hiding (CmmAGraph, CmmBlock, CmmTopZ, CmmZ, CmmGraph)
Ian Lynagh's avatar
Ian Lynagh committed
42
import Control.Monad
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
43 44 45 46 47
import Name
import Outputable
import SMRep
import StgCmmClosure
import StgCmmForeign
48
-- import StgCmmMonad
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
49 50 51 52 53 54 55
import StgCmmUtils
import UniqSupply
import ZipCfg hiding (zip, unzip, last)
import qualified ZipCfg as G
import ZipCfgCmmRep
import ZipDataflow

56 57 58 59
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
----------------------------------------------------------------
-- Building InfoTables


-----------------------------------------------------------------------
-- Stack Maps

-- Given a block ID, we return a representation of the layout of the stack,
-- as suspended before entering that block.
-- (For a return site to a function call, the layout does not include the
--  parameter passing area (or the "return address" on the stack)).
-- If the element is `Nothing`, then it represents a word of the stack that
-- does not contain a live pointer.
-- If the element is `Just` a register, then it represents a live spill slot
-- for a pointer; we assume that a pointer is the size of a word.
-- The head of the list represents the young end of the stack where the infotable
-- pointer for the block `Bid` is stored.
-- The infotable pointer itself is not included in the list.
-- Call areas are also excluded from the list: besides the stuff in the update
-- frame (and the return infotable), call areas should never be live across
-- function calls.

-- RTS Invariant: All pointers must be word-aligned because each bit in the bitmap
-- represents a word. Consequently, we have to be careful when we see a live slot
-- on the stack: if we have packed multiple sub-word values into a word,
-- we have to make sure that we only mark the entire word as a non-pointer.

-- Also, don't forget to stop at the old end of the stack (oldByte),
-- which may differ depending on whether there is an update frame.
89 90 91 92 93 94

type RegSlotInfo
   = ( Int	  -- Offset from oldest byte of Old area
     , LocalReg   -- The register
     , Int)       -- Width of the register

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
95 96
live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg]
live_ptrs oldByte slotEnv areaMap bid =
97 98 99 100 101
  -- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
  --                           ppr liveSlots) $
  -- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
  res
  where res = reverse $ slotsToList youngByte liveSlots []
102 103 104 105 106 107 108
 
        slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg]
        -- n starts at youngByte and is decremented down to oldByte
	-- Returns a list, one element per word, with 
	--    (Just r) meaning 'pointer register r is saved here', 
	--    Nothing  meaning 'non-pointer or empty'

109
        slotsToList n [] results | n == oldByte = results -- at old end of stack frame
110

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
111 112 113
        slotsToList n (s : _) _  | n == oldByte =
          pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+>
               ppr n <+> ppr liveSlots <+> ppr youngByte)
114

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
115 116
        slotsToList n _ _ | n < oldByte =
          panic "stack slots not allocated on word boundaries?"
117

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
118 119 120 121 122 123 124 125 126 127
        slotsToList n l@((n', r, w) : rst) results =
          if n == (n' + w) then -- slot's young byte is at n
            ASSERT (not (isPtr r) ||
                    (n `mod` wORD_SIZE == 0 && w == wORD_SIZE)) -- ptrs must be aligned
            slotsToList next (dropWhile (non_ptr_younger_than next) rst)
                        (stack_rep : results)
          else slotsToList next (dropWhile (non_ptr_younger_than next) l)
                           (Nothing : results)
          where next = n - wORD_SIZE
                stack_rep = if isPtr r then Just r else Nothing
128

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
129
        slotsToList n [] results = slotsToList (n - wORD_SIZE) [] (Nothing : results)
130

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
131 132 133 134 135
        non_ptr_younger_than next (n', r, w) =
          n' + w > next &&
            ASSERT (not (isPtr r))
            True
        isPtr = isGcPtrType . localRegType
136 137

        liveSlots :: [RegSlotInfo]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
138
        liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
139
                           (Map.foldRightWithKey (\_ -> flip $ foldl add_slot) [] slots)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
140
                    
141
        add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
142 143
        add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) = 
          if off == w && widthInBytes (typeWidth ty) == w then
144
            (expectJust "add_slot" (Map.lookup a areaMap), r, w) : rst
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
145
          else panic "live_ptrs: only part of a variable live at a proc point"
146
        add_slot rst (CallArea Old, _, _) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
147 148
          rst -- the update frame (or return infotable) should be live
              -- would be nice to check that only that part of the callarea is live...
149
        add_slot rst ((CallArea _), _, _) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
150 151 152 153 154 155 156 157
          rst
          -- JD: THIS ISN'T CURRENTLY A CORRECTNESS PROBLEM, BUT WE SHOULD REALLY
          -- MAKE LIVENESS INFO AROUND CALLS MORE PRECISE -- FOR NOW, A 32-BIT
          -- FLOAT PADS OUT TO 64 BITS, BUT WE ASSUME THE WHOLE PARAMETER-PASSING
          -- AREA IS LIVE (WHICH IT ISN'T...).  WE SHOULD JUST PUT THE LIVE AREAS
          -- IN THE CALL NODES, WHICH SHOULD EVENTUALLY HAVE LIVE REGISTER AS WELL,
          -- SO IT'S ALL GOING IN THE SAME DIRECTION.
          -- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c)
158 159

        slots :: SubAreaSet	 -- The SubAreaSet for 'bid'
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
160
        slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
161
        youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
162 163 164 165

-- Construct the stack maps for the given procedure.
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables 
setInfoTableStackMap _ _ t@(NoInfoTable _) = t
166
setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
167 168
  updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
setInfoTableStackMap slotEnv areaMap
169
     t@(ProcInfoTable (CmmProc (CmmInfo _ _ _) _ _ ((_, Just updfr_off), _)) procpoints) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
170
  case blockSetToList procpoints of
171 172
    [bid] -> updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
    _ -> panic "setInfoTableStackMap: unexpected number of procpoints"
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
173
           -- until we stop splitting the graphs at procpoints in the native path
174 175
setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" (ppr t)
                 
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192


-----------------------------------------------------------------------
-- SRTs

-- WE NEED AN EXAMPLE HERE.
-- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN
-- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED
-- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT).
-- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY
-- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
-- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).


-----------------------------------------------------------------------
-- Finding the CAFs used by a procedure

193
type CAFSet = Map CLabel ()
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
194 195 196 197
type CAFEnv = BlockEnv CAFSet

-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
198 199 200 201 202
cafLattice = DataflowLattice "live cafs" Map.empty add False
  where add new old = if Map.size new' > Map.size old
                      then aTx new'
                      else noTx new'
          where new' = new `Map.union` old
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
203 204 205

cafTransfers :: BackwardTransfers Middle Last CAFSet
cafTransfers = BackwardTransfers first middle last
206 207 208 209 210 211 212 213
  where first  _ live = live
        middle m live = foldExpDeepMiddle addCaf m live
        last   l env  = foldExpDeepLast   addCaf l (joinOuts cafLattice env l)
        addCaf e set = case e of
               CmmLit (CmmLabel c)              -> add c set
               CmmLit (CmmLabelOff c _)         -> add c set
               CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
               _ -> set
214
        add l s = if hasCAF l then Map.insert (cvtToClosureLbl l) () s else s
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
215 216 217 218 219 220 221 222 223 224 225 226 227 228 229

type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv
cafAnal g = liftM zdfFpFacts (res :: CafFix ())
  where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice
                            cafTransfers (fact_bot cafLattice) g

-----------------------------------------------------------------------
-- Building the SRTs

-- Description of the SRT for a given module.
-- Note that this SRT may grow as we greedily add new CAFs to it.
data TopSRT = TopSRT { lbl      :: CLabel
                     , next_elt :: Int -- the next entry in the table
                     , rev_elts :: [CLabel]
230
                     , elt_map  :: Map CLabel Int }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
231 232 233 234 235 236 237 238
                        -- map: CLabel -> its last entry in the table
instance Outputable TopSRT where
  ppr (TopSRT lbl next elts eltmap) =
    text "TopSRT:" <+> ppr lbl <+> ppr next <+> ppr elts <+> ppr eltmap

emptySRT :: MonadUnique m => m TopSRT
emptySRT =
  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 }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
240 241

cafMember :: TopSRT -> CLabel -> Bool
242
cafMember srt lbl = Map.member lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
243 244

cafOffset :: TopSRT -> CLabel -> Maybe Int
245
cafOffset srt lbl = Map.lookup lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
246 247 248 249 250

addCAF :: CLabel -> TopSRT -> TopSRT
addCAF caf srt =
  srt { next_elt = last + 1
      , rev_elts = caf : rev_elts srt
251
      , elt_map  = Map.insert caf last (elt_map srt) }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
252 253 254 255 256 257 258 259 260 261 262 263 264 265
    where last  = next_elt srt

srtToData :: TopSRT -> CmmZ
srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)]
    where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))

-- Once we have found the CAFs, we need to do two things:
-- 1. Build a table of all the CAFs used in the procedure.
-- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
--
-- When building the local view of the SRT, we first make sure that all the CAFs are 
-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
266
buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
267 268
             FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
buildSRTs topSRT topCAFMap cafs =
269
  do let liftCAF lbl () z = -- get CAFs for functions without static closures
270 271
           case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs
                                            Nothing   -> Map.insert lbl () z
272 273
         -- For each label referring to a function f without a static closure,
         -- replace it with the CAFs that are reachable from f.
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
274
         sub_srt topSRT localCafs =
275
           let cafs = Map.keys (Map.foldRightWithKey liftCAF Map.empty localCafs)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
276 277 278
               mkSRT topSRT =
                 do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
                    return (topSRT, localSRTs)
279
           in if length cafs > maxBmpSize then
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
280 281 282 283 284 285 286 287 288 289 290
                mkSRT (foldl add_if_missing topSRT cafs)
              else -- make sure all the cafs are near the bottom of the srt
                mkSRT (add_if_too_far topSRT cafs)
         add_if_missing srt caf =
           if cafMember srt caf then srt else addCAF caf srt
         -- If a CAF is more than maxBmpSize entries from the young end of the
         -- SRT, then we add it to the SRT again.
         -- (Note: Not in the SRT => infinitely far.)
         add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
           add srt (sortBy farthestFst cafs)
             where
291
               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308
                                   (Nothing, Nothing) -> EQ
                                   (Nothing, Just _)  -> LT
                                   (Just _,  Nothing) -> GT
                                   (Just d, Just d')  -> compare d' d
               add srt [] = srt
               add srt@(TopSRT {next_elt = next}) (caf : rst) =
                 case cafOffset srt caf of
                   Just ix -> if next - ix > maxBmpSize then
                                add (addCAF caf srt) rst
                              else srt
                   Nothing -> add (addCAF caf srt) rst
     (topSRT, subSRTs) <- sub_srt topSRT cafs
     let (sub_tbls, blockSRTs) = subSRTs
     return (topSRT, sub_tbls, blockSRTs)

-- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
309
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
310
                FuelMonad (Maybe CmmTopZ, C_SRT)
311
procpointSRT _ _ [] =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
312 313 314 315 316
 return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries =
 do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
    return (top, srt)
  where
317
    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346
    sorted_ints = sortLe (<=) ints
    offset = head sorted_ints
    bitmap_entries = map (subtract offset) sorted_ints
    len = P.last bitmap_entries + 1
    bitmap = intsToBitmap len bitmap_entries

maxBmpSize :: Int
maxBmpSize = widthInBits wordWidth `div` 2

-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT)
to_SRT top_srt off len bmp
  | len > maxBmpSize || bmp == [fromIntegral srt_escape]
  = do id <- getUniqueM
       let srt_desc_lbl = mkLargeSRTLabel id
           tbl = CmmData RelocatableReadOnlyData $
                   CmmDataLabel srt_desc_lbl : map CmmStaticLit
                     ( cmmLabelOffW top_srt off
                     : mkWordCLit (fromIntegral len)
                     : map mkWordCLit bmp)
       return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
  | otherwise
  = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
	-- The fromIntegral converts to StgHalfWord

-- Gather CAF info for a procedure, but only if the procedure
-- doesn't have a static closure.
-- (If it has a static closure, it will already have an SRT to
--  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.
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
349
localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
350
localCAFInfo _      (CmmData _ _) = Nothing
351
localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368
  case infoTbl of
    CmmInfoTable False _ _ _ ->
      Just (cvtToClosureLbl top_l,
            expectJust "maybeBindCAFs" $ lookupBlockEnv cafEnv entry)
    _ -> Nothing

-- Once we have the local CAF sets for some (possibly) mutually
-- recursive functions, we can create an environment mapping
-- each function to its set of CAFs. Note that a CAF may
-- be a reference to a function. If that function f does not have
-- a static closure, then we need to refer specifically
-- to the set of CAFs used by f. Of course, the set of CAFs
-- used by f must be included in the local CAF sets that are input to
-- this function. To minimize lookup time later, we return
-- the environment with every reference to f replaced by its set of CAFs.
-- To do this replacement efficiently, we gather strongly connected
-- components, then we sort the components in topological order.
369 370
mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet
mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
371
  where addToTop env (AcyclicSCC (l, cafset)) =
372
          Map.insert l (flatten env cafset) env
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
373 374
        addToTop env (CyclicSCC nodes) =
          let (lbls, cafsets) = unzip nodes
375 376 377
              cafset  = lbls `Map.deleteList` foldl Map.union Map.empty cafsets
          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
        flatten env cafset = Map.foldRightWithKey (lookup env) Map.empty cafset
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
378
        lookup env caf () cafset' =
379 380 381
          case Map.lookup caf env of Just cafs -> Map.foldRightWithKey add cafset' cafs
                                     Nothing -> add caf () cafset'
        add caf () cafset' = Map.insert caf () cafset'
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
382
        g = stronglyConnCompFromEdgedVertices
383
              (map (\n@(l, cafs) -> (n, l, Map.keys cafs)) localCAFs)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
384 385 386

type StackLayout = [Maybe LocalReg]

387 388 389 390
-- Bundle the CAFs used at a procpoint.
bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables)
bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
  case blockSetToList procpoints of
391
    [bid] -> (expectJust "bundleCAFs" (lookupBlockEnv cafEnv bid), t)
392 393 394 395
    _     -> panic "setInfoTableStackMap: unexpect number of procpoints"
             -- until we stop splitting the graphs at procpoints in the native path
bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
  (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
396
bundleCAFs _ t@(NoInfoTable _) = (Map.empty, t)
397

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
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)) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
402
  case blockSetToList procpoints of
403 404 405 406
    [_] -> setSRT cafs topCAFMap topSRT t
    _   -> panic "setInfoTableStackMap: unexpect number of procpoints"
           -- until we stop splitting the graphs at procpoints in the native path
setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) =
407 408 409
  setSRT cafs topCAFMap topSRT t
setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])

410
setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
411 412 413
          CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
setSRT cafs topCAFMap topSRT t =
  do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
414 415 416 417 418 419 420 421 422 423 424
     let t' = updInfo id (const srt) t
     case cafTable of
       Just tbl -> return (topSRT, [t', NoInfoTable tbl])
       Nothing  -> return (topSRT, [t'])

updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) ->
           CmmTopForInfoTables -> CmmTopForInfoTables 
updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints) =
  ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints
updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) =
  FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off
425
updInfo _ _ (NoInfoTable _) = panic "can't update NoInfoTable"
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
426 427 428 429 430 431 432 433 434 435 436
updInfo _ _ _ = panic "unexpected arg to updInfo"

updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo 
updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo))
  = CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo')
    where typeinfo' = case typeinfo of
            t@(ConstrInfo _ _ _)    -> t
            (FunInfo    c s a d e)  -> FunInfo c (toSrt s) a d e
            (ThunkInfo  c s)        -> ThunkInfo c (toSrt s)
            (ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
            (ContInfo v s)          -> ContInfo (toVars v) (toSrt s)
437
updInfoTbl _ _ t@(CmmInfo _ _ CmmNonInfoTable) = t
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
438 439 440 441 442 443 444 445 446 447 448 449 450 451 452
  
-- Lower the CmmTopForInfoTables type down to good old CmmTopZ
-- by emitting info tables as data where necessary.
finishInfoTables :: CmmTopForInfoTables -> IO [CmmTopZ]
finishInfoTables (NoInfoTable t) = return [t]
finishInfoTables (ProcInfoTable p _) = return [p]
finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
  do uniq_supply <- mkSplitUniqSupply 'i'
     return $ mkBareInfoTable (retPtLbl bid) (uniqFromSupply uniq_supply) infotbl

----------------------------------------------------------------
-- Safe foreign calls:
-- Our analyses capture the dataflow facts at block boundaries, but we need
-- to extend the CAF and live-slot analyses to safe foreign calls as well,
-- which show up as middle nodes.
453 454 455 456 457 458 459 460 461
extendEnvWithSafeForeignCalls ::
  BackwardTransfers Middle Last a -> BlockEnv a -> CmmGraph -> BlockEnv a
extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g
  where block b z =
          tail (bt_last_in transfers l (lookup env)) z head
           where (head, last) = goto_end (G.unzip b)
                 l = case last of LastOther l -> l
                                  LastExit -> panic "extendEnvs lastExit"
        tail _ z (ZFirst _) = z
462
        tail fact env (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
463 464 465 466 467 468
          tail (mid m fact) (extendBlockEnv env bid fact) h
        tail fact env (ZHead h m) = tail (mid m fact) env h
        lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k
        mid = bt_middle_in transfers


dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
469 470 471
extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
extendEnvsForSafeForeignCalls cafEnv slotEnv g =
  fold_blocks block (cafEnv, slotEnv) g
472
    where block b z =
473 474
            tail ( bt_last_in cafTransfers      l (lookupFn cafEnv)
                 , bt_last_in liveSlotTransfers l (lookupFn slotEnv))
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
475 476 477 478
                 z head
             where (head, last) = goto_end (G.unzip b)
                   l = case last of LastOther l -> l
                                    LastExit -> panic "extendEnvs lastExit"
479
          tail _ z (ZFirst _) = z
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
480
          tail lives@(cafs, slots) (cafEnv, slotEnv)
481
               (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
482 483 484 485 486 487 488
            let slots'   = removeLiveSlotDefs slots m
                slotEnv' = extendBlockEnv slotEnv bid slots'
                cafEnv'  = extendBlockEnv cafEnv  bid cafs
            in  tail (upd lives m) (cafEnv', slotEnv') h
          tail lives z (ZHead h m) = tail (upd lives m) z h
          lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k
          upd (cafs, slots) m =
489
            (bt_middle_in cafTransfers m cafs, bt_middle_in liveSlotTransfers m slots)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523

-- Safe foreign calls: We need to insert the code that suspends and resumes
-- the thread before and after a safe foreign call.
-- Why do we do this so late in the pipeline?
-- Because we need this code to appear without interrruption: you can't rely on the
-- value of the stack pointer between the call and resetting the thread state;
-- you need to have an infotable on the young end of the stack both when
-- suspending the thread and making the foreign call.
-- All of this is much easier if we insert the suspend and resume calls here.

-- At the same time, we prepare for the stages of the compiler that
-- build the proc points. We have to do this at the same time because
-- the safe foreign calls need special treatment with respect to infotables.
-- A safe foreign call needs an infotable even though it isn't
-- a procpoint. The following datatype captures the information
-- needed to generate the infotables along with the Cmm data and procedures.

data CmmTopForInfoTables
  = NoInfoTable       CmmTopZ  -- must be CmmData
  | ProcInfoTable     CmmTopZ BlockSet -- CmmProc; argument is its set of procpoints
  | FloatingInfoTable CmmInfo BlockId UpdFrameOffset
instance Outputable CmmTopForInfoTables where
  ppr (NoInfoTable t) = text "NoInfoTable: " <+> ppr t
  ppr (ProcInfoTable t bids) = text "ProcInfoTable: " <+> ppr t <+> ppr bids
  ppr (FloatingInfoTable info bid upd) =
    text "FloatingInfoTable: " <+> ppr info <+> ppr bid <+> ppr upd

-- The `safeState' record collects the info we update while lowering the
-- safe foreign calls in the graph.
data SafeState = State { s_blocks    :: BlockEnv CmmBlock
                       , s_pps       :: ProcPointSet
                       , s_safeCalls :: [CmmTopForInfoTables]}

lowerSafeForeignCalls
524 525
  :: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
526
lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
527
  let init = return $ State emptyBlockEnv emptyBlockSet []
528
  let block b@(Block bid _) z = do
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
529 530 531 532 533 534 535
        state@(State {s_pps = ppset, s_blocks = blocks}) <- z
        let ppset' = if bid == entry then extendBlockSet ppset bid else ppset
            state' = state { s_pps = ppset' }
        if hasSafeForeignCall b
         then lowerSafeCallBlock state' b
         else return (state' { s_blocks = insertBlock b blocks })
  State blocks' g_procpoints safeCalls <- fold_blocks block init g
536 537 538 539 540
  let proc = (CmmProc info l args (off, LGraph entry blocks'))
      procTable = case off of
                    (_, Just _) -> [ProcInfoTable proc g_procpoints]
                    _ -> [NoInfoTable proc] -- not a successor of a call
  return $ safeCalls : procTable : rst
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
541 542 543

-- Check for foreign calls -- if none, then we can avoid copying the block.
hasSafeForeignCall :: CmmBlock -> Bool
544
hasSafeForeignCall (Block _ t) = tail t
545
  where tail (ZTail (MidForeignCall (Safe _ _ _) _ _ _) _) = True
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
546 547 548 549 550 551 552 553
        tail (ZTail _ t) = tail t
        tail (ZLast _)   = False

-- Lower each safe call in the block, update the CAF and slot environments
-- to include each of those calls, and insert the new block in the blockEnv.
lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState
lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
  where (head, last) = goto_end (G.unzip b)
554
        tail s b@(ZBlock (ZFirst _) _) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
555 556
          do state <- s
             return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
557
        tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off _) _ _ _)) t) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
558 559 560 561 562 563 564 565 566 567 568 569 570
          do state <- s
             let state' = state
                   { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
                                     s_safeCalls state }
             (state'', t') <- lowerSafeForeignCall state' m t
             tail (return state'') (ZBlock h t')
        tail s (ZBlock (ZHead h m) t) = tail s (ZBlock h (ZTail m t))
           

-- Late in the code generator, we want to insert the code necessary
-- to lower a safe foreign call to a sequence of unsafe calls.
lowerSafeForeignCall ::
  SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
571
lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _ interruptible) _ _ _) tail = do
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
572 573 574 575 576 577 578
    let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
    -- Both 'id' and 'new_base' are KindNonPtr because they're
    -- RTS-only objects and are not subject to garbage collection
    id <- newTemp bWord
    new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
    let (caller_save, caller_load) = callerSaveVolatileRegs 
    load_tso <- newTemp gcWord -- TODO FIXME NOW
579 580
    let suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
        resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
581 582 583 584
        suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
                  saveThreadState <*>
                  caller_save <*>
                  mkUnsafeCall (ForeignTarget suspendThread
585 586 587
                                  (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
                    -- XXX Not sure if the size of the CmmInt is correct
                    [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum interruptible)) wordWidth)]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
588 589 590 591 592 593 594 595 596 597 598 599
        resume = mkUnsafeCall (ForeignTarget resumeThread
                                  (ForeignConvention CCallConv [AddrHint] [AddrHint]))
                    [new_base] [CmmReg (CmmLocal id)] <*>
                 -- Assign the result to BaseReg: we
                 -- might now have a different Capability!
                 mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
                 caller_load <*>
                 loadThreadState load_tso
    Graph tail' blocks' <-
      liftUniq (graphOfAGraph (suspend <*> mkMiddle m <*> resume <*> mkZTail tail))
    return (state {s_blocks = s_blocks state `plusBlockEnv` blocks'}, tail')
lowerSafeForeignCall _ _ _ = panic "lowerSafeForeignCall was passed something else"