StixMacro.lhs 11.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
%
% (c) The AQUA Project, Glasgow University, 1993-1995
%

\begin{code}
#include "HsVersions.h"

module StixMacro (
	genMacroCode, doHeapCheck, smStablePtrTable,

	Target, StixTree, SplitUniqSupply, CAddrMode, CExprMacro,
	CStmtMacro
    ) where

import AbsCSyn
import AbsPrel      ( PrimOp(..)
		      IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
		    )
import MachDesc	    {- lots -}
import CgCompInfo   ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE )
import Stix
import SplitUniq
import Unique
import Util

\end{code}

The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
closure address.

\begin{code}
mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
mkIntCLit_3 = mkIntCLit 3

38
39
40
-- hacking with Uncle Will:
#define target_STRICT target@(Target _ _ _ _ _ _ _ _)

41
42
43
44
45
46
genMacroCode 
    :: Target 
    -> CStmtMacro   	    -- statement macro
    -> [CAddrMode]  	    -- args
    -> SUniqSM StixTreeList

47
48
49
50
51
52
53
54
55
genMacroCode target_STRICT macro args
 = genmacro macro args
 where
  a2stix  = amodeToStix target
  stg_reg = stgReg target

  -- real thing: here we go -----------------------

  genmacro ARGS_CHK_A_LOAD_NODE args = 
56
    getUniqLabelNCG					`thenSUs` \ ulbl ->
57
    let [words, lbl] = map a2stix args
58
59
60
61
62
63
64
65
    	temp = StIndex PtrKind stgSpA words
	test = StPrim AddrGeOp [stgSuA, temp]
	cjmp = StCondJump ulbl test
	assign = StAssign PtrKind stgNode lbl
	join = StLabel ulbl
    in
	returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)

66
  genmacro ARGS_CHK_A [words] = 
67
    getUniqLabelNCG					`thenSUs` \ ulbl ->
68
    let temp = StIndex PtrKind stgSpA (a2stix words)
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
	test = StPrim AddrGeOp [stgSuA, temp]
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
	returnSUs (\xs -> cjmp : updatePAP : join : xs)

\end{code}

Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
sufficient arguments on the B stack, and perform a tail call to
@UpdatePAP@ if the arguments are not there.  The @_LOAD_NODE@ version
also loads R1 with an appropriate closure address.  Note that the
directions are swapped relative to the A stack.

\begin{code}

85
  genmacro ARGS_CHK_B_LOAD_NODE args = 
86
    getUniqLabelNCG					`thenSUs` \ ulbl ->
87
    let [words, lbl] = map a2stix args
88
89
90
91
92
93
94
95
    	temp = StIndex PtrKind stgSuB (StPrim IntNegOp [words])
	test = StPrim AddrGeOp [stgSpB, temp]
	cjmp = StCondJump ulbl test
	assign = StAssign PtrKind stgNode lbl
	join = StLabel ulbl
    in
	returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)

96
  genmacro ARGS_CHK_B [words] = 
97
    getUniqLabelNCG					`thenSUs` \ ulbl ->
98
    let	temp = StIndex PtrKind stgSuB (StPrim IntNegOp [a2stix words])
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
	test = StPrim AddrGeOp [stgSpB, temp]
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
	returnSUs (\xs -> cjmp : updatePAP : join : xs)

\end{code}

The @HEAP_CHK@ macro checks to see that there are enough words
available in the heap (before reaching @HpLim@).  When a heap check
fails, it has to call @PerformGC@ via the @PerformGC_wrapper@.  The
call wrapper saves all of our volatile registers so that we don't have to.

Since there are @HEAP_CHK@s buried at unfortunate places in the integer
primOps, this is just a wrapper.

\begin{code}

117
118
  genmacro HEAP_CHK args =
    let [liveness,words,reenter] = map a2stix args
119
    in
120
	doHeapCheck {-UNUSED NOW:target-} liveness words reenter
121
122
123
124
125
126
127
128
129
130
131

\end{code}

The @STK_CHK@ macro checks for enough space on the stack between @SpA@
and @SpB@.  A stack check can be complicated in the parallel world,
but for the sequential case, we just need to ensure that we have
enough space to continue.  Not that @_StackOverflow@ doesn't return,
so we don't have to @callWrapper@ it.

\begin{code}

132
  genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] = 
133
134
135
{- Need to check to see if we are compiling with stack checks
    getUniqLabelNCG					`thenSUs` \ ulbl ->
    let words = StPrim IntNegOp 
136
    	    [StPrim IntAddOp [a2stix aWords, a2stix bWords]]
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
	temp = StIndex PtrKind stgSpA words
	test = StPrim AddrGtOp [temp, stgSpB]
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
	returnSUs (\xs -> cjmp : stackOverflow : join : xs)
-}
    returnSUs id

\end{code}

@UPD_CAF@ involves changing the info pointer of the closure, adding an indirection,
and putting the new CAF on a linked list for the storage manager.

\begin{code}

153
154
  genmacro UPD_CAF args =
    let [cafptr,bhptr] = map a2stix args
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
    	w0 = StInd PtrKind cafptr
	w1 = StInd PtrKind (StIndex PtrKind cafptr (StInt 1))
	w2 = StInd PtrKind (StIndex PtrKind cafptr (StInt 2))
	a1 = StAssign PtrKind w0 caf_info
	a2 = StAssign PtrKind w1 smCAFlist
	a3 = StAssign PtrKind w2 bhptr
	a4 = StAssign PtrKind smCAFlist cafptr
    in
	returnSUs (\xs -> a1 : a2 : a3 : a4 : xs)

\end{code}

@UPD_IND@ is complicated by the fact that we are supporting the
Appel-style garbage collector by default.  This means some extra work
if we update an old generation object.

\begin{code}

173
  genmacro UPD_IND args = 
174
    getUniqLabelNCG					`thenSUs` \ ulbl ->
175
    let [updptr, heapptr] = map a2stix args
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
    	test = StPrim AddrGtOp [updptr, smOldLim]
    	cjmp = StCondJump ulbl test
    	updRoots = StAssign PtrKind smOldMutables updptr
	join = StLabel ulbl
    	upd0 = StAssign PtrKind (StInd PtrKind updptr) ind_info
    	upd1 = StAssign PtrKind (StInd PtrKind 
    	    	(StIndex PtrKind updptr (StInt 1))) smOldMutables
    	upd2 = StAssign PtrKind (StInd PtrKind 
    	    	(StIndex PtrKind updptr (StInt 2))) heapptr
    in
    	returnSUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)

\end{code}

@UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.

\begin{code}

194
  genmacro UPD_INPLACE_NOPTRS args = returnSUs id
195
196
197
198
199
200
201
202
203

\end{code}

@UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
the Appel-style garbage collector by default.  This means some extra work 
if we update an old generation object.

\begin{code}

204
  genmacro UPD_INPLACE_PTRS [liveness] =
205
206
207
208
209
210
211
212
213
214
215
216
217
    getUniqLabelNCG					`thenSUs` \ ulbl ->
    let cjmp = StCondJump ulbl testOldLim
        testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
	join = StLabel ulbl
        updUpd0 = StAssign PtrKind (StInd PtrKind stgNode) ind_info
    	updUpd1 = StAssign PtrKind (StInd PtrKind 
	    	    (StIndex PtrKind stgNode (StInt 1))) smOldMutables
    	updUpd2 = StAssign PtrKind (StInd PtrKind 
    	    	    (StIndex PtrKind stgNode (StInt 2))) hpBack2
    	hpBack2 = StIndex PtrKind stgHp (StInt (-2))
    	updOldMutables = StAssign PtrKind smOldMutables stgNode
    	updUpdReg = StAssign PtrKind stgNode hpBack2
    in
218
	genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
219
220
221
222
223
224
225
226
227
228
229
230
231
							`thenSUs` \ heap_chk ->
	returnSUs (\xs -> (cjmp : 
    	    	    	    heap_chk (updUpd0 : updUpd1 : updUpd2 : 
    	    	    	    	    	updOldMutables : updUpdReg : join : xs)))

\end{code}

@UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
the sequential case, the GC takes care of this).  However, we do need
to handle @UPD_BH_SINGLE_ENTRY@ in all cases.

\begin{code}

232
  genmacro UPD_BH_UPDATABLE args = returnSUs id
233

234
  genmacro UPD_BH_SINGLE_ENTRY [arg] =
235
    let
236
    	update = StAssign PtrKind (StInd PtrKind (a2stix arg)) bh_info
237
238
239
240
241
242
243
244
245
246
    in
        returnSUs (\xs -> update : xs)

\end{code}

Push a four word update frame on the stack and slide the Su[AB]
registers to the current Sp[AB] locations.

\begin{code}

247
248
  genmacro PUSH_STD_UPD_FRAME args =
    let [bhptr, aWords, bWords] = map a2stix args
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
    	frame n = StInd PtrKind 
	    (StIndex PtrKind stgSpB (StPrim IntAddOp 
    	    	[bWords, StInt (toInteger (sTD_UF_SIZE - n))]))

	a1 = StAssign PtrKind (frame uF_RET) stgRetReg
	a2 = StAssign PtrKind (frame uF_SUB) stgSuB
	a3 = StAssign PtrKind (frame uF_SUA) stgSuA
	a4 = StAssign PtrKind (frame uF_UPDATEE) bhptr

	updSuB = StAssign PtrKind
	    stgSuB (StIndex PtrKind stgSpB (StPrim IntAddOp 
    	    	[bWords, StInt (toInteger sTD_UF_SIZE)]))
	updSuA = StAssign PtrKind
	    stgSuA (StIndex PtrKind stgSpA (StPrim IntNegOp [aWords]))
    in
	returnSUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)

\end{code}

Pop a standard update frame.

\begin{code}

272
  genmacro POP_STD_UPD_FRAME args =
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
    let frame n = StInd PtrKind (StIndex PtrKind stgSpB (StInt (toInteger (-n))))

	grabRet = StAssign PtrKind stgRetReg (frame uF_RET)
	grabSuB = StAssign PtrKind stgSuB    (frame uF_SUB)
	grabSuA = StAssign PtrKind stgSuA    (frame uF_SUA)

	updSpB = StAssign PtrKind
	    stgSpB (StIndex PtrKind stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
    in
	returnSUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)

\end{code}

@PUSH_CON_UPD_FRAME@ appears to be unused at the moment.

\begin{code}
{- UNUSED:
290
  genmacro PUSH_CON_UPD_FRAME args = 
291
292
293
294
295
296
297
298
    panic "genMacroCode:PUSH_CON_UPD_FRAME"
-}
\end{code}

The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' compilation.

\begin{code}

299
300
  genmacro SET_ARITY args = returnSUs id
  genmacro CHK_ARITY args = returnSUs id
301
302
303
304
305
306
307

\end{code}

This one only applies if we have a machine register devoted to TagReg.

\begin{code}

308
309
  genmacro SET_TAG [tag] = 
    let set_tag = StAssign IntKind stgTagReg (a2stix tag)
310
    in
311
        case stg_reg TagReg of
312
313
314
315
316
317
318
319
320
321
322
            Always _ -> returnSUs id
            Save _ -> returnSUs (\xs -> set_tag : xs)

\end{code}

Do the business for a @HEAP_CHK@, having converted the args to Trees
of StixOp.

\begin{code}

doHeapCheck 
323
324
    :: {- unused now: Target 
    -> -}StixTree  	-- liveness
325
326
327
328
    -> StixTree  	-- words needed
    -> StixTree  	-- always reenter node? (boolean)
    -> SUniqSM StixTreeList

329
doHeapCheck {-target:unused now-} liveness words reenter =
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
    getUniqLabelNCG					`thenSUs` \ ulbl ->
    let newHp = StIndex PtrKind stgHp words
	assign = StAssign PtrKind stgHp newHp
	test = StPrim AddrLeOp [stgHp, stgHpLim]
	cjmp = StCondJump ulbl test
        arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
	-- ToDo: Overflow?  (JSM)
	gc = StCall SLIT("PerformGC_wrapper") VoidKind [arg]
	join = StLabel ulbl
    in
	returnSUs (\xs -> assign : cjmp : gc : join : xs)

\end{code}

Let's make sure that these CAFs are lifted out, shall we?

\begin{code}

-- Some common labels

bh_info, caf_info, ind_info :: StixTree

bh_info   = sStLitLbl SLIT("BH_SINGLE_info")
caf_info  = sStLitLbl SLIT("Caf_info")
ind_info  = sStLitLbl SLIT("Ind_info")

-- Some common call trees

updatePAP, stackOverflow :: StixTree

updatePAP     = StJump (sStLitLbl SLIT("UpdatePAP"))
stackOverflow = StCall SLIT("StackOverflow") VoidKind []

\end{code}

Storage manager nonsense.  Note that the indices are dependent on 
the definition of the smInfo structure in SMinterface.lh

\begin{code}

#include "../../includes/platform.h"

#if alpha_TARGET_ARCH
#include "../../includes/alpha-dec-osf1.h"
#else
#if sunos4_TARGET_OS
#include "../../includes/sparc-sun-sunos4.h"
#else
#include "../../includes/sparc-sun-solaris2.h"
#endif
#endif

storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree

storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
smCAFlist  = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_CAFLIST))
smOldMutables = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDMUTABLES))
smOldLim   = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDLIM))

smStablePtrTable = StInd PtrKind 
    	    	    	 (StIndex PtrKind storageMgrInfo (StInt SM_STABLEPOINTERTABLE))

\end{code}