CgHeapery.lhs 14.2 KB
Newer Older
1
%
2
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
4
% $Id: CgHeapery.lhs,v 1.15 1999/03/08 17:05:41 simonm Exp $
5
6
7
8
9
%
\section[CgHeapery]{Heap management functions}

\begin{code}
module CgHeapery (
10
	fastEntryChecks, altHeapCheck, thunkChecks,
11
	allocDynClosure
12

13
        -- new functions, basically inserting macro calls into Code -- HWL
14
        ,fetchAndReschedule, yield
15
16
    ) where

17
#include "HsVersions.h"
18

19
import AbsCSyn
20
import CLabel
21
22
import CgMonad

23
import CgStackery	( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
24
import SMRep		( fixedHdrSize )
25
import AbsCUtils	( mkAbstractCs, getAmodeRep )
26
import CgUsages		( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
27
28
			  initHeapUsage
			)
29
30
31
import ClosureInfo	( closureSize, closureGoodStuffSize,
			  slopSize, allocProfilingMsg, ClosureInfo,
			  closureSMRep
32
			)
33
34
35
import PrimRep		( PrimRep(..), isFollowableRep )
import CmdLineOpts	( opt_SccProfilingOn )
import GlaExts
36
import Outputable
37
38
39
40

#ifdef DEBUG
import PprAbsC		( pprMagicId ) -- tmp
#endif
41
42
43
44
45
46
47
48
\end{code}

%************************************************************************
%*									*
\subsection[CgHeapery-heap-overflow]{Heap overflow checking}
%*									*
%************************************************************************

49
50
51
52
53
54
55
The new code  for heapChecks. For GrAnSim the code for doing a heap check
and doing a context switch has been separated. Especially, the HEAP_CHK
macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
beginning of every slow entry code in order to simulate the fetching of
closures. If fetching is necessary (i.e. current closure is not local) then
an automatic context switch is done.
56

57
58
59
-----------------------------------------------------------------------------
A heap/stack check at a fast entry point.

60
61
\begin{code}

62
63
64
65
66
67
68
fastEntryChecks
	:: [MagicId]			-- Live registers
	-> [(VirtualSpOffset,Int)]	-- stack slots to tag
	-> CLabel			-- return point
	-> Bool				-- node points to closure
	-> Code
	-> Code
69

70
71
72
73
74
75
fastEntryChecks regs tags ret node_points code
  =  mkTagAssts tags			         `thenFC` \tag_assts ->
     getFinalStackHW				 (\ spHw -> 
     getRealSp					 `thenFC` \ sp ->
     let stk_words = spHw - sp in
     initHeapUsage				 (\ hp_words  ->
76

77
78
79
     ( if all_pointers then -- heap checks are quite easy
	  absC (checking_code stk_words hp_words tag_assts 
		    free_reg (length regs))
80

81
       else -- they are complicated
82

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
	  -- save all registers on the stack and adjust the stack pointer.
	  -- ToDo: find the initial all-pointer segment and don't save them.

	  mkTaggedStkAmodes sp addrmode_regs 
	  	  `thenFC` \(new_sp, stk_assts, more_tag_assts) ->

	  -- only let the extra stack assignments affect the stack
	  -- high water mark if we were doing a stack check anyway;
	  -- otherwise we end up generating unnecessary stack checks.
	  -- Careful about knot-tying loops!
	  let real_stk_words =  if new_sp - sp > stk_words && stk_words /= 0
					then new_sp - sp
					else stk_words
	  in

	  let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in

	  absC (checking_code real_stk_words hp_words 
	            (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
				   adjust_sp])
	            (CReg node) 0)

      ) `thenC`

      setRealHp hp_words `thenC`
      code))
109
110

  where
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
	
    checking_code stk hp assts ret regs
	| node_points = do_checks_np stk hp assts (regs+1) -- ret not required
        | otherwise   = do_checks    stk hp assts ret regs

    -- When node points to the closure for the function:

    do_checks_np
	:: Int				-- stack headroom
	-> Int				-- heap  headroom
	-> AbstractC			-- assignments to perform on failure
	-> Int				-- number of pointer registers live
	-> AbstractC
    do_checks_np 0 0 _ _ = AbsCNop
    do_checks_np 0 hp_words tag_assts ptrs =
	    CCheck HP_CHK_NP [
		  mkIntCLit hp_words,
		  mkIntCLit ptrs
	         ]
	         tag_assts
    do_checks_np stk_words 0 tag_assts ptrs =
	    CCheck STK_CHK_NP [
		  mkIntCLit stk_words,
		  mkIntCLit ptrs
		 ]
		 tag_assts
    do_checks_np stk_words hp_words tag_assts ptrs =
	    CCheck HP_STK_CHK_NP [
		  mkIntCLit stk_words,
		  mkIntCLit hp_words,
		  mkIntCLit ptrs
		 ]
		 tag_assts

    -- When node doesn't point to the closure (we need an explicit retn addr)

    do_checks 
	:: Int				-- stack headroom
	-> Int				-- heap  headroom
	-> AbstractC			-- assignments to perform on failure
	-> CAddrMode			-- a register to hold the retn addr.
	-> Int				-- number of pointer registers live
	-> AbstractC

    do_checks 0 0 _ _ _ = AbsCNop
    do_checks 0 hp_words tag_assts ret_reg ptrs =
	    CCheck HP_CHK [
		  mkIntCLit hp_words,
		  CLbl ret CodePtrRep,
		  ret_reg,
		  mkIntCLit ptrs
		 ]
		 tag_assts
    do_checks stk_words 0 tag_assts ret_reg ptrs =
	    CCheck STK_CHK [
		  mkIntCLit stk_words,
		  CLbl ret CodePtrRep,
		  ret_reg,
		  mkIntCLit ptrs
		 ]
		 tag_assts
    do_checks stk_words hp_words tag_assts ret_reg ptrs =
	    CCheck HP_STK_CHK [
		  mkIntCLit stk_words,
		  mkIntCLit hp_words,
		  CLbl ret CodePtrRep,
		  ret_reg,
		  mkIntCLit ptrs
		 ]
		 tag_assts

    free_reg  = case length regs + 1 of 
		       IBOX(x) -> CReg (VanillaReg PtrRep x)

    all_pointers = all pointer regs
    pointer (VanillaReg rep _) = isFollowableRep rep
    pointer _ = False

    addrmode_regs = map CReg regs

-- Checking code for thunks is just a special case of fast entry points:

thunkChecks :: CLabel -> Bool -> Code -> Code
thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
\end{code}
196

197
198
Heap checks in a case alternative are nice and easy, provided this is
a bog-standard algebraic case.  We have in our hand:
199

200
201
       * one return address, on the stack,
       * one return value, in Node.
202

203
204
205
206
207
208
the canned code for this heap check failure just pushes Node on the
stack, saying 'EnterGHC' to return.  The scheduler will return by
entering the top value on the stack, which in turn will return through
the return address, getting us back to where we were.  This is
therefore only valid if the return value is *lifted* (just being
boxed isn't good enough).  Only a PtrRep will do.
209

210
211
212
For primitive returns, we have an unlifted value in some register
(either R1 or FloatReg1 or DblReg1).  This means using specialised
heap-check code for these cases.
213

214
215
216
217
For unboxed tuple returns, there are an arbitrary number of possibly
unboxed return values, some of which will be in registers, and the
others will be on the stack, with gaps left for tagging the unboxed
objects.  If a heap check is required, we need to fill in these tags.
218

219
220
221
The code below will cover all cases for the x86 architecture (where R1
is the only VanillaReg ever used).  For other architectures, we'll
have to do something about saving and restoring the other registers.
222

223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
\begin{code}
altHeapCheck 
	:: Bool				-- is an algebraic alternative
	-> [MagicId]			-- live registers
	-> [(VirtualSpOffset,Int)]	-- stack slots to tag
	-> AbstractC
	-> Maybe CLabel			-- ret address if not on top of stack.
	-> Code
	-> Code

-- unboxed tuple alternatives and let-no-escapes (the two most annoying
-- constructs to generate code for!):

altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
  = mkTagAssts tags `thenFC` \tag_assts1 ->
    let tag_assts = mkAbstractCs [fail_code, tag_assts1]
    in
    initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
  where
    do_heap_chk words_required tag_assts
      = absC (if words_required == 0
		then  AbsCNop
		else  checking_code tag_assts)  `thenC`
	setRealHp words_required
247

248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
      where
      	non_void_regs = filter (/= VoidReg) regs

	checking_code tag_assts = 
	  case non_void_regs of

	    -- this will cover all cases for x86
	    [VanillaReg rep ILIT(1)] 

	       | isFollowableRep rep ->
	          CCheck HP_CHK_UT_ALT
		      [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
			CReg (VanillaReg RetRep ILIT(2)),
			CLbl ret_addr RetRep]
		      tag_assts

	       | otherwise ->
	          CCheck HP_CHK_UT_ALT
		      [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
			CReg (VanillaReg RetRep ILIT(2)),
			CLbl ret_addr RetRep]
		      tag_assts

	    several_regs ->
                let liveness = mkRegLiveness several_regs
 		in
		CCheck HP_CHK_GEN
		     [mkIntCLit words_required, 
		      mkIntCLit (IBOX(word2Int# liveness)),
		      CLbl ret_addr RetRep] 
		     tag_assts

-- normal algebraic and primitive case alternatives:

altHeapCheck is_fun regs [] AbsCNop Nothing code
  = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
  where
    do_heap_chk :: HeapOffset -> Code
    do_heap_chk words_required
      = absC (if words_required == 0
		then  AbsCNop
		else  checking_code)  `thenC`
	setRealHp words_required
291

292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
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
      where
        non_void_regs = filter (/= VoidReg) regs

	checking_code = 
          case non_void_regs of

	    -- No regs live: probably a Void return
	    [] ->
	       CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop

	    -- The SEQ case (polymophic/function typed case branch)
	    [VanillaReg rep ILIT(1)]
		|  rep == PtrRep
 		&& is_fun ->
	          CCheck HP_CHK_SEQ_NP
			[mkIntCLit words_required, mkIntCLit 1{-regs live-}]
			AbsCNop

	    -- R1 is lifted (the common case)
	    [VanillaReg rep ILIT(1)]
	        | rep == PtrRep ->
	          CCheck HP_CHK_NP
			[mkIntCLit words_required, mkIntCLit 1{-regs live-}]
			AbsCNop

	    -- R1 is boxed, but unlifted
		| isFollowableRep rep ->
		  CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop

	    -- R1 is unboxed
		| otherwise ->
		  CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop

	    -- FloatReg1
	    [FloatReg ILIT(1)] ->
		  CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop

	    -- DblReg1
	    [DoubleReg ILIT(1)] ->
		  CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop

	    -- LngReg1
	    [LongReg _ ILIT(1)] ->
		  CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop

#ifdef DEBUG
	    _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
#endif

-- build up a bitmap of the live pointer registers

mkRegLiveness :: [MagicId] -> Word#
344
345
mkRegLiveness []  =  int2Word# 0#
mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep 
346
  =  ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
347
mkRegLiveness (_ : regs)  =  mkRegLiveness regs
348
349
350
351

-- Emit macro for simulating a fetch and then reschedule

fetchAndReschedule ::   [MagicId]               -- Live registers
352
			-> Bool                 -- Node reqd?
353
			-> Code
354

355
fetchAndReschedule regs node_reqd  =
356
357
358
359
      if (node `elem` regs || node_reqd)
	then fetch_code `thenC` reschedule_code
	else absC AbsCNop
      where
360
	all_regs = if node_reqd then node:regs else regs
361
	liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
362

363
364
365
	reschedule_code = absC  (CMacroStmt GRAN_RESCHEDULE [
				 mkIntCLit liveness_mask,
				 mkIntCLit (if node_reqd then 1 else 0)])
366

367
368
369
	 --HWL: generate GRAN_FETCH macro for GrAnSim
	 --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
	fetch_code = absC (CMacroStmt GRAN_FETCH [])
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
\end{code}

The @GRAN_YIELD@ macro is taken from JSM's  code for Concurrent Haskell. It
allows to context-switch at  places where @node@ is  not alive (it uses the
@Continue@ rather  than the @EnterNodeCode@  function in the  RTS). We emit
this kind of macro at the beginning of the following kinds of basic bocks:
\begin{itemize}
 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally 
       we use @fetchAndReschedule@ at a slow entry code.
 \item Fast entry code (see @CgClosure.lhs@).
 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
       that they are not inlined (see @CgCases.lhs@). These alternatives will 
       be turned into separate functions.
\end{itemize}

\begin{code}
yield ::   [MagicId]               -- Live registers
             -> Bool                 -- Node reqd?
             -> Code 

yield regs node_reqd =
      -- NB: node is not alive; that's why we use DO_YIELD rather than 
      --     GRAN_RESCHEDULE 
      yield_code
      where
        all_regs = if node_reqd then node:regs else regs
396
        liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
397

398
        yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
\end{code}

%************************************************************************
%*									*
\subsection[initClosure]{Initialise a dynamic closure}
%*									*
%************************************************************************

@allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
to account for this.

\begin{code}
allocDynClosure
	:: ClosureInfo
	-> CAddrMode		-- Cost Centre to stick in the object
	-> CAddrMode		-- Cost Centre to blame for this alloc
				-- (usually the same; sometimes "OVERHEAD")

	-> [(CAddrMode, VirtualHeapOffset)]	-- Offsets from start of the object
						-- ie Info ptr has offset zero.
	-> FCode VirtualHeapOffset		-- Returns virt offset of object

allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
  = getVirtAndRealHp				`thenFC` \ (virtHp, realHp) ->

	-- FIND THE OFFSET OF THE INFO-PTR WORD
	-- virtHp points to last allocated word, ie 1 *before* the
	-- info-ptr word of new object.
427
    let  info_offset = virtHp + 1
428
429

	-- do_move IS THE ASSIGNMENT FUNCTION
430
	 do_move (amode, offset_from_start)
431
432
	   = CAssign (CVal (hpRel realHp
				  (info_offset + offset_from_start))
433
			   (getAmodeRep amode))
434
435
436
437
		     amode
    in
	-- SAY WHAT WE ARE ABOUT TO DO
    profCtrC (allocProfilingMsg closure_info)
438
439
			   [mkIntCLit (closureGoodStuffSize closure_info),
			    mkIntCLit slop_size]	`thenC`
440
441
442

	-- GENERATE THE CODE
    absC ( mkAbstractCs (
443
	   [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
444
445
446
	   ++ (map do_move amodes_with_offsets)))	`thenC`

	-- GENERATE CC PROFILING MESSAGES
447
    costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
448
449
450
					 		`thenC`

	-- BUMP THE VIRTUAL HEAP POINTER
451
    setVirtHp (virtHp + closure_size)			`thenC`
452
453
454
455
456
457

	-- RETURN PTR TO START OF OBJECT
    returnFC info_offset
  where
    closure_size = closureSize closure_info
    slop_size    = slopSize closure_info
458
459
460
461
462
463
464

-- Avoid hanging on to anything in the CC field when we're not profiling.

cInitHdr closure_info amode cc 
  | opt_SccProfilingOn = CInitHdr closure_info amode cc
  | otherwise          = CInitHdr closure_info amode (panic "absent cc")
	
465
\end{code}