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

SCM Repository

[smlnj] Diff of /sml/branches/SMLNJ/src/compiler/CodeGen/cpscompile/callgc.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/CodeGen/cpscompile/callgc.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 428, Wed Sep 8 09:47:00 1999 UTC revision 429, Wed Sep 8 09:47:00 1999 UTC
# Line 16  Line 16 
16    structure R = CPSRegions    structure R = CPSRegions
17    structure W = Word    structure W = Word
18    structure S = SortedList    structure S = SortedList
19      structure St = T.Stream
20    
21    val dtoi = LargeWord.toInt    val dtoi = LargeWord.toInt
22    
23    val skidPad = 4096                    (* extra space in allocation space *)    val skidPad = 4096                    (* extra space in allocation space *)
24    
25      type emitter = (T.stm,int Intmap.intmap) T.stream
26    
27    fun error msg = ErrorMsg.impossible ("CallGC." ^ msg)    fun error msg = ErrorMsg.impossible ("CallGC." ^ msg)
28    
29    type t =    type t =
# Line 29  Line 32 
32       regtys: CPS.cty list,       regtys: CPS.cty list,
33       return: T.stm}       return: T.stm}
34    
   type emitter = {emit:T.stm -> unit, comp:T.mltree -> unit}  
   
35    datatype binding =    datatype binding =
36        Reg of int                        (* register *)        Reg of int                        (* register *)
37      | Raw of                            (* float + int32 record *)      | Raw of                            (* float + int32 record *)
# Line 155  Line 156 
156           maskList(rl, tl, b, i, r::f)           maskList(rl, tl, b, i, r::f)
157        | maskList _ = error "checkLimit.maskList"        | maskList _ = error "checkLimit.maskList"
158    
159      fun genGcInfo (clusterRef,known) ({emit,comp}:emitter)      fun genGcInfo (clusterRef,known) (St.STREAM{emit,...} : emitter)
160                    {maxAlloc, regfmls, regtys, return} = let                    {maxAlloc, regfmls, regtys, return} = let
161        val (boxed, int32, float) = maskList(regfmls, regtys, [], [], [])        val (boxed, int32, float) = maskList(regfmls, regtys, [], [], [])
162      in      in
# Line 176  Line 177 
177    (* allocptr must always be in a register *)    (* allocptr must always be in a register *)
178    val T.REG(_,allocptrR) = C.allocptr    val T.REG(_,allocptrR) = C.allocptr
179    
180    fun invokeGC {emit,comp} (external, regmap) gcInfo = let    fun invokeGC
181          (emitter as
182           St.STREAM{emit,defineLabel,entryLabel,exitBlock,annotation,...},
183           external) gcInfo = let
184      val {known, boxed, int32, float, regfmls, ret, lab} =      val {known, boxed, int32, float, regfmls, ret, lab} =
185        (case gcInfo        (case gcInfo
186          of GCINFO info => info          of GCINFO info => info
# Line 403  Line 407 
407        val use = roots        val use = roots
408        val gcAddr = T.ADD (32, C.stackptr, T.LI MS.startgcOffset)        val gcAddr = T.ADD (32, C.stackptr, T.LI MS.startgcOffset)
409      in      in
410          annotation(BasicAnnotations.CALLGC);
411        emit(T.CALL(T.LOAD(32, gcAddr, R.stack), def, use, R.stack));        emit(T.CALL(T.LOAD(32, gcAddr, R.stack), def, use, R.stack));
412        if known then let                 (* recompute base address *)        if known then let                 (* recompute base address *)
413            val returnLab = Label.newLabel ""            val returnLab = Label.newLabel ""
# Line 418  Line 423 
423               | _  => error "callGc: baseptr"               | _  => error "callGc: baseptr"
424            end            end
425          in          in
426            comp(T.DEFINELABEL returnLab);            defineLabel returnLab;
427            emit(assignBasePtr(C.baseptr))            emit(assignBasePtr(C.baseptr))
428          end          end
429        else ()        else ()
430      end      end
431      fun gcReturn () = let      fun gcReturn () = let
432        val live = case C.exhausted of NONE => regfmls | SOME cc => T.CCR cc::regfmls        val live = case C.exhausted of NONE => regfmls | SOME cc => T.CCR cc::regfmls
433      in emit ret; comp(T.ESCAPEBLOCK live)      in emit ret; exitBlock live
434      end      end
435    in    in
436      comp ((if external then T.ENTRYLABEL else T.DEFINELABEL)(!lab));      (if external then entryLabel else defineLabel)(!lab);
437      unzip(zip() before callGc());      unzip(zip() before callGc());
438      gcReturn()      gcReturn()
439    end (*invokeGC*)    end (*invokeGC*)
# Line 439  Line 444 
444    (* Generates long jumps to the end of the module unit for    (* Generates long jumps to the end of the module unit for
445     * standard functions, and directly invokes GC for known functions.     * standard functions, and directly invokes GC for known functions.
446     *)     *)
447    fun emitLongJumpsToGCInvocation {emit,comp} regmap = let    fun emitLongJumpsToGCInvocation
448           (emitter as St.STREAM{emit,defineLabel,entryLabel,exitBlock,...}) = let
449      (* GC code can be shared if the calling convention is the same *)      (* GC code can be shared if the calling convention is the same *)
450      fun equal      fun equal
451           (GCINFO{boxed=b1, int32=i1, float=f1, ret=T.JMP(ret1, _), ...},           (GCINFO{boxed=b1, int32=i1, float=f1, ret=T.JMP(ret1, _), ...},
# Line 490  Line 496 
496        val liveOut = fregRoots @ regRoots        val liveOut = fregRoots @ regRoots
497        val l = !lab        val l = !lab
498      in      in
499        app (fn lab => comp(T.DEFINELABEL lab)) (!addrs) before addrs:=[];        app defineLabel (!addrs) before addrs:=[];
500        emit(T.JMP(T.LABEL(LE.LABEL(l)), [l]));        emit(T.JMP(T.LABEL(LE.LABEL(l)), [l]));
501        comp(T.ESCAPEBLOCK liveOut)        exitBlock liveOut
502      end      end
503    in    in
504      (app find (!clusterGcBlocks)) before clusterGcBlocks := [];      (app find (!clusterGcBlocks)) before clusterGcBlocks := [];
505      app longJumps (!moduleGcBlocks);      app longJumps (!moduleGcBlocks);
506      (app (invokeGC {emit=emit,comp=comp}      (app (invokeGC (emitter,false)) (!knownGcBlocks)) before knownGcBlocks:=[]
           (false,regmap)) (!knownGcBlocks)) before knownGcBlocks:=[]  
507    end (*emitLongJumpsToGC*)    end (*emitLongJumpsToGC*)
508    
509    (* module specific gc invocation code *)    (* module specific gc invocation code *)
510    fun emitModuleGC emit regmap =    fun emitModuleGC stream =
511      (app (invokeGC emit (true,regmap)) (!moduleGcBlocks)) before moduleGcBlocks:=[]      (app (invokeGC (stream,true)) (!moduleGcBlocks)) before moduleGcBlocks:=[]
512    
513      fun init() = (clusterGcBlocks := [];
514                    knownGcBlocks := [];
515                    moduleGcBlocks := [])
516    
517  end  end
518    

Legend:
Removed from v.428  
changed lines
  Added in v.429

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