2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 #include "HsVersions.h"
8 module StixMacro ( macroCode, heapCheck ) where
10 import Ubiq{-uitious-}
11 import NcgLoop ( amodeToStix )
16 import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
17 import CgCompInfo ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
20 import OrdList ( OrdList )
21 import PrimOp ( PrimOp(..) )
22 import PrimRep ( PrimRep(..) )
24 import UniqSupply ( returnUs, thenUs, UniqSM(..) )
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
33 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
34 mkIntCLit_3 = mkIntCLit 3
37 :: CStmtMacro -- statement macro
38 -> [CAddrMode] -- args
39 -> UniqSM StixTreeList
41 macroCode ARGS_CHK_A_LOAD_NODE args
42 = getUniqLabelNCG `thenUs` \ ulbl ->
44 [words, lbl] = map amodeToStix args
45 temp = StIndex PtrRep stgSpA words
46 test = StPrim AddrGeOp [stgSuA, temp]
47 cjmp = StCondJump ulbl test
48 assign = StAssign PtrRep stgNode lbl
51 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
53 macroCode ARGS_CHK_A [words]
54 = getUniqLabelNCG `thenUs` \ ulbl ->
55 let temp = StIndex PtrRep stgSpA (amodeToStix words)
56 test = StPrim AddrGeOp [stgSuA, temp]
57 cjmp = StCondJump ulbl test
60 returnUs (\xs -> cjmp : updatePAP : join : xs)
63 Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
64 sufficient arguments on the B stack, and perform a tail call to
65 @UpdatePAP@ if the arguments are not there. The @_LOAD_NODE@ version
66 also loads R1 with an appropriate closure address. Note that the
67 directions are swapped relative to the A stack.
70 macroCode ARGS_CHK_B_LOAD_NODE args
71 = getUniqLabelNCG `thenUs` \ ulbl ->
73 [words, lbl] = map amodeToStix args
74 temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
75 test = StPrim AddrGeOp [stgSpB, temp]
76 cjmp = StCondJump ulbl test
77 assign = StAssign PtrRep stgNode lbl
80 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
82 macroCode ARGS_CHK_B [words]
83 = getUniqLabelNCG `thenUs` \ ulbl ->
85 temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
86 test = StPrim AddrGeOp [stgSpB, temp]
87 cjmp = StCondJump ulbl test
90 returnUs (\xs -> cjmp : updatePAP : join : xs)
93 The @HEAP_CHK@ macro checks to see that there are enough words
94 available in the heap (before reaching @HpLim@). When a heap check
95 fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The
96 call wrapper saves all of our volatile registers so that we don't have
99 Since there are @HEAP_CHK@s buried at unfortunate places in the
100 integer primOps, this is just a wrapper.
103 macroCode HEAP_CHK args
104 = let [liveness,words,reenter] = map amodeToStix args
106 heapCheck liveness words reenter
109 The @STK_CHK@ macro checks for enough space on the stack between @SpA@
110 and @SpB@. A stack check can be complicated in the parallel world,
111 but for the sequential case, we just need to ensure that we have
112 enough space to continue. Not that @_StackOverflow@ doesn't return,
113 so we don't have to @callWrapper@ it.
116 macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter]
118 {- Need to check to see if we are compiling with stack checks
119 getUniqLabelNCG `thenUs` \ ulbl ->
120 let words = StPrim IntNegOp
121 [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]]
122 temp = StIndex PtrRep stgSpA words
123 test = StPrim AddrGtOp [temp, stgSpB]
124 cjmp = StCondJump ulbl test
127 returnUs (\xs -> cjmp : stackOverflow : join : xs)
132 @UPD_CAF@ involves changing the info pointer of the closure, adding an
133 indirection, and putting the new CAF on a linked list for the storage
137 macroCode UPD_CAF args
139 [cafptr,bhptr] = map amodeToStix args
140 w0 = StInd PtrRep cafptr
141 w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
142 w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
143 a1 = StAssign PtrRep w0 caf_info
144 a2 = StAssign PtrRep w1 smCAFlist
145 a3 = StAssign PtrRep w2 bhptr
146 a4 = StAssign PtrRep smCAFlist cafptr
148 returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
151 @UPD_IND@ is complicated by the fact that we are supporting the
152 Appel-style garbage collector by default. This means some extra work
153 if we update an old generation object.
156 macroCode UPD_IND args
157 = getUniqLabelNCG `thenUs` \ ulbl ->
159 [updptr, heapptr] = map amodeToStix args
160 test = StPrim AddrGtOp [updptr, smOldLim]
161 cjmp = StCondJump ulbl test
162 updRoots = StAssign PtrRep smOldMutables updptr
164 upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
165 upd1 = StAssign PtrRep (StInd PtrRep
166 (StIndex PtrRep updptr (StInt 1))) smOldMutables
167 upd2 = StAssign PtrRep (StInd PtrRep
168 (StIndex PtrRep updptr (StInt 2))) heapptr
170 returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
173 @UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
176 macroCode UPD_INPLACE_NOPTRS args = returnUs id
179 @UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
180 the Appel-style garbage collector by default. This means some extra
181 work if we update an old generation object.
184 macroCode UPD_INPLACE_PTRS [liveness]
185 = getUniqLabelNCG `thenUs` \ ulbl ->
186 let cjmp = StCondJump ulbl testOldLim
187 testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
189 updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
190 updUpd1 = StAssign PtrRep (StInd PtrRep
191 (StIndex PtrRep stgNode (StInt 1))) smOldMutables
192 updUpd2 = StAssign PtrRep (StInd PtrRep
193 (StIndex PtrRep stgNode (StInt 2))) hpBack2
194 hpBack2 = StIndex PtrRep stgHp (StInt (-2))
195 updOldMutables = StAssign PtrRep smOldMutables stgNode
196 updUpdReg = StAssign PtrRep stgNode hpBack2
198 macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
199 `thenUs` \ heap_chk ->
200 returnUs (\xs -> (cjmp :
201 heap_chk (updUpd0 : updUpd1 : updUpd2 :
202 updOldMutables : updUpdReg : join : xs)))
205 @UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
206 the sequential case, the GC takes care of this). However, we do need
207 to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
210 macroCode UPD_BH_UPDATABLE args = returnUs id
212 macroCode UPD_BH_SINGLE_ENTRY [arg]
214 update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
216 returnUs (\xs -> update : xs)
219 Push a four word update frame on the stack and slide the Su[AB]
220 registers to the current Sp[AB] locations.
223 macroCode PUSH_STD_UPD_FRAME args
225 [bhptr, aWords, bWords] = map amodeToStix args
226 frame n = StInd PtrRep
227 (StIndex PtrRep stgSpB (StPrim IntAddOp
228 [bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
230 a1 = StAssign PtrRep (frame uF_RET) stgRetReg
231 a2 = StAssign PtrRep (frame uF_SUB) stgSuB
232 a3 = StAssign PtrRep (frame uF_SUA) stgSuA
233 a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
235 updSuB = StAssign PtrRep
236 stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
237 [bWords, StInt (toInteger sTD_UF_SIZE)]))
238 updSuA = StAssign PtrRep
239 stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
241 returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
244 Pop a standard update frame.
247 macroCode POP_STD_UPD_FRAME args
249 frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
251 grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
252 grabSuB = StAssign PtrRep stgSuB (frame uF_SUB)
253 grabSuA = StAssign PtrRep stgSuA (frame uF_SUA)
255 updSpB = StAssign PtrRep
256 stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
258 returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
261 The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal''
264 macroCode SET_ARITY args = returnUs id
265 macroCode CHK_ARITY args = returnUs id
268 This one only applies if we have a machine register devoted to TagReg.
270 macroCode SET_TAG [tag]
271 = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
273 case stgReg TagReg of
274 Always _ -> returnUs id
275 Save _ -> returnUs (\ xs -> set_tag : xs)
278 Do the business for a @HEAP_CHK@, having converted the args to Trees
283 :: StixTree -- liveness
284 -> StixTree -- words needed
285 -> StixTree -- always reenter node? (boolean)
286 -> UniqSM StixTreeList
288 heapCheck liveness words reenter
289 = getUniqLabelNCG `thenUs` \ ulbl ->
290 let newHp = StIndex PtrRep stgHp words
291 assign = StAssign PtrRep stgHp newHp
292 test = StPrim AddrLeOp [stgHp, stgHpLim]
293 cjmp = StCondJump ulbl test
294 arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
295 -- ToDo: Overflow? (JSM)
296 gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
299 returnUs (\xs -> assign : cjmp : gc : join : xs)
302 Let's make sure that these CAFs are lifted out, shall we?
305 -- Some common labels
307 bh_info, caf_info, ind_info :: StixTree
309 bh_info = sStLitLbl SLIT("BH_SINGLE_info")
310 caf_info = sStLitLbl SLIT("Caf_info")
311 ind_info = sStLitLbl SLIT("Ind_info")
313 -- Some common call trees
315 updatePAP, stackOverflow :: StixTree
317 updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
318 stackOverflow = StCall SLIT("StackOverflow") VoidRep []