StixMacro.lhs 8.91 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
#include "HsVersions.h"
9
#include "nativeGen/NCG.h"
10

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

13
import MachRegs
14
import AbsCSyn		( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) )
15
import Constants	( uF_RET, uF_UPDATEE, uF_SIZE )
16
import ForeignCall	( CCallConv(..) )
17
import MachOp		( MachOp(..) )
18
import PrimRep		( PrimRep(..) )
19
import Stix
20
import Panic		( panic )
21
import UniqSupply	( returnUs, thenUs, UniqSM )
22
import CLabel		( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
23
			  mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
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 StixStmtList
36
37
38
39
\end{code}

-----------------------------------------------------------------------------
Updating a CAF
40

41
42
@UPD_CAF@ involves changing the info pointer of the closure, and
adding an indirection.
43
44

\begin{code}
45
46
47
macroCode UPD_CAF args
  = let
	[cafptr,bhptr] = map amodeToStix args
48
	new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr])
49
50
	a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
	a2 = StAssignMem PtrRep cafptr ind_static_info
51
    in
52
    returnUs (\xs -> new_caf : a1 : a2 : xs)
53
54
\end{code}

55
56
-----------------------------------------------------------------------------
Blackholing
57

58
59
60
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.
61

62
63
64
65
66
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...)
67

68
69
	- no need to blackhole for concurrency reasons, because nothing
	  can block on the result of this computation.
70
71

\begin{code}
72
macroCode UPD_BH_UPDATABLE args = returnUs id
73

74
75
macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
{-
76
77
  = let
    	update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
78
    in
79
    returnUs (\xs -> update : xs)
80
-}
81
82
\end{code}

83
84
85
-----------------------------------------------------------------------------
Update frames

86
Push an update frame on the stack.
87
88

\begin{code}
89
macroCode PUSH_UPD_FRAME args
90
  = let
91
	[bhptr, _{-0-}] = map amodeToStix args
92
    	frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
93

94
        -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
95
96
	a1 = StAssignMem PtrRep (frame uF_RET)     upd_frame_info
	a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
97
    in
98
    returnUs (\xs -> a1 : a4 : xs)
99
100
\end{code}

101
102
-----------------------------------------------------------------------------
Setting the tag register
103
104

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

106
\begin{code}
107
macroCode SET_TAG [tag]
108
109
110
111
112
113
  = case get_MagicId_reg_or_addr tagreg of
       Right baseRegAddr 
          -> returnUs id
       Left  realreg 
          -> let a1 = StAssignReg IntRep (StixMagicId tagreg) (amodeToStix tag)
             in returnUs ( \xs -> a1 : xs )
114
115
116
117
118
119
120
\end{code}

-----------------------------------------------------------------------------

\begin{code}
macroCode REGISTER_IMPORT [arg]
   = returnUs (
121
122
	\xs -> StAssignMem WordRep (StReg stgSp) (amodeToStix arg)
	     : StAssignReg PtrRep  stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
123
124
125
126
127
	     : xs
     )

macroCode REGISTER_FOREIGN_EXPORT [arg]
   = returnUs (
128
	\xs -> StVoidable (
129
                  StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep 
130
                         [amodeToStix arg]
131
               )
132
133
	     : xs
     )
134

135
macroCode other args
136
   = panic "StixMacro.macroCode"
137
138
139
140
141
\end{code}

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

142
-----------------------------------------------------------------------------
143
144
145
146
147
Let's make sure that these CAFs are lifted out, shall we?

\begin{code}
-- Some common labels

148
bh_info, ind_static_info, ind_info :: StixExpr
149

150
151
152
153
bh_info   	= StCLbl mkBlackHoleInfoTableLabel
ind_static_info	= StCLbl mkIndStaticInfoLabel
ind_info  	= StCLbl mkIndInfoLabel
upd_frame_info	= StCLbl mkUpdInfoLabel
154

155
-- Some common call trees
156
\end{code}
157
158
159
160
161

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

\begin{code}
162
checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
163
164
165
166
checkCode macro args assts
  = getUniqLabelNCG		`thenUs` \ ulbl_fail ->
    getUniqLabelNCG		`thenUs` \ ulbl_pass ->

167
168
169
170
171
172
173
174
175
    let args_stix        = map amodeToStix args
	newHp wds        = StIndex PtrRep (StReg stgHp) wds
	assign_hp wds    = StAssignReg PtrRep stgHp (newHp wds)
	hp_alloc wds     = StAssignReg IntRep stgHpAlloc wds
	test_hp          = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
	cjmp_hp          = StCondJump ulbl_pass test_hp
	newSp wds        = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
	test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
	test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
176
177
	cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
	cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
178
	assign_ret r ret = mkStAssign CodePtrRep r ret
179
180
181

	fail = StLabel ulbl_fail
	join = StLabel ulbl_pass
182
183

        -- see includes/StgMacros.h for explaination of these magic consts
184
        aLL_NON_PTRS = 0xff
185
186

        assign_liveness ptr_regs 
187
188
           = StAssignReg WordRep stgR9
                         (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
189
        assign_reentry reentry 
190
           = StAssignReg WordRep stgR10 reentry
191
192
193
194
195
    in	

    returnUs (
    case macro of
	HP_CHK_NP      -> 
196
		let [words] = args_stix
197
		in  (\xs -> assign_hp words : cjmp_hp : 
198
			    assts (hp_alloc words : gc_enter : join : xs))
199

200
	STK_CHK_NP     -> 
201
		let [words] = args_stix
202
		in  (\xs -> cjmp_sp_pass words :
203
			    assts (gc_enter : join : xs))
204
205

	HP_STK_CHK_NP  -> 
206
		let [sp_words,hp_words] = args_stix
207
208
209
		in  (\xs -> cjmp_sp_fail sp_words : 
			    assign_hp hp_words : cjmp_hp :
			    fail :
210
			    assts (hp_alloc hp_words : gc_enter
211
				   : join : xs))
212

213
214
	HP_CHK_FUN       -> 
		let [words] = args_stix
215
		in  (\xs -> assign_hp words : cjmp_hp :
216
			    assts (hp_alloc words : gc_fun : join : xs))
217

218
219
	STK_CHK_FUN       -> 
		let [words] = args_stix
220
		in  (\xs -> cjmp_sp_pass words :
221
			    assts (gc_fun : join : xs))
222

223
224
	HP_STK_CHK_FUN    -> 
		let [sp_words,hp_words] = args_stix
225
226
227
		in  (\xs -> cjmp_sp_fail sp_words :
			    assign_hp hp_words : cjmp_hp :
			    fail :
228
229
			    assts (hp_alloc hp_words
				  : gc_fun : join : xs))
230
231
232
233

	HP_CHK_NOREGS  -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
234
			    assts (hp_alloc words : gc_noregs : join : xs))
235
236
237
238

	HP_CHK_UNPT_R1 -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
239
			    assts (hp_alloc words : gc_unpt_r1 : join : xs))
240
241
242
243

	HP_CHK_UNBX_R1 -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
244
			    assts (hp_alloc words : gc_unbx_r1 : join : xs))
245
246
247
248

	HP_CHK_F1      -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
249
			    assts (hp_alloc words : gc_f1 : join : xs))
250
251
252
253

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

256
257
258
259
260
	HP_CHK_L1      -> 
		let [words] = args_stix
		in  (\xs -> assign_hp words : cjmp_hp : 
			    assts (hp_alloc words : gc_l1 : join : xs))

261
262
	HP_CHK_UNBX_TUPLE  -> 
                let [words,liveness] = args_stix
263
                in (\xs -> assign_hp words : cjmp_hp :
264
                           assts (hp_alloc words : assign_liveness liveness :
265
                                  gc_ut : join : xs))
266
    )
267

268
269
-- Various canned heap-check routines

270
271
mkStJump_to_GCentry_name :: String -> StixStmt
mkStJump_to_GCentry_name gcname
272
--   | opt_Static
273
   = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
274
275
276
--   | otherwise -- it's in a different DLL
--   = StJump (StInd PtrRep (StLitLbl True sdoc))

277
278
279
280
281
282
283
mkStJump_to_RegTable_offw :: Int -> StixStmt
mkStJump_to_RegTable_offw regtable_offw
--   | opt_Static
   = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
--   | otherwise
--   do something plausible for cross-DLL jump

284
285
gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
gc_fun   = mkStJump_to_RegTable_offw OFFSET_stgGCFun
286
287
288
289
290
291

gc_noregs          = mkStJump_to_GCentry_name "stg_gc_noregs"
gc_unpt_r1         = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
gc_unbx_r1         = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
gc_f1              = mkStJump_to_GCentry_name "stg_gc_f1"
gc_d1              = mkStJump_to_GCentry_name "stg_gc_d1"
292
gc_l1              = mkStJump_to_GCentry_name "stg_gc_l1"
293
gc_ut              = mkStJump_to_GCentry_name "stg_gc_ut"
294
\end{code}