CmmBuildInfoTables.hs 23.4 KB
Newer Older
1
{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
Ian Lynagh's avatar
Ian Lynagh committed
2 3 4 5 6 7 8
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

9
-- Norman likes local bindings
Ian Lynagh's avatar
Ian Lynagh committed
10 11
-- If this module lives on I'd like to get rid of the -XNoMonoLocalBinds
-- flag in due course
12

Ian Lynagh's avatar
Ian Lynagh committed
13
-- Todo: remove -fno-warn-warnings-deprecations
14
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
15
module CmmBuildInfoTables
16
    ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
17 18
    , setInfoTableSRT, setInfoTableStackMap
    , TopSRT, emptySRT, srtToData
19
    , bundleCAFs
20
    , lowerSafeForeignCalls
21 22
    , cafTransfers, liveSlotTransfers
    , mkLiveness )
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
23 24 25 26
where

#include "HsVersions.h"

27 28 29 30
-- These should not be imported here!
import StgCmmForeign
import StgCmmUtils

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
31 32 33
import Constants
import Digraph
import qualified Prelude as P
34
import Prelude hiding (succ)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
35 36 37 38 39
import Util (sortLe)

import BlockId
import Bitmap
import CLabel
40
import Cmm
41
import CmmUtils
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
42
import CmmStackLayout
43
import Module
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
44 45 46
import FastString
import ForeignCall
import IdInfo
Ian Lynagh's avatar
Ian Lynagh committed
47
import Data.List
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
48
import Maybes
49
import MkGraph as M
Ian Lynagh's avatar
Ian Lynagh committed
50
import Control.Monad
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
51
import Name
52
import OptimizationFuel
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
53
import Outputable
54
import Platform
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
55 56
import SMRep
import UniqSupply
57

Simon Marlow's avatar
Simon Marlow committed
58
import Hoopl
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
59

60 61
import Data.Map (Map)
import qualified Data.Map as Map
62 63
import Data.Set (Set)
import qualified Data.Set as Set
64 65
import qualified FiniteMap as Map

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94
----------------------------------------------------------------
-- 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.
95 96 97 98 99 100

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

101
live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> StackLayout
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
102
live_ptrs oldByte slotEnv areaMap bid =
103 104 105 106
  -- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
  --                           ppr liveSlots) $
  -- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
  res
107 108
  where 
        res = mkLiveness (reverse $ slotsToList youngByte liveSlots [])
109 110 111 112 113 114 115
 
        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'

116
        slotsToList n [] results | n == oldByte = results -- at old end of stack frame
117

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
118 119 120
        slotsToList n (s : _) _  | n == oldByte =
          pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+>
               ppr n <+> ppr liveSlots <+> ppr youngByte)
121

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

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
125 126 127 128 129 130 131 132 133 134
        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
135

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

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
138 139 140 141 142
        non_ptr_younger_than next (n', r, w) =
          n' + w > next &&
            ASSERT (not (isPtr r))
            True
        isPtr = isGcPtrType . localRegType
143 144

        liveSlots :: [RegSlotInfo]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
145
        liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
146
                           (Map.foldRightWithKey (\_ -> flip $ foldl add_slot) [] slots)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
147
                    
148
        add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
149 150
        add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) = 
          if off == w && widthInBytes (typeWidth ty) == w then
151
            (expectJust "add_slot" (Map.lookup a areaMap), r, w) : rst
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
152
          else panic "live_ptrs: only part of a variable live at a proc point"
153
        add_slot rst (CallArea Old, _, _) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
154 155
          rst -- the update frame (or return infotable) should be live
              -- would be nice to check that only that part of the callarea is live...
156
        add_slot rst ((CallArea _), _, _) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
157 158 159 160 161 162 163 164
          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)
165 166

        slots :: SubAreaSet	 -- The SubAreaSet for 'bid'
167
        slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv
168
        youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
169

