2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 module StixMacro ( macroCode, heapCheck ) where
8 #include "HsVersions.h"
10 import {-# SOURCE #-} StixPrim ( amodeToStix )
14 import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
15 import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
18 import OrdList ( OrdList )
19 import PrimOp ( PrimOp(..) )
20 import PrimRep ( PrimRep(..) )
22 import UniqSupply ( returnUs, thenUs, UniqSM )
25 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
26 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
27 not there. The @_LOAD_NODE@ version also loads R1 with an appropriate
31 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
32 mkIntCLit_3 = mkIntCLit 3
35 :: CStmtMacro -- statement macro
36 -> [CAddrMode] -- args
37 -> UniqSM StixTreeList
39 macroCode ARGS_CHK_A_LOAD_NODE args
40 = getUniqLabelNCG `thenUs` \ ulbl ->
42 [words, lbl] = map amodeToStix args
43 temp = StIndex PtrRep stgSpA words
44 test = StPrim AddrGeOp [stgSuA, temp]
45 cjmp = StCondJump ulbl test
46 assign = StAssign PtrRep stgNode lbl
49 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
51 macroCode ARGS_CHK_A [words]
52 = getUniqLabelNCG `thenUs` \ ulbl ->
53 let temp = StIndex PtrRep stgSpA (amodeToStix words)
54 test = StPrim AddrGeOp [stgSuA, temp]
55 cjmp = StCondJump ulbl test
58 returnUs (\xs -> cjmp : updatePAP : join : xs)
61 Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
62 sufficient arguments on the B stack, and perform a tail call to
63 @UpdatePAP@ if the arguments are not there. The @_LOAD_NODE@ version
64 also loads R1 with an appropriate closure address. Note that the
65 directions are swapped relative to the A stack.
68 macroCode ARGS_CHK_B_LOAD_NODE args
69 = getUniqLabelNCG `thenUs` \ ulbl ->
71 [words, lbl] = map amodeToStix args
72 temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
73 test = StPrim AddrGeOp [stgSpB, temp]
74 cjmp = StCondJump ulbl test
75 assign = StAssign PtrRep stgNode lbl
78 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
80 macroCode ARGS_CHK_B [words]
81 = getUniqLabelNCG `thenUs` \ ulbl ->
83 temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
84 test = StPrim AddrGeOp [stgSpB, temp]
85 cjmp = StCondJump ulbl test
88 returnUs (\xs -> cjmp : updatePAP : join : xs)
91 The @HEAP_CHK@ macro checks to see that there are enough words
92 available in the heap (before reaching @HpLim@). When a heap check
93 fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The
94 call wrapper saves all of our volatile registers so that we don't have
97 Since there are @HEAP_CHK@s buried at unfortunate places in the
98 integer primOps, this is just a wrapper.
101 macroCode HEAP_CHK args
102 = let [liveness,words,reenter] = map amodeToStix args
104 heapCheck liveness words reenter
107 The @STK_CHK@ macro checks for enough space on the stack between @SpA@
108 and @SpB@. A stack check can be complicated in the parallel world,
109 but for the sequential case, we just need to ensure that we have
110 enough space to continue. Not that @_StackOverflow@ doesn't return,
111 so we don't have to @callWrapper@ it.
114 macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter]
116 {- Need to check to see if we are compiling with stack checks
117 getUniqLabelNCG `thenUs` \ ulbl ->
118 let words = StPrim IntNegOp
119 [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]]
120 temp = StIndex PtrRep stgSpA words
121 test = StPrim AddrGtOp [temp, stgSpB]
122 cjmp = StCondJump ulbl test
125 returnUs (\xs -> cjmp : stackOverflow : join : xs)
130 @UPD_CAF@ involves changing the info pointer of the closure, adding an
131 indirection, and putting the new CAF on a linked list for the storage
135 macroCode UPD_CAF args
137 [cafptr,bhptr] = map amodeToStix args
138 w0 = StInd PtrRep cafptr
139 w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
140 w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
141 a1 = StAssign PtrRep w0 caf_info
142 a2 = StAssign PtrRep w1 smCAFlist
143 a3 = StAssign PtrRep w2 bhptr
144 a4 = StAssign PtrRep smCAFlist cafptr
146 returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
149 @UPD_IND@ is complicated by the fact that we are supporting the
150 Appel-style garbage collector by default. This means some extra work
151 if we update an old generation object.
154 macroCode UPD_IND args
155 = getUniqLabelNCG `thenUs` \ ulbl ->
157 [updptr, heapptr] = map amodeToStix args
158 test = StPrim AddrGtOp [updptr, smOldLim]
159 cjmp = StCondJump ulbl test
160 updRoots = StAssign PtrRep smOldMutables updptr
162 upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
163 upd1 = StAssign PtrRep (StInd PtrRep
164 (StIndex PtrRep updptr (StInt 1))) smOldMutables
165 upd2 = StAssign PtrRep (StInd PtrRep
166 (StIndex PtrRep updptr (StInt 2))) heapptr
168 returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
171 @UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
174 macroCode UPD_INPLACE_NOPTRS args = returnUs id
177 @UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
178 the Appel-style garbage collector by default. This means some extra
179 work if we update an old generation object.
182 macroCode UPD_INPLACE_PTRS [liveness]
183 = getUniqLabelNCG `thenUs` \ ulbl ->
184 let cjmp = StCondJump ulbl testOldLim
185 testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
187 updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
188 updUpd1 = StAssign PtrRep (StInd PtrRep
189 (StIndex PtrRep stgNode (StInt 1))) smOldMutables
190 updUpd2 = StAssign PtrRep (StInd PtrRep
191 (StIndex PtrRep stgNode (StInt 2))) hpBack2
192 hpBack2 = StIndex PtrRep stgHp (StInt (-2))
193 updOldMutables = StAssign PtrRep smOldMutables stgNode
194 updUpdReg = StAssign PtrRep stgNode hpBack2
196 macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
197 `thenUs` \ heap_chk ->
198 returnUs (\xs -> (cjmp :
199 heap_chk (updUpd0 : updUpd1 : updUpd2 :
200 updOldMutables : updUpdReg : join : xs)))
203 @UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
204 the sequential case, the GC takes care of this). However, we do need
205 to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
208 macroCode UPD_BH_UPDATABLE args = returnUs id
210 macroCode UPD_BH_SINGLE_ENTRY [arg]
212 update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
214 returnUs (\xs -> update : xs)
217 Push a four word update frame on the stack and slide the Su[AB]
218 registers to the current Sp[AB] locations.
221 macroCode PUSH_STD_UPD_FRAME args
223 [bhptr, aWords, bWords] = map amodeToStix args
224 frame n = StInd PtrRep
225 (StIndex PtrRep stgSpB (StPrim IntAddOp
226 [bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
228 a1 = StAssign PtrRep (frame uF_RET) stgRetReg
229 a2 = StAssign PtrRep (frame uF_SUB) stgSuB
230 a3 = StAssign PtrRep (frame uF_SUA) stgSuA
231 a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
233 updSuB = StAssign PtrRep
234 stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
235 [bWords, StInt (toInteger sTD_UF_SIZE)]))
236 updSuA = StAssign PtrRep
237 stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
239 returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
242 Pop a standard update frame.
245 macroCode POP_STD_UPD_FRAME args
247 frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
249 grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
250 grabSuB = StAssign PtrRep stgSuB (frame uF_SUB)
251 grabSuA = StAssign PtrRep stgSuA (frame uF_SUA)
253 updSpB = StAssign PtrRep
254 stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
256 returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
259 This one only applies if we have a machine register devoted to TagReg.
261 macroCode SET_TAG [tag]
262 = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
264 case stgReg TagReg of
265 Always _ -> returnUs id
266 Save _ -> returnUs (\ xs -> set_tag : xs)
269 Do the business for a @HEAP_CHK@, having converted the args to Trees
274 :: StixTree -- liveness
275 -> StixTree -- words needed
276 -> StixTree -- always reenter node? (boolean)
277 -> UniqSM StixTreeList
279 heapCheck liveness words reenter
280 = getUniqLabelNCG `thenUs` \ ulbl ->
281 let newHp = StIndex PtrRep stgHp words
282 assign = StAssign PtrRep stgHp newHp
283 test = StPrim AddrLeOp [stgHp, stgHpLim]
284 cjmp = StCondJump ulbl test
285 arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
286 -- ToDo: Overflow? (JSM)
287 gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
290 returnUs (\xs -> assign : cjmp : gc : join : xs)
293 Let's make sure that these CAFs are lifted out, shall we?
296 -- Some common labels
298 bh_info, caf_info, ind_info :: StixTree
300 bh_info = sStLitLbl SLIT("BH_SINGLE_info")
301 caf_info = sStLitLbl SLIT("Caf_info")
302 ind_info = sStLitLbl SLIT("Ind_info")
304 -- Some common call trees
306 updatePAP, stackOverflow :: StixTree
308 updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
309 stackOverflow = StCall SLIT("StackOverflow") VoidRep []