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 SMRep ( fixedHdrSize )
16 import Constants ( uF_RET, uF_UPDATEE, uF_SIZE )
17 import ForeignCall ( CCallConv(..) )
18 import MachOp ( MachOp(..) )
19 import PrimRep ( PrimRep(..) )
21 import Panic ( panic )
22 import UniqSupply ( returnUs, thenUs, UniqSM )
23 import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
24 mkBlackHoleBQInfoTableLabel,
25 mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
27 --------------------------------------------------------------------------------
28 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
29 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
30 not there. The @_LOAD_NODE@ version also loads R1 with an appropriate
35 :: CStmtMacro -- statement macro
37 -> UniqSM StixStmtList
40 -----------------------------------------------------------------------------
43 @UPD_CAF@ involves changing the info pointer of the closure, and
44 adding an indirection.
47 macroCode UPD_CAF [cafptr,bhptr]
49 new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr])
50 a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
51 a2 = StAssignMem PtrRep cafptr ind_static_info
53 returnUs (\xs -> new_caf : a1 : a2 : xs)
56 -----------------------------------------------------------------------------
59 We do lazy blackholing: no need to overwrite thunks with blackholes
60 the minute they're entered, as long as we do it before a context
61 switch or garbage collection, that's ok.
63 Don't blackhole single entry closures, for the following reasons:
65 - if the compiler has decided that they won't be entered again,
66 that probably means that nothing has a pointer to it
67 (not necessarily true, but...)
69 - no need to blackhole for concurrency reasons, because nothing
70 can block on the result of this computation.
73 macroCode UPD_BH_UPDATABLE args = returnUs id
75 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
78 update = StAssign PtrRep (StInd PtrRep arg) bh_info
80 returnUs (\xs -> update : xs)
84 -----------------------------------------------------------------------------
87 Push an update frame on the stack.
90 macroCode PUSH_UPD_FRAME [bhptr, _{-0-}]
92 frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
94 -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
95 a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info
96 a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
98 returnUs (\xs -> a1 : a4 : xs)
101 -----------------------------------------------------------------------------
102 Setting the tag register
104 This one only applies if we have a machine register devoted to TagReg.
107 macroCode SET_TAG [tag]
108 = case get_MagicId_reg_or_addr tagreg of
112 -> let a1 = StAssignReg IntRep (StixMagicId tagreg) tag
113 in returnUs ( \xs -> a1 : xs )
116 -----------------------------------------------------------------------------
119 macroCode AWAKEN_BQ_CLOSURE [arg]
120 = getUniqLabelNCG `thenUs` \ label ->
122 info = StInd AddrRep arg
123 cond = StMachOp MO_Nat_Ne [info, bq_info ]
124 jump = StCondJump label cond
125 blocking_queue = StInd PtrRep
126 (StIndex PtrRep arg (StInt (toInteger fixedHdrSize)))
127 call = StVoidable (StCall (Left FSLIT("awakenBlockedQueue"))
128 CCallConv VoidRep [blocking_queue])
130 returnUs ( \xs -> jump : call : StLabel label : xs )
133 -----------------------------------------------------------------------------
136 macroCode REGISTER_IMPORT [arg]
138 \xs -> StAssignMem WordRep (StReg stgSp) arg
139 : StAssignReg PtrRep stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
143 macroCode REGISTER_FOREIGN_EXPORT [arg]
146 StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep
153 = panic "StixMacro.macroCode"
156 Do the business for a @HEAP_CHK@, having converted the args to Trees
159 -----------------------------------------------------------------------------
160 Let's make sure that these CAFs are lifted out, shall we?
163 -- Some common labels
165 bh_info, ind_static_info, ind_info :: StixExpr
167 bh_info = StCLbl mkBlackHoleInfoTableLabel
168 bq_info = StCLbl mkBlackHoleBQInfoTableLabel
169 ind_static_info = StCLbl mkIndStaticInfoLabel
170 ind_info = StCLbl mkIndInfoLabel
171 upd_frame_info = StCLbl mkUpdInfoLabel
173 -- Some common call trees
176 -----------------------------------------------------------------------------
180 checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
181 checkCode macro args assts
182 = getUniqLabelNCG `thenUs` \ ulbl_fail ->
183 getUniqLabelNCG `thenUs` \ ulbl_pass ->
185 let args_stix = map amodeToStix args
186 newHp wds = StIndex PtrRep (StReg stgHp) wds
187 assign_hp wds = StAssignReg PtrRep stgHp (newHp wds)
188 hp_alloc wds = StAssignReg IntRep stgHpAlloc wds
189 test_hp = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
190 cjmp_hp = StCondJump ulbl_pass test_hp
191 newSp wds = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
192 test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
193 test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
194 cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
195 cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
196 assign_ret r ret = mkStAssign CodePtrRep r ret
198 fail = StLabel ulbl_fail
199 join = StLabel ulbl_pass
201 -- see includes/StgMacros.h for explaination of these magic consts
204 assign_liveness ptr_regs
205 = StAssignReg WordRep stgR9
206 (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
207 assign_reentry reentry
208 = StAssignReg WordRep stgR10 reentry
214 let [words] = args_stix
215 in (\xs -> assign_hp words : cjmp_hp :
216 assts (hp_alloc words : gc_enter : join : xs))
219 let [words] = args_stix
220 in (\xs -> cjmp_sp_pass words :
221 assts (gc_enter : join : xs))
224 let [sp_words,hp_words] = args_stix
225 in (\xs -> cjmp_sp_fail sp_words :
226 assign_hp hp_words : cjmp_hp :
228 assts (hp_alloc hp_words : gc_enter
232 let [words] = args_stix
233 in (\xs -> assign_hp words : cjmp_hp :
234 assts (hp_alloc words : gc_fun : join : xs))
237 let [words] = args_stix
238 in (\xs -> cjmp_sp_pass words :
239 assts (gc_fun : join : xs))
242 let [sp_words,hp_words] = args_stix
243 in (\xs -> cjmp_sp_fail sp_words :
244 assign_hp hp_words : cjmp_hp :
246 assts (hp_alloc hp_words
247 : gc_fun : join : xs))
250 let [words] = args_stix
251 in (\xs -> assign_hp words : cjmp_hp :
252 assts (hp_alloc words : gc_noregs : join : xs))
255 let [words] = args_stix
256 in (\xs -> assign_hp words : cjmp_hp :
257 assts (hp_alloc words : gc_unpt_r1 : join : xs))
260 let [words] = args_stix
261 in (\xs -> assign_hp words : cjmp_hp :
262 assts (hp_alloc words : gc_unbx_r1 : join : xs))
265 let [words] = args_stix
266 in (\xs -> assign_hp words : cjmp_hp :
267 assts (hp_alloc words : gc_f1 : join : xs))
270 let [words] = args_stix
271 in (\xs -> assign_hp words : cjmp_hp :
272 assts (hp_alloc words : gc_d1 : join : xs))
275 let [words] = args_stix
276 in (\xs -> assign_hp words : cjmp_hp :
277 assts (hp_alloc words : gc_l1 : join : xs))
280 let [words,liveness] = args_stix
281 in (\xs -> assign_hp words : cjmp_hp :
282 assts (hp_alloc words : assign_liveness liveness :
286 -- Various canned heap-check routines
288 mkStJump_to_GCentry_name :: String -> StixStmt
289 mkStJump_to_GCentry_name gcname
291 = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
292 -- | otherwise -- it's in a different DLL
293 -- = StJump (StInd PtrRep (StLitLbl True sdoc))
295 mkStJump_to_RegTable_offw :: Int -> StixStmt
296 mkStJump_to_RegTable_offw regtable_offw
298 = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
300 -- do something plausible for cross-DLL jump
302 gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
303 gc_fun = mkStJump_to_RegTable_offw OFFSET_stgGCFun
305 gc_noregs = mkStJump_to_GCentry_name "stg_gc_noregs"
306 gc_unpt_r1 = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
307 gc_unbx_r1 = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
308 gc_f1 = mkStJump_to_GCentry_name "stg_gc_f1"
309 gc_d1 = mkStJump_to_GCentry_name "stg_gc_d1"
310 gc_l1 = mkStJump_to_GCentry_name "stg_gc_l1"
311 gc_ut = mkStJump_to_GCentry_name "stg_gc_ut"