Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/CodeGen/cpscompile/invokegc.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/CodeGen/cpscompile/invokegc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 591 - (view) (download)

1 : monnier 427 (*
2 :     * This module is responsible for generating code to invoke the
3 :     * garbage collector. This new version is derived from the functor CallGC.
4 :     * It can handle derived pointers as roots and it can also be used as
5 :     * callbacks. These extra facilities are neccessary for global optimizations
6 : blume 515 * in the presence of GC.
7 : monnier 427 *
8 :     * -- Allen
9 :     *
10 :     *)
11 :    
12 :     functor InvokeGC
13 :     (structure Cells : CELLS
14 :     structure C : CPSREGS where T.Region=CPSRegions
15 :     structure MS: MACH_SPEC
16 :     ) : INVOKE_GC =
17 :     struct
18 :    
19 :     structure T = C.T
20 :     structure D = MS.ObjDesc
21 : george 546 structure LE = T.LabelExp
22 : monnier 427 structure R = CPSRegions
23 :     structure S = SortedList
24 :     structure St = T.Stream
25 :     structure GC = SMLGCType
26 : monnier 498 structure Cells = Cells
27 : blume 515 structure A = Array
28 : monnier 427
29 :     fun error msg = ErrorMsg.impossible("InvokeGC."^msg)
30 :    
31 :     type t = { maxAlloc : int,
32 : george 555 regfmls : T.mlrisc list,
33 : monnier 427 regtys : CPS.cty list,
34 : george 555 return : T.stm
35 : monnier 427 }
36 :    
37 : george 555 type stream = (T.stm,Cells.regmap,T.mlrisc list) T.stream
38 : monnier 427
39 :     val debug = Control.MLRISC.getFlag "debug-gc";
40 :    
41 :     val addrTy = C.addressWidth
42 :    
43 : blume 515 (* The following datatype is used to encapsulates
44 :     * all the information needed to generate code to invoke gc.
45 :     * The important fields are:
46 :     * known -- is the function a known (i.e. internal) function
47 :     * optimized -- if this is on, gc code generation is delayed until
48 :     * we have performed all optimizations. This is false
49 :     * for normal SML/NJ use.
50 :     * lab -- a list of labels that belongs to the call gc block
51 :     * boxed, float, int32 -- roots partitioned by types
52 :     * regfmls -- the roots
53 :     * ret -- how to return from the call gc block.
54 : monnier 427 *)
55 :     datatype gcInfo =
56 :     GCINFO of
57 : george 546 {known : bool, (* known function ? *)
58 :     optimized : bool, (* optimized? *)
59 :     lab : Label.label ref, (* labels to invoke GC *)
60 : george 555 boxed : T.rexp list, (* locations with boxed objects *)
61 :     int32 : T.rexp list, (* locations with int32 objects *)
62 :     float : T.fexp list, (* locations with float objects *)
63 :     regfmls : T.mlrisc list, (* all live registers *)
64 :     ret : T.stm} (* how to return *)
65 : monnier 427 | MODULE of
66 :     {info: gcInfo,
67 :     addrs: Label.label list ref} (* addrs associated with long jump *)
68 :    
69 :     (*====================================================================
70 :     * Implementation/architecture specific stuff starts here.
71 :     *====================================================================*)
72 :    
73 :     (* Extra space in allocation space
74 :     * The SML/NJ runtime system leaves around 4K of extra space
75 :     * in the allocation space for safety.
76 :     *)
77 :     val skidPad = 4096
78 :     val pty = 32
79 :    
80 :     val sp = Cells.stackptrR (* stack pointer *)
81 : blume 515 val spR = T.REG(addrTy,sp)
82 :     val unit = T.LI 1 (* representation of ML's unit;
83 :     * this is used to initialize registers.
84 :     *)
85 :     (*
86 :     * Callee-save registers
87 :     * All callee save registers are used in the gc calling convention.
88 : monnier 427 *)
89 :     val calleesaves = List.take(C.miscregs, MS.numCalleeSaves)
90 :    
91 :     (*
92 :     * registers that are the roots of gc.
93 :     *)
94 :     val gcParamRegs = (C.stdlink::C.stdclos::C.stdcont::C.stdarg::calleesaves)
95 :    
96 :     (*
97 :     * How to call the call the GC
98 :     *)
99 :     local val use = map T.GPR gcParamRegs
100 :     val def = case C.exhausted of NONE => use
101 :     | SOME cc => T.CCR cc::use
102 : george 555 in val gcCall =
103 : monnier 427 T.ANNOTATION(
104 : leunga 591 T.CALL{
105 :     funct=T.LOAD(32, T.ADD(addrTy,C.stackptr,T.LI MS.startgcOffset),
106 :     R.stack),
107 :     targets=[], defs=def, uses=use, cdefs=[], cuses=[], region=R.stack},
108 : monnier 498 #create MLRiscAnnotations.COMMENT "call gc")
109 : blume 515
110 : leunga 585 val ZERO_FREQ = #create MLRiscAnnotations.EXECUTION_FREQ 0
111 : monnier 427 end
112 : monnier 469
113 : monnier 498 val CALLGC = #create MLRiscAnnotations.CALLGC ()
114 : leunga 585 val NO_OPTIMIZATION = #create MLRiscAnnotations.NO_OPTIMIZATION ()
115 : monnier 469
116 : monnier 427 (*
117 :     * record descriptors
118 :     *)
119 :     val dtoi = LargeWord.toInt
120 :     fun unboxedDesc words = dtoi(D.makeDesc(words, D.tag_raw64))
121 :     fun boxedDesc words = dtoi(D.makeDesc(words, D.tag_record))
122 :    
123 :     (* the allocation pointer must always in a register! *)
124 : blume 515 val allocptrR =
125 :     case C.allocptr of
126 :     T.REG(_,allocptrR) => allocptrR
127 :     | _ => error "allocptr must be a register"
128 : monnier 427
129 :     (* what type of comparison to use for GC test? *)
130 :     val gcCmp = if C.signedGCTest then T.GT else T.GTU
131 :    
132 : monnier 498 val unlikely = #create MLRiscAnnotations.BRANCH_PROB 0
133 : monnier 427
134 :     val normalTestLimit = T.CMP(pty, gcCmp, C.allocptr, C.limitptr)
135 :    
136 :     (*====================================================================
137 :     * Private state
138 :     *====================================================================*)
139 :     (* gc info required for standard functions within the cluster *)
140 :     val clusterGcBlocks = ref([]: gcInfo list)
141 :    
142 :     (* gc info required for known functions within the cluster *)
143 :     val knownGcBlocks = ref([]: gcInfo list)
144 :    
145 :     (* gc info required for modules *)
146 :     val moduleGcBlocks = ref ([]: gcInfo list)
147 :    
148 :     (*====================================================================
149 :     * Auxiliary functions
150 :     *====================================================================*)
151 :    
152 :     (*
153 :     * Convert a list of rexps into a set of registers and memory offsets.
154 :     * Memory offsets must be relative to the stack pointer.
155 :     *)
156 :     fun set bindings =
157 :     let fun isStackPtr sp = sp = Cells.stackptrR
158 :     fun live(T.REG(_,r)::es, regs, mem) = live(es, r::regs, mem)
159 :     | live(T.LOAD(_, T.REG(_, sp), _)::es, regs, mem) =
160 :     if isStackPtr sp then live(es, regs, 0::mem)
161 :     else error "set:LOAD32"
162 :     | live(T.LOAD(_, T.ADD(_, T.REG(_, sp), T.LI i), _)::es, regs, mem) =
163 :     if isStackPtr sp then live(es, regs, i::mem)
164 :     else error "set:LOAD32"
165 :     | live([], regs, mem) = (regs, mem)
166 :     | live _ = error "live"
167 :     val (regs, mem) = live(bindings, [], [])
168 :     in {regs=S.uniq regs, mem=S.uniq mem} end
169 :    
170 :     fun difference({regs=r1,mem=m1}, {regs=r2,mem=m2}) =
171 :     {regs=S.difference(r1,r2), mem=S.difference(m1,m2)}
172 :    
173 :     fun setToString{regs,mem} =
174 :     "{"^foldr (fn (r,s) => Cells.toString Cells.GP r^" "^s) "" regs
175 :     ^foldr (fn (m,s) => Int.toString m^" "^s) "" mem^"}"
176 :    
177 :     fun setToMLTree{regs,mem} =
178 :     map (fn r => T.REG(32,r)) regs @
179 :     map (fn i => T.LOAD(32, T.ADD(addrTy, spR, T.LI i), R.memory)) mem
180 :    
181 : blume 515 (* The client communicates root pointers to the gc via the following set
182 : monnier 427 * of registers and memory locations.
183 :     *)
184 :     val gcrootSet = set gcParamRegs
185 :     val aRoot = hd(#regs gcrootSet)
186 :     val aRootReg = T.REG(32,aRoot)
187 :    
188 :     (*
189 :     * This function generates a gc limit check.
190 :     * It returns the label to the GC invocation block.
191 :     *)
192 :     fun checkLimit(emit, maxAlloc) =
193 :     let val lab = Label.newLabel ""
194 : george 546 fun gotoGC(cc) = emit(T.ANNOTATION(T.BCC([], cc, lab), unlikely))
195 : monnier 427 in if maxAlloc < skidPad then
196 :     (case C.exhausted of
197 :     SOME cc => gotoGC cc
198 :     | NONE => gotoGC(normalTestLimit)
199 :     )
200 :     else
201 :     let val shiftedAllocPtr = T.ADD(addrTy,C.allocptr,T.LI(maxAlloc-skidPad))
202 :     val shiftedTestLimit = T.CMP(pty, gcCmp, shiftedAllocPtr, C.limitptr)
203 :     in case C.exhausted of
204 : george 546 SOME(cc as T.CC(_,r)) =>
205 : monnier 427 (emit(T.CCMV(r, shiftedTestLimit)); gotoGC(cc))
206 :     | NONE => gotoGC(shiftedTestLimit)
207 :     | _ => error "checkLimit"
208 :     end;
209 :     lab
210 :     end
211 :    
212 :     (*
213 : blume 515 * This function recomputes the base pointer address.
214 : monnier 427 *)
215 : blume 515 fun computeBasePtr(emit,defineLabel,annotation) =
216 : monnier 427 let val returnLab = Label.newLabel ""
217 :     val baseExp =
218 :     T.ADD(addrTy, C.gcLink,
219 : george 546 T.LABEL(LE.MINUS(LE.INT MS.constBaseRegOffset,
220 : monnier 427 LE.LABEL returnLab)))
221 :     in defineLabel returnLab;
222 : leunga 585 annotation(ZERO_FREQ);
223 : monnier 427 emit(case C.baseptr of
224 :     T.REG(ty, bpt) => T.MV(ty, bpt, baseExp)
225 :     | T.LOAD(ty, ea, mem) => T.STORE(ty, ea, baseExp, mem)
226 :     | _ => error "computeBasePtr")
227 :     end
228 :    
229 :     (*====================================================================
230 :     * Main functions
231 :     *====================================================================*)
232 :     fun init() =
233 : monnier 498 (clusterGcBlocks := [];
234 :     knownGcBlocks := [];
235 :     moduleGcBlocks := []
236 : monnier 427 )
237 :    
238 : monnier 498 (*
239 :     * Partition the root set into types
240 :     *)
241 :     fun split([], [], boxed, int32, float) =
242 :     {boxed=boxed, int32=int32, float=float}
243 :     | split(T.GPR r::rl, CPS.INT32t::tl, b, i, f) = split(rl,tl,b,r::i,f)
244 :     | split(T.GPR r::rl, CPS.FLTt::tl, b, i, f) = error "split: T.GPR"
245 :     | split(T.GPR r::rl, _::tl, b, i, f) = split(rl,tl,r::b,i,f)
246 :     | split(T.FPR r::rl, CPS.FLTt::tl, b, i, f) = split(rl,tl,b,i,r::f)
247 :     | split _ = error "split"
248 :    
249 :     fun genGcInfo (clusterRef,known,optimized) (St.STREAM{emit,...} : stream)
250 : monnier 427 {maxAlloc, regfmls, regtys, return} =
251 : monnier 498 let (* partition the root set into the appropriate classes *)
252 :     val {boxed, int32, float} = split(regfmls, regtys, [], [], [])
253 : monnier 427
254 :     in clusterRef :=
255 : monnier 498 GCINFO{ known = known,
256 :     optimized=optimized,
257 :     lab = ref (checkLimit(emit,maxAlloc)),
258 :     boxed = boxed,
259 :     int32 = int32,
260 :     float = float,
261 :     regfmls = regfmls,
262 :     ret = return } :: (!clusterRef)
263 : monnier 427 end
264 :    
265 :     (*
266 :     * Check-limit for standard functions, i.e.~functions with
267 :     * external entries.
268 :     *)
269 : monnier 498 val stdCheckLimit = genGcInfo (clusterGcBlocks, false, false)
270 : monnier 427
271 :     (*
272 :     * Check-limit for known functions, i.e.~functions with entries from
273 :     * within the same cluster.
274 :     *)
275 : monnier 498 val knwCheckLimit = genGcInfo (knownGcBlocks, true, false)
276 : monnier 427
277 :     (*
278 : monnier 498 * Check-limit for optimized, known functions.
279 : monnier 427 *)
280 : monnier 498 val optimizedKnwCheckLimit = genGcInfo(knownGcBlocks, true, true)
281 : monnier 427
282 : monnier 498 (*
283 : blume 515 * An array for checking cycles
284 :     *)
285 :     local
286 :     val N = (foldr Int.max 0 (#regs gcrootSet))+1
287 :     in
288 :     val clientRoots = A.array(N, ~1)
289 :     val stamp = ref 0
290 :     end
291 :    
292 :     (*
293 :     * This function packs boxed, int32 and float into gcroots.
294 :     * gcroots must be non-empty. Return a function to unpack.
295 :     *)
296 :     fun pack(emit, gcroots, boxed, int32, float) =
297 :     let (*
298 :     * Datatype binding describes the contents a gc root.
299 :     *)
300 :     datatype binding =
301 :     Reg of Cells.cell (* integer register *)
302 :     | Freg of Cells.cell (* floating point register*)
303 : george 555 | Mem of T.rexp * R.region (* integer memory register *)
304 : blume 515 | Record of {boxed: bool, (* is it a boxed record *)
305 :     words:int, (* how many words *)
306 :     reg: Cells.cell, (* address of this record *)
307 :     regTmp: Cells.cell, (* temp used for unpacking *)
308 :     fields: binding list (* its fields *)
309 :     }
310 :    
311 :     (*
312 :     * Translates rexp/fexp into bindings.
313 :     * Note: client roots from memory (XXX) should NOT be used without
314 :     * fixing a potential cycle problem in the parallel copies below.
315 :     * Currently, all architectures, including the x86, do not uses
316 :     * the LOAD(...) form. So we are safe.
317 :     *)
318 :     fun bind(T.REG(32, r)) = Reg r
319 :     | bind(T.LOAD(32, ea, mem)) = Mem(ea, mem) (* XXX *)
320 :     | bind(_) = error "bind"
321 :     fun fbind(T.FREG(64, r)) = Freg r
322 :     | fbind(_) = error "fbind"
323 :    
324 :     val st = !stamp
325 :     val cyclic = st + 1
326 :     val _ = if st > 100000 then stamp := 0 else stamp := st + 2
327 :     val N = A.length clientRoots
328 :     fun markClients [] = ()
329 :     | markClients(T.REG(_, r)::rs) =
330 :     (if r < N then A.update(clientRoots, r, st) else ();
331 :     markClients rs)
332 :     | markClients(_::rs) = markClients rs
333 :     fun markGCRoots [] = ()
334 :     | markGCRoots(T.REG(_, r)::rs) =
335 :     (if A.sub(clientRoots, r) = st then
336 :     A.update(clientRoots, r, cyclic)
337 :     else ();
338 :     markGCRoots rs)
339 :     | markGCRoots(_::rs) = markGCRoots rs
340 :    
341 :     val _ = markClients boxed
342 :     val _ = markClients int32
343 :     val _ = markGCRoots gcroots
344 :    
345 :     (*
346 :     * First, we pack all unboxed roots, if any, into a record.
347 :     *)
348 :     val boxedStuff =
349 :     case (int32, float) of
350 :     ([], []) => map bind boxed
351 :     | _ =>
352 :     (* align the allocptr if we have floating point roots *)
353 :     (case float of
354 :     [] => ()
355 :     | _ => emit(T.MV(addrTy, allocptrR,
356 :     T.ORB(addrTy, C.allocptr, T.LI 4)));
357 :     (* If we have int32 or floating point stuff, package them
358 :     * up into a raw record. Floating point stuff have to come first.
359 :     *)
360 :     let val qwords=length float + (length int32 + 1) div 2
361 :     in Record{boxed=false, reg=Cells.newReg(),
362 :     regTmp=Cells.newReg(),
363 :     words=qwords + qwords,
364 :     fields=map fbind float @ map bind int32}
365 :     ::map bind boxed
366 :     end
367 :     )
368 :     (*
369 :     * Then, we check whether we have enough gc roots to store boxedStuff.
370 :     * If so, we are safe. Otherwise, we have to pack up some of the
371 :     * boxed stuff into a record too.
372 :     *)
373 :    
374 :     val nBoxedStuff = length boxedStuff
375 :     val nGcRoots = length gcroots
376 :    
377 :     val bindings =
378 :     if nBoxedStuff <= nGcRoots
379 :     then boxedStuff (* good enough *)
380 :     else (* package up some of the boxed stuff *)
381 :     let val extra = nBoxedStuff - nGcRoots + 1
382 :     val packUp = List.take(boxedStuff, extra)
383 :     val don'tPackUp = List.drop(boxedStuff, extra)
384 :     in Record{boxed=true, words=length packUp,
385 :     regTmp=Cells.newReg(),
386 :     reg=Cells.newReg(), fields=packUp}::don'tPackUp
387 :     end
388 :    
389 :     fun copy([], _) = ()
390 :     | copy(dst, src) = emit(T.COPY(32, dst, src))
391 :    
392 :     (*
393 :     * The following routine copies the client roots into the real gc roots.
394 :     * We have to make sure that cycles have correctly handled. So we
395 :     * can't do a copy at a time! But see XXX below.
396 :     *)
397 :     fun prolog(hp, unusedRoots, [], rds, rss) =
398 :     let fun init [] = ()
399 :     | init(T.REG(ty, rd)::roots) =
400 :     (emit(T.MV(ty, rd, unit)); init roots)
401 :     | init(T.LOAD(ty, ea, mem)::roots) =
402 :     (emit(T.STORE(ty, ea, unit, mem)); init roots)
403 :     | init _ = error "init"
404 :     in (* update the heap pointer if we have done any allocation *)
405 :     if hp > 0 then
406 :     emit(T.MV(addrTy, allocptrR,
407 :     T.ADD(addrTy, C.allocptr, T.LI hp)))
408 :     else ();
409 :     (* emit the parallel copies *)
410 :     copy(rds, rss);
411 :     (*
412 :     * Any unused gc roots have to be initialized with unit.
413 :     * The following MUST come last.
414 :     *)
415 :     init unusedRoots
416 :     end
417 :     | prolog(hp, T.REG(_,rd)::roots, Reg rs::bs, rds, rss) =
418 :     (* copy client root rs into gc root rd *)
419 :     prolog(hp, roots, bs, rd::rds, rs::rss)
420 :     | prolog(hp, T.REG(_,rd)::roots, Record(r as {reg,...})::bs,rds,rss) =
421 :     (* make a record then copy *)
422 :     let val hp = makeRecord(hp, r)
423 :     in prolog(hp, roots, bs, rd::rds, reg::rss)
424 :     end
425 :     (*| prolog(hp, T.LOAD(_,ea,mem)::roots, b::bs, rds, rss) = (* XXX *)
426 :     (* The following code is unsafe because of potential cycles!
427 :     * But luckly, it is unused XXX.
428 :     *)
429 :     let val (hp, e) =
430 :     case b of
431 :     Reg r => (hp, T.REG(32, r))
432 :     | Mem(ea, mem) => (hp, T.LOAD(32, ea, mem))
433 :     | Record(r as {reg, ...}) =>
434 :     (makeRecord(hp, r), T.REG(32,reg))
435 :     | _ => error "floating point root"
436 :     in emit(T.STORE(32, ea, e, mem));
437 :     prolog(hp, roots, bs, rds, rss)
438 :     end*)
439 :     | prolog _ = error "prolog"
440 :    
441 :     (* Make a record and put it in reg *)
442 :     and makeRecord(hp, {boxed, words, reg, fields, ...}) =
443 :     let fun disp(n) = T.ADD(addrTy, C.allocptr, T.LI n)
444 :     fun alloci(hp, e) = emit(T.STORE(32, disp hp, e, R.memory))
445 :     fun allocf(hp, e) = emit(T.FSTORE(64, disp hp, e, R.memory))
446 :     fun alloc(hp, []) = ()
447 :     | alloc(hp, b::bs) =
448 :     (case b of
449 :     Reg r => (alloci(hp, T.REG(32,r)); alloc(hp+4, bs))
450 :     | Record{reg, ...} =>
451 :     (alloci(hp, T.REG(32,reg)); alloc(hp+4, bs))
452 :     | Mem(ea,m) => (alloci(hp, T.LOAD(32,ea,m)); alloc(hp+4,bs))
453 :     | Freg r => (allocf(hp, T.FREG(64,r)); alloc(hp+8, bs))
454 :     )
455 :     fun evalArgs([], hp) = hp
456 :     | evalArgs(Record r::args, hp) =
457 :     evalArgs(args, makeRecord(hp, r))
458 :     | evalArgs(_::args, hp) = evalArgs(args, hp)
459 :     (* MUST evaluate nested records first *)
460 :     val hp = evalArgs(fields, hp)
461 :     val desc = if boxed then boxedDesc words else unboxedDesc words
462 :     in emit(T.STORE(32, disp hp, T.LI desc, R.memory));
463 :     alloc(hp+4, fields);
464 :     emit(T.MV(addrTy, reg, disp(hp+4)));
465 :     hp + 4 + Word.toIntX(Word.<<(Word.fromInt words,0w2))
466 :     end
467 :    
468 :     (* Copy the gc roots back to client roots.
469 :     * Again, to avoid potential cycles, we generate a single
470 :     * parallel copy that moves the gc roots back to the client roots.
471 :     *)
472 :     fun epilog([], unusedGcRoots, rds, rss) =
473 :     copy(rds, rss)
474 :     | epilog(Reg rd::bs, T.REG(_,rs)::roots, rds, rss) =
475 :     epilog(bs, roots, rd::rds, rs::rss)
476 :     | epilog(Record{fields,regTmp,...}::bs, T.REG(_,r)::roots, rds, rss) =
477 :     (* unbundle record *)
478 :     let val _ = emit(T.COPY(32, [regTmp], [r]))
479 :     val (rds, rss) = unpack(regTmp, fields, rds, rss)
480 :     in epilog(bs, roots, rds, rss) end
481 :     | epilog(b::bs, r::roots, rds, rss) =
482 :     (assign(b, r); (* XXX *)
483 :     epilog(bs, roots, rds, rss)
484 :     )
485 :     | epilog _ = error "epilog"
486 :    
487 :     and assign(Reg r, e) = emit(T.MV(32, r, e))
488 :     | assign(Mem(ea, mem), e) = emit(T.STORE(32, ea, e, mem))
489 :     | assign _ = error "assign"
490 :    
491 :     (* unpack fields from record *)
492 :     and unpack(recordR, fields, rds, rss) =
493 :     let val record = T.REG(32, recordR)
494 :     fun disp n = T.ADD(addrTy, record, T.LI n)
495 :     fun sel n = T.LOAD(32, disp n, R.memory)
496 :     fun fsel n = T.FLOAD(64, disp n, R.memory)
497 :     val N = A.length clientRoots
498 :     (* unpack normal fields *)
499 :     fun unpackFields(n, [], rds, rss) = (rds, rss)
500 :     | unpackFields(n, Freg r::bs, rds, rss) =
501 :     (emit(T.FMV(64, r, fsel n));
502 :     unpackFields(n+8, bs, rds, rss))
503 :     | unpackFields(n, Mem(ea, mem)::bs, rds, rss) =
504 :     (emit(T.STORE(32, ea, sel n, mem)); (* XXX *)
505 :     unpackFields(n+4, bs, rds, rss))
506 :     | unpackFields(n, Record{regTmp, ...}::bs, rds, rss) =
507 :     (emit(T.MV(32, regTmp, sel n));
508 :     unpackFields(n+4, bs, rds, rss))
509 :     | unpackFields(n, Reg rd::bs, rds, rss) =
510 :     if rd < N andalso A.sub(clientRoots, rd) = cyclic then
511 :     let val tmpR = Cells.newReg()
512 :     in (* print "WARNING: CYCLE\n"; *)
513 :     emit(T.MV(32, tmpR, sel n));
514 :     unpackFields(n+4, bs, rd::rds, tmpR::rss)
515 :     end else
516 :     (emit(T.MV(32, rd, sel n));
517 :     unpackFields(n+4, bs, rds, rss))
518 :    
519 :     (* unpack nested record *)
520 :     fun unpackNested(_, [], rds, rss) = (rds, rss)
521 :     | unpackNested(n, Record{fields, regTmp, ...}::bs, rds, rss) =
522 :     let val (rds, rss) = unpack(regTmp, fields, rds, rss)
523 :     in unpackNested(n+4, bs, rds, rss)
524 :     end
525 :     | unpackNested(n, Freg _::bs, rds, rss) =
526 :     unpackNested(n+8, bs, rds, rss)
527 :     | unpackNested(n, _::bs, rds, rss) =
528 :     unpackNested(n+4, bs, rds, rss)
529 :    
530 :     val (rds, rss)= unpackFields(0, fields, rds, rss)
531 :     in unpackNested(0, fields, rds, rss)
532 :     end
533 :    
534 :     (* generate code *)
535 :     in prolog(0, gcroots, bindings, [], []);
536 :     (* return the unpack function *)
537 :     fn () => epilog(bindings, gcroots, [], [])
538 :     end
539 :    
540 :     (*
541 : monnier 498 * The following auxiliary function generates the actual call gc code.
542 :     * It packages up the roots into the appropriate
543 :     * records, call the GC routine, then unpack the roots from the record.
544 :     *)
545 :     fun emitCallGC{stream=St.STREAM{emit, annotation, defineLabel, ...},
546 :     known, boxed, int32, float, ret} =
547 :     let (* IMPORTANT NOTE:
548 : monnier 427 * If a boxed root happens be in a gc root register, we can remove
549 :     * this root since it will be correctly targetted.
550 :     *
551 :     * boxedRoots are the boxed roots that we have to move to the appropriate
552 :     * registers. gcrootSet are the registers that are available
553 :     * for communicating to the collector.
554 :     *)
555 :     val boxedSet = set boxed
556 :     val boxedRoots = difference(boxedSet,gcrootSet) (* roots *)
557 :     val gcrootAvail = difference(gcrootSet,boxedSet) (* gcroots available *)
558 :    
559 :     fun mark(call) =
560 :     if !debug then
561 : monnier 498 T.ANNOTATION(call,#create MLRiscAnnotations.COMMENT
562 : monnier 427 ("roots="^setToString gcrootAvail^
563 :     " boxed="^setToString boxedRoots))
564 :     else call
565 : monnier 498
566 : monnier 427 (* convert them back to MLTREE *)
567 :     val boxed = setToMLTree boxedRoots
568 :     val gcroots = setToMLTree gcrootAvail
569 :    
570 :     (* If we have any remaining roots after the above trick, we have to
571 :     * make sure that gcroots is not empty.
572 :     *)
573 :     val (gcroots, boxed) =
574 :     case (gcroots, int32, float, boxed) of
575 :     ([], [], [], []) => ([], []) (* it's okay *)
576 : george 546 | ([], _, _, _) => ([aRootReg], boxed @ [aRootReg])
577 :     (* put aRootReg last to reduce register pressure
578 :     * during unpacking
579 :     *)
580 : monnier 427 | _ => (gcroots, boxed)
581 :    
582 : blume 515 val unpack = pack(emit, gcroots, boxed, int32, float)
583 :     in annotation(CALLGC);
584 : leunga 585 annotation(NO_OPTIMIZATION);
585 :     annotation(ZERO_FREQ);
586 : monnier 427 emit(mark(gcCall));
587 : blume 515 if known then computeBasePtr(emit,defineLabel,annotation) else ();
588 : leunga 585 annotation(NO_OPTIMIZATION);
589 : monnier 427 unpack();
590 : monnier 498 emit ret
591 :     end
592 :    
593 :     (*
594 :     * The following function is responsible for generating only the
595 :     * callGC code.
596 :     *)
597 :     fun callGC stream {regfmls, regtys, ret} =
598 :     let val {boxed, int32, float} = split(regfmls, regtys, [], [], [])
599 :     in emitCallGC{stream=stream, known=true,
600 :     boxed=boxed, int32=int32, float=float, ret=ret}
601 :     end
602 :    
603 :     (*
604 : george 546 * This function emits a comment that pretty prints the root set.
605 :     * This is used for debugging only.
606 :     *)
607 :     fun rootSetToString{boxed, int32, float} =
608 :     let fun extract(T.REG(32, r)) = r
609 :     | extract _ = error "extract"
610 :     fun fextract(T.FREG(64, f)) = f
611 :     | fextract _ = error "fextract"
612 :     fun listify title f [] = ""
613 :     | listify title f l =
614 :     title^foldr (fn (x,"") => f x
615 :     | (x,y) => f x ^", "^y) "" (S.uniq l)^" "
616 :     in listify "boxed=" (Cells.toString Cells.GP) (map extract boxed)^
617 :     listify "int32=" (Cells.toString Cells.GP) (map extract int32)^
618 :     listify "float=" (Cells.toString Cells.FP) (map fextract float)
619 :     end
620 :    
621 :     (*
622 : monnier 498 * The following function is responsible for generating actual
623 :     * GC calling code, with entry labels and return information.
624 :     *)
625 :     fun invokeGC(stream as
626 :     St.STREAM{emit,defineLabel,entryLabel,exitBlock,annotation,...},
627 :     externalEntry) gcInfo =
628 :     let val {known, optimized, boxed, int32, float, regfmls, ret, lab} =
629 :     case gcInfo of
630 :     GCINFO info => info
631 :     | MODULE{info=GCINFO info,...} => info
632 :     | _ => error "invokeGC:gcInfo"
633 :    
634 : george 546 val liveout = if optimized then [] else regfmls
635 : monnier 498
636 :     in if externalEntry then entryLabel (!lab) else defineLabel (!lab);
637 :     (* When the known block is optimized, no actual code is generated
638 :     * until later.
639 :     *)
640 : george 546 if optimized then
641 :     (annotation(#create MLRiscAnnotations.GCSAFEPOINT
642 :     (rootSetToString{boxed=boxed, int32=int32, float=float}));
643 :     emit ret
644 :     )
645 : monnier 498 else emitCallGC{stream=stream, known=known,
646 :     boxed=boxed, int32=int32, float=float, ret=ret};
647 : george 546 exitBlock(case C.exhausted of NONE => liveout
648 :     | SOME cc => T.CCR cc::liveout)
649 : monnier 427 end
650 :    
651 :     (*
652 :     * The following function checks whether two root set have the
653 :     * same calling convention.
654 :     *)
655 :     fun sameCallingConvention
656 : george 546 (GCINFO{boxed=b1, int32=i1, float=f1, ret=T.JMP(_, ret1, _), ...},
657 :     GCINFO{boxed=b2, int32=i2, float=f2, ret=T.JMP(_, ret2, _), ...}) =
658 : monnier 427 let fun eqEA(T.REG(_, r1), T.REG(_, r2)) = r1 = r2
659 :     | eqEA(T.ADD(_,T.REG(_,r1),T.LI i), T.ADD(_,T.REG(_,r2),T.LI j)) =
660 :     r1 = r2 andalso i = j
661 :     | eqEA _ = false
662 :     fun eqR(T.REG(_,r1), T.REG(_,r2)) = r1 = r2
663 :     | eqR(T.LOAD(_,ea1,_), T.LOAD(_,ea2,_)) = eqEA(ea1, ea2)
664 :     | eqR _ = false
665 :     fun eqF(T.FREG(_,f1), T.FREG(_,f2)) = f1 = f2
666 :     | eqF(T.FLOAD(_,ea1,_), T.FLOAD(_,ea2,_)) = eqEA(ea1, ea2)
667 :     | eqF _ = false
668 :    
669 :     fun all predicate =
670 :     let fun f(a::x,b::y) = predicate(a,b) andalso f(x,y)
671 :     | f([],[]) = true
672 :     | f _ = false
673 :     in f end
674 :    
675 :     val eqRexp = all eqR
676 :     in eqRexp(b1, b2) andalso eqR(ret1,ret2) andalso
677 :     eqRexp(i1,i2) andalso all eqF(f1,f2)
678 :     end
679 :     | sameCallingConvention _ = false
680 :    
681 :     (*
682 :     * The following function is called once at the end of compiling a cluster.
683 :     * Generates long jumps to the end of the module unit for
684 :     * standard functions, and directly invokes GC for known functions.
685 :     * The actual GC invocation code is not generated yet.
686 :     *)
687 :     fun emitLongJumpsToGCInvocation
688 :     (stream as St.STREAM{emit,defineLabel,exitBlock,...}) =
689 :     let (* GC code can be shared if the calling convention is the same
690 :     * Use linear search to find the gc subroutine.
691 :     *)
692 :     fun find(info as GCINFO{lab as ref l, ...}) =
693 :     let fun search(MODULE{info=info', addrs}::rest) =
694 :     if sameCallingConvention(info, info') then
695 :     addrs := l :: (!addrs)
696 :     else search rest
697 :     | search [] = (* no matching convention *)
698 :     let val label = Label.newLabel ""
699 :     in lab := label;
700 :     moduleGcBlocks := MODULE{info=info, addrs=ref[l]} ::
701 :     (!moduleGcBlocks)
702 :     end
703 : blume 515 | search _ = error "search"
704 : monnier 427 in search(!moduleGcBlocks)
705 :     end
706 : blume 515 | find _ = error "find"
707 : monnier 427
708 :     (*
709 :     * Generate a long jump to all external callgc routines
710 :     *)
711 :     fun longJumps(MODULE{addrs=ref [],...}) = ()
712 :     | longJumps(MODULE{info=GCINFO{lab,boxed,int32,float,...}, addrs}) =
713 : blume 515 let val regRoots = map T.GPR (int32 @ boxed)
714 :     val fregRoots = map T.FPR float
715 :     val liveOut = regRoots @ fregRoots
716 :     val l = !lab
717 :     in app defineLabel (!addrs) before addrs := [];
718 : george 546 emit(T.JMP([], T.LABEL(LE.LABEL l), []));
719 : blume 515 exitBlock liveOut
720 :     end
721 :     | longJumps _ = error "longJumps"
722 : monnier 427
723 :     in app find (!clusterGcBlocks) before clusterGcBlocks := [];
724 :     app longJumps (!moduleGcBlocks);
725 :     app (invokeGC(stream,false)) (!knownGcBlocks) before knownGcBlocks := []
726 :     end (* emitLongJumpsToGC *)
727 :    
728 :     (*
729 :     * The following function is called to generate module specific
730 :     * GC invocation code
731 :     *)
732 :     fun emitModuleGC(stream) =
733 :     app (invokeGC(stream,true)) (!moduleGcBlocks) before moduleGcBlocks := []
734 :    
735 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0