2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 #include "HsVersions.h"
8 module StixMacro ( macroCode, heapCheck ) where
11 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
12 IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
14 import {-# SOURCE #-} StixPrim ( amodeToStix )
19 -- In 2.0x we import Addr via GlaExts, so we better hide the other one here.
20 #if __GLASGOW_HASKELL__ >= 202
21 import MachRegs hiding (Addr)
26 import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
27 import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
30 import OrdList ( OrdList )
31 import PrimOp ( PrimOp(..) )
32 import PrimRep ( PrimRep(..) )
34 import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
37 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
38 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
39 not there. The @_LOAD_NODE@ version also loads R1 with an appropriate
43 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
44 mkIntCLit_3 = mkIntCLit 3
47 :: CStmtMacro -- statement macro
48 -> [CAddrMode] -- args
49 -> UniqSM StixTreeList
51 macroCode ARGS_CHK_A_LOAD_NODE args
52 = getUniqLabelNCG `thenUs` \ ulbl ->
54 [words, lbl] = map amodeToStix args
55 temp = StIndex PtrRep stgSpA words
56 test = StPrim AddrGeOp [stgSuA, temp]
57 cjmp = StCondJump ulbl test
58 assign = StAssign PtrRep stgNode lbl
61 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
63 macroCode ARGS_CHK_A [words]
64 = getUniqLabelNCG `thenUs` \ ulbl ->
65 let temp = StIndex PtrRep stgSpA (amodeToStix words)
66 test = StPrim AddrGeOp [stgSuA, temp]
67 cjmp = StCondJump ulbl test
70 returnUs (\xs -> cjmp : updatePAP : join : xs)
73 Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
74 sufficient arguments on the B stack, and perform a tail call to
75 @UpdatePAP@ if the arguments are not there. The @_LOAD_NODE@ version
76 also loads R1 with an appropriate closure address. Note that the
77 directions are swapped relative to the A stack.
80 macroCode ARGS_CHK_B_LOAD_NODE args
81 = getUniqLabelNCG `thenUs` \ ulbl ->
83 [words, lbl] = map amodeToStix args
84 temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
85 test = StPrim AddrGeOp [stgSpB, temp]
86 cjmp = StCondJump ulbl test
87 assign = StAssign PtrRep stgNode lbl
90 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
92 macroCode ARGS_CHK_B [words]
93 = getUniqLabelNCG `thenUs` \ ulbl ->
95 temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
96 test = StPrim AddrGeOp [stgSpB, temp]
97 cjmp = StCondJump ulbl test
100 returnUs (\xs -> cjmp : updatePAP : join : xs)
103 The @HEAP_CHK@ macro checks to see that there are enough words
104 available in the heap (before reaching @HpLim@). When a heap check
105 fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The
106 call wrapper saves all of our volatile registers so that we don't have
109 Since there are @HEAP_CHK@s buried at unfortunate places in the
110 integer primOps, this is just a wrapper.
113 macroCode HEAP_CHK args
114 = let [liveness,words,reenter] = map amodeToStix args
116 heapCheck liveness words reenter
119 The @STK_CHK@ macro checks for enough space on the stack between @SpA@
120 and @SpB@. A stack check can be complicated in the parallel world,
121 but for the sequential case, we just need to ensure that we have
122 enough space to continue. Not that @_StackOverflow@ doesn't return,
123 so we don't have to @callWrapper@ it.
126 macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter]
128 {- Need to check to see if we are compiling with stack checks
129 getUniqLabelNCG `thenUs` \ ulbl ->
130 let words = StPrim IntNegOp
131 [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]]
132 temp = StIndex PtrRep stgSpA words
133 test = StPrim AddrGtOp [temp, stgSpB]
134 cjmp = StCondJump ulbl test
137 returnUs (\xs -> cjmp : stackOverflow : join : xs)
142 @UPD_CAF@ involves changing the info pointer of the closure, adding an
143 indirection, and putting the new CAF on a linked list for the storage
147 macroCode UPD_CAF args
149 [cafptr,bhptr] = map amodeToStix args
150 w0 = StInd PtrRep cafptr
151 w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
152 w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
153 a1 = StAssign PtrRep w0 caf_info
154 a2 = StAssign PtrRep w1 smCAFlist
155 a3 = StAssign PtrRep w2 bhptr
156 a4 = StAssign PtrRep smCAFlist cafptr
158 returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
161 @UPD_IND@ is complicated by the fact that we are supporting the
162 Appel-style garbage collector by default. This means some extra work
163 if we update an old generation object.
166 macroCode UPD_IND args
167 = getUniqLabelNCG `thenUs` \ ulbl ->
169 [updptr, heapptr] = map amodeToStix args
170 test = StPrim AddrGtOp [updptr, smOldLim]
171 cjmp = StCondJump ulbl test
172 updRoots = StAssign PtrRep smOldMutables updptr
174 upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
175 upd1 = StAssign PtrRep (StInd PtrRep
176 (StIndex PtrRep updptr (StInt 1))) smOldMutables
177 upd2 = StAssign PtrRep (StInd PtrRep
178 (StIndex PtrRep updptr (StInt 2))) heapptr
180 returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
183 @UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
186 macroCode UPD_INPLACE_NOPTRS args = returnUs id
189 @UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
190 the Appel-style garbage collector by default. This means some extra
191 work if we update an old generation object.
194 macroCode UPD_INPLACE_PTRS [liveness]
195 = getUniqLabelNCG `thenUs` \ ulbl ->
196 let cjmp = StCondJump ulbl testOldLim
197 testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
199 updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
200 updUpd1 = StAssign PtrRep (StInd PtrRep
201 (StIndex PtrRep stgNode (StInt 1))) smOldMutables
202 updUpd2 = StAssign PtrRep (StInd PtrRep
203 (StIndex PtrRep stgNode (StInt 2))) hpBack2
204 hpBack2 = StIndex PtrRep stgHp (StInt (-2))
205 updOldMutables = StAssign PtrRep smOldMutables stgNode
206 updUpdReg = StAssign PtrRep stgNode hpBack2
208 macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
209 `thenUs` \ heap_chk ->
210 returnUs (\xs -> (cjmp :
211 heap_chk (updUpd0 : updUpd1 : updUpd2 :
212 updOldMutables : updUpdReg : join : xs)))
215 @UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
216 the sequential case, the GC takes care of this). However, we do need
217 to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
220 macroCode UPD_BH_UPDATABLE args = returnUs id
222 macroCode UPD_BH_SINGLE_ENTRY [arg]
224 update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
226 returnUs (\xs -> update : xs)
229 Push a four word update frame on the stack and slide the Su[AB]
230 registers to the current Sp[AB] locations.
233 macroCode PUSH_STD_UPD_FRAME args
235 [bhptr, aWords, bWords] = map amodeToStix args
236 frame n = StInd PtrRep
237 (StIndex PtrRep stgSpB (StPrim IntAddOp
238 [bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
240 a1 = StAssign PtrRep (frame uF_RET) stgRetReg
241 a2 = StAssign PtrRep (frame uF_SUB) stgSuB
242 a3 = StAssign PtrRep (frame uF_SUA) stgSuA
243 a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
245 updSuB = StAssign PtrRep
246 stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
247 [bWords, StInt (toInteger sTD_UF_SIZE)]))
248 updSuA = StAssign PtrRep
249 stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
251 returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
254 Pop a standard update frame.
257 macroCode POP_STD_UPD_FRAME args
259 frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
261 grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
262 grabSuB = StAssign PtrRep stgSuB (frame uF_SUB)
263 grabSuA = StAssign PtrRep stgSuA (frame uF_SUA)
265 updSpB = StAssign PtrRep
266 stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
268 returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
271 This one only applies if we have a machine register devoted to TagReg.
273 macroCode SET_TAG [tag]
274 = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
276 case stgReg TagReg of
277 Always _ -> returnUs id
278 Save _ -> returnUs (\ xs -> set_tag : xs)
281 Do the business for a @HEAP_CHK@, having converted the args to Trees
286 :: StixTree -- liveness
287 -> StixTree -- words needed
288 -> StixTree -- always reenter node? (boolean)
289 -> UniqSM StixTreeList
291 heapCheck liveness words reenter
292 = getUniqLabelNCG `thenUs` \ ulbl ->
293 let newHp = StIndex PtrRep stgHp words
294 assign = StAssign PtrRep stgHp newHp
295 test = StPrim AddrLeOp [stgHp, stgHpLim]
296 cjmp = StCondJump ulbl test
297 arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
298 -- ToDo: Overflow? (JSM)
299 gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
302 returnUs (\xs -> assign : cjmp : gc : join : xs)
305 Let's make sure that these CAFs are lifted out, shall we?
308 -- Some common labels
310 bh_info, caf_info, ind_info :: StixTree
312 bh_info = sStLitLbl SLIT("BH_SINGLE_info")
313 caf_info = sStLitLbl SLIT("Caf_info")
314 ind_info = sStLitLbl SLIT("Ind_info")
316 -- Some common call trees
318 updatePAP, stackOverflow :: StixTree
320 updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
321 stackOverflow = StCall SLIT("StackOverflow") VoidRep []