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

SCM Repository

[smlnj] View of /sml/trunk/src/compiler/CodeGen/cpscompile/invokegc.sml
ViewVC logotype

View of /sml/trunk/src/compiler/CodeGen/cpscompile/invokegc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 984 - (download) (annotate)
Wed Nov 21 19:00:08 2001 UTC (18 years, 7 months ago) by george
File size: 30160 byte(s)
  Implemented a complete redesign of MLRISC pseudo-ops. Now there
  ought to never be any question of incompatabilities with
  pseudo-op syntax expected by host assemblers.

  For now, only modules supporting GAS syntax are implemented
  but more should follow, such as MASM, and vendor assembler
  syntax, e.g. IBM as, Sun as, etc.
(*
 * This module is responsible for generating code to invoke the 
 * garbage collector.  This new version is derived from the functor CallGC.
 * It can handle derived pointers as roots and it can also be used as 
 * callbacks.  These extra facilities are neccessary for global optimizations  
 * in the presence of GC.  
 * 
 * -- Allen
 *)

functor InvokeGC
   (
    structure MS    : MACH_SPEC
    structure C     : CPSREGS 
		        where T.Region=CPSRegions
    structure TS    : MLTREE_STREAM
		        where T = C.T
    structure CFG   : CONTROL_FLOW_GRAPH 
		        where P = TS.S.P
   ) : INVOKE_GC =
struct
   structure CB = CellsBasis
   structure S  = CB.SortedCells
   structure T  = C.T
   structure D  = MS.ObjDesc
   structure R  = CPSRegions
   structure SL = SortedList
   structure GC = SMLGCType
   structure Cells = C.C
   structure CFG = CFG
   structure TS = TS

   fun error msg = ErrorMsg.impossible("InvokeGC."^msg)

   type t = { maxAlloc : int,
              regfmls  : T.mlrisc list,
              regtys   : CPS.cty list,
              return   : T.stm
            }

   type stream = (T.stm, T.mlrisc list, CFG.cfg) TS.stream

   val debug = Control.MLRISC.getFlag "debug-gc";

   val addrTy = C.addressWidth

   (* The following datatype is used to encapsulates 
    * all the information needed to generate code to invoke gc.
    * The important fields are:
    *    known     -- is the function a known (i.e. internal) function 
    *    optimized -- if this is on, gc code generation is delayed until
    *                 we have performed all optimizations.  This is false
    *                 for normal SML/NJ use.
    *    lab       -- a list of labels that belongs to the call gc block
    *    boxed, float, int32 -- roots partitioned by types
    *    regfmls   -- the roots
    *    ret       -- how to return from the call gc block.
    *)
   datatype gcInfo =
      GCINFO of
        {known     : bool,            (* known function ? *)
         optimized : bool,            (* optimized? *)
         lab       : Label.label ref, (* labels to invoke GC *)
         boxed     : T.rexp list,     (* locations with boxed objects *)
         int32     : T.rexp list,     (* locations with int32 objects *)
         float     : T.fexp list,     (* locations with float objects *)
         regfmls   : T.mlrisc list,   (* all live registers *)
         ret       : T.stm}           (* how to return *)
    | MODULE of
        {info: gcInfo,
         addrs: Label.label list ref} (* addrs associated with long jump *)

   (*====================================================================
    * Implementation/architecture specific stuff starts here.
    *====================================================================*)

      (* Extra space in allocation space 
       * The SML/NJ runtime system leaves around 4K of extra space
       * in the allocation space for safety.
       *)
   val skidPad = 4096
   val pty  = 32

   val vfp = false			(* don't use virtual frame ptr here *)

   val unit = T.LI(T.I.int_1)  (* representation of ML's unit; 
                                * this is used to initialize registers.
                                *)
   fun LI i = T.LI (T.I.fromInt(32, i))
       (*
        * Callee-save registers 
        * All callee save registers are used in the gc calling convention.
        *)
   val calleesaves = List.take(C.miscregs, MS.numCalleeSaves)

       (* 
        * registers that are the roots of gc.
        *)
   val gcParamRegs = 
     (C.stdlink(vfp)::C.stdclos(vfp)::C.stdcont(vfp)::C.stdarg(vfp)
      ::calleesaves)

       (*
        * How to call the call the GC 
        *)
   val gcCall = let
       val use = map T.GPR gcParamRegs
       val def = case C.exhausted of NONE => use 
                                   | SOME cc => T.CCR cc::use
   in
       T.ANNOTATION(
          T.CALL{
            funct=
	      T.LOAD(32, 
		     T.ADD(addrTy,C.frameptr vfp, LI MS.startgcOffset),
		     R.stack),
            targets=[], defs=def, uses=use, region=R.stack,
	    pops=0},
          #create MLRiscAnnotations.COMMENT "call gc")
   end
   
   val ZERO_FREQ = #create MLRiscAnnotations.EXECUTION_FREQ 0

   val CALLGC = #create MLRiscAnnotations.CALLGC ()
   val NO_OPTIMIZATION = #create MLRiscAnnotations.NO_OPTIMIZATION ()

       (*
        * record descriptors
        *)
   val dtoi = LargeWord.toInt
   fun unboxedDesc words = dtoi(D.makeDesc(words, D.tag_raw64))
   fun boxedDesc words   = dtoi(D.makeDesc(words, D.tag_record))

       (* the allocation pointer must always in a register! *)
   val allocptrR = 
       case C.allocptr of
         T.REG(_,allocptrR) => allocptrR 
       | _ => error "allocptr must be a register"

       (* what type of comparison to use for GC test? *)
   val gcCmp = if C.signedGCTest then T.GT else T.GTU

   val unlikely = #create MLRiscAnnotations.BRANCH_PROB 0

   val normalTestLimit =
       T.CMP(pty, gcCmp, C.allocptr, C.limitptr(vfp))

   (*====================================================================
    * Private state
    *====================================================================*)
   (* gc info required for standard functions within the cluster *)
   val clusterGcBlocks = ref([]: gcInfo list)

   (* gc info required for known functions within the cluster *)
   val knownGcBlocks = ref([]: gcInfo list)

   (* gc info required for modules *)
   val moduleGcBlocks = ref ([]: gcInfo list)

   (*====================================================================
    * Auxiliary functions
    *====================================================================*)

   (*
    * Convert a list of rexps into a set of registers and memory offsets.
    * Memory offsets must be relative to the frame pointer.
    *)
   fun set bindings =
   let val theVfp = C.vfp
       val T.REG (_, theFp) = C.frameptr false
       (* At this point, theVfp will always eventually end up
	* being theFp, but mlriscGen might pass in references to theVfp
	* anyway (because of some RCC that happens to be in the cluster).
	* Therefor, we test for either the real frame pointer (theFp) or
	* the virtual frame pointer (theVfp) here. *)
       fun isFramePtr fp = CB.sameColor (fp, theFp) orelse
			   CB.sameColor (fp, theVfp)
       fun live(T.REG(_,r)::es, regs, mem) = live(es, r::regs, mem)
         | live(T.LOAD(_, T.REG(_, fp), _)::es, regs, mem) =
           if isFramePtr fp then live(es, regs, 0::mem)
           else error "set:LOAD32"
         | live(T.LOAD(_, T.ADD(_, T.REG(_, fp), T.LI i), _)::es, regs, mem) =
           if isFramePtr fp then live(es, regs, T.I.toInt(32,i)::mem)
           else error "set:LOAD32"
         | live([], regs, mem) = (regs, mem)
         | live _ = error "live"
       val (regs, mem) = live(bindings, [], [])
   in  {regs=S.return(S.uniq regs), mem=SL.uniq mem} 
   end

   fun difference({regs=r1,mem=m1}, {regs=r2,mem=m2}) =
       {regs=S.difference(r1,r2), mem=SL.difference(m1,m2)}
 
   fun setToString{regs,mem} =
       "{"^foldr (fn (r,s) => CB.toString r^" "^s) "" regs
          ^foldr (fn (m,s) => Int.toString m^" "^s) "" mem^"}"

   (* The client communicates root pointers to the gc via the following set
    * of registers and memory locations.
    *)
   val gcrootSet = set gcParamRegs
   val aRoot     = hd(#regs gcrootSet)
   val aRootReg  = T.REG(32,aRoot)

   (* 
    * This function generates a gc limit check.
    * It returns the label to the GC invocation block.
    *) 
   fun checkLimit(emit, maxAlloc) =
   let val lab = Label.anon()
       fun gotoGC(cc) = emit(T.ANNOTATION(T.BCC(cc, lab), unlikely))
   in  if maxAlloc < skidPad then
          (case C.exhausted of
             SOME cc => gotoGC cc
           | NONE => gotoGC normalTestLimit
          )
       else  
       let val shiftedAllocPtr = T.ADD(addrTy,C.allocptr,LI(maxAlloc-skidPad))
           val shiftedTestLimit =
	       T.CMP(pty, gcCmp, shiftedAllocPtr, C.limitptr(vfp))
       in  case C.exhausted of
             SOME(cc as T.CC(_,r)) => 
               (emit(T.CCMV(r, shiftedTestLimit)); gotoGC(cc))
           | NONE => gotoGC(shiftedTestLimit)
           | _ => error "checkLimit"
       end;
       lab
   end

   val baseOffset = T.LI(IntInf.fromInt MS.constBaseRegOffset)
   (* 
    * This function recomputes the base pointer address.
    *)
   fun computeBasePtr(emit,defineLabel,annotation) =
   let val returnLab = Label.anon()
       val baseExp = 
           T.ADD(addrTy, C.gcLink(vfp),
                 T.LABEXP(T.SUB(addrTy,baseOffset,T.LABEL returnLab)))
   in  defineLabel returnLab;
       annotation(ZERO_FREQ); 
       emit(case C.baseptr(vfp) of 
              T.REG(ty, bpt) => T.MV(ty, bpt, baseExp)
            | T.LOAD(ty, ea, mem) => T.STORE(ty, ea, baseExp, mem)
            | _ => error "computeBasePtr")
   end 

   (*====================================================================
    * Main functions
    *====================================================================*)
   fun init() =
       (clusterGcBlocks        := [];
        knownGcBlocks          := [];
        moduleGcBlocks         := []
       )

   (*
    * Partition the root set into types 
    *)
   fun split([], [], boxed, int32, float) = 
         {boxed=boxed, int32=int32, float=float}
     | split(T.GPR r::rl, CPS.INT32t::tl, b, i, f) = split(rl,tl,b,r::i,f)
     | split(T.GPR r::rl, CPS.FLTt::tl, b, i, f) = error "split: T.GPR"
     | split(T.GPR r::rl, _::tl, b, i, f) = split(rl,tl,r::b,i,f)
     | split(T.FPR r::rl, CPS.FLTt::tl, b, i, f) = split(rl,tl,b,i,r::f)
     | split _ = error "split"

   fun genGcInfo (clusterRef,known,optimized) (TS.S.STREAM{emit,...} : stream)
                 {maxAlloc, regfmls, regtys, return} =
   let (* partition the root set into the appropriate classes *)
       val {boxed, int32, float} = split(regfmls, regtys, [], [], [])

   in  clusterRef := 
          GCINFO{ known    = known,
                  optimized=optimized,
                  lab      = ref (checkLimit(emit,maxAlloc)),
                  boxed    = boxed,
                  int32    = int32,
                  float    = float,
                  regfmls  = regfmls,
                  ret      = return }
	  :: (!clusterRef)
   end

   (* 
    * Check-limit for standard functions, i.e.~functions with 
    * external entries.
    *)
   val stdCheckLimit = genGcInfo (clusterGcBlocks, false, false)

   (*
    * Check-limit for known functions, i.e.~functions with entries from
    * within the same cluster.
    *)
   val knwCheckLimit = genGcInfo (knownGcBlocks, true, false)

   (*
    * Check-limit for optimized, known functions.  
    *)
   val optimizedKnwCheckLimit = genGcInfo(knownGcBlocks, true, true)

   (*
    * An array for checking cycles  
    *)
   local
       val N = 1 + foldr (fn (r,n) => Int.max(CB.registerNum r,n)) 
			 0 (#regs gcrootSet)
   in
       val clientRoots = Array.array(N, ~1)
       val stamp       = ref 0
   end

   (*
    * This function packs boxed, int32 and float into gcroots.
    * gcroots must be non-empty.  Return a function to unpack.
    *)
   fun pack(emit, gcroots, boxed, int32, float) =
   let (* 
        * Datatype binding describes the contents a gc root.
        *)
       datatype binding =
         Reg     of CB.cell               (* integer register *)
       | Freg    of CB.cell               (* floating point register*)
       | Mem     of T.rexp * R.region        (* integer memory register *)
       | Record  of {boxed: bool,            (* is it a boxed record *)
                     words:int,              (* how many words *)
                     reg: CB.cell,        (* address of this record *)
                     regTmp: CB.cell,     (* temp used for unpacking *)
                     fields: binding list    (* its fields *)
                    }

       (* 
        * Translates rexp/fexp into bindings.
        * Note: client roots from memory (XXX) should NOT be used without
        * fixing a potential cycle problem in the parallel copies below.
        * Currently, all architectures, including the x86, do not uses
        * the LOAD(...) form.  So we are safe.
        *)
       fun bind(T.REG(32, r)) = Reg r
         | bind(T.LOAD(32, ea, mem)) = Mem(ea, mem)  (* XXX *)
         | bind(_) = error "bind"
       fun fbind(T.FREG(64, r)) = Freg r
         | fbind(_) = error "fbind"

       val st     = !stamp 
       val cyclic = st + 1
       val _      = if st > 100000 then stamp := 0 else stamp := st + 2
       val N = Array.length clientRoots
       fun markClients [] = ()
         | markClients(T.REG(_, r)::rs) = 
           let val rx = CB.registerNum r
           in  if rx < N then Array.update(clientRoots, rx, st) else ();
               markClients rs
           end
         | markClients(_::rs) = markClients rs
       fun markGCRoots [] = ()
         | markGCRoots(T.REG(_, r)::rs) = 
           let val rx = CB.registerNum r
           in  if Array.sub(clientRoots, rx) = st then
                  Array.update(clientRoots, rx, cyclic)
               else (); 
               markGCRoots rs
           end
         | markGCRoots(_::rs) = markGCRoots rs

       val _ = markClients boxed
       val _ = markClients int32
       val _ = markGCRoots gcroots

       (*
        * First, we pack all unboxed roots, if any, into a record. 
        *) 
       val boxedStuff = 
           case (int32, float) of
             ([], []) => map bind boxed
           | _ =>
             (* align the allocptr if we have floating point roots *)
             (case float of
                [] => ()
              | _  => emit(T.MV(addrTy, allocptrR, 
                                T.ORB(addrTy, C.allocptr, LI 4)));
              (* If we have int32 or floating point stuff, package them
               * up into a raw record.  Floating point stuff have to come first.
               *)
               let val qwords=length float + (length int32 + 1) div 2
               in  Record{boxed=false, reg=Cells.newReg(), 
                          regTmp=Cells.newReg(),
                          words=qwords + qwords,
                          fields=map fbind float @ map bind int32} 
                      ::map bind boxed
               end
             )
       (*
        * Then, we check whether we have enough gc roots to store boxedStuff.
        * If so, we are safe. Otherwise, we have to pack up some of the 
        * boxed stuff into a record too.
        *) 
 
       val nBoxedStuff = length boxedStuff
       val nGcRoots    = length gcroots

       val bindings = 
           if nBoxedStuff <= nGcRoots 
           then boxedStuff (* good enough *)
           else (* package up some of the boxed stuff *)
           let val extra       = nBoxedStuff - nGcRoots + 1
               val packUp      = List.take(boxedStuff, extra)
               val don'tPackUp = List.drop(boxedStuff, extra)
           in  Record{boxed=true, words=length packUp,
                      regTmp=Cells.newReg(),
                      reg=Cells.newReg(), fields=packUp}::don'tPackUp 
           end
 
       fun copy([], _) = ()
         | copy(dst, src) = emit(T.COPY(32, dst, src))

       (* 
        * The following routine copies the client roots into the real gc roots.
        * We have to make sure that cycles have correctly handled.  So we
        * can't do a copy at a time!  But see XXX below.
        *)
       fun prolog(hp, unusedRoots, [], rds, rss) = 
           let fun init [] = ()
                 | init(T.REG(ty, rd)::roots) = 
                     (emit(T.MV(ty, rd, unit)); init roots)
                 | init(T.LOAD(ty, ea, mem)::roots) = 
                     (emit(T.STORE(ty, ea, unit, mem)); init roots)
                 | init _ = error "init"
           in  (* update the heap pointer if we have done any allocation *)
               if hp > 0 then  
                  emit(T.MV(addrTy, allocptrR, 
                            T.ADD(addrTy, C.allocptr, LI hp)))
               else ();
               (* emit the parallel copies *)
               copy(rds, rss);
               (*
                * Any unused gc roots have to be initialized with unit.
                * The following MUST come last. 
                *)
               init unusedRoots
           end
         | prolog(hp, T.REG(_,rd)::roots, Reg rs::bs, rds, rss) = 
             (* copy client root rs into gc root rd  *)
             prolog(hp, roots, bs, rd::rds, rs::rss)
         | prolog(hp, T.REG(_,rd)::roots, Record(r as {reg,...})::bs,rds,rss) = 
             (* make a record then copy *)
             let val hp = makeRecord(hp, r)
             in  prolog(hp, roots, bs, rd::rds, reg::rss)
             end
         (*| prolog(hp, T.LOAD(_,ea,mem)::roots, b::bs, rds, rss) = (* XXX *)
             (* The following code is unsafe because of potential cycles!
              * But luckly, it is unused XXX.
              *)
             let val (hp, e) = 
                     case b of
                       Reg r => (hp, T.REG(32, r))
                     | Mem(ea, mem) => (hp, T.LOAD(32, ea, mem))
                     | Record(r as {reg, ...}) => 
                         (makeRecord(hp, r), T.REG(32,reg))
                     | _ => error "floating point root"
             in  emit(T.STORE(32, ea, e, mem)); 
                 prolog(hp, roots, bs, rds, rss) 
             end*)
         | prolog _ = error "prolog"

            (* Make a record and put it in reg *) 
       and makeRecord(hp, {boxed, words, reg, fields, ...}) = 
           let fun disp(n) = T.ADD(addrTy, C.allocptr, LI n)
               fun alloci(hp, e) = emit(T.STORE(32, disp hp, e, R.memory))
               fun allocf(hp, e) = emit(T.FSTORE(64, disp hp, e, R.memory))
               fun alloc(hp, []) = ()
                 | alloc(hp, b::bs) = 
                   (case b of 
                     Reg r => (alloci(hp, T.REG(32,r)); alloc(hp+4, bs))
                   | Record{reg, ...} => 
                      (alloci(hp, T.REG(32,reg)); alloc(hp+4, bs))
                   | Mem(ea,m) => (alloci(hp, T.LOAD(32,ea,m)); alloc(hp+4,bs))
                   | Freg r => (allocf(hp, T.FREG(64,r)); alloc(hp+8, bs))
                   )
               fun evalArgs([], hp) = hp
                 | evalArgs(Record r::args, hp) = 
                    evalArgs(args, makeRecord(hp, r))
                 | evalArgs(_::args, hp) = evalArgs(args, hp)
               (* MUST evaluate nested records first *)
               val hp   = evalArgs(fields, hp)
               val desc = if boxed then boxedDesc words else unboxedDesc words
           in  emit(T.STORE(32, disp hp, LI desc, R.memory));
               alloc(hp+4, fields);
               emit(T.MV(addrTy, reg, disp(hp+4))); 
               hp + 4 + Word.toIntX(Word.<<(Word.fromInt words,0w2))
           end

          (* Copy the gc roots back to client roots. 
           * Again, to avoid potential cycles, we generate a single 
           * parallel copy that moves the gc roots back to the client roots.
           *)
       fun epilog([], unusedGcRoots, rds, rss) = 
             copy(rds, rss)
         | epilog(Reg rd::bs, T.REG(_,rs)::roots, rds, rss) = 
             epilog(bs, roots, rd::rds, rs::rss)
         | epilog(Record{fields,regTmp,...}::bs, T.REG(_,r)::roots, rds, rss) = 
              (* unbundle record *)
              let val _   = emit(T.COPY(32, [regTmp], [r]))
                  val (rds, rss) = unpack(regTmp, fields, rds, rss)
              in  epilog(bs, roots, rds, rss) end
         | epilog(b::bs, r::roots, rds, rss) = 
             (assign(b, r); (* XXX *)
              epilog(bs, roots, rds, rss)
             )
         | epilog _ = error "epilog"

       and assign(Reg r, e)        = emit(T.MV(32, r, e))
         | assign(Mem(ea, mem), e) = emit(T.STORE(32, ea, e, mem))
         | assign _ = error "assign"

           (* unpack fields from record *)
       and unpack(recordR, fields, rds, rss) = 
           let val record = T.REG(32, recordR)
               fun disp n = T.ADD(addrTy, record, LI n)
               fun sel n = T.LOAD(32, disp n, R.memory)
               fun fsel n = T.FLOAD(64, disp n, R.memory)
               val N = Array.length clientRoots
               (* unpack normal fields *)
               fun unpackFields(n, [], rds, rss) = (rds, rss)
                 | unpackFields(n, Freg r::bs, rds, rss) = 
                     (emit(T.FMV(64, r, fsel n)); 
                      unpackFields(n+8, bs, rds, rss))
                 | unpackFields(n, Mem(ea, mem)::bs, rds, rss) = 
                     (emit(T.STORE(32, ea, sel n, mem));  (* XXX *)
                      unpackFields(n+4, bs, rds, rss))
                 | unpackFields(n, Record{regTmp, ...}::bs, rds, rss) = 
                     (emit(T.MV(32, regTmp, sel n));
                      unpackFields(n+4, bs, rds, rss))
                 | unpackFields(n, Reg rd::bs, rds, rss) = 
                   let val rdx = CB.registerNum rd
                   in  if rdx < N andalso Array.sub(clientRoots, rdx) = cyclic then
                       let val tmpR = Cells.newReg()
                       in  (* print "WARNING: CYCLE\n"; *)
                           emit(T.MV(32, tmpR, sel n));
                           unpackFields(n+4, bs, rd::rds, tmpR::rss)
                       end else
                           (emit(T.MV(32, rd, sel n));
                            unpackFields(n+4, bs, rds, rss))
                   end

               (* unpack nested record *)
               fun unpackNested(_, [], rds, rss) = (rds, rss)
                 | unpackNested(n, Record{fields, regTmp, ...}::bs, rds, rss) = 
                   let val (rds, rss) = unpack(regTmp, fields, rds, rss)
                   in  unpackNested(n+4, bs, rds, rss)
                   end
                 | unpackNested(n, Freg _::bs, rds, rss) =
                     unpackNested(n+8, bs, rds, rss)
                 | unpackNested(n, _::bs, rds, rss) =
                     unpackNested(n+4, bs, rds, rss)

               val (rds, rss)= unpackFields(0, fields, rds, rss)
           in  unpackNested(0, fields, rds, rss)
           end

       (* generate code *)
   in  prolog(0, gcroots, bindings, [], []);
       (* return the unpack function *)
       fn () => epilog(bindings, gcroots, [], [])
   end

   (*
    * The following auxiliary function generates the actual call gc code. 
    * It packages up the roots into the appropriate
    * records, call the GC routine, then unpack the roots from the record.
    *) 
   fun emitCallGC{stream=TS.S.STREAM{emit, annotation, defineLabel, ...}, 
                  known, boxed, int32, float, ret } =
   let fun setToMLTree{regs,mem} =
	   map (fn r => T.REG(32,r)) regs @ 
	   map (fn i => T.LOAD(32, T.ADD(addrTy, C.frameptr vfp, LI(i)),
			       R.memory)) mem

       (* IMPORTANT NOTE:  
        * If a boxed root happens be in a gc root register, we can remove
        * this root since it will be correctly targetted. 
        *
        * boxedRoots are the boxed roots that we have to move to the
	* appropriate registers.  gcrootSet are the registers that are
	* available for communicating to the collector.
        *)

       val boxedSet   = set boxed
       val boxedRoots = difference(boxedSet,gcrootSet)  (* roots *)
       val gcrootAvail = difference(gcrootSet,boxedSet) (* gcroots available *)

       fun mark(call) =
           if !debug then
              T.ANNOTATION(call,#create MLRiscAnnotations.COMMENT 
                 ("roots="^setToString gcrootAvail^
                  " boxed="^setToString boxedRoots))
           else call
 
       (* convert them back to MLTREE *)
       val boxed   = setToMLTree boxedRoots 
       val gcroots = setToMLTree gcrootAvail

       (* If we have any remaining roots after the above trick, we have to 
        * make sure that gcroots is not empty.
        *)
       val (gcroots, boxed) = 
           case (gcroots, int32, float, boxed) of
             ([], [], [], []) => ([], []) (* it's okay *)
           | ([], _, _, _) => ([aRootReg], boxed @ [aRootReg]) 
             (* put aRootReg last to reduce register pressure 
              * during unpacking
              *)
           | _  => (gcroots, boxed)

       val unpack = pack(emit, gcroots, boxed, int32, float)
   in  annotation(CALLGC);
       annotation(NO_OPTIMIZATION); 
       annotation(ZERO_FREQ);
       emit(mark(gcCall));
       if known then computeBasePtr(emit,defineLabel,annotation) else ();
       annotation(NO_OPTIMIZATION);
       unpack();
       emit ret
   end

   (*
    * The following function is responsible for generating only the
    * callGC code.
    *)
   fun callGC stream {regfmls, regtys, ret} =
   let val {boxed, int32, float} = split(regfmls, regtys, [], [], [])
   in  emitCallGC{stream=stream, known=true, 
                  boxed=boxed, int32=int32, float=float, ret=ret}
   end

   (*
    * This function emits a comment that pretty prints the root set.
    * This is used for debugging only.
    *)
   fun rootSetToString{boxed, int32, float} = 
   let fun extract(T.REG(32, r)) = r
         | extract _ = error "extract"
       fun fextract(T.FREG(64, f)) = f
         | fextract _ = error "fextract"
       fun listify title f [] = ""
         | listify title f l  = 
             title^foldr (fn (x,"") => f x
                           | (x,y)  => f x ^", "^y) "" (S.uniq l)^" "
   in  listify "boxed=" CB.toString (map extract boxed)^
       listify "int32=" CB.toString (map extract int32)^
       listify "float=" CB.toString (map fextract float)
   end

   (*
    * The following function is responsible for generating actual
    * GC calling code, with entry labels and return information.
    *)
   fun invokeGC(stream as 
               TS.S.STREAM{emit,defineLabel,entryLabel,exitBlock,annotation,...},
                externalEntry) gcInfo = 
   let val {known, optimized, boxed, int32, float, regfmls, ret, lab} =
           case gcInfo of
             GCINFO info => info
           | MODULE{info=GCINFO info,...} => info
           | _ => error "invokeGC:gcInfo"

       val liveout = if optimized then [] else regfmls

   in  if externalEntry then entryLabel (!lab) else defineLabel (!lab);
       (* When the known block is optimized, no actual code is generated
        * until later.
        *)
       if optimized then 
            (annotation(#create MLRiscAnnotations.GCSAFEPOINT 
               (if !debug then
                 rootSetToString{boxed=boxed, int32=int32, float=float}
                else ""
               ));
             emit ret
            )
       else emitCallGC{stream=stream, known=known,
                       boxed=boxed, int32=int32, float=float, ret=ret};
       exitBlock(case C.exhausted of NONE    => liveout 
                                   | SOME cc => T.CCR cc::liveout)
   end

   (*
    * The following function checks whether two root set have the
    * same calling convention.
    *)
   fun sameCallingConvention
          (GCINFO{boxed=b1, int32=i1, float=f1, ret=T.JMP(ret1, _),...},
           GCINFO{boxed=b2, int32=i2, float=f2, ret=T.JMP(ret2, _),...}) =
	  let fun eqEA(T.REG(_, r1), T.REG(_, r2)) = CB.sameColor(r1,r2)
		| eqEA(T.ADD(_,T.REG(_,r1),T.LI i),
		       T.ADD(_,T.REG(_,r2),T.LI j)) =  
		  CB.sameColor(r1,r2) andalso T.I.EQ(32,i,j)
		| eqEA _ = false
	      fun eqR(T.REG(_,r1), T.REG(_,r2)) = CB.sameColor(r1,r2)
		| eqR(T.LOAD(_,ea1,_), T.LOAD(_,ea2,_)) = eqEA(ea1, ea2)
		| eqR _ = false
	      fun eqF(T.FREG(_,f1), T.FREG(_,f2)) = CB.sameColor(f1,f2)
		| eqF(T.FLOAD(_,ea1,_), T.FLOAD(_,ea2,_)) = eqEA(ea1, ea2)
		| eqF _ = false

	      fun all predicate = 
		  let fun f(a::x,b::y) = predicate(a,b) andalso f(x,y)
			| f([],[]) = true
			| f _ = false
		  in  f end

	      val eqRexp = all eqR
	  in  eqRexp(b1, b2) andalso eqR(ret1,ret2) andalso 
	      eqRexp(i1,i2) andalso all eqF(f1,f2)
	  end 
     | sameCallingConvention _ = false

   (*
    * The following function is called once at the end of compiling a cluster.
    * Generates long jumps to the end of the module unit for
    * standard functions, and directly invokes GC for known functions.
    * The actual GC invocation code is not generated yet.
    *)
   fun emitLongJumpsToGCInvocation
       (stream as TS.S.STREAM{emit,defineLabel,exitBlock,...}) =
   let (* GC code can be shared if the calling convention is the same 
        * Use linear search to find the gc subroutine.
        *)
       fun find(info as GCINFO{lab as ref l, ...}) =
	   let fun search(MODULE{info=info', addrs}::rest) =
		   if sameCallingConvention(info, info') then
                       addrs := l :: (!addrs) 
		   else search rest
		 | search [] = (* no matching convention *)
		   let val label = Label.anon()
		   in  lab := label;
                   moduleGcBlocks := MODULE{info=info, addrs=ref[l]}
				     :: (!moduleGcBlocks)
		   end
		 | search _ = error "search"
	   in  search(!moduleGcBlocks) 
	   end
         | find _ = error "find"

       (*
        * Generate a long jump to all external callgc routines 
        *)
       fun longJumps(MODULE{addrs=ref [],...}) = ()
         | longJumps(MODULE{info=GCINFO{lab,boxed,int32,float,...}, addrs}) =
           let val regRoots  = map T.GPR (int32 @ boxed)
               val fregRoots = map T.FPR float
               val liveOut   = regRoots @ fregRoots
               val l         = !lab
           in  app defineLabel (!addrs) before addrs := [];
               emit(T.JMP(T.LABEL l, []));
               exitBlock liveOut
           end
         | longJumps _ = error "longJumps"

   in  app find (!clusterGcBlocks) before clusterGcBlocks := [];
       app longJumps (!moduleGcBlocks);
       app (invokeGC(stream,false)) (!knownGcBlocks)
       before knownGcBlocks := []
   end (* emitLongJumpsToGC *)

   (* 
    * The following function is called to generate module specific 
    * GC invocation code 
    *)
   fun emitModuleGC stream =
       app (invokeGC(stream,true)) (!moduleGcBlocks)
       before moduleGcBlocks := []

end

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