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(..), CAddrMode, tagreg,
16 import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
17 import ForeignCall ( 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 new_caf = StCall SLIT("newCAF") CCallConv VoidRep [cafptr]
76 w0 = StInd PtrRep cafptr
77 w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
78 a1 = StAssign PtrRep w1 bhptr
79 a2 = StAssign PtrRep w0 ind_static_info
81 returnUs (\xs -> new_caf : a1 : a2 : 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)
171 -----------------------------------------------------------------------------
174 macroCode REGISTER_IMPORT [arg]
176 \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg)
177 : StAssign PtrRep stgSp (StPrim IntAddOp [stgSp, StInt 4])
181 macroCode REGISTER_FOREIGN_EXPORT [arg]
183 \xs -> StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
189 SET_TAG -> error "foobarxyzzy8"
190 _ -> error "StixMacro.macroCode: unknown macro/args"
194 Do the business for a @HEAP_CHK@, having converted the args to Trees
197 -----------------------------------------------------------------------------
198 Let's make sure that these CAFs are lifted out, shall we?
201 -- Some common labels
203 bh_info, ind_static_info, ind_info :: StixTree
205 bh_info = StCLbl mkBlackHoleInfoTableLabel
206 ind_static_info = StCLbl mkIndStaticInfoLabel
207 ind_info = StCLbl mkIndInfoLabel
208 upd_frame_info = StCLbl mkUpdInfoLabel
209 seq_frame_info = StCLbl mkSeqInfoLabel
211 stg_update_PAP = regTableEntry CodePtrRep OFFSET_stgUpdatePAP
213 -- Some common call trees
215 updatePAP :: StixTree
216 updatePAP = StJump NoDestInfo stg_update_PAP
219 -----------------------------------------------------------------------------
223 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
224 checkCode macro args assts
225 = getUniqLabelNCG `thenUs` \ ulbl_fail ->
226 getUniqLabelNCG `thenUs` \ ulbl_pass ->
228 let args_stix = map amodeToStix args
229 newHp wds = StIndex PtrRep stgHp wds
230 assign_hp wds = StAssign PtrRep stgHp (newHp wds)
231 hp_alloc wds = StAssign IntRep stgHpAlloc 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 (hp_alloc words : gc_enter ptrs : join : xs))
265 let [words,ptrs] = args_stix
266 in (\xs -> assign_hp words : cjmp_hp :
267 assts (hp_alloc words : 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 (hp_alloc hp_words : gc_enter ptrs
283 let [words,ret,r,ptrs] = args_stix
284 in (\xs -> assign_hp words : cjmp_hp :
285 assts (hp_alloc words : assign_ret r ret
286 : gc_chk ptrs : join : xs))
289 let [words,ret,r,ptrs] = args_stix
290 in (\xs -> cjmp_sp_pass words :
291 assts (assign_ret r ret : gc_chk ptrs : join : xs))
294 let [sp_words,hp_words,ret,r,ptrs] = args_stix
295 in (\xs -> cjmp_sp_fail sp_words :
296 assign_hp hp_words : cjmp_hp :
298 assts (hp_alloc hp_words : assign_ret r ret
299 : gc_chk ptrs : join : xs))
302 let [words] = args_stix
303 in (\xs -> assign_hp words : cjmp_hp :
304 assts (hp_alloc words : gc_noregs : join : xs))
307 let [words] = args_stix
308 in (\xs -> assign_hp words : cjmp_hp :
309 assts (hp_alloc words : gc_unpt_r1 : join : xs))
312 let [words] = args_stix
313 in (\xs -> assign_hp words : cjmp_hp :
314 assts (hp_alloc words : gc_unbx_r1 : join : xs))
317 let [words] = args_stix
318 in (\xs -> assign_hp words : cjmp_hp :
319 assts (hp_alloc words : gc_f1 : join : xs))
322 let [words] = args_stix
323 in (\xs -> assign_hp words : cjmp_hp :
324 assts (hp_alloc words : gc_d1 : join : xs))
327 let [words,ptrs,nonptrs,r,ret] = args_stix
328 in (\xs -> assign_hp words : cjmp_hp :
329 assts (hp_alloc words : assign_ret r ret
334 let [words,liveness,reentry] = args_stix
335 in (\xs -> assign_hp words : cjmp_hp :
336 assts (hp_alloc words : assign_liveness liveness :
337 assign_reentry reentry :
341 -- Various canned heap-check routines
343 mkStJump_to_GCentry :: String -> StixTree
344 mkStJump_to_GCentry gcname
346 = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
347 -- | otherwise -- it's in a different DLL
348 -- = StJump (StInd PtrRep (StLitLbl True sdoc))
350 gc_chk (StInt 0) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk0)
351 gc_chk (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk1)
352 gc_chk (StInt n) = mkStJump_to_GCentry ("stg_chk_" ++ show n)
354 gc_enter (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgGCEnter1)
355 gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
357 gc_seq (StInt n) = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
358 gc_noregs = mkStJump_to_GCentry "stg_gc_noregs"
359 gc_unpt_r1 = mkStJump_to_GCentry "stg_gc_unpt_r1"
360 gc_unbx_r1 = mkStJump_to_GCentry "stg_gc_unbx_r1"
361 gc_f1 = mkStJump_to_GCentry "stg_gc_f1"
362 gc_d1 = mkStJump_to_GCentry "stg_gc_d1"
363 gc_gen = mkStJump_to_GCentry "stg_gen_chk"
364 gc_ut (StInt p) (StInt np)
365 = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p