CmmBuildInfoTables.hs 22.8 KB
Newer Older
1
{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
2
3
4
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course

5
6
7
-- Todo: remove

{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
8
module CmmBuildInfoTables
9
    ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
10
11
    , setInfoTableSRT, setInfoTableStackMap
    , TopSRT, emptySRT, srtToData
12
    , bundleCAFs
13
    , lowerSafeForeignCalls
14
15
    , cafTransfers, liveSlotTransfers
    , mkLiveness )
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
16
17
18
19
where

#include "HsVersions.h"

20
21
22
23
-- These should not be imported here!
import StgCmmForeign
import StgCmmUtils

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
24
25
26
import Constants
import Digraph
import qualified Prelude as P
27
import Prelude hiding (succ)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
28
29
30
31
32
import Util (sortLe)

import BlockId
import Bitmap
import CLabel
33
import Cmm
34
import CmmUtils
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
35
import CmmStackLayout
36
import Module
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
37
38
39
import FastString
import ForeignCall
import IdInfo
Ian Lynagh's avatar
Ian Lynagh committed
40
import Data.List
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
41
import Maybes
42
import MkGraph as M
Ian Lynagh's avatar
Ian Lynagh committed
43
import Control.Monad
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
44
import Name
45
import OptimizationFuel
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
46
47
48
import Outputable
import SMRep
import UniqSupply
49
50

import Compiler.Hoopl
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
51

52
53
54
55
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
56
57
58
59
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
----------------------------------------------------------------
-- 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.
85
86
87
88
89
90

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

91
live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> StackLayout
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
92
live_ptrs oldByte slotEnv areaMap bid =
93
94
95
96
  -- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
  --                           ppr liveSlots) $
  -- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
  res
97
98
  where 
        res = mkLiveness (reverse $ slotsToList youngByte liveSlots [])
99
100
101
102
103
104
105
 
        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'

106
        slotsToList n [] results | n == oldByte = results -- at old end of stack frame
107

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

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

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
115
116
117
118
119
120
121
122
123
124
        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
125

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

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

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

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

160
161
162
163
-- 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.
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTop -> CmmTop
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
164
setInfoTableStackMap slotEnv areaMap
165
166
167
     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
168
setInfoTableStackMap _ _ t = t
169
                 
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186


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

187
type CAFSet = Map CLabel ()
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
188
189
190
191
type CAFEnv = BlockEnv CAFSet

-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
192
193
194
195
196
197
cafLattice = DataflowLattice "live cafs" Map.empty add
  where add _ (OldFact old) (NewFact new) = case old `Map.union` new of
                                              new' -> (changeIf $ Map.size new' > Map.size old, new')

cafTransfers :: BwdTransfer CmmNode CAFSet
cafTransfers = mkBTransfer3 first middle last
198
  where first  _ live = live
199
200
        middle m live = foldExpDeep addCaf m live
        last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
201
202
203
204
205
        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
206
        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
207

208
209
cafAnal :: CmmGraph -> FuelUniqSM CAFEnv
cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
210
211
212
213
214
215
216
217
218

-----------------------------------------------------------------------
-- 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]
219
                     , elt_map  :: Map CLabel Int }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
220
221
222
223
224
225
226
227
                        -- 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
228
     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
229
230

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

cafOffset :: TopSRT -> CLabel -> Maybe Int
234
cafOffset srt lbl = Map.lookup lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
235
236
237
238
239

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

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

375
-- Bundle the CAFs used at a procpoint.
376
377
378
379
bundleCAFs :: CAFEnv -> CmmTop -> (CAFSet, CmmTop)
bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
  (expectJust "bundleCAFs" (mapLookup entry cafEnv), t)
bundleCAFs _ t = (Map.empty, t)
380

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
381
-- Construct the SRTs for the given procedure.
382
383
384
setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTop) ->
                   FuelUniqSM (TopSRT, [CmmTop])
setInfoTableSRT topCAFMap topSRT (cafs, t) =
385
386
  setSRT cafs topCAFMap topSRT t

387
setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
388
          CmmTop -> FuelUniqSM (TopSRT, [CmmTop])
389
390
setSRT cafs topCAFMap topSRT t =
  do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
391
392
     let t' = updInfo id (const srt) t
     case cafTable of
393
       Just tbl -> return (topSRT, [t', tbl])
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
394
395
       Nothing  -> return (topSRT, [t'])

396
397
type StackLayout = Liveness

398
399
400
401
402
403
updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmTop -> CmmTop
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
404
405
406
407
408
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 }
409
updInfoTbl _ _ t@CmmNonInfoTable = t
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
  
----------------------------------------------------------------
-- 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.

428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
-- JD: Why not do this while splitting procedures?
lowerSafeForeignCalls :: AreaMap -> CmmTop -> FuelUniqSM CmmTop
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
444
445
446

-- Late in the code generator, we want to insert the code necessary
-- to lower a safe foreign call to a sequence of unsafe calls.
447
448
449
450
451
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
452
453
454
455
    -- 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))
456
    let (caller_save, caller_load) = callerSaveVolatileRegs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
457
    load_tso <- newTemp gcWord -- TODO FIXME NOW
458
459
460
461
462
463
464
    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
465
                  mkUnsafeCall (ForeignTarget suspendThread
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
                                (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
                               [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum intrbl)) wordWidth)]
        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...
        saveRetVals = foldl (<**>) emptyAGraph $ map (M.mkMiddle . spill) rs
        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"
497