2 % (c) The AQUA Project, Glasgow University, 1993-1998
6 module StixMacro ( macroCode, checkCode ) where
8 #include "HsVersions.h"
9 #include "nativeGen/NCG.h"
11 import {-# SOURCE #-} StixPrim ( amodeToStix )
15 import AbsCSyn ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
17 import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE )
18 import CallConv ( cCallConv )
19 import PrimOp ( PrimOp(..) )
20 import PrimRep ( PrimRep(..) )
22 import UniqSupply ( returnUs, thenUs, UniqSM )
26 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
27 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
28 not there. The @_LOAD_NODE@ version also loads R1 with an appropriate
33 :: CStmtMacro -- statement macro
34 -> [CAddrMode] -- args
35 -> UniqSM StixTreeList
38 -----------------------------------------------------------------------------
39 Argument satisfaction checks.
42 macroCode ARGS_CHK_LOAD_NODE args
43 = getUniqLabelNCG `thenUs` \ ulbl ->
45 [words, lbl] = map amodeToStix args
46 temp = StIndex PtrRep stgSp words
47 test = StPrim AddrGeOp [stgSu, temp]
48 cjmp = StCondJump ulbl test
49 assign = StAssign PtrRep stgNode lbl
52 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
54 macroCode ARGS_CHK [words]
55 = getUniqLabelNCG `thenUs` \ ulbl ->
56 let temp = StIndex PtrRep stgSp (amodeToStix words)
57 test = StPrim AddrGeOp [stgSu, temp]
58 cjmp = StCondJump ulbl test
61 returnUs (\xs -> cjmp : updatePAP : join : xs)
64 -----------------------------------------------------------------------------
67 @UPD_CAF@ involves changing the info pointer of the closure, and
68 adding an indirection.
71 macroCode UPD_CAF args
73 [cafptr,bhptr] = map amodeToStix args
74 w0 = StInd PtrRep cafptr
75 w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
76 blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
77 a1 = StAssign PtrRep w0 ind_static_info
78 a2 = StAssign PtrRep w1 bhptr
79 a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
81 returnUs (\xs -> a1 : a2 : a3 : xs)
84 -----------------------------------------------------------------------------
87 We do lazy blackholing: no need to overwrite thunks with blackholes
88 the minute they're entered, as long as we do it before a context
89 switch or garbage collection, that's ok.
91 Don't blackhole single entry closures, for the following reasons:
93 - if the compiler has decided that they won't be entered again,
94 that probably means that nothing has a pointer to it
95 (not necessarily true, but...)
97 - no need to blackhole for concurrency reasons, because nothing
98 can block on the result of this computation.
101 macroCode UPD_BH_UPDATABLE args = returnUs id
103 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
106 update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
108 returnUs (\xs -> update : xs)
112 -----------------------------------------------------------------------------
115 Push a four word update frame on the stack and slide the Su registers
116 to the current Sp location.
119 macroCode PUSH_UPD_FRAME args
121 [bhptr, _{-0-}] = map amodeToStix args
122 frame n = StInd PtrRep
123 (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
125 -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
126 a1 = StAssign PtrRep (frame uF_RET) upd_frame_info
127 a3 = StAssign PtrRep (frame uF_SU) stgSu
128 a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
130 updSu = StAssign PtrRep stgSu
131 (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
133 returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
136 macroCode PUSH_SEQ_FRAME args
137 = let [arg_frame] = map amodeToStix args
138 frame n = StInd PtrRep
139 (StIndex PtrRep arg_frame (StInt (toInteger n)))
140 a1 = StAssign PtrRep (frame 0) seq_frame_info
141 a2 = StAssign PtrRep (frame 1) stgSu
142 updSu = StAssign PtrRep stgSu arg_frame
144 returnUs (\xs -> a1 : a2 : updSu : xs)
147 macroCode UPDATE_SU_FROM_UPD_FRAME args
148 = let [arg_frame] = map amodeToStix args
149 frame n = StInd PtrRep
150 (StIndex PtrRep arg_frame (StInt (toInteger n)))
152 = StAssign PtrRep stgSu (frame uF_SU)
154 returnUs (\xs -> updSu : xs)
157 -----------------------------------------------------------------------------
158 Setting the tag register
160 This one only applies if we have a machine register devoted to TagReg.
163 macroCode SET_TAG [tag]
164 = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
166 case stgReg tagreg of
167 Always _ -> returnUs id
168 Save _ -> returnUs (\ xs -> set_tag : xs)
172 ARGS_CHK -> error "foobarxyzzy1"
173 ARGS_CHK_LOAD_NODE -> error "foobarxyzzy2"
174 UPD_CAF -> error "foobarxyzzy3"
175 UPD_BH_UPDATABLE -> error "foobarxyzzy4"
176 UPD_BH_SINGLE_ENTRY -> error "foobarxyzzy5"
177 PUSH_UPD_FRAME -> error "foobarxyzzy6"
178 PUSH_SEQ_FRAME -> error "foobarxyzzy7"
179 UPDATE_SU_FROM_UPD_FRAME -> error "foobarxyzzy8"
180 SET_TAG -> error "foobarxyzzy9"
185 Do the business for a @HEAP_CHK@, having converted the args to Trees
188 -----------------------------------------------------------------------------
189 Let's make sure that these CAFs are lifted out, shall we?
192 -- Some common labels
194 bh_info, ind_static_info, ind_info :: StixTree
196 bh_info = sStLitLbl SLIT("BLACKHOLE_info")
197 ind_static_info = sStLitLbl SLIT("IND_STATIC_info")
198 ind_info = sStLitLbl SLIT("IND_info")
199 upd_frame_info = sStLitLbl SLIT("Upd_frame_info")
200 seq_frame_info = sStLitLbl SLIT("seq_frame_info")
202 -- Some common call trees
204 updatePAP, stackOverflow :: StixTree
206 updatePAP = StJump (sStLitLbl SLIT("stg_update_PAP"))
207 stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
210 -----------------------------------------------------------------------------
214 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
215 checkCode macro args assts
216 = getUniqLabelNCG `thenUs` \ ulbl_fail ->
217 getUniqLabelNCG `thenUs` \ ulbl_pass ->
219 let args_stix = map amodeToStix args
220 newHp wds = StIndex PtrRep stgHp wds
221 assign_hp wds = StAssign PtrRep stgHp (newHp wds)
222 test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
223 cjmp_hp = StCondJump ulbl_pass test_hp
225 newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
226 test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
227 test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
228 cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
229 cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
231 assign_ret r ret = StAssign CodePtrRep r ret
233 fail = StLabel ulbl_fail
234 join = StLabel ulbl_pass
236 -- see includes/StgMacros.h for explaination of these magic consts
238 = IF_ARCH_alpha(16383,65535)
240 assign_liveness ptr_regs
241 = StAssign WordRep stgR9
242 (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
243 assign_reentry reentry
244 = StAssign WordRep stgR10 reentry
250 let [words,ptrs] = args_stix
251 in (\xs -> assign_hp words : cjmp_hp :
252 assts (gc_enter ptrs : join : xs))
255 let [words,ptrs] = args_stix
256 in (\xs -> assign_hp words : cjmp_hp :
257 assts (gc_seq ptrs : join : xs))
260 let [words,ptrs] = args_stix
261 in (\xs -> cjmp_sp_pass words :
262 assts (gc_enter ptrs : join : xs))
265 let [sp_words,hp_words,ptrs] = args_stix
266 in (\xs -> cjmp_sp_fail sp_words :
267 assign_hp hp_words : cjmp_hp :
269 assts (gc_enter ptrs : join : xs))
272 let [words,ret,r,ptrs] = args_stix
273 in (\xs -> assign_hp words : cjmp_hp :
274 assts (assign_ret r ret : gc_chk ptrs : join : xs))
277 let [words,ret,r,ptrs] = args_stix
278 in (\xs -> cjmp_sp_pass words :
279 assts (assign_ret r ret : gc_chk ptrs : join : xs))
282 let [sp_words,hp_words,ret,r,ptrs] = args_stix
283 in (\xs -> cjmp_sp_fail sp_words :
284 assign_hp hp_words : cjmp_hp :
286 assts (assign_ret r ret : gc_chk ptrs : join : xs))
289 let [words] = args_stix
290 in (\xs -> assign_hp words : cjmp_hp :
291 assts (gc_noregs : join : xs))
294 let [words] = args_stix
295 in (\xs -> assign_hp words : cjmp_hp :
296 assts (gc_unpt_r1 : join : xs))
299 let [words] = args_stix
300 in (\xs -> assign_hp words : cjmp_hp :
301 assts (gc_unbx_r1 : join : xs))
304 let [words] = args_stix
305 in (\xs -> assign_hp words : cjmp_hp :
306 assts (gc_f1 : join : xs))
309 let [words] = args_stix
310 in (\xs -> assign_hp words : cjmp_hp :
311 assts (gc_d1 : join : xs))
314 let [words,ptrs,nonptrs,r,ret] = args_stix
315 in (\xs -> assign_hp words : cjmp_hp :
316 assts (assign_ret r ret : gc_ut ptrs nonptrs
320 let [words,liveness,reentry] = args_stix
321 in (\xs -> assign_hp words : cjmp_hp :
322 assts (assign_liveness liveness :
323 assign_reentry reentry :
327 -- Various canned heap-check routines
329 gc_chk (StInt n) = StJump (StLitLbl (ptext SLIT("stg_chk_")
330 <> int (fromInteger n)))
331 gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_")
332 <> int (fromInteger n)))
333 gc_seq (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_seq_")
334 <> int (fromInteger n)))
335 gc_noregs = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
336 gc_unpt_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
337 gc_unbx_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
338 gc_f1 = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
339 gc_d1 = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))
340 gc_gen = StJump (StLitLbl (ptext SLIT("stg_gen_chk")))
342 gc_ut (StInt p) (StInt np)
343 = StJump (StLitLbl (ptext SLIT("stg_gc_ut_")
344 <> int (fromInteger p)
345 <> char '_' <> int (fromInteger np)))