StixMacro.lhs 9.82 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
IMP_Ubiq(){-uitious-}
sof's avatar
sof committed
11
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
12
IMPORT_DELOOPER(NcgLoop)		( amodeToStix )
sof's avatar
sof committed
13
14
15
#else
import {-# SOURCE #-} StixPrim ( amodeToStix )
#endif
16

17
import MachMisc
sof's avatar
sof committed
18
19

-- In 2.0x we import Addr via GlaExts, so we better hide the other one here.
sof's avatar
sof committed
20
21
22
#if __GLASGOW_HASKELL__ >= 202
import MachRegs hiding (Addr)
#else
23
import MachRegs
sof's avatar
sof committed
24
#endif
25
26

import AbsCSyn		( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
27
import Constants	( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
28
29
30
31
32
			  sTD_UF_SIZE
			)
import OrdList		( OrdList )
import PrimOp		( PrimOp(..) )
import PrimRep		( PrimRep(..) )
33
import Stix
34
import UniqSupply	( returnUs, thenUs, SYN_IE(UniqSM) )
35
36
37
38
39
40
41
42
43
44
45
\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

46
47
macroCode
    :: CStmtMacro   	    -- statement macro
48
    -> [CAddrMode]  	    -- args
49
    -> UniqSM StixTreeList
50

51
52
53
54
55
56
57
58
59
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
60
    in
61
    returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
62

63
64
65
macroCode ARGS_CHK_A [words]
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let temp = StIndex PtrRep stgSpA (amodeToStix words)
66
67
68
69
	test = StPrim AddrGeOp [stgSuA, temp]
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
70
    returnUs (\xs -> cjmp : updatePAP : join : xs)
71
72
73
74
75
76
77
78
79
\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}
80
81
82
83
macroCode ARGS_CHK_B_LOAD_NODE args
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let
	[words, lbl] = map amodeToStix args
84
    	temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
85
86
	test = StPrim AddrGeOp [stgSpB, temp]
	cjmp = StCondJump ulbl test
87
	assign = StAssign PtrRep stgNode lbl
88
89
	join = StLabel ulbl
    in
90
    returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
91

92
93
94
95
macroCode ARGS_CHK_B [words]
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let
	temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
96
97
98
99
	test = StPrim AddrGeOp [stgSpB, temp]
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
100
    returnUs (\xs -> cjmp : updatePAP : join : xs)
101
102
103
104
105
\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
106
107
call wrapper saves all of our volatile registers so that we don't have
to.
108

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

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

142
143
144
@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.
145
146

\begin{code}
147
148
149
macroCode UPD_CAF args
  = let
	[cafptr,bhptr] = map amodeToStix args
150
151
152
153
154
155
156
    	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
157
    in
158
    returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
159
160
161
162
163
164
165
\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}
166
167
168
169
macroCode UPD_IND args
  = getUniqLabelNCG					`thenUs` \ ulbl ->
    let
	[updptr, heapptr] = map amodeToStix args
170
171
    	test = StPrim AddrGtOp [updptr, smOldLim]
    	cjmp = StCondJump ulbl test
172
    	updRoots = StAssign PtrRep smOldMutables updptr
173
	join = StLabel ulbl
174
175
176
177
178
    	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
179
    in
180
    returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
181
182
183
184
185
\end{code}

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

\begin{code}
186
macroCode UPD_INPLACE_NOPTRS args = returnUs id
187
188
189
\end{code}

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

\begin{code}
194
195
macroCode UPD_INPLACE_PTRS [liveness]
  = getUniqLabelNCG					`thenUs` \ ulbl ->
196
    let cjmp = StCondJump ulbl testOldLim
197
	testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
198
	join = StLabel ulbl
199
200
201
202
203
204
205
206
	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
207
    in
208
209
210
211
212
    macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
						    `thenUs` \ heap_chk ->
    returnUs (\xs -> (cjmp :
			heap_chk (updUpd0 : updUpd1 : updUpd2 :
				    updOldMutables : updUpdReg : join : xs)))
213
214
215
216
217
218
219
\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}
220
macroCode UPD_BH_UPDATABLE args = returnUs id
221

222
223
224
macroCode UPD_BH_SINGLE_ENTRY [arg]
  = let
    	update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
225
    in
226
    returnUs (\xs -> update : xs)
227
228
229
230
231
232
\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}
233
234
235
macroCode PUSH_STD_UPD_FRAME args
  = let
	[bhptr, aWords, bWords] = map amodeToStix args
236
237
    	frame n = StInd PtrRep
	    (StIndex PtrRep stgSpB (StPrim IntAddOp
238
239
    	    	[bWords, StInt (toInteger (sTD_UF_SIZE - n))]))

240
241
242
243
	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
244

245
246
	updSuB = StAssign PtrRep
	    stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
247
    	    	[bWords, StInt (toInteger sTD_UF_SIZE)]))
248
249
	updSuA = StAssign PtrRep
	    stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
250
    in
251
    returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
252
253
254
255
256
\end{code}

Pop a standard update frame.

\begin{code}
257
258
259
macroCode POP_STD_UPD_FRAME args
  = let
	frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
260

261
262
263
	grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
	grabSuB = StAssign PtrRep stgSuB    (frame uF_SUB)
	grabSuA = StAssign PtrRep stgSuA    (frame uF_SUA)
264

265
266
	updSpB = StAssign PtrRep
	    stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
267
    in
268
    returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
269
270
271
272
\end{code}

This one only applies if we have a machine register devoted to TagReg.
\begin{code}
273
274
macroCode SET_TAG [tag]
  = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
275
    in
276
277
278
    case stgReg TagReg of
      Always _ -> returnUs id
      Save   _ -> returnUs (\ xs -> set_tag : xs)
279
280
281
282
283
284
\end{code}

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

\begin{code}
285
286
heapCheck
    :: StixTree  	-- liveness
287
288
    -> StixTree  	-- words needed
    -> StixTree  	-- always reenter node? (boolean)
289
    -> UniqSM StixTreeList
290

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