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 521 - (view) (download)

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

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