StixMacro.lhs 9.53 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 )
15
import Constants	( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
16
17
18
19
20
			  sTD_UF_SIZE
			)
import OrdList		( OrdList )
import PrimOp		( PrimOp(..) )
import PrimRep		( PrimRep(..) )
21
import Stix
22
import UniqSupply	( returnUs, thenUs, UniqSM )
23
24
25
26
27
28
29
30
31
32
33
\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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Pop a standard update frame.

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

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

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

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

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

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

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