170 171 172
-- Construct the stack maps for a procedure _if_ it needs an infotable.
-- When wouldn't a procedure need an infotable? If it is a procpoint that
-- is not the successor of a call.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
173
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmDecl -> CmmDecl
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
174
setInfoTableStackMap slotEnv areaMap
175 176 177
     t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _ 
                (CmmGraph {g_entry = eid}))
  = updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
178
setInfoTableStackMap _ _ t = t
179
                 
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196


-----------------------------------------------------------------------
-- 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

197
type CAFSet = Set CLabel
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
198 199 200 201
type CAFEnv = BlockEnv CAFSet

-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
202 203 204
cafLattice = DataflowLattice "live cafs" Set.empty add
  where add _ (OldFact old) (NewFact new) = case old `Set.union` new of
                                              new' -> (changeIf $ Set.size new' > Set.size old, new')
205

206 207
cafTransfers :: Platform -> BwdTransfer CmmNode CAFSet
cafTransfers platform = mkBTransfer3 first middle last
208
  where first  _ live = live
209 210
        middle m live = {-# SCC middle #-} foldExpDeep addCaf m live
        last   l live = {-# SCC last #-} foldExpDeep addCaf l (joinOutFacts cafLattice l live)
211 212 213 214 215
        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
216
        add l s = if hasCAF l then Set.insert (toClosureLbl platform l) s
217
                              else s
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
218

219 220
cafAnal :: Platform -> CmmGraph -> FuelUniqSM CAFEnv
cafAnal platform g
Simon Marlow's avatar
Simon Marlow committed
221
    = dataflowAnalBwd g [] $ analBwd cafLattice (cafTransfers platform)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
222 223 224 225 226 227 228 229 230

-----------------------------------------------------------------------
-- 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]
231
                     , elt_map  :: Map CLabel Int }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
232
                        -- map: CLabel -> its last entry in the table
233 234 235 236 237 238
instance PlatformOutputable TopSRT where
  pprPlatform platform (TopSRT lbl next elts eltmap) =
    text "TopSRT:" <+> pprPlatform platform lbl
                   <+> ppr next
                   <+> pprPlatform platform elts
                   <+> pprPlatform platform eltmap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
239 240 241 242

emptySRT :: MonadUnique m => m TopSRT
emptySRT =
  do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
243
     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
244 245

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

cafOffset :: TopSRT -> CLabel -> Maybe Int
249
cafOffset srt lbl = Map.lookup lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
250 251 252 253 254

addCAF :: CLabel -> TopSRT -> TopSRT
addCAF caf srt =
  srt { next_elt = last + 1
      , rev_elts = caf : rev_elts srt
255
      , elt_map  = Map.insert caf last (elt_map srt) }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
256 257
    where last  = next_elt srt

Simon Peyton Jones's avatar
Simon Peyton Jones committed
258
srtToData :: TopSRT -> CmmGroup
259
srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
260 261 262 263 264 265 266 267 268 269
    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.
270
buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
Simon Peyton Jones's avatar
Simon Peyton Jones committed
271
             FuelUniqSM (TopSRT, Maybe CmmDecl, C_SRT)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
272
buildSRTs topSRT topCAFMap cafs =
273 274 275
  do let liftCAF lbl z = -- get CAFs for functions without static closures
           case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs
                                            Nothing   -> Set.insert lbl z
276 277
         -- 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
278
         sub_srt topSRT localCafs =
279
           let cafs = Set.elems (Set.foldr liftCAF Set.empty localCafs)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
280 281 282
               mkSRT topSRT =
                 do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
                    return (topSRT, localSRTs)
283
           in if length cafs > maxBmpSize then
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
284 285 286 287 288 289 290 291 292 293 294
                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
295
               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312
                                   (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.
313
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
Simon Peyton Jones's avatar
Simon Peyton Jones committed
314
                FuelUniqSM (Maybe CmmDecl, C_SRT)
315
procpointSRT _ _ [] =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
316 317 318 319 320
 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
321
    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
322 323 324 325 326 327 328 329 330 331
    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.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
332
to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmDecl, C_SRT)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
333 334 335 336 337
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 $
338
                   Statics srt_desc_lbl $ map CmmStaticLit
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
339 340 341 342 343 344 345 346 347 348 349 350
                     ( 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.)
351
-- Any procedure referring to a non-static CAF c must keep live
352
-- any CAF that is reachable from c.
353 354 355
localCAFInfo :: Platform -> CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet)
localCAFInfo _        _      (CmmData _ _) = Nothing
localCAFInfo platform cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
356
  case info_tbl top_info of
357 358
    CmmInfoTable { cit_rep = rep } 
      | not (isStaticRep rep) 
359
      -> Just (toClosureLbl platform top_l,
360
               expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
361 362 363 364 365 366 367 368 369 370 371 372 373
    _ -> 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.
374 375
mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet
mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
376
  where addToTop env (AcyclicSCC (l, cafset)) =
377
          Map.insert l (flatten env cafset) env
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
378 379
        addToTop env (CyclicSCC nodes) =
          let (lbls, cafsets) = unzip nodes
380
              cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
381
          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
382 383 384 385 386
        flatten env cafset = Set.foldr (lookup env) Set.empty cafset
        lookup env caf cafset' =
          case Map.lookup caf env of Just cafs -> Set.foldr add cafset' cafs
                                     Nothing -> add caf cafset'
        add caf cafset' = Set.insert caf cafset'
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
387
        g = stronglyConnCompFromEdgedVertices
388
              (map (\n@(l, cafs) -> (n, l, Set.elems cafs)) localCAFs)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
389

390
-- Bundle the CAFs used at a procpoint.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
391
bundleCAFs :: CAFEnv -> CmmDecl -> (CAFSet, CmmDecl)
392 393
bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
  (expectJust "bundleCAFs" (mapLookup entry cafEnv), t)
394
bundleCAFs _ t = (Set.empty, t)
395

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
396
-- Construct the SRTs for the given procedure.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
397 398
setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) ->
                   FuelUniqSM (TopSRT, [CmmDecl])
399
setInfoTableSRT topCAFMap topSRT (cafs, t) =
400 401
  setSRT cafs topCAFMap topSRT t

402
setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
Simon Peyton Jones's avatar
Simon Peyton Jones committed
403
          CmmDecl -> FuelUniqSM (TopSRT, [CmmDecl])
404 405
setSRT cafs topCAFMap topSRT t =
  do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
406 407
     let t' = updInfo id (const srt) t
     case cafTable of
