2 % (c) The AQUA Project, Glasgow University, 1993-1995
6 #include "HsVersions.h"
9 genMacroCode, doHeapCheck, smStablePtrTable,
11 Target, StixTree, UniqSupply, CAddrMode, CExprMacro,
16 import PrelInfo ( PrimOp(..)
17 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
18 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
20 import MachDesc {- lots -}
21 import CgCompInfo ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE )
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
36 -- hacking with Uncle Will:
37 #define target_STRICT target@(Target _ _ _ _ _ _ _ _)
41 -> CStmtMacro -- statement macro
42 -> [CAddrMode] -- args
43 -> UniqSM StixTreeList
45 genMacroCode target_STRICT macro args
48 a2stix = amodeToStix target
49 stg_reg = stgReg target
51 -- real thing: here we go -----------------------
53 genmacro ARGS_CHK_A_LOAD_NODE args =
54 getUniqLabelNCG `thenUs` \ ulbl ->
55 let [words, lbl] = map a2stix args
56 temp = StIndex PtrRep stgSpA words
57 test = StPrim AddrGeOp [stgSuA, temp]
58 cjmp = StCondJump ulbl test
59 assign = StAssign PtrRep stgNode lbl
62 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
64 genmacro ARGS_CHK_A [words] =
65 getUniqLabelNCG `thenUs` \ ulbl ->
66 let temp = StIndex PtrRep stgSpA (a2stix words)
67 test = StPrim AddrGeOp [stgSuA, temp]
68 cjmp = StCondJump ulbl test
71 returnUs (\xs -> cjmp : updatePAP : join : xs)
75 Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
76 sufficient arguments on the B stack, and perform a tail call to
77 @UpdatePAP@ if the arguments are not there. The @_LOAD_NODE@ version
78 also loads R1 with an appropriate closure address. Note that the
79 directions are swapped relative to the A stack.
83 genmacro ARGS_CHK_B_LOAD_NODE args =
84 getUniqLabelNCG `thenUs` \ ulbl ->
85 let [words, lbl] = map a2stix args
86 temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
87 test = StPrim AddrGeOp [stgSpB, temp]
88 cjmp = StCondJump ulbl test
89 assign = StAssign PtrRep stgNode lbl
92 returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
94 genmacro ARGS_CHK_B [words] =
95 getUniqLabelNCG `thenUs` \ ulbl ->
96 let temp = StIndex PtrRep stgSuB (StPrim IntNegOp [a2stix words])
97 test = StPrim AddrGeOp [stgSpB, temp]
98 cjmp = StCondJump ulbl test
101 returnUs (\xs -> cjmp : updatePAP : join : xs)
105 The @HEAP_CHK@ macro checks to see that there are enough words
106 available in the heap (before reaching @HpLim@). When a heap check
107 fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The
108 call wrapper saves all of our volatile registers so that we don't have to.
110 Since there are @HEAP_CHK@s buried at unfortunate places in the integer
111 primOps, this is just a wrapper.
115 genmacro HEAP_CHK args =
116 let [liveness,words,reenter] = map a2stix args
118 doHeapCheck liveness words reenter
121 The @STK_CHK@ macro checks for enough space on the stack between @SpA@
122 and @SpB@. A stack check can be complicated in the parallel world,
123 but for the sequential case, we just need to ensure that we have
124 enough space to continue. Not that @_StackOverflow@ doesn't return,
125 so we don't have to @callWrapper@ it.
129 genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
130 {- Need to check to see if we are compiling with stack checks
131 getUniqLabelNCG `thenUs` \ ulbl ->
132 let words = StPrim IntNegOp
133 [StPrim IntAddOp [a2stix aWords, a2stix bWords]]
134 temp = StIndex PtrRep stgSpA words
135 test = StPrim AddrGtOp [temp, stgSpB]
136 cjmp = StCondJump ulbl test
139 returnUs (\xs -> cjmp : stackOverflow : join : xs)
145 @UPD_CAF@ involves changing the info pointer of the closure, adding an indirection,
146 and putting the new CAF on a linked list for the storage manager.
150 genmacro UPD_CAF args =
151 let [cafptr,bhptr] = map a2stix args
152 w0 = StInd PtrRep cafptr
153 w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
154 w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
155 a1 = StAssign PtrRep w0 caf_info
156 a2 = StAssign PtrRep w1 smCAFlist
157 a3 = StAssign PtrRep w2 bhptr
158 a4 = StAssign PtrRep smCAFlist cafptr
160 returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
164 @UPD_IND@ is complicated by the fact that we are supporting the
165 Appel-style garbage collector by default. This means some extra work
166 if we update an old generation object.
170 genmacro UPD_IND args =
171 getUniqLabelNCG `thenUs` \ ulbl ->
172 let [updptr, heapptr] = map a2stix args
173 test = StPrim AddrGtOp [updptr, smOldLim]
174 cjmp = StCondJump ulbl test
175 updRoots = StAssign PtrRep smOldMutables updptr
177 upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
178 upd1 = StAssign PtrRep (StInd PtrRep
179 (StIndex PtrRep updptr (StInt 1))) smOldMutables
180 upd2 = StAssign PtrRep (StInd PtrRep
181 (StIndex PtrRep updptr (StInt 2))) heapptr
183 returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
187 @UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
191 genmacro UPD_INPLACE_NOPTRS args = returnUs id
195 @UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
196 the Appel-style garbage collector by default. This means some extra work
197 if we update an old generation object.
201 genmacro UPD_INPLACE_PTRS [liveness] =
202 getUniqLabelNCG `thenUs` \ ulbl ->
203 let cjmp = StCondJump ulbl testOldLim
204 testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
206 updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
207 updUpd1 = StAssign PtrRep (StInd PtrRep
208 (StIndex PtrRep stgNode (StInt 1))) smOldMutables
209 updUpd2 = StAssign PtrRep (StInd PtrRep
210 (StIndex PtrRep stgNode (StInt 2))) hpBack2
211 hpBack2 = StIndex PtrRep stgHp (StInt (-2))
212 updOldMutables = StAssign PtrRep smOldMutables stgNode
213 updUpdReg = StAssign PtrRep stgNode hpBack2
215 genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
216 `thenUs` \ heap_chk ->
217 returnUs (\xs -> (cjmp :
218 heap_chk (updUpd0 : updUpd1 : updUpd2 :
219 updOldMutables : updUpdReg : join : xs)))
223 @UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
224 the sequential case, the GC takes care of this). However, we do need
225 to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
229 genmacro UPD_BH_UPDATABLE args = returnUs id
231 genmacro UPD_BH_SINGLE_ENTRY [arg] =
233 update = StAssign PtrRep (StInd PtrRep (a2stix arg)) bh_info
235 returnUs (\xs -> update : xs)
239 Push a four word update frame on the stack and slide the Su[AB]
240 registers to the current Sp[AB] locations.
244 genmacro PUSH_STD_UPD_FRAME args =
245 let [bhptr, aWords, bWords] = map a2stix args
246 frame n = StInd PtrRep
247 (StIndex PtrRep stgSpB (StPrim IntAddOp
248 [bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
250 a1 = StAssign PtrRep (frame uF_RET) stgRetReg
251 a2 = StAssign PtrRep (frame uF_SUB) stgSuB
252 a3 = StAssign PtrRep (frame uF_SUA) stgSuA
253 a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
255 updSuB = StAssign PtrRep
256 stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
257 [bWords, StInt (toInteger sTD_UF_SIZE)]))
258 updSuA = StAssign PtrRep
259 stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
261 returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
265 Pop a standard update frame.
269 genmacro POP_STD_UPD_FRAME args =
270 let frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
272 grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
273 grabSuB = StAssign PtrRep stgSuB (frame uF_SUB)
274 grabSuA = StAssign PtrRep stgSuA (frame uF_SUA)
276 updSpB = StAssign PtrRep
277 stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
279 returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
283 The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal''
286 genmacro SET_ARITY args = returnUs id
287 genmacro CHK_ARITY args = returnUs id
290 This one only applies if we have a machine register devoted to TagReg.
292 genmacro SET_TAG [tag] =
293 let set_tag = StAssign IntRep stgTagReg (a2stix tag)
295 case stg_reg TagReg of
296 Always _ -> returnUs id
297 Save _ -> returnUs (\ xs -> set_tag : xs)
300 Do the business for a @HEAP_CHK@, having converted the args to Trees
306 :: {- unused now: Target
307 -> -}StixTree -- liveness
308 -> StixTree -- words needed
309 -> StixTree -- always reenter node? (boolean)
310 -> UniqSM StixTreeList
312 doHeapCheck {-target:unused now-} liveness words reenter =
313 getUniqLabelNCG `thenUs` \ ulbl ->
314 let newHp = StIndex PtrRep stgHp words
315 assign = StAssign PtrRep stgHp newHp
316 test = StPrim AddrLeOp [stgHp, stgHpLim]
317 cjmp = StCondJump ulbl test
318 arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
319 -- ToDo: Overflow? (JSM)
320 gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
323 returnUs (\xs -> assign : cjmp : gc : join : xs)
327 Let's make sure that these CAFs are lifted out, shall we?
331 -- Some common labels
333 bh_info, caf_info, ind_info :: StixTree
335 bh_info = sStLitLbl SLIT("BH_SINGLE_info")
336 caf_info = sStLitLbl SLIT("Caf_info")
337 ind_info = sStLitLbl SLIT("Ind_info")
339 -- Some common call trees
341 updatePAP, stackOverflow :: StixTree
343 updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
344 stackOverflow = StCall SLIT("StackOverflow") VoidRep []
348 Storage manager nonsense. Note that the indices are dependent on
349 the definition of the smInfo structure in SMinterface.lh
353 #include "../../includes/platform.h"
355 #if alpha_TARGET_ARCH
356 #include "../../includes/alpha-dec-osf1.h"
359 #include "../../includes/sparc-sun-sunos4.h"
361 #include "../../includes/sparc-sun-solaris2.h"
365 storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
367 storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
368 smCAFlist = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST))
369 smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES))
370 smOldLim = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM))
372 smStablePtrTable = StInd PtrRep
373 (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE))