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

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