408
       Just tbl -> return (topSRT, [t', tbl])
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
409 410
       Nothing  -> return (topSRT, [t'])

411 412
type StackLayout = Liveness

Simon Peyton Jones's avatar
Simon Peyton Jones committed
413
updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
414 415 416 417 418
updInfo toVars toSrt (CmmProc top_info top_l g) =
  CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
updInfo _ _ t = t

updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
419 420 421 422 423
updInfoTbl toVars toSrt info_tbl@(CmmInfoTable {})
  = info_tbl { cit_srt = toSrt (cit_srt info_tbl)
             , cit_rep = case cit_rep info_tbl of
                           StackRep ls -> StackRep (toVars ls)
                           other       -> other }
424
updInfoTbl _ _ t@CmmNonInfoTable = t
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442
  
----------------------------------------------------------------
-- 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.

443
-- JD: Why not do this while splitting procedures?
Simon Peyton Jones's avatar
Simon Peyton Jones committed
444
lowerSafeForeignCalls :: AreaMap -> CmmDecl -> FuelUniqSM CmmDecl
445 446 447 448 449 450 451 452 453 454 455 456 457 458
lowerSafeForeignCalls _ t@(CmmData _ _) = return t
lowerSafeForeignCalls areaMap (CmmProc info l g@(CmmGraph {g_entry=entry})) = do
  let block b mblocks = mblocks >>= lowerSafeCallBlock entry areaMap b
  blocks <- foldGraphBlocks block (return mapEmpty) g
  return $ CmmProc info l (ofBlockMap entry blocks)

-- If the block ends with a safe call in the block, lower it to an unsafe
-- call (with appropriate saves and restores before and after).
lowerSafeCallBlock :: BlockId -> AreaMap -> CmmBlock -> BlockEnv CmmBlock
                              -> FuelUniqSM (BlockEnv CmmBlock)
lowerSafeCallBlock entry areaMap b blocks =
  case blockToNodeList b of
    (JustC (CmmEntry id), m, JustC l@(CmmForeignCall {})) -> lowerSafeForeignCall entry areaMap blocks id m l
    _                                                    -> return $ insertBlock b blocks
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
459 460 461

-- Late in the code generator, we want to insert the code necessary
-- to lower a safe foreign call to a sequence of unsafe calls.
462 463 464 465 466
lowerSafeForeignCall :: BlockId -> AreaMap -> BlockEnv CmmBlock -> BlockId -> [CmmNode O O] -> CmmNode O C
                                -> FuelUniqSM (BlockEnv CmmBlock)
lowerSafeForeignCall entry areaMap blocks bid m
    (CmmForeignCall {tgt=tgt, res=rs, args=as, succ=succ, updfr = updfr_off, intrbl = intrbl}) =
 do let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
467 468 469 470
    -- 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))
471
    let (caller_save, caller_load) = callerSaveVolatileRegs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
472
    load_tso <- newTemp gcWord -- TODO FIXME NOW
473 474 475 476 477 478 479
    load_stack <- newTemp gcWord -- TODO FIXME NOW
    let (<**>) = (M.<*>)
    let suspendThread = foreignLbl "suspendThread"
        resumeThread  = foreignLbl "resumeThread"
        foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit name)))
        suspend = saveThreadState <**>
                  caller_save <**>
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
480
                  mkUnsafeCall (ForeignTarget suspendThread
481
                                (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
Simon Marlow's avatar
Simon Marlow committed
482
                               [id] [CmmReg (CmmGlobal BaseReg), CmmLit (mkIntCLit (fromEnum intrbl))]
483 484 485 486 487 488 489 490 491 492 493
        midCall = mkUnsafeCall tgt rs as
        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 load_stack
        -- We have to save the return value on the stack because its next use
        -- may appear in a different procedure due to procpoint splitting...
494
        saveRetVals = foldl (<**>) mkNop $ map (M.mkMiddle . spill) rs
495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511
        spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
        regSlot r@(LocalReg _ _) = CmmRegOff (CmmGlobal Sp) (sp_off - offset)
          where offset = w + expectJust "lowerForeign" (Map.lookup (RegSlot r) areaMap)
                sp_off = wORD_SIZE + expectJust "lowerForeign" (Map.lookup (CallArea area) areaMap)
                area = if succ == entry then Old else Young succ
                w = widthInBytes $ typeWidth $ localRegType r
        -- Note: The successor must be a procpoint, and we have already split,
        --       so we use a jump, not a branch.
        succLbl = CmmLit (CmmLabel (infoTblLbl succ))
        jump = CmmCall { cml_target  = succLbl, cml_cont = Nothing
                       , cml_args    = widthInBytes wordWidth ,cml_ret_args = 0
                       , cml_ret_off = updfr_off}
    graph' <- liftUniq $ labelAGraph bid $ catAGraphs (map M.mkMiddle m) <**>
                                           suspend <**> midCall <**>
                                           resume  <**> saveRetVals <**> M.mkLast jump
    return $ blocks `mapUnion` toBlockMap graph'
lowerSafeForeignCall _ _ _ _ _ _ = panic "lowerSafeForeignCall was passed something else"
512