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, CCheckMacro(..) )
15 import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
16 import ForeignCall ( CCallConv(..) )
17 import MachOp ( MachOp(..) )
18 import PrimRep ( PrimRep(..) )
20 import Panic ( panic )
21 import UniqSupply ( returnUs, thenUs, UniqSM )
22 import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
23 mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
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 StixStmtList
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 (StReg stgSp) words
48 test = StMachOp MO_NatU_Ge [StReg stgSu, temp]
49 cjmp = StCondJump ulbl test
50 assign = StAssignReg 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 (StReg stgSp) (amodeToStix words)
58 test = StMachOp MO_NatU_Ge [StReg 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 = StVoidable (StCall SLIT("newCAF") CCallConv VoidRep [cafptr])
76 a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
77 a2 = StAssignMem PtrRep cafptr ind_static_info
79 returnUs (\xs -> new_caf : a1 : a2 : xs)
82 -----------------------------------------------------------------------------
85 We do lazy blackholing: no need to overwrite thunks with blackholes
86 the minute they're entered, as long as we do it before a context
87 switch or garbage collection, that's ok.
89 Don't blackhole single entry closures, for the following reasons:
91 - if the compiler has decided that they won't be entered again,
92 that probably means that nothing has a pointer to it
93 (not necessarily true, but...)
95 - no need to blackhole for concurrency reasons, because nothing
96 can block on the result of this computation.
99 macroCode UPD_BH_UPDATABLE args = returnUs id
101 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
104 update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
106 returnUs (\xs -> update : xs)
110 -----------------------------------------------------------------------------
113 Push a four word update frame on the stack and slide the Su registers
114 to the current Sp location.
117 macroCode PUSH_UPD_FRAME args
119 [bhptr, _{-0-}] = map amodeToStix args
120 frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
122 -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
123 a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info
124 a3 = StAssignMem PtrRep (frame uF_SU) (StReg stgSu)
125 a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
130 (StIndex PtrRep (StReg stgSp) (StInt (toInteger (-uF_SIZE))))
132 returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
135 macroCode PUSH_SEQ_FRAME args
136 = let [arg_frame] = map amodeToStix args
137 frame n = StIndex PtrRep arg_frame (StInt (toInteger n))
138 a1 = StAssignMem PtrRep (frame 0) seq_frame_info
139 a2 = StAssignMem PtrRep (frame 1) (StReg stgSu)
140 updSu = StAssignReg PtrRep stgSu arg_frame
142 returnUs (\xs -> a1 : a2 : updSu : xs)
145 macroCode UPDATE_SU_FROM_UPD_FRAME args
146 = let [arg_frame] = map amodeToStix args
147 frame n = StIndex PtrRep arg_frame (StInt (toInteger n))
148 updSu = StAssignReg PtrRep stgSu (StInd PtrRep (frame uF_SU))
150 returnUs (\xs -> updSu : xs)
153 -----------------------------------------------------------------------------
154 Setting the tag register
156 This one only applies if we have a machine register devoted to TagReg.
159 macroCode SET_TAG [tag]
160 = case get_MagicId_reg_or_addr tagreg of
164 -> let a1 = StAssignReg IntRep (StixMagicId tagreg) (amodeToStix tag)
165 in returnUs ( \xs -> a1 : xs )
168 -----------------------------------------------------------------------------
171 macroCode REGISTER_IMPORT [arg]
173 \xs -> StAssignMem WordRep (StReg stgSp) (amodeToStix arg)
174 : StAssignReg PtrRep stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
178 macroCode REGISTER_FOREIGN_EXPORT [arg]
181 StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
187 = panic "StixMacro.macroCode"
190 Do the business for a @HEAP_CHK@, having converted the args to Trees
193 -----------------------------------------------------------------------------
194 Let's make sure that these CAFs are lifted out, shall we?
197 -- Some common labels
199 bh_info, ind_static_info, ind_info :: StixExpr
201 bh_info = StCLbl mkBlackHoleInfoTableLabel
202 ind_static_info = StCLbl mkIndStaticInfoLabel
203 ind_info = StCLbl mkIndInfoLabel
204 upd_frame_info = StCLbl mkUpdInfoLabel
205 seq_frame_info = StCLbl mkSeqInfoLabel
207 -- Some common call trees
209 updatePAP :: StixStmt
210 updatePAP = mkStJump_to_RegTable_offw OFFSET_stgUpdatePAP
214 -----------------------------------------------------------------------------
218 checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
219 checkCode macro args assts
220 = getUniqLabelNCG `thenUs` \ ulbl_fail ->
221 getUniqLabelNCG `thenUs` \ ulbl_pass ->
223 let args_stix = map amodeToStix args
224 newHp wds = StIndex PtrRep (StReg stgHp) wds
225 assign_hp wds = StAssignReg PtrRep stgHp (newHp wds)
226 hp_alloc wds = StAssignReg IntRep stgHpAlloc wds
227 test_hp = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
228 cjmp_hp = StCondJump ulbl_pass test_hp
229 newSp wds = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
230 test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
231 test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
232 cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
233 cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
234 assign_ret r ret = mkStAssign CodePtrRep r ret
236 fail = StLabel ulbl_fail
237 join = StLabel ulbl_pass
239 -- see includes/StgMacros.h for explaination of these magic consts
241 = IF_ARCH_alpha(16383,65535)
243 assign_liveness ptr_regs
244 = StAssignReg WordRep stgR9
245 (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
246 assign_reentry reentry
247 = StAssignReg WordRep stgR10 reentry
253 let [words,ptrs] = args_stix
254 in (\xs -> assign_hp words : cjmp_hp :
255 assts (hp_alloc words : gc_enter ptrs : join : xs))
258 let [words,ptrs] = args_stix
259 in (\xs -> assign_hp words : cjmp_hp :
260 assts (hp_alloc words : gc_seq ptrs : join : xs))
263 let [words,ptrs] = args_stix
264 in (\xs -> cjmp_sp_pass words :
265 assts (gc_enter ptrs : join : xs))
268 let [sp_words,hp_words,ptrs] = args_stix
269 in (\xs -> cjmp_sp_fail sp_words :
270 assign_hp hp_words : cjmp_hp :
272 assts (hp_alloc hp_words : gc_enter ptrs
276 let [words,ret,r,ptrs] = args_stix
277 in (\xs -> assign_hp words : cjmp_hp :
278 assts (hp_alloc words : assign_ret r ret
279 : gc_chk ptrs : join : xs))
282 let [words,ret,r,ptrs] = args_stix
283 in (\xs -> cjmp_sp_pass words :
284 assts (assign_ret r ret : gc_chk ptrs : join : xs))
287 let [sp_words,hp_words,ret,r,ptrs] = args_stix
288 in (\xs -> cjmp_sp_fail sp_words :
289 assign_hp hp_words : cjmp_hp :
291 assts (hp_alloc hp_words : assign_ret r ret
292 : gc_chk ptrs : join : xs))
295 let [words] = args_stix
296 in (\xs -> assign_hp words : cjmp_hp :
297 assts (hp_alloc words : gc_noregs : join : xs))
300 let [words] = args_stix
301 in (\xs -> assign_hp words : cjmp_hp :
302 assts (hp_alloc words : gc_unpt_r1 : join : xs))
305 let [words] = args_stix
306 in (\xs -> assign_hp words : cjmp_hp :
307 assts (hp_alloc words : gc_unbx_r1 : join : xs))
310 let [words] = args_stix
311 in (\xs -> assign_hp words : cjmp_hp :
312 assts (hp_alloc words : gc_f1 : join : xs))
315 let [words] = args_stix
316 in (\xs -> assign_hp words : cjmp_hp :
317 assts (hp_alloc words : gc_d1 : join : xs))
320 let [words] = args_stix
321 in (\xs -> assign_hp words : cjmp_hp :
322 assts (hp_alloc words : gc_l1 : join : xs))
325 let [words,ptrs,nonptrs,r,ret] = args_stix
326 in (\xs -> assign_hp words : cjmp_hp :
327 assts (hp_alloc words : assign_ret r ret
332 let [words,liveness,reentry] = args_stix
333 in (\xs -> assign_hp words : cjmp_hp :
334 assts (hp_alloc words : assign_liveness liveness :
335 assign_reentry reentry :
339 -- Various canned heap-check routines
341 mkStJump_to_GCentry_name :: String -> StixStmt
342 mkStJump_to_GCentry_name gcname
344 = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
345 -- | otherwise -- it's in a different DLL
346 -- = StJump (StInd PtrRep (StLitLbl True sdoc))
348 mkStJump_to_RegTable_offw :: Int -> StixStmt
349 mkStJump_to_RegTable_offw regtable_offw
351 = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
353 -- do something plausible for cross-DLL jump
355 gc_chk (StInt 0) = mkStJump_to_RegTable_offw OFFSET_stgChk0
356 gc_chk (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgChk1
357 gc_chk (StInt n) = mkStJump_to_GCentry_name ("stg_chk_" ++ show n)
359 gc_enter (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
360 gc_enter (StInt n) = mkStJump_to_GCentry_name ("stg_gc_enter_" ++ show n)
362 gc_seq (StInt n) = mkStJump_to_GCentry_name ("stg_gc_seq_" ++ show n)
363 gc_noregs = mkStJump_to_GCentry_name "stg_gc_noregs"
364 gc_unpt_r1 = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
365 gc_unbx_r1 = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
366 gc_f1 = mkStJump_to_GCentry_name "stg_gc_f1"
367 gc_d1 = mkStJump_to_GCentry_name "stg_gc_d1"
368 gc_l1 = mkStJump_to_GCentry_name "stg_gc_l1"
369 gc_gen = mkStJump_to_GCentry_name "stg_gen_chk"
370 gc_ut (StInt p) (StInt np)
371 = mkStJump_to_GCentry_name ("stg_gc_ut_" ++ show p ++ "_" ++ show np)