2 % (c) The AQUA Project, Glasgow University, 1993-1998
6 module StixMacro ( macroCode, checkCode ) where
8 #include "HsVersions.h"
10 import {-# SOURCE #-} StixPrim ( amodeToStix )
14 import AbsCSyn ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
16 import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
17 import CallConv ( cCallConv )
18 import OrdList ( OrdList )
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 = StAssign PtrRep blocking_queue end_tso_queue
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 a1 = StAssign PtrRep (frame uF_RET) upd_frame_info
126 a3 = StAssign PtrRep (frame uF_SU) stgSu
127 a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
129 updSu = StAssign PtrRep stgSu
130 (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
132 returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
135 -----------------------------------------------------------------------------
136 Setting the tag register
138 This one only applies if we have a machine register devoted to TagReg.
141 macroCode SET_TAG [tag]
142 = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
144 case stgReg tagreg of
145 Always _ -> returnUs id
146 Save _ -> returnUs (\ xs -> set_tag : xs)
149 Do the business for a @HEAP_CHK@, having converted the args to Trees
152 -----------------------------------------------------------------------------
153 Let's make sure that these CAFs are lifted out, shall we?
156 -- Some common labels
158 bh_info, ind_static_info, ind_info :: StixTree
160 bh_info = sStLitLbl SLIT("BLACKHOLE_info")
161 ind_static_info = sStLitLbl SLIT("IND_STATIC_info")
162 ind_info = sStLitLbl SLIT("IND_info")
163 upd_frame_info = sStLitLbl SLIT("Upd_frame_entry")
164 end_tso_queue = sStLitLbl SLIT("END_TSO_QUEUE_closure")
166 -- Some common call trees
168 updatePAP, stackOverflow :: StixTree
170 updatePAP = StJump (sStLitLbl SLIT("stg_update_PAP"))
171 stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
174 -----------------------------------------------------------------------------
178 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
179 checkCode macro args assts
180 = getUniqLabelNCG `thenUs` \ ulbl_fail ->
181 getUniqLabelNCG `thenUs` \ ulbl_pass ->
183 let args_stix = map amodeToStix args
184 newHp wds = StIndex PtrRep stgHp wds
185 assign_hp wds = StAssign PtrRep stgHp (newHp wds)
186 test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
187 cjmp_hp = StCondJump ulbl_pass test_hp
189 newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
190 test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
191 test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
192 cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
193 cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
195 assign_ret r ret = StAssign CodePtrRep r ret
197 fail = StLabel ulbl_fail
198 join = StLabel ulbl_pass
204 let [words,ptrs] = args_stix
205 in (\xs -> assign_hp words : cjmp_hp :
206 assts (gc_enter ptrs : join : xs))
209 let [words,ptrs] = args_stix
210 in (\xs -> cjmp_sp_pass words :
211 assts (gc_enter ptrs : join : xs))
214 let [sp_words,hp_words,ptrs] = args_stix
215 in (\xs -> cjmp_sp_fail sp_words :
216 assign_hp hp_words : cjmp_hp :
218 assts (gc_enter ptrs : join : xs))
221 let [words,ret,r,ptrs] = args_stix
222 in (\xs -> assign_hp words : cjmp_hp :
223 assts (assign_ret r ret : gc_chk ptrs : join : xs))
226 let [words,ret,r,ptrs] = args_stix
227 in (\xs -> cjmp_sp_pass words :
228 assts (assign_ret r ret : gc_chk ptrs : join : xs))
231 let [sp_words,hp_words,ret,r,ptrs] = args_stix
232 in (\xs -> cjmp_sp_fail sp_words :
233 assign_hp hp_words : cjmp_hp :
235 assts (assign_ret r ret : gc_chk ptrs : join : xs))
238 let [words] = args_stix
239 in (\xs -> assign_hp words : cjmp_hp :
240 assts (gc_noregs : join : xs))
243 let [words] = args_stix
244 in (\xs -> assign_hp words : cjmp_hp :
245 assts (gc_unpt_r1 : join : xs))
248 let [words] = args_stix
249 in (\xs -> assign_hp words : cjmp_hp :
250 assts (gc_unbx_r1 : join : xs))
253 let [words] = args_stix
254 in (\xs -> assign_hp words : cjmp_hp :
255 assts (gc_f1 : join : xs))
258 let [words] = args_stix
259 in (\xs -> assign_hp words : cjmp_hp :
260 assts (gc_d1 : join : xs))
263 error "unimplemented check"
266 error "unimplemented check"
269 -- Various canned heap-check routines
271 gc_chk (StInt n) = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n)))
272 gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n)))
273 gc_noregs = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
274 gc_unpt_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
275 gc_unbx_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
276 gc_f1 = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
277 gc_d1 = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))