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

\begin{code}
6
module StixMacro ( macroCode, heapCheck ) where
7

8
9
#include "HsVersions.h"

sof's avatar
sof committed
10
import {-# SOURCE #-} StixPrim ( amodeToStix )
11

12
13
14
import MachMisc
import MachRegs
import AbsCSyn		( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
sof's avatar
sof committed
15
import CallConv		( cCallConv )
16
import Constants	( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
17
18
19
20
21
			  sTD_UF_SIZE
			)
import OrdList		( OrdList )
import PrimOp		( PrimOp(..) )
import PrimRep		( PrimRep(..) )
22
import Stix
23
import UniqSupply	( returnUs, thenUs, UniqSM )
24
25
26
27
28
29
30
31
32
33
34
\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

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

40
41
42
43
44
45
46
47
48
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
49
    in
50
    returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
51

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

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

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

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

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

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

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

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

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

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

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

229
230
231
232
	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
233

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

Pop a standard update frame.

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

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

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

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

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

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

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