StixMacro.lhs 9.55 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1993-1996
3
4
5
6
7
%

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

8
module StixMacro ( macroCode, heapCheck ) where
9

10
11
IMP_Ubiq(){-uitious-}
IMPORT_DELOOPER(NcgLoop)		( amodeToStix )
12

13
14
15
16
17
18
19
20
21
22
import MachMisc
import MachRegs

import AbsCSyn		( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
import CgCompInfo	( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
			  sTD_UF_SIZE
			)
import OrdList		( OrdList )
import PrimOp		( PrimOp(..) )
import PrimRep		( PrimRep(..) )
23
import Stix
24
import UniqSupply	( returnUs, thenUs, SYN_IE(UniqSM) )
25
26
27
28
29
30
31
32
33
34
35
\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

36
37
macroCode
    :: CStmtMacro   	    -- statement macro
38
    -> [CAddrMode]  	    -- args
39
    -> UniqSM StixTreeList
40

41
42
43
44
45
46
47
48
49
macroCode ARGS_CHK_A_LOAD_NODE args
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let
	  [words, lbl] = map amodeToStix args
	  temp = StIndex PtrRep stgSpA words
	  test = StPrim AddrGeOp [stgSuA, temp]
	  cjmp = StCondJump ulbl test
	  assign = StAssign PtrRep stgNode lbl
	  join = StLabel ulbl
50
    in
51
    returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
52

53
54
55
macroCode ARGS_CHK_A [words]
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let temp = StIndex PtrRep stgSpA (amodeToStix words)
56
57
58
59
	test = StPrim AddrGeOp [stgSuA, temp]
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
60
    returnUs (\xs -> cjmp : updatePAP : join : xs)
61
62
63
64
65
66
67
68
69
\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}
70
71
72
73
macroCode ARGS_CHK_B_LOAD_NODE args
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let
	[words, lbl] = map amodeToStix args
74
    	temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
75
76
	test = StPrim AddrGeOp [stgSpB, temp]
	cjmp = StCondJump ulbl test
77
	assign = StAssign PtrRep stgNode lbl
78
79
	join = StLabel ulbl
    in
80
    returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
81

82
83
84
85
macroCode ARGS_CHK_B [words]
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let
	temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
86
87
88
89
	test = StPrim AddrGeOp [stgSpB, temp]
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
90
    returnUs (\xs -> cjmp : updatePAP : join : xs)
91
92
93
94
95
\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
96
97
call wrapper saves all of our volatile registers so that we don't have
to.
98

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

\begin{code}
103
104
macroCode HEAP_CHK args
  = let [liveness,words,reenter] = map amodeToStix args
105
    in
106
    heapCheck liveness words reenter
107
108
109
110
111
112
113
114
115
\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}
116
117
macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter]
  =
118
{- Need to check to see if we are compiling with stack checks
119
   getUniqLabelNCG					`thenUs` \ ulbl ->
120
    let words = StPrim IntNegOp
121
    	    [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]]
122
	temp = StIndex PtrRep stgSpA words
123
124
125
126
	test = StPrim AddrGtOp [temp, stgSpB]
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
127
	returnUs (\xs -> cjmp : stackOverflow : join : xs)
128
-}
129
    returnUs id
130
131
\end{code}

132
133
134
@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.
135
136

\begin{code}
137
138
139
macroCode UPD_CAF args
  = let
	[cafptr,bhptr] = map amodeToStix args
140
141
142
143
144
145
146
    	w0 = StInd PtrRep cafptr
	w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
	w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
	a1 = StAssign PtrRep w0 caf_info
	a2 = StAssign PtrRep w1 smCAFlist
	a3 = StAssign PtrRep w2 bhptr
	a4 = StAssign PtrRep smCAFlist cafptr
147
    in
148
    returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
149
150
151
152
153
154
155
\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}
156
157
158
159
macroCode UPD_IND args
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let
	[updptr, heapptr] = map amodeToStix args
160
161
    	test = StPrim AddrGtOp [updptr, smOldLim]
    	cjmp = StCondJump ulbl test
162
    	updRoots = StAssign PtrRep smOldMutables updptr
163
	join = StLabel ulbl
164
165
166
167
168
    	upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
    	upd1 = StAssign PtrRep (StInd PtrRep
    	    	(StIndex PtrRep updptr (StInt 1))) smOldMutables
    	upd2 = StAssign PtrRep (StInd PtrRep
    	    	(StIndex PtrRep updptr (StInt 2))) heapptr
169
    in
170
    returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
171
172
173
174
175
\end{code}

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

\begin{code}
176
macroCode UPD_INPLACE_NOPTRS args = returnUs id
177
178
179
\end{code}

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

\begin{code}
184
185
macroCode UPD_INPLACE_PTRS [liveness]
  = getUniqLabelNCG					`thenUs` \ ulbl ->
186
    let cjmp = StCondJump ulbl testOldLim
187
	testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
188
	join = StLabel ulbl
189
190
191
192
193
194
195
196
	updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
    	updUpd1 = StAssign PtrRep (StInd PtrRep
	    	    (StIndex PtrRep stgNode (StInt 1))) smOldMutables
    	updUpd2 = StAssign PtrRep (StInd PtrRep
    	    	    (StIndex PtrRep stgNode (StInt 2))) hpBack2
    	hpBack2 = StIndex PtrRep stgHp (StInt (-2))
    	updOldMutables = StAssign PtrRep smOldMutables stgNode
    	updUpdReg = StAssign PtrRep stgNode hpBack2
197
    in
198
199
200
201
202
    macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
						    `thenUs` \ heap_chk ->
    returnUs (\xs -> (cjmp :
			heap_chk (updUpd0 : updUpd1 : updUpd2 :
				    updOldMutables : updUpdReg : join : xs)))
203
204
205
206
207
208
209
\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}
210
macroCode UPD_BH_UPDATABLE args = returnUs id
211

212
213
214
macroCode UPD_BH_SINGLE_ENTRY [arg]
  = let
    	update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
215
    in
216
    returnUs (\xs -> update : xs)
217
218
219
220
221
222
\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}
223
224
225
macroCode PUSH_STD_UPD_FRAME args
  = let
	[bhptr, aWords, bWords] = map amodeToStix args
226
227
    	frame n = StInd PtrRep
	    (StIndex PtrRep stgSpB (StPrim IntAddOp
228
229
    	    	[bWords, StInt (toInteger (sTD_UF_SIZE - n))]))

230
231
232
233
	a1 = StAssign PtrRep (frame uF_RET) stgRetReg
	a2 = StAssign PtrRep (frame uF_SUB) stgSuB
	a3 = StAssign PtrRep (frame uF_SUA) stgSuA
	a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
234

235
236
	updSuB = StAssign PtrRep
	    stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
237
    	    	[bWords, StInt (toInteger sTD_UF_SIZE)]))
238
239
	updSuA = StAssign PtrRep
	    stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
240
    in
241
    returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
242
243
244
245
246
\end{code}

Pop a standard update frame.

\begin{code}
247
248
249
macroCode POP_STD_UPD_FRAME args
  = let
	frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
250

251
252
253
	grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
	grabSuB = StAssign PtrRep stgSuB    (frame uF_SUB)
	grabSuA = StAssign PtrRep stgSuA    (frame uF_SUA)
254

255
256
	updSpB = StAssign PtrRep
	    stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
257
    in
258
    returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
259
260
261
262
\end{code}

This one only applies if we have a machine register devoted to TagReg.
\begin{code}
263
264
macroCode SET_TAG [tag]
  = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
265
    in
266
267
268
    case stgReg TagReg of
      Always _ -> returnUs id
      Save   _ -> returnUs (\ xs -> set_tag : xs)
269
270
271
272
273
274
\end{code}

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

\begin{code}
275
276
heapCheck
    :: StixTree  	-- liveness
277
278
    -> StixTree  	-- words needed
    -> StixTree  	-- always reenter node? (boolean)
279
    -> UniqSM StixTreeList
280

281
282
heapCheck liveness words reenter
  = getUniqLabelNCG					`thenUs` \ ulbl ->
283
284
    let newHp = StIndex PtrRep stgHp words
	assign = StAssign PtrRep stgHp newHp
285
286
	test = StPrim AddrLeOp [stgHp, stgHpLim]
	cjmp = StCondJump ulbl test
287
	arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
288
	-- ToDo: Overflow?  (JSM)
289
	gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
290
291
	join = StLabel ulbl
    in
292
    returnUs (\xs -> assign : cjmp : gc : join : xs)
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
\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"))
311
stackOverflow = StCall SLIT("StackOverflow") VoidRep []
312
\end{code}