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 499 - (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 :     * in the presence of GC. (Also, I am afraid of changing the old version
7 :     * since I'm not sure I understand every little detail in it.)
8 :     *
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 : monnier 427
29 :     fun error msg = ErrorMsg.impossible("InvokeGC."^msg)
30 :    
31 :     type t = { maxAlloc : int,
32 :     regfmls : T.mlrisc list,
33 :     regtys : CPS.cty list,
34 :     return : T.stm
35 :     }
36 :    
37 :     type stream = (T.stm,Cells.regmap) T.stream
38 :    
39 :     val debug = Control.MLRISC.getFlag "debug-gc";
40 :    
41 :     val addrTy = C.addressWidth
42 :    
43 :     (* GcInfo encapsulates all the information needed to generate
44 :     * code to invoke gc
45 :     *)
46 :     datatype gcInfo =
47 :     GCINFO of
48 : monnier 498 {known : bool, (* known function ? *)
49 :     optimized : bool, (* optimized? *)
50 :     lab : Label.label ref, (* labels to invoke GC *)
51 :     boxed : T.rexp list, (* locations with boxed objects *)
52 :     int32 : T.rexp list, (* locations with int32 objects *)
53 :     float : T.fexp list, (* locations with float objects *)
54 :     regfmls : T.mlrisc list, (* all live registers *)
55 :     ret : T.stm} (* how to return *)
56 : monnier 427 | MODULE of
57 :     {info: gcInfo,
58 :     addrs: Label.label list ref} (* addrs associated with long jump *)
59 :    
60 :     (*====================================================================
61 :     * Implementation/architecture specific stuff starts here.
62 :     *====================================================================*)
63 :    
64 :     (* Extra space in allocation space
65 :     * The SML/NJ runtime system leaves around 4K of extra space
66 :     * in the allocation space for safety.
67 :     *)
68 :     val skidPad = 4096
69 :     val pty = 32
70 :    
71 :     val sp = Cells.stackptrR (* stack pointer *)
72 :     val spR = T.REG(32,sp)
73 :     val unit = T.LI 1 (* representation of ML's unit;
74 :     * this is used to initialize registers
75 :     *)
76 :     (* callee-save registers
77 :     *
78 :     *)
79 :     val calleesaves = List.take(C.miscregs, MS.numCalleeSaves)
80 :    
81 :     (*
82 :     * registers that are the roots of gc.
83 :     *)
84 :     val gcParamRegs = (C.stdlink::C.stdclos::C.stdcont::C.stdarg::calleesaves)
85 :    
86 :     (*
87 :     * How to call the call the GC
88 :     *)
89 :     local val use = map T.GPR gcParamRegs
90 :     val def = case C.exhausted of NONE => use
91 :     | SOME cc => T.CCR cc::use
92 :     in val gcCall =
93 :     T.ANNOTATION(
94 :     T.CALL(
95 :     T.LOAD(32, T.ADD(addrTy,C.stackptr,T.LI MS.startgcOffset), R.stack),
96 :     def, use, R.stack),
97 : monnier 498 #create MLRiscAnnotations.COMMENT "call gc")
98 : monnier 427 end
99 : monnier 469
100 : monnier 498 val CALLGC = #create MLRiscAnnotations.CALLGC ()
101 : monnier 469
102 : monnier 427 (*
103 :     * record descriptors
104 :     *)
105 :     val dtoi = LargeWord.toInt
106 :     fun unboxedDesc words = dtoi(D.makeDesc(words, D.tag_raw64))
107 :     fun boxedDesc words = dtoi(D.makeDesc(words, D.tag_record))
108 :    
109 :     (* the allocation pointer must always in a register! *)
110 :     val T.REG(_,allocptrR) = C.allocptr
111 :    
112 :     (* what type of comparison to use for GC test? *)
113 :     val gcCmp = if C.signedGCTest then T.GT else T.GTU
114 :    
115 : monnier 498 val unlikely = #create MLRiscAnnotations.BRANCH_PROB 0
116 : monnier 427
117 :     val normalTestLimit = T.CMP(pty, gcCmp, C.allocptr, C.limitptr)
118 :    
119 :     (*====================================================================
120 :     * Private state
121 :     *====================================================================*)
122 :     (* gc info required for standard functions within the cluster *)
123 :     val clusterGcBlocks = ref([]: gcInfo list)
124 :    
125 :     (* gc info required for known functions within the cluster *)
126 :     val knownGcBlocks = ref([]: gcInfo list)
127 :    
128 :     (* gc info required for modules *)
129 :     val moduleGcBlocks = ref ([]: gcInfo list)
130 :    
131 :     (*====================================================================
132 :     * Auxiliary functions
133 :     *====================================================================*)
134 :    
135 :     (*
136 :     * Convert a list of rexps into a set of registers and memory offsets.
137 :     * Memory offsets must be relative to the stack pointer.
138 :     *)
139 :     fun set bindings =
140 :     let fun isStackPtr sp = sp = Cells.stackptrR
141 :     fun live(T.REG(_,r)::es, regs, mem) = live(es, r::regs, mem)
142 :     | live(T.LOAD(_, T.REG(_, sp), _)::es, regs, mem) =
143 :     if isStackPtr sp then live(es, regs, 0::mem)
144 :     else error "set:LOAD32"
145 :     | live(T.LOAD(_, T.ADD(_, T.REG(_, sp), T.LI i), _)::es, regs, mem) =
146 :     if isStackPtr sp then live(es, regs, i::mem)
147 :     else error "set:LOAD32"
148 :     | live([], regs, mem) = (regs, mem)
149 :     | live _ = error "live"
150 :     val (regs, mem) = live(bindings, [], [])
151 :     in {regs=S.uniq regs, mem=S.uniq mem} end
152 :    
153 :     fun difference({regs=r1,mem=m1}, {regs=r2,mem=m2}) =
154 :     {regs=S.difference(r1,r2), mem=S.difference(m1,m2)}
155 :    
156 :     fun setToString{regs,mem} =
157 :     "{"^foldr (fn (r,s) => Cells.toString Cells.GP r^" "^s) "" regs
158 :     ^foldr (fn (m,s) => Int.toString m^" "^s) "" mem^"}"
159 :    
160 :     fun setToMLTree{regs,mem} =
161 :     map (fn r => T.REG(32,r)) regs @
162 :     map (fn i => T.LOAD(32, T.ADD(addrTy, spR, T.LI i), R.memory)) mem
163 :    
164 :     (* The client communicate root pointers to the gc via the following set
165 :     * of registers and memory locations.
166 :     *)
167 :     val gcrootSet = set gcParamRegs
168 :     val aRoot = hd(#regs gcrootSet)
169 :     val aRootReg = T.REG(32,aRoot)
170 :    
171 :     (*
172 :     * This function generates a gc limit check.
173 :     * It returns the label to the GC invocation block.
174 :     *)
175 :     fun checkLimit(emit, maxAlloc) =
176 :     let val lab = Label.newLabel ""
177 :     fun gotoGC(cc) = emit(T.ANNOTATION(T.BCC(gcCmp, cc, lab), unlikely))
178 :     in if maxAlloc < skidPad then
179 :     (case C.exhausted of
180 :     SOME cc => gotoGC cc
181 :     | NONE => gotoGC(normalTestLimit)
182 :     )
183 :     else
184 :     let val shiftedAllocPtr = T.ADD(addrTy,C.allocptr,T.LI(maxAlloc-skidPad))
185 :     val shiftedTestLimit = T.CMP(pty, gcCmp, shiftedAllocPtr, C.limitptr)
186 :     in case C.exhausted of
187 :     SOME(cc as T.CC r) =>
188 :     (emit(T.CCMV(r, shiftedTestLimit)); gotoGC(cc))
189 :     | NONE => gotoGC(shiftedTestLimit)
190 :     | _ => error "checkLimit"
191 :     end;
192 :     lab
193 :     end
194 :    
195 :     (*
196 :     * This function recomputes the base pointer address
197 :     *)
198 :     fun computeBasePtr(emit,defineLabel) =
199 :     let val returnLab = Label.newLabel ""
200 :     val baseExp =
201 :     T.ADD(addrTy, C.gcLink,
202 :     T.LABEL(LE.MINUS(LE.CONST MS.constBaseRegOffset,
203 :     LE.LABEL returnLab)))
204 :     in defineLabel returnLab;
205 :     emit(case C.baseptr of
206 :     T.REG(ty, bpt) => T.MV(ty, bpt, baseExp)
207 :     | T.LOAD(ty, ea, mem) => T.STORE(ty, ea, baseExp, mem)
208 :     | _ => error "computeBasePtr")
209 :     end
210 :    
211 :    
212 :     (*
213 :     * Functions to pack and unpack roots.
214 :     *
215 :     * There are two types of records. One contains boxed objects
216 :     * (ints and pointers) and another containing unboxed objects
217 :     * (int32s and reals).
218 :     *
219 :     *)
220 :     local
221 :     fun allocF(emit, [], offset) = offset
222 :     | allocF(emit, f::fs, offset) =
223 :     (emit(T.FSTORE(64, T.ADD(32, C.allocptr, T.LI offset), f, R.memory));
224 :     allocF(emit, fs, offset + 8))
225 :     fun allocR(emit, [], offset) = offset
226 :     | allocR(emit, i::is, offset) =
227 :     (emit(T.STORE(32, T.ADD(32, C.allocptr, T.LI offset), i, R.memory));
228 :     allocR(emit, is, offset + 4))
229 :     fun doNothing _ = ()
230 :    
231 :     (*
232 :     * Parallel copy dst <- src.
233 :     * If pad is true then dst can have more
234 :     * elements than src. The extra elements are padded with unit.
235 :     *)
236 :     fun move(emit, dst, src, pad) =
237 :     let fun copy([],[]) = ()
238 :     | copy(rd,rs) = emit(T.COPY(32,rd,rs))
239 :     fun loop([],[],rd,rs) = ([],rd,rs)
240 :     | loop([],src,rd,rs) = ([],rd,rs)
241 :     | loop(dst,[],rd,rs) =
242 :     (if pad then dst else
243 :     error("missing src "^
244 :     Int.toString(length dst)^" "^Int.toString(length src)),
245 :     rd,rs)
246 :     | loop(T.REG(_,r)::dst,T.REG(_,s)::src,rd,rs) =
247 :     loop(dst,src,r::rd,s::rs)
248 :     | loop(T.REG(ty,r)::dst,e::src,rd,rs) =
249 :     (emit(T.MV(ty,r,e)); loop(dst,src,rd,rs))
250 :     | loop(T.LOAD(ty,ea,mem)::dst,e::src,rd,rs) =
251 :     (emit(T.STORE(ty,ea,e,mem)); loop(dst,src,rd,rs))
252 :     | loop _ = error "loop"
253 :     val (toPad,dst,src) = loop(dst,src,[],[])
254 :     in copy(dst,src); toPad
255 :     end
256 :    
257 :     (* Unpack objects from record, usable by both tagged
258 :     * and untagged objects.
259 :     *)
260 :     fun unpack(emit, record, int, float) () =
261 :     let fun selectR(off) = T.LOAD(32,T.ADD(addrTy,record,T.LI off),R.memory)
262 :     fun selectF(off) = T.FLOAD(64,T.ADD(addrTy,record,T.LI off),R.memory)
263 :     fun doR([], offset) = ()
264 :     | doR(T.REG(t,r)::es, offset) =
265 :     (emit(T.MV(t,r,selectR(offset))); doR(es, offset+4))
266 :     | doR(T.LOAD(t,ea,mem)::es, offset) =
267 :     (emit(T.STORE(t,ea,selectR(offset),mem)); doR(es, offset+4))
268 :     | doR _ = error "unpack.doR"
269 :     fun doF([], offset) = offset
270 :     | doF(T.FREG(t,r)::es, offset) =
271 :     (emit(T.FMV(t,r,selectF(offset))); doF(es, offset+8))
272 :     | doF(T.FLOAD(t,ea,mem)::es, offset) =
273 :     (emit(T.FSTORE(t,ea,selectF(offset),mem)); doF(es, offset+8))
274 :     | doF _ = error "unpack.doF"
275 :     in doR(int, doF(float, 0))
276 :     end
277 :    
278 :     (* Pack int32s + floats together into a raw64 record.
279 :     * Return the record pointer, and the new heap pointer offset.
280 :     *)
281 :     fun packUnboxed(emit, int32, float) =
282 :     let val qwords = length float + (length int32 + 1) div 2
283 :     val desc = unboxedDesc(qwords + qwords)
284 :     val _ =
285 :     (* align the allocptr if we have floating point roots *)
286 :     case float of
287 :     [] => ()
288 :     | _ => emit(T.MV(32, allocptrR, T.ORB(32, C.allocptr, T.LI 4)))
289 :     val _ = emit(T.STORE(pty, C.allocptr, T.LI desc, R.memory))
290 :     val _ = allocR(emit, int32, allocF(emit, float, 4))
291 :     val t = Cells.newReg()
292 :     in emit(T.MV(pty, t, T.ADD(addrTy, C.allocptr, T.LI 4)));
293 :     (T.REG(32,t), qwords * 8 + 4)
294 :     end
295 :    
296 :     (*
297 :     * Pack tagged objects into a single record.
298 :     * Return the record pointer, and the new heap pointer offset.
299 :     *)
300 :     fun packBoxed(emit, hp, boxed) =
301 :     let val words = length boxed
302 :     val desc = boxedDesc(words)
303 :     val _ = emit(T.STORE(pty, T.ADD(addrTy, C.allocptr, T.LI hp),
304 :     T.LI desc, R.memory))
305 :     val hp' = allocR(emit, boxed, hp+4)
306 :     val t = Cells.newReg()
307 :     in emit(T.MV(pty, t, T.ADD(addrTy, C.allocptr, T.LI(hp+4))));
308 :     (T.REG(32,t), hp')
309 :     end
310 :    
311 :     in
312 :     (*
313 :     * Initialize the list of roots with unit
314 :     *)
315 :     fun initRoots(emit,roots) =
316 :     app (fn T.REG(ty,r) => emit(T.MV(ty,r,unit))
317 :     | T.LOAD(ty,ea,mem) => emit(T.STORE(ty,ea,unit,mem))
318 :     | _ => error "initRoots") roots
319 :    
320 :     (*
321 :     * Pack all the roots together into the appropriate records.
322 :     * Invariant: gcRoots must be non-empty.
323 :     *)
324 :     fun pack(emit, gcRoots, boxed, int32, float) =
325 :     let (* package up the unboxed things first *)
326 :     val (boxedIn,boxedOut,raw,hp,unpackRaw) =
327 :     case (int32,float) of
328 :     ([],[]) => (boxed, boxed, ~1, 0, doNothing)
329 :     | _ =>
330 :     let val (r, hp) = packUnboxed(emit, int32, float)
331 :     val r' = Cells.newReg()
332 :     val r'' = T.REG(32,r')
333 :     in (r::boxed, r''::boxed, r',
334 :     hp, unpack(emit, r'', int32, float))
335 :     end
336 :    
337 :     val nGcRoots = length gcRoots
338 :     val nBoxed = length boxedIn
339 :    
340 :     (* package up the boxed things if necessary *)
341 :     val (rootsIn, rootsOut, cooked, hp, unpackBoxed) =
342 :     if nBoxed > nGcRoots then
343 :     let fun take(0, l, front) = (rev front, l)
344 :     | take(n, x::xs, front) = take(n-1, xs, x::front)
345 :     | take _ = error "take"
346 :     val nRoots = nGcRoots - 1
347 :     val (restIn, extraIn) = take(nRoots,boxedIn,[])
348 :     val (restOut, extraOut) = take(nRoots,boxedOut,[])
349 :     val (r, hp) = packBoxed(emit, hp, extraIn)
350 :     val r' = Cells.newReg()
351 :     val r'' = T.REG(32,r')
352 :     in (r::restIn, r''::restOut, r',
353 :     hp, unpack(emit, r'', extraOut, []))
354 :     end
355 :     else (boxedIn, boxedOut, ~1, hp, doNothing)
356 :    
357 :     fun unpack() =
358 :     let fun get(r,(d as T.REG(_,r'))::dst,s::src,dst',src') =
359 :     if r = r' then ([d],[s],rev dst'@dst,rev src'@src)
360 :     else get(r,dst,src,d::dst',s::src')
361 :     | get(r,d::dst,s::src,dst',src') =
362 :     get(r,dst,src,d::dst',s::src')
363 :     | get(r,dst,src,dst',src') = ([],[],rev dst'@dst,rev src'@src)
364 :     val (rawDst,rawSrc,rootsOut,gcRoots) =
365 :     get(raw,rootsOut,gcRoots,[],[])
366 :     val (cookedDst,cookedSrc,rootsOut,gcRoots) =
367 :     get(cooked,rootsOut,gcRoots,[],[])
368 :     in (* copy the boxed record root to its temporary *)
369 :     move(emit,cookedDst,cookedSrc,false);
370 :     unpackBoxed();
371 :     (* copy the raw record root to its temporary *)
372 :     move(emit,rawDst,rawSrc,false);
373 :     unpackRaw();
374 :     (* copy the rest of the roots back to its original registers *)
375 :     move(emit,rootsOut,gcRoots,false)
376 :     end
377 :    
378 :     in (* update the allocation pointer *)
379 :     if hp > 0 then
380 :     emit(T.MV(pty, allocptrR, T.ADD(addrTy, C.allocptr, T.LI hp)))
381 :     else ();
382 :     (move(emit,gcRoots,rootsIn,true), unpack)
383 :     end
384 :    
385 :     end
386 :    
387 :     (*====================================================================
388 :     * Main functions
389 :     *====================================================================*)
390 :     fun init() =
391 : monnier 498 (clusterGcBlocks := [];
392 :     knownGcBlocks := [];
393 :     moduleGcBlocks := []
394 : monnier 427 )
395 :    
396 : monnier 498 (*
397 :     * Partition the root set into types
398 :     *)
399 :     fun split([], [], boxed, int32, float) =
400 :     {boxed=boxed, int32=int32, float=float}
401 :     | split(T.GPR r::rl, CPS.INT32t::tl, b, i, f) = split(rl,tl,b,r::i,f)
402 :     | split(T.GPR r::rl, CPS.FLTt::tl, b, i, f) = error "split: T.GPR"
403 :     | split(T.GPR r::rl, _::tl, b, i, f) = split(rl,tl,r::b,i,f)
404 :     | split(T.FPR r::rl, CPS.FLTt::tl, b, i, f) = split(rl,tl,b,i,r::f)
405 :     | split _ = error "split"
406 :    
407 :     fun genGcInfo (clusterRef,known,optimized) (St.STREAM{emit,...} : stream)
408 : monnier 427 {maxAlloc, regfmls, regtys, return} =
409 : monnier 498 let (* partition the root set into the appropriate classes *)
410 :     val {boxed, int32, float} = split(regfmls, regtys, [], [], [])
411 : monnier 427
412 :     in clusterRef :=
413 : monnier 498 GCINFO{ known = known,
414 :     optimized=optimized,
415 :     lab = ref (checkLimit(emit,maxAlloc)),
416 :     boxed = boxed,
417 :     int32 = int32,
418 :     float = float,
419 :     regfmls = regfmls,
420 :     ret = return } :: (!clusterRef)
421 : monnier 427 end
422 :    
423 :     (*
424 :     * Check-limit for standard functions, i.e.~functions with
425 :     * external entries.
426 :     *)
427 : monnier 498 val stdCheckLimit = genGcInfo (clusterGcBlocks, false, false)
428 : monnier 427
429 :     (*
430 :     * Check-limit for known functions, i.e.~functions with entries from
431 :     * within the same cluster.
432 :     *)
433 : monnier 498 val knwCheckLimit = genGcInfo (knownGcBlocks, true, false)
434 : monnier 427
435 :     (*
436 : monnier 498 * Check-limit for optimized, known functions.
437 : monnier 427 *)
438 : monnier 498 val optimizedKnwCheckLimit = genGcInfo(knownGcBlocks, true, true)
439 : monnier 427
440 : monnier 498 (*
441 :     * The following auxiliary function generates the actual call gc code.
442 :     * It packages up the roots into the appropriate
443 :     * records, call the GC routine, then unpack the roots from the record.
444 :     *)
445 :     fun emitCallGC{stream=St.STREAM{emit, annotation, defineLabel, ...},
446 :     known, boxed, int32, float, ret} =
447 :     let (* IMPORTANT NOTE:
448 : monnier 427 * If a boxed root happens be in a gc root register, we can remove
449 :     * this root since it will be correctly targetted.
450 :     *
451 :     * boxedRoots are the boxed roots that we have to move to the appropriate
452 :     * registers. gcrootSet are the registers that are available
453 :     * for communicating to the collector.
454 :     *)
455 :     val boxedSet = set boxed
456 :     val boxedRoots = difference(boxedSet,gcrootSet) (* roots *)
457 :     val gcrootAvail = difference(gcrootSet,boxedSet) (* gcroots available *)
458 :    
459 :     fun mark(call) =
460 :     if !debug then
461 : monnier 498 T.ANNOTATION(call,#create MLRiscAnnotations.COMMENT
462 : monnier 427 ("roots="^setToString gcrootAvail^
463 :     " boxed="^setToString boxedRoots))
464 :     else call
465 : monnier 498
466 : monnier 427 (* convert them back to MLTREE *)
467 :     val boxed = setToMLTree boxedRoots
468 :     val gcroots = setToMLTree gcrootAvail
469 :    
470 :     (* If we have any remaining roots after the above trick, we have to
471 :     * make sure that gcroots is not empty.
472 :     *)
473 :     val (gcroots, boxed) =
474 :     case (gcroots, int32, float, boxed) of
475 :     ([], [], [], []) => ([], []) (* it's okay *)
476 :     | ([], _, _, _) => ([aRootReg], aRootReg::boxed)
477 :     | _ => (gcroots, boxed)
478 :    
479 :     val (extraRoots,unpack) = pack(emit, gcroots, boxed, int32, float)
480 :     in initRoots(emit, extraRoots);
481 : monnier 469 annotation(CALLGC);
482 : monnier 427 emit(mark(gcCall));
483 :     if known then computeBasePtr(emit,defineLabel) else ();
484 :     unpack();
485 : monnier 498 emit ret
486 :     end
487 :    
488 :     (*
489 :     * The following function is responsible for generating only the
490 :     * callGC code.
491 :     *)
492 :     fun callGC stream {regfmls, regtys, ret} =
493 :     let val {boxed, int32, float} = split(regfmls, regtys, [], [], [])
494 :     in emitCallGC{stream=stream, known=true,
495 :     boxed=boxed, int32=int32, float=float, ret=ret}
496 :     end
497 :    
498 :     (*
499 :     * The following function is responsible for generating actual
500 :     * GC calling code, with entry labels and return information.
501 :     *)
502 :     fun invokeGC(stream as
503 :     St.STREAM{emit,defineLabel,entryLabel,exitBlock,annotation,...},
504 :     externalEntry) gcInfo =
505 :     let val {known, optimized, boxed, int32, float, regfmls, ret, lab} =
506 :     case gcInfo of
507 :     GCINFO info => info
508 :     | MODULE{info=GCINFO info,...} => info
509 :     | _ => error "invokeGC:gcInfo"
510 :    
511 :     val regfmls = if optimized then [] else regfmls
512 :    
513 :     in if externalEntry then entryLabel (!lab) else defineLabel (!lab);
514 :     (* When the known block is optimized, no actual code is generated
515 :     * until later.
516 :     *)
517 :     if optimized then (annotation(CALLGC); emit ret)
518 :     else emitCallGC{stream=stream, known=known,
519 :     boxed=boxed, int32=int32, float=float, ret=ret};
520 : monnier 427 exitBlock(case C.exhausted of NONE => regfmls
521 :     | SOME cc => T.CCR cc::regfmls)
522 :     end
523 :    
524 :     (*
525 :     * The following function checks whether two root set have the
526 :     * same calling convention.
527 :     *)
528 :     fun sameCallingConvention
529 :     (GCINFO{boxed=b1, int32=i1, float=f1, ret=T.JMP(ret1, _), ...},
530 :     GCINFO{boxed=b2, int32=i2, float=f2, ret=T.JMP(ret2, _), ...}) =
531 :     let fun eqEA(T.REG(_, r1), T.REG(_, r2)) = r1 = r2
532 :     | eqEA(T.ADD(_,T.REG(_,r1),T.LI i), T.ADD(_,T.REG(_,r2),T.LI j)) =
533 :     r1 = r2 andalso i = j
534 :     | eqEA _ = false
535 :     fun eqR(T.REG(_,r1), T.REG(_,r2)) = r1 = r2
536 :     | eqR(T.LOAD(_,ea1,_), T.LOAD(_,ea2,_)) = eqEA(ea1, ea2)
537 :     | eqR _ = false
538 :     fun eqF(T.FREG(_,f1), T.FREG(_,f2)) = f1 = f2
539 :     | eqF(T.FLOAD(_,ea1,_), T.FLOAD(_,ea2,_)) = eqEA(ea1, ea2)
540 :     | eqF _ = false
541 :    
542 :     fun all predicate =
543 :     let fun f(a::x,b::y) = predicate(a,b) andalso f(x,y)
544 :     | f([],[]) = true
545 :     | f _ = false
546 :     in f end
547 :    
548 :     val eqRexp = all eqR
549 :     in eqRexp(b1, b2) andalso eqR(ret1,ret2) andalso
550 :     eqRexp(i1,i2) andalso all eqF(f1,f2)
551 :     end
552 :     | sameCallingConvention _ = false
553 :    
554 :     (*
555 :     * The following function is called once at the end of compiling a cluster.
556 :     * Generates long jumps to the end of the module unit for
557 :     * standard functions, and directly invokes GC for known functions.
558 :     * The actual GC invocation code is not generated yet.
559 :     *)
560 :     fun emitLongJumpsToGCInvocation
561 :     (stream as St.STREAM{emit,defineLabel,exitBlock,...}) =
562 :     let (* GC code can be shared if the calling convention is the same
563 :     * Use linear search to find the gc subroutine.
564 :     *)
565 :     fun find(info as GCINFO{lab as ref l, ...}) =
566 :     let fun search(MODULE{info=info', addrs}::rest) =
567 :     if sameCallingConvention(info, info') then
568 :     addrs := l :: (!addrs)
569 :     else search rest
570 :     | search [] = (* no matching convention *)
571 :     let val label = Label.newLabel ""
572 :     in lab := label;
573 :     moduleGcBlocks := MODULE{info=info, addrs=ref[l]} ::
574 :     (!moduleGcBlocks)
575 :     end
576 :     in search(!moduleGcBlocks)
577 :     end
578 :    
579 :     (*
580 :     * Generate a long jump to all external callgc routines
581 :     *)
582 :     fun longJumps(MODULE{addrs=ref [],...}) = ()
583 :     | longJumps(MODULE{info=GCINFO{lab,boxed,int32,float,...}, addrs}) =
584 :     let val regRoots = map T.GPR (int32 @ boxed)
585 :     val fregRoots = map T.FPR float
586 :     val liveOut = regRoots @ fregRoots
587 :     val l = !lab
588 :     in app defineLabel (!addrs) before addrs := [];
589 :     emit(T.JMP(T.LABEL(LE.LABEL l),[l]));
590 :     exitBlock liveOut
591 :     end
592 :    
593 :     in app find (!clusterGcBlocks) before clusterGcBlocks := [];
594 :     app longJumps (!moduleGcBlocks);
595 :     app (invokeGC(stream,false)) (!knownGcBlocks) before knownGcBlocks := []
596 :     end (* emitLongJumpsToGC *)
597 :    
598 :     (*
599 :     * The following function is called to generate module specific
600 :     * GC invocation code
601 :     *)
602 :     fun emitModuleGC(stream) =
603 :     app (invokeGC(stream,true)) (!moduleGcBlocks) before moduleGcBlocks := []
604 :    
605 :     end

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