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 )
14 import AbsCSyn ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
16 import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE )
17 import CallConv ( cCallConv )
18 import PrimOp ( PrimOp(..) )
19 import PrimRep ( PrimRep(..) )
21 import UniqSupply ( returnUs, thenUs, UniqSM )
22 import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
23 mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
24 mkRtsGCEntryLabel, mkStgUpdatePAPLabel )
27 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
28 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
29 not there. The @_LOAD_NODE@ version also loads R1 with an appropriate
34 :: CStmtMacro -- statement macro
35 -> [CAddrMode] -- args
36 -> UniqSM StixTreeList
39 -----------------------------------------------------------------------------
40 Argument satisfaction checks.
43 macroCode ARGS_CHK_LOAD_NODE args
44 = getUniqLabelNCG `thenUs` \ ulbl ->
46 [words, lbl] = map amodeToStix args
47 temp = StIndex PtrRep stgSp words
48 test = StPrim AddrGeOp [stgSu, temp]
49 cjmp = StCondJump ulbl test
50 assign = StAssign PtrRep stgNode lbl
53 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
55 macroCode ARGS_CHK [words]
56 = getUniqLabelNCG `thenUs` \ ulbl ->
57 let temp = StIndex PtrRep stgSp (amodeToStix words)
58 test = StPrim AddrGeOp [stgSu, temp]
59 cjmp = StCondJump ulbl test
62 returnUs (\xs -> cjmp : updatePAP : join : xs)
65 -----------------------------------------------------------------------------
68 @UPD_CAF@ involves changing the info pointer of the closure, and
69 adding an indirection.
72 macroCode UPD_CAF args
74 [cafptr,bhptr] = map amodeToStix args
75 w0 = StInd PtrRep cafptr
76 w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
77 blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
78 a1 = StAssign PtrRep w0 ind_static_info
79 a2 = StAssign PtrRep w1 bhptr
80 a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
82 returnUs (\xs -> a1 : a2 : a3 : xs)
85 -----------------------------------------------------------------------------
88 We do lazy blackholing: no need to overwrite thunks with blackholes
89 the minute they're entered, as long as we do it before a context
90 switch or garbage collection, that's ok.
92 Don't blackhole single entry closures, for the following reasons:
94 - if the compiler has decided that they won't be entered again,
95 that probably means that nothing has a pointer to it
96 (not necessarily true, but...)
98 - no need to blackhole for concurrency reasons, because nothing
99 can block on the result of this computation.
102 macroCode UPD_BH_UPDATABLE args = returnUs id
104 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
107 update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
109 returnUs (\xs -> update : xs)
113 -----------------------------------------------------------------------------
116 Push a four word update frame on the stack and slide the Su registers
117 to the current Sp location.
120 macroCode PUSH_UPD_FRAME args
122 [bhptr, _{-0-}] = map amodeToStix args
123 frame n = StInd PtrRep
124 (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
126 -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
127 a1 = StAssign PtrRep (frame uF_RET) upd_frame_info
128 a3 = StAssign PtrRep (frame uF_SU) stgSu
129 a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
131 updSu = StAssign PtrRep stgSu
132 (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
134 returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
137 macroCode PUSH_SEQ_FRAME args
138 = let [arg_frame] = map amodeToStix args
139 frame n = StInd PtrRep
140 (StIndex PtrRep arg_frame (StInt (toInteger n)))
141 a1 = StAssign PtrRep (frame 0) seq_frame_info
142 a2 = StAssign PtrRep (frame 1) stgSu
143 updSu = StAssign PtrRep stgSu arg_frame
145 returnUs (\xs -> a1 : a2 : updSu : xs)
148 macroCode UPDATE_SU_FROM_UPD_FRAME args
149 = let [arg_frame] = map amodeToStix args
150 frame n = StInd PtrRep
151 (StIndex PtrRep arg_frame (StInt (toInteger n)))
153 = StAssign PtrRep stgSu (frame uF_SU)
155 returnUs (\xs -> updSu : xs)
158 -----------------------------------------------------------------------------
159 Setting the tag register
161 This one only applies if we have a machine register devoted to TagReg.
164 macroCode SET_TAG [tag]
165 = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
167 case stgReg tagreg of
168 Always _ -> returnUs id
169 Save _ -> returnUs (\ xs -> set_tag : xs)
172 -----------------------------------------------------------------------------
175 macroCode REGISTER_IMPORT [arg]
177 \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg)
178 : StAssign PtrRep stgSp (StPrim IntAddOp [stgSp, StInt 4])
182 macroCode REGISTER_FOREIGN_EXPORT [arg]
184 \xs -> StCall SLIT("getStablePtr") cCallConv VoidRep [amodeToStix arg]
190 SET_TAG -> error "foobarxyzzy8"
191 _ -> error "StixMacro.macroCode: unknown macro/args"
195 Do the business for a @HEAP_CHK@, having converted the args to Trees
198 -----------------------------------------------------------------------------
199 Let's make sure that these CAFs are lifted out, shall we?
202 -- Some common labels
204 bh_info, ind_static_info, ind_info :: StixTree
206 bh_info = StCLbl mkBlackHoleInfoTableLabel
207 ind_static_info = StCLbl mkIndStaticInfoLabel
208 ind_info = StCLbl mkIndInfoLabel
209 upd_frame_info = StCLbl mkUpdInfoLabel
210 seq_frame_info = StCLbl mkSeqInfoLabel
211 stg_update_PAP = StCLbl mkStgUpdatePAPLabel
212 -- Some common call trees
214 updatePAP, stackOverflow :: StixTree
216 updatePAP = StJump stg_update_PAP
217 stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
220 -----------------------------------------------------------------------------
224 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
225 checkCode macro args assts
226 = getUniqLabelNCG `thenUs` \ ulbl_fail ->
227 getUniqLabelNCG `thenUs` \ ulbl_pass ->
229 let args_stix = map amodeToStix args
230 newHp wds = StIndex PtrRep stgHp wds
231 assign_hp wds = StAssign PtrRep stgHp (newHp wds)
232 test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
233 cjmp_hp = StCondJump ulbl_pass test_hp
235 newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
236 test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
237 test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
238 cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
239 cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
241 assign_ret r ret = StAssign CodePtrRep r ret
243 fail = StLabel ulbl_fail
244 join = StLabel ulbl_pass
246 -- see includes/StgMacros.h for explaination of these magic consts
248 = IF_ARCH_alpha(16383,65535)
250 assign_liveness ptr_regs
251 = StAssign WordRep stgR9
252 (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
253 assign_reentry reentry
254 = StAssign WordRep stgR10 reentry
260 let [words,ptrs] = args_stix
261 in (\xs -> assign_hp words : cjmp_hp :
262 assts (gc_enter ptrs : join : xs))
265 let [words,ptrs] = args_stix
266 in (\xs -> assign_hp words : cjmp_hp :
267 assts (gc_seq ptrs : join : xs))
270 let [words,ptrs] = args_stix
271 in (\xs -> cjmp_sp_pass words :
272 assts (gc_enter ptrs : join : xs))
275 let [sp_words,hp_words,ptrs] = args_stix
276 in (\xs -> cjmp_sp_fail sp_words :
277 assign_hp hp_words : cjmp_hp :
279 assts (gc_enter ptrs : join : xs))
282 let [words,ret,r,ptrs] = args_stix
283 in (\xs -> assign_hp words : cjmp_hp :
284 assts (assign_ret r ret : gc_chk ptrs : join : xs))
287 let [words,ret,r,ptrs] = args_stix
288 in (\xs -> cjmp_sp_pass words :
289 assts (assign_ret r ret : gc_chk ptrs : join : xs))
292 let [sp_words,hp_words,ret,r,ptrs] = args_stix
293 in (\xs -> cjmp_sp_fail sp_words :
294 assign_hp hp_words : cjmp_hp :
296 assts (assign_ret r ret : gc_chk ptrs : join : xs))
299 let [words] = args_stix
300 in (\xs -> assign_hp words : cjmp_hp :
301 assts (gc_noregs : join : xs))
304 let [words] = args_stix
305 in (\xs -> assign_hp words : cjmp_hp :
306 assts (gc_unpt_r1 : join : xs))
309 let [words] = args_stix
310 in (\xs -> assign_hp words : cjmp_hp :
311 assts (gc_unbx_r1 : join : xs))
314 let [words] = args_stix
315 in (\xs -> assign_hp words : cjmp_hp :
316 assts (gc_f1 : join : xs))
319 let [words] = args_stix
320 in (\xs -> assign_hp words : cjmp_hp :
321 assts (gc_d1 : join : xs))
324 let [words,ptrs,nonptrs,r,ret] = args_stix
325 in (\xs -> assign_hp words : cjmp_hp :
326 assts (assign_ret r ret : gc_ut ptrs nonptrs
330 let [words,liveness,reentry] = args_stix
331 in (\xs -> assign_hp words : cjmp_hp :
332 assts (assign_liveness liveness :
333 assign_reentry reentry :
337 -- Various canned heap-check routines
339 mkStJump_to_GCentry :: String -> StixTree
340 mkStJump_to_GCentry gcname
342 = StJump (StCLbl (mkRtsGCEntryLabel gcname))
343 -- | otherwise -- it's in a different DLL
344 -- = StJump (StInd PtrRep (StLitLbl True sdoc))
346 gc_chk (StInt n) = mkStJump_to_GCentry ("stg_chk_" ++ show n)
347 gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
348 gc_seq (StInt n) = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
349 gc_noregs = mkStJump_to_GCentry "stg_gc_noregs"
350 gc_unpt_r1 = mkStJump_to_GCentry "stg_gc_unpt_r1"
351 gc_unbx_r1 = mkStJump_to_GCentry "stg_gc_unbx_r1"
352 gc_f1 = mkStJump_to_GCentry "stg_gc_f1"
353 gc_d1 = mkStJump_to_GCentry "stg_gc_d1"
354 gc_gen = mkStJump_to_GCentry "stg_gen_chk"
355 gc_ut (StInt p) (StInt np)
356 = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p