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

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

8
9
#include "HsVersions.h"

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

12
13
import MachMisc
import MachRegs
14
15
16
import AbsCSyn		( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
			  CCheckMacro(..) )
import Constants	( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
sof's avatar
sof committed
17
import CallConv		( cCallConv )
18
19
20
import OrdList		( OrdList )
import PrimOp		( PrimOp(..) )
import PrimRep		( PrimRep(..) )
21
import Stix
22
import UniqSupply	( returnUs, thenUs, UniqSM )
23
import Outputable
24
25
26
27
28
29
30
31
\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}
32
33
macroCode
    :: CStmtMacro   	    -- statement macro
34
    -> [CAddrMode]  	    -- args
35
    -> UniqSM StixTreeList
36
37
38
39
\end{code}

-----------------------------------------------------------------------------
Argument satisfaction checks.
40

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

54
macroCode ARGS_CHK [words]
55
  = getUniqLabelNCG					`thenUs` \ ulbl ->
56
57
    let temp = StIndex PtrRep stgSp (amodeToStix words)
	test = StPrim AddrGeOp [stgSu, temp]
58
59
60
	cjmp = StCondJump ulbl test
	join = StLabel ulbl
    in
61
    returnUs (\xs -> cjmp : updatePAP : join : xs)
62
63
\end{code}

64
65
-----------------------------------------------------------------------------
Updating a CAF
66

67
68
@UPD_CAF@ involves changing the info pointer of the closure, and
adding an indirection.
69
70

\begin{code}
71
72
73
macroCode UPD_CAF args
  = let
	[cafptr,bhptr] = map amodeToStix args
74
    	w0 = StInd PtrRep cafptr
75
76
77
78
	w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
	blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
	a1 = StAssign PtrRep w0 ind_static_info
	a2 = StAssign PtrRep w1 bhptr
79
	a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
80
    in
81
    returnUs (\xs -> a1 : a2 : a3 : xs)
82
83
\end{code}

84
85
-----------------------------------------------------------------------------
Blackholing
86

87
88
89
We do lazy blackholing: no need to overwrite thunks with blackholes
the minute they're entered, as long as we do it before a context
switch or garbage collection, that's ok.
90

91
92
93
94
95
Don't blackhole single entry closures, for the following reasons:
	
	- if the compiler has decided that they won't be entered again,
	  that probably means that nothing has a pointer to it
	  (not necessarily true, but...)
96

97
98
	- no need to blackhole for concurrency reasons, because nothing
	  can block on the result of this computation.
99
100

\begin{code}
101
macroCode UPD_BH_UPDATABLE args = returnUs id
102

103
104
macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
{-
105
106
  = let
    	update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
107
    in
108
    returnUs (\xs -> update : xs)
109
-}
110
111
\end{code}

112
113
114
115
116
-----------------------------------------------------------------------------
Update frames

Push a four word update frame on the stack and slide the Su registers
to the current Sp location.
117
118

\begin{code}
119
macroCode PUSH_UPD_FRAME args
120
  = let
121
	[bhptr, _{-0-}] = map amodeToStix args
122
    	frame n = StInd PtrRep
123
	    (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
124

125
        -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
126
127
	a1 = StAssign PtrRep (frame uF_RET)     upd_frame_info
	a3 = StAssign PtrRep (frame uF_SU)      stgSu
128
	a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
129

130
131
	updSu = StAssign PtrRep stgSu
		(StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
132
    in
133
    returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
134
135
\end{code}

136
137
-----------------------------------------------------------------------------
Setting the tag register
138
139

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

141
\begin{code}
142
143
macroCode SET_TAG [tag]
  = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
144
    in
145
    case stgReg tagreg of
146
147
      Always _ -> returnUs id
      Save   _ -> returnUs (\ xs -> set_tag : xs)
148
149
150
151
152
\end{code}

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

153
-----------------------------------------------------------------------------
154
155
156
157
158
Let's make sure that these CAFs are lifted out, shall we?

\begin{code}
-- Some common labels

159
bh_info, ind_static_info, ind_info :: StixTree
160

161
162
163
164
bh_info   	= sStLitLbl SLIT("BLACKHOLE_info")
ind_static_info	= sStLitLbl SLIT("IND_STATIC_info")
ind_info  	= sStLitLbl SLIT("IND_info")
upd_frame_info	= sStLitLbl SLIT("Upd_frame_entry")
165
166
167
168
169

-- Some common call trees

updatePAP, stackOverflow :: StixTree

170
updatePAP     = StJump (sStLitLbl SLIT("stg_update_PAP"))
sof's avatar
sof committed
171
stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
172
\end{code}
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279

-----------------------------------------------------------------------------
Heap/Stack checks

\begin{code}
checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
checkCode macro args assts
  = getUniqLabelNCG		`thenUs` \ ulbl_fail ->
    getUniqLabelNCG		`thenUs` \ ulbl_pass ->

    let args_stix = map amodeToStix args
	newHp wds = StIndex PtrRep stgHp wds
	assign_hp wds = StAssign PtrRep stgHp (newHp wds)
	test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
	cjmp_hp = StCondJump ulbl_pass test_hp

	newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
	test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
	test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
	cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
	cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)

	assign_ret r ret = StAssign CodePtrRep r ret

	fail = StLabel ulbl_fail
	join = StLabel ulbl_pass
    in	

    returnUs (
    case macro of
	HP_CHK_NP      -> 
		let [words,ptrs] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
			    assts (gc_enter ptrs : join : xs))

	STK_CHK_NP     -> 
		let [words,ptrs] = args_stix
		in  (\xs -> cjmp_sp_pass words :
			    assts (gc_enter ptrs : join : xs))

	HP_STK_CHK_NP  -> 
		let [sp_words,hp_words,ptrs] = args_stix
		in  (\xs -> cjmp_sp_fail sp_words : 
			    assign_hp hp_words : cjmp_hp :
			    fail :
			    assts (gc_enter ptrs : join : xs))

	HP_CHK	       -> 
		let [words,ret,r,ptrs] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp :
			    assts (assign_ret r ret : gc_chk ptrs : join : xs))

	STK_CHK	       -> 
		let [words,ret,r,ptrs] = args_stix
		in  (\xs -> cjmp_sp_pass words :
			    assts (assign_ret r ret : gc_chk ptrs : join : xs))

	HP_STK_CHK     -> 
		let [sp_words,hp_words,ret,r,ptrs] = args_stix
		in  (\xs -> cjmp_sp_fail sp_words :
			    assign_hp hp_words : cjmp_hp :
			    fail :
			    assts (assign_ret r ret : gc_chk ptrs : join : xs))

	HP_CHK_NOREGS  -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
			    assts (gc_noregs : join : xs))

	HP_CHK_UNPT_R1 -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
			    assts (gc_unpt_r1 : join : xs))

	HP_CHK_UNBX_R1 -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
			    assts (gc_unbx_r1 : join : xs))

	HP_CHK_F1      -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
			    assts (gc_f1 : join : xs))

	HP_CHK_D1      -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
			    assts (gc_d1 : join : xs))

	HP_CHK_UT_ALT  -> 
		error "unimplemented check"

	HP_CHK_GEN     -> 
		error "unimplemented check"
  )
	
-- Various canned heap-check routines

gc_chk (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n)))
gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n)))
gc_noregs          = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
gc_unpt_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
gc_unbx_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
gc_f1              = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
gc_d1              = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))

\end{code}