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

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