SCM Repository
View of /sml/trunk/src/compiler/CodeGen/main/mlriscGen.sml
Parent Directory
| 
Revision Log
Revision 780 -
(download)
(annotate)
Tue Jan 30 22:45:26 2001 UTC (19 years, 11 months ago) by blume
File size: 83384 byte(s)
Tue Jan 30 22:45:26 2001 UTC (19 years, 11 months ago) by blume
File size: 83384 byte(s)
merging changes from private devel branch
(* mlriscGenNew.sml --- translate CPS to MLRISC.
*
* This version of MLRiscGen also injects GC types to the MLRISC backend.
* I've also reorganized it a bit and added a few comments
* so that I can understand it.
*
* COPYRIGHT (c) 1996 AT&T Bell Laboratories.
*
*)
signature MLRISCGEN =
sig
val codegen :
CPS.function list * (CPS.lvar -> (int * int)) * ErrorMsg.complainer -> unit
end
functor MLRiscGen
( structure MachineSpec: MACH_SPEC
structure PseudoOp : SMLNJ_PSEUDO_OP_TYPE
structure Ext : SMLNJ_MLTREE_EXT
structure C : CPSREGS where T.Region = CPSRegions
and T.Constant = SMLNJConstant
and T.Extension = Ext
structure InvokeGC : INVOKE_GC where T = C.T
structure MLTreeComp : MLTREECOMP where T = C.T
structure Flowgen : FLOWGRAPH_GEN where T = C.T
structure Cells : CELLS
structure CCalls : C_CALLS where T = C.T
sharing C.T.PseudoOp = PseudoOp
sharing Flowgen.I = MLTreeComp.I
val compile : Flowgen.flowgraph -> unit
) : MLRISCGEN =
struct
structure M = C.T (* MLTree *)
structure E = Ext (* Extensions *)
structure P = CPS.P (* CPS primitive operators *)
structure R = CPSRegions (* Regions *)
structure PT = R.PT (* PointsTo *)
structure CG = Control.CG (* Compiler Control *)
structure MS = MachineSpec (* Machine Specification *)
structure D = MS.ObjDesc (* ML Object Descriptors *)
structure ArgP = (* Argument passing *)
ArgPassing(structure Cells=Cells
structure C=C
structure MS=MachineSpec)
structure Frag = Frag(M) (* Decompose a compilation unit into clusters *)
structure MemAliasing = MemAliasing(Cells) (* Memory aliasing *)
fun error msg = MLRiscErrorMsg.error("MLRiscGen", msg)
(*
* Debugging
*)
fun printCPSFun cps =
(Control.Print.say "*********************************************** \n";
PPCps.printcps0 cps;
Control.Print.say "*********************************************** \n";
Control.Print.flush()
)
val print = Control.Print.say
(*
* GC Safety
*)
structure GCCells = (* How to annotate GC information *)
GCCells(structure C = Cells
structure GC = SMLGCType)
val I31 = SMLGCType.I31 (* tagged integers *)
val I32 = SMLGCType.I32 (* untagged integers *)
val REAL64 = SMLGCType.REAL64 (* untagged floats *)
val PTR = SMLGCType.PTR (* boxed objects *)
val NO_OPT = [#create MLRiscAnnotations.NO_OPTIMIZATION ()]
val enterGC = GCCells.setGCType
val ptr = #create MLRiscAnnotations.MARK_REG(fn r => enterGC(r,PTR))
val i32 = #create MLRiscAnnotations.MARK_REG(fn r => enterGC(r,I32))
val i31 = #create MLRiscAnnotations.MARK_REG(fn r => enterGC(r,I31))
val flt = #create MLRiscAnnotations.MARK_REG(fn r => enterGC(r,REAL64))
fun ctyToAnn CPS.INTt = i31
| ctyToAnn CPS.INT32t = i32
| ctyToAnn CPS.FLTt = flt
| ctyToAnn _ = ptr
(*
* Convert kind to gc type
*)
fun kindToGCty(CPS.P.INT 31) = I31
| kindToGCty(CPS.P.UINT 31) = I31
| kindToGCty(_) = I32
fun ctyToGCty(CPS.FLTt) = REAL64
| ctyToGCty(CPS.INTt) = I31
| ctyToGCty(CPS.INT32t) = I32
| ctyToGCty _ = PTR
(*
* Make a GC livein/liveout annotation
*)
fun gcAnnotation(an, args, ctys) =
let fun collect(M.GPR(M.REG(_,r))::args,cty::ctys,gctys) =
collect(args,ctys,(r,ctyToGCty cty)::gctys)
| collect(M.FPR(M.FREG(_,r))::args,cty::ctys,gctys) =
collect(args,ctys,(r,ctyToGCty cty)::gctys)
| collect(_::args,_::ctys,gctys) = collect(args,ctys,gctys)
| collect([], [], gctys) = gctys
| collect _ = error "gcAnnotation"
in an(collect(args, ctys, [])) end
(*
* These are the type widths of ML. They are hardwired for now.
*)
val pty = 32 (* size of ML's pointer *)
val ity = 32 (* size of ML's integer *)
val fty = 64 (* size of ML's real number *)
val zero = M.LI M.I.int_0
val one = M.LI M.I.int_1
val two = M.LI M.I.int_2
val mlZero = one (* tagged zero *)
val offp0 = CPS.OFFp 0
fun LI i = M.LI (M.I.fromInt(ity, i))
fun LW w = M.LI (M.I.fromWord32(ity, w))
val constBaseRegOffset = LI MachineSpec.constBaseRegOffset
(*
* The allocation pointer. This must be a register
*)
val M.REG(_,allocptrR) = C.allocptr
(*
* Dedicated registers.
*)
val dedicated' =
map (fn r => M.GPR(M.REG(ity,r))) C.dedicatedR @
map (fn f => M.FPR(M.FREG(fty,f))) C.dedicatedF
val dedicated =
case C.exhausted of NONE => dedicated'
| SOME cc => M.CCR cc :: dedicated'
(*
* This flag controls whether extra MLRISC optimizations should be
* performed. By default, this is off.
*)
val mlrisc = Control.MLRISC.getFlag "mlrisc"
(*
* If this flag is on then annotate the registers with GC type info.
* Otherwise use the default behavior.
*)
val gctypes = Control.MLRISC.getFlag "mlrisc-gc-types"
(*
* If this flag is on then perform optimizations before generating gc code.
* If this flag is on then gctypes must also be turned on!
* Otherwise use the default behavior.
*)
val gcsafety = Control.MLRISC.getFlag "mlrisc-gcsafety"
(*
* If this flag is on then split the entry block.
* This should be on for SSA optimizations.
*)
val splitEntry = Control.MLRISC.getFlag "split-entry-block"
(*
* This dummy annotation is used to get an empty block
*)
val EMPTY_BLOCK = #create MLRiscAnnotations.EMPTY_BLOCK ()
(*
* convert object descriptor to int
*)
val dtoi = LargeWord.toInt
(*
* The mltree stream
*)
val stream as M.Stream.STREAM
{ beginCluster, (* start a cluster *)
endCluster, (* end a cluster *)
emit, (* emit MLTREE stm *)
defineLabel, (* define a local label *)
entryLabel, (* define an external entry *)
exitBlock, (* mark the end of a procedure *)
pseudoOp, (* emit a pseudo op *)
annotation, (* add an annotation *)
... } =
MLTreeComp.selectInstructions
(Flowgen.newStream{compile=compile, flowgraph=NONE})
(*
* The main codegen function.
*)
fun codegen(funcs : CPS.function list, limits:CPS.lvar -> (int*int), err) =
let
val maxAlloc = #1 o limits
val splitEntry = !splitEntry
(*
* The natural address arithmetic width of the architecture.
* For most architecture this is 32 but for the Alpha this is 64,
* since 64-bit address arithmetic is more efficiently implemented
* on the Alpha.
*)
val addrTy = C.addressWidth
(*
* These functions generate new virtual register names and
* mark expressions with their gc types.
* When the gc-safety feature is turned on, we'll use the
* versions of newReg that automatically update the GCMap.
* Otherwise, we'll just use the normal version.
*)
val gctypes = !gctypes
val (newReg, newRegWithCty, newRegWithKind, newFreg) =
if gctypes then
let val newReg = GCCells.newCell Cells.GP
val newFreg = GCCells.newCell Cells.FP
fun newRegWithCty cty = newReg(ctyToGCty cty)
fun newRegWithKind kind = newReg(kindToGCty kind)
in (newReg, newRegWithCty, newRegWithKind, newFreg) end
else (Cells.newReg, Cells.newReg, Cells.newReg, Cells.newFreg)
fun markPTR e = if gctypes then M.MARK(e,ptr) else e
fun markI32 e = if gctypes then M.MARK(e,i32) else e
fun markFLT e = if gctypes then M.FMARK(e,flt) else e
fun markGC(e,cty) = if gctypes then M.MARK(e,ctyToAnn cty) else e
fun markNothing e = e
(*
* Known functions have parameters passed in fresh temporaries.
* We also annotate the gc types of these temporaries.
*)
fun known [] = []
| known(cty::rest) =
(case cty of
CPS.FLTt => M.FPR(M.FREG(fty,newFreg REAL64))
| CPS.INTt => M.GPR(M.REG(ity,newReg I31))
| CPS.INT32t => M.GPR(M.REG(ity,newReg I32))
| _ => M.GPR(M.REG(pty,newReg PTR))
)::known rest
(*
* labelTbl is a mapping of function names (CPS.lvars) to labels.
* If the flag splitEntry is on, we also distinguish between external and
* internal labels, make sure that no directly branches go to the
* external labels.
*)
exception LabelBind and TypTbl
val labelTbl : Label.label IntHashTable.hash_table =
IntHashTable.mkTable(32, LabelBind)
val functionLabel = IntHashTable.lookup labelTbl
val addLabelTbl = IntHashTable.insert labelTbl
(*
* typTbl is a mapping of CPS.lvars to CPS types
*)
val typTbl : CPS.cty IntHashTable.hash_table =
IntHashTable.mkTable(32, TypTbl)
val addTypBinding = IntHashTable.insert typTbl
val typmap = IntHashTable.lookup typTbl
(*
* mkGlobalTables define the labels and cty for all CPS functions
*)
fun mkGlobalTables(fk, f, _, _, _) =
((* internal label *)
addLabelTbl (f, Label.newLabel "");
(* external entry label *)
if splitEntry then
(case fk of
(CPS.CONT | CPS.ESCAPE) =>
addLabelTbl (~f-1, Label.newLabel(Int.toString f))
| _ => ()
)
else ();
case fk
of CPS.CONT => addTypBinding(f, CPS.CNTt)
| _ => addTypBinding(f, CPS.BOGt)
(*esac*))
(*
* This is the GC comparison test used. We have a choice of signed
* and unsigned comparisons. This usually doesn't matter, but some
* architectures work better in one way or the other, so we are given
* a choice here. For example, the Alpha has to do extra for unsigned
* tests, so on the Alpha we use signed tests.
*)
val gcTest = M.CMP(pty, if C.signedGCTest then M.GT else M.GTU,
C.allocptr, C.limitptr)
(*
* Function for generating code for one cluster.
*)
fun genCluster(cluster) =
let val _ = if !Control.debugging then app PPCps.printcps0 cluster else ()
val clusterSize = length cluster
(* per-cluster tables *)
exception RegMap and GenTbl
(*
* genTbl -- is used to retrieve the parameter passing
* conventions once a function has been compiled.
*)
val genTbl : Frag.frag IntHashTable.hash_table =
IntHashTable.mkTable(clusterSize, GenTbl)
val addGenTbl = IntHashTable.insert genTbl
val lookupGenTbl = IntHashTable.lookup genTbl
(*
* {fp,gp}RegTbl -- mapping of lvars to registers
*)
val fpRegTbl : M.fexp IntHashTable.hash_table =
IntHashTable.mkTable(2, RegMap)
val gpRegTbl : M.rexp IntHashTable.hash_table =
IntHashTable.mkTable(32, RegMap)
val addExpBinding = IntHashTable.insert gpRegTbl
fun addRegBinding(x,r) = addExpBinding(x,M.REG(ity,r))
val addFregBinding = IntHashTable.insert fpRegTbl
(*
* The following function is used to translate CPS into
* larger trees. Definitions marked TREEIFY can be forward
* propagated to their (only) use. This can drastically reduce
* register pressure.
*)
datatype treeify = TREEIFY | TREEIFIED | COMPUTE | DEAD
exception UseCntTbl
val useCntTbl : treeify IntHashTable.hash_table =
IntHashTable.mkTable(32, UseCntTbl)
fun treeify i = getOpt (IntHashTable.find useCntTbl i, DEAD)
val addCntTbl = IntHashTable.insert useCntTbl
fun markAsTreeified r = addCntTbl(r, TREEIFIED)
(*
* Reset the bindings and use count tables. These tables
* can be reset at the same time.
*)
fun clearTables() =
(IntHashTable.clear gpRegTbl;
IntHashTable.clear fpRegTbl;
IntHashTable.clear useCntTbl
)
(*
* memDisambiguation uses the new register counters,
* so this must be reset here.
*)
val _ = Cells.reset()
val memDisambig = MemAliasing.analyze(cluster)
(*
* Points-to analysis projection.
*)
fun pi(x as ref(PT.TOP _),_) = x
| pi(x,i) = PT.pi(x,i)
val memDisambigFlag = !CG.memDisambiguate
fun getRegion e =
if memDisambigFlag then
(case e of
CPS.VAR v => memDisambig v
| _ => R.readonly
)
else R.memory
fun getRegionPi(e,i) =
if memDisambigFlag then
(case e of
CPS.VAR v => pi(memDisambig v,i)
| _ => R.readonly
)
else R.memory
fun dataptrRegion v = getRegionPi(v, 0)
(* fun arrayRegion(x as ref(PT.TOP _)) = x
| arrayRegion x = PT.weakSubscript x *)
(* For safety, let's assume it's the global memory right now *)
fun arrayRegion _ = R.memory
(* This keeps track of all the advanced offset on the hp
* since the beginning of the CPS function.
* This is important for generating the correct address offset
* for newly allocated records.
*)
val advancedHP = ref 0
(*
* Function grabty lookups the CPS type of a value expression in CPS.
*)
fun grabty(CPS.VAR v) = typmap v
| grabty(CPS.LABEL v) = typmap v
| grabty(CPS.INT _) = CPS.INTt
| grabty(CPS.INT32 _) = CPS.INT32t
| grabty(CPS.VOID) = CPS.FLTt
| grabty _ = CPS.BOGt
(*
* The baseptr contains the start address of the entire
* compilation unit. This function generates the address of
* a label that is embedded in the same compilation unit. The
* generated address is relative to the baseptr.
*
* Note: For GC safety, we considered this to be an object reference
*)
fun laddr(lab, k) =
let val e =
M.ADD(addrTy, C.baseptr,
M.LABEXP(M.ADD(addrTy,M.LABEL lab,
M.LI(IntInf.fromInt
(k-MachineSpec.constBaseRegOffset)))))
in markPTR e end
(*
* A CPS register may be implemented as a physical
* register or a memory location. The function assign moves a
* value v into a register or a memory location.
*)
fun assign(M.REG(ty,r), v) = M.MV(ty, r, v)
| assign(M.LOAD(ty, ea, mem), v) = M.STORE(ty, ea, v, mem)
| assign _ = error "assign"
(*
* The following function looks up the MLTREE expression associated
* with a general purpose value expression.
*)
val lookupGpRegTbl = IntHashTable.lookup gpRegTbl
(*
* This function resolve the address computation of the
* form M.CONST k, where offset is a reference to the
* kth byte allocated since the beginning of the CPS function.
*)
fun resolveHpOffset(M.CONST(absoluteHpOffset)) =
let val tmpR = newReg PTR
val offset = absoluteHpOffset - !advancedHP
in emit(M.MV(pty, tmpR, M.ADD(addrTy, C.allocptr, LI offset)));
M.REG(pty, tmpR)
end
| resolveHpOffset(e) = e
fun regbind(CPS.VAR v) = resolveHpOffset(lookupGpRegTbl v)
| regbind(CPS.INT i) = LI (i+i+1)
| regbind(CPS.INT32 w) = LW w
| regbind(CPS.LABEL v) =
laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
| regbind _ = error "regbind"
(*
* This version allows the value to be further propagated
*)
fun resolveHpOffset'(M.CONST(absoluteHpOffset)) =
let val offset = absoluteHpOffset - !advancedHP
in markPTR(M.ADD(addrTy, C.allocptr, LI offset))
end
| resolveHpOffset'(e) = e
fun regbind'(CPS.VAR v) = resolveHpOffset'(lookupGpRegTbl v)
| regbind'(CPS.INT i) = LI (i+i+1)
| regbind'(CPS.INT32 w) = LW w
| regbind'(CPS.LABEL v) =
laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
| regbind' _ = error "regbind'"
(*
* The following function looks up the MLTREE expression associated
* with a floating point value expression.
*)
val lookupFpRegTbl = IntHashTable.lookup fpRegTbl
fun fregbind(CPS.VAR v) = lookupFpRegTbl v
| fregbind _ = error "fregbind"
(* On entry to a function, the parameters will be in formal
* parameter passing registers. Within the body of the function, they
* are moved immediately to fresh temporary registers. This ensures
* that the life time of the formal paramters is restricted to the
* function body and is critical in avoiding artificial register
* interferences.
*)
fun initialRegBindingsEscaping(vl, rl, tl) =
let fun eCopy(x::xs, M.GPR(M.REG(_,r))::rl, rds, rss, xs', rl') =
let val t = newReg PTR
in addRegBinding(x, t);
eCopy(xs, rl, t::rds, r::rss, xs', rl')
end
| eCopy(x::xs, r::rl, rds, rss, xs', rl') =
eCopy(xs, rl, rds, rss, x::xs', r::rl')
| eCopy([], [], [], [], xs', rl') = (xs', rl')
| eCopy([], [], rds, rss, xs', rl') =
(emit(M.COPY(ity, rds, rss)); (xs', rl'))
fun eOther(x::xs, M.GPR(r)::rl, xs', rl') =
let val t = newReg PTR
in addRegBinding(x, t); emit(M.MV(ity, t, r));
eOther(xs, rl, xs', rl')
end
| eOther(x::xs, (M.FPR(M.FREG(_,f)))::rl, xs', rl') =
eOther(xs, rl, x::xs', f::rl')
| eOther([], [], xs, rl) = (xs, rl)
fun eFcopy([], []) = ()
| eFcopy(xs, rl) =
let val fs = map (fn _ => newFreg REAL64) xs
in ListPair.app
(fn (x,f) => addFregBinding(x,M.FREG(fty,f))) (xs,fs);
emit(M.FCOPY(fty, fs, rl))
end
val (vl', rl') = eCopy(vl, rl, [], [], [], [])
in eFcopy(eOther(vl', rl', [], []));
ListPair.app addTypBinding (vl, tl)
end
fun initialRegBindingsKnown(vl, rl, tl) =
let fun f(v, M.GPR(reg as M.REG _)) = addExpBinding(v, reg)
| f(v, M.FPR(freg as M.FREG _)) = addFregBinding(v, freg)
| f _ = error "initialRegBindingsKnown.f"
in ListPair.app f (vl, rl);
ListPair.app addTypBinding (vl, tl)
end
(* Keep allocation pointer aligned on odd boundary
* Note: We have accounted for the extra space this eats up in
* limit.sml
*)
fun updtHeapPtr(hp) =
let fun advBy hp =
(advancedHP := !advancedHP + hp;
emit(M.MV(pty, allocptrR, M.ADD(addrTy, C.allocptr, LI hp))))
in if hp = 0 then ()
else if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then advBy(hp+4)
else advBy(hp)
end
fun testLimit hp =
let fun assignCC(M.CC(_, cc), v) = emit(M.CCMV(cc, v))
| assignCC _ = error "testLimit.assign"
in updtHeapPtr(hp);
case C.exhausted
of NONE => ()
| SOME cc => assignCC(cc, gcTest)
(*esac*)
end
(*
* Function to allocate an integer record
* x <- [descriptor ... fields]
*)
fun ea(r, 0) = r
| ea(r, n) = M.ADD(addrTy, r, LI n)
fun indexEA(r, 0) = r
| indexEA(r, n) = M.ADD(addrTy, r, LI(n*4))
fun allocRecord(markComp, mem, desc, fields, hp) =
let fun getField(v, e, CPS.OFFp 0) = e
| getField(v, e, CPS.OFFp n) = M.ADD(addrTy, e, LI(4*n))
| getField(v, e, p) = getPath(getRegion v, e, p)
and getPath(mem, e, CPS.OFFp n) = indexEA(e, n)
| getPath(mem, e, CPS.SELp(n, CPS.OFFp 0)) =
markComp(M.LOAD(ity, indexEA(e, n), pi(mem, n)))
| getPath(mem, e, CPS.SELp(n, p)) =
let val mem = pi(mem, n)
in getPath(mem, markPTR(M.LOAD(ity, indexEA(e, n), mem)), p)
end
fun storeFields([], hp, elem) = hp
| storeFields((v, p)::fields, hp, elem) =
(emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, LI hp),
getField(v, regbind' v, p), pi(mem, elem)));
storeFields(fields, hp+4, elem+1)
)
in emit(M.STORE(ity, ea(C.allocptr, hp), desc, pi(mem, ~1)));
storeFields(fields, hp+4, 0);
hp+4
end
(*
* Functions to allocate a floating point record
* x <- [descriptor ... fields]
*)
fun allocFrecord(mem, desc, fields, hp) =
let fun fea(r, 0) = r
| fea(r, n) = M.ADD(addrTy, r, LI(n*8))
fun fgetField(v, CPS.OFFp 0) = fregbind v
| fgetField(v, CPS.OFFp _) = error "allocFrecord.fgetField"
| fgetField(v, p) = fgetPath(getRegion v, regbind' v, p)
and fgetPath(mem, e, CPS.OFFp _) = error "allocFrecord.fgetPath"
| fgetPath(mem, e, CPS.SELp(n, CPS.OFFp 0)) =
markFLT(M.FLOAD(fty, fea(e, n), pi(mem, n)))
| fgetPath(mem, e, CPS.SELp(n, p)) =
let val mem = pi(mem, n)
in fgetPath(mem, markPTR(M.LOAD(ity, indexEA(e, n), mem)),p)
end
fun fstoreFields([], hp, elem) = hp
| fstoreFields((v, p)::fields, hp, elem) =
(emit(M.FSTORE(fty, M.ADD(addrTy, C.allocptr, LI hp),
fgetField(v, p), pi(mem, elem)));
fstoreFields(fields, hp+8, elem+1)
)
in emit(M.STORE(ity, ea(C.allocptr, hp), desc, pi(mem, ~1)));
fstoreFields(fields, hp+4, 0);
hp+4
end
(* Allocate a header pair for vector or array *)
fun allocHeaderPair(hdrDesc, mem, dataPtr, len, hp) =
(emit(M.STORE(ity, ea(C.allocptr, hp), LI hdrDesc,pi(mem,~1)));
emit(M.STORE(ity, ea(C.allocptr, hp+4),
M.REG(ity,dataPtr),pi(mem, 0)));
emit(M.STORE(ity, ea(C.allocptr, hp+8), LI(len+len+1),
pi(mem, 1)));
hp+4
)
(*
* Int 31 tag optimizations.
* Note: if the tagging scheme changes then we'll have to redo these.
*)
fun addTag e = M.ADD(ity, e, one)
fun stripTag e = M.SUB(ity, e, one)
fun orTag e = M.ORB(ity, e, one)
fun tag(false, e) = tagUnsigned e
| tag(true, e) = tagSigned e
and tagUnsigned e =
let fun double r = M.ADD(ity,r,r)
in case e
of M.REG _ => addTag(double e)
| _ => let val tmp = newReg PTR (* XXX ??? *)
in M.LET(M.MV(ity, tmp, e),
addTag(double(M.REG(ity,tmp))))
end
end
and tagSigned e =
let fun double r = M.ADDT(ity,r,r)
in case e
of M.REG _ => addTag(double e)
| _ => let val tmp = newReg PTR (* XXX ??? *)
in M.LET(M.MV(ity, tmp, e),
addTag(double(M.REG(ity,tmp))))
end
end
fun untag(true, e) = untagSigned e
| untag(false, e) = untagUnsigned e
and untagUnsigned(CPS.INT i) = LI i
| untagUnsigned v = M.SRL(ity, regbind v, one)
and untagSigned(CPS.INT i) = LI i
| untagSigned v = M.SRA(ity, regbind v, one)
(*
* Integer operators
*)
fun int31add(addOp, CPS.INT k, w) = addOp(ity, LI(k+k), regbind w)
| int31add(addOp, w, v as CPS.INT _) = int31add(addOp, v, w)
| int31add(addOp, v, w) = addOp(ity,regbind v,stripTag(regbind w))
fun int31sub(subOp, CPS.INT k, w) = subOp(ity, LI(k+k+2),regbind w)
| int31sub(subOp, v, CPS.INT k) = subOp(ity, regbind v, LI(k+k))
| int31sub(subOp, v, w) = addTag(subOp(ity, regbind v, regbind w))
fun int31xor(CPS.INT k, w) = M.XORB(ity, LI(k+k), regbind w)
| int31xor(w, v as CPS.INT _) = int31xor (v,w)
| int31xor(v, w) = addTag (M.XORB(ity, regbind v, regbind w))
fun int31mul(signed, v, w) =
let fun f(CPS.INT k, CPS.INT j) = (LI(k+k), LI(j))
| f(CPS.INT k, w) = (untag(signed,w), LI(k+k))
| f(v, w as CPS.INT _) = f(w, v)
| f(v, w) = (stripTag(regbind v), untag(signed,w))
val (v, w) = f(v, w)
in addTag(if signed then M.MULT(ity, v, w) else M.MULU(ity, v, w))
end
fun int31div(signed, v, w) =
let val (v, w) =
case (v, w) of
(CPS.INT k, CPS.INT j) => (LI k, LI j)
| (CPS.INT k, w) => (LI k, untag(signed, w))
| (v, CPS.INT k) => (untag(signed, v), LI(k))
| (v, w) => (untag(signed, v), untag(signed, w))
in tag(signed,
if signed then M.DIVT(ity, v, w) else M.DIVU(ity, v, w))
end
fun int31lshift(CPS.INT k, w) =
addTag (M.SLL(ity, LI(k+k), untagUnsigned(w)))
| int31lshift(v, CPS.INT k) =
addTag(M.SLL(ity,stripTag(regbind v), LI(k)))
| int31lshift(v,w) =
addTag(M.SLL(ity,stripTag(regbind v), untagUnsigned(w)))
fun int31rshift(rshiftOp, v, CPS.INT k) =
orTag(rshiftOp(ity, regbind v, LI(k)))
| int31rshift(rshiftOp, v, w) =
orTag(rshiftOp(ity, regbind v, untagUnsigned(w)))
fun getObjDescriptor(v) =
M.LOAD(ity, M.SUB(pty, regbind v, LI(4)), getRegionPi(v, ~1))
fun getObjLength(v) =
M.SRL(ity, getObjDescriptor(v), LI(D.tagWidth -1))
(*
* Note: because formals are moved into fresh temporaries,
* (formals intersection actuals) is empty.
*
* Do the treeified computation first so as to prevent extra
* interferences from being created.
*
*)
fun callSetup(formals, actuals) =
let fun isTreeified(CPS.VAR r) = treeify r = TREEIFIED
| isTreeified _ = false
fun gather([], [], cpRd, cpRs, fcopies, treeified, moves) =
(app emit treeified;
case (cpRd,cpRs)
of ([],[]) => ()
| _ => emit(M.COPY(ity, cpRd, cpRs));
case fcopies
of [] => ()
| _ => emit(M.FCOPY(fty, map #1 fcopies, map #2 fcopies));
app emit moves
)
| gather(M.GPR(M.REG(ty,rd))::fmls,act::acts,cpRd,cpRs,f,t,m) =
(case regbind act
of M.REG(_,rs) => gather(fmls,acts,rd::cpRd,rs::cpRs,f,t,m)
| e => if isTreeified act then
gather(fmls, acts, cpRd, cpRs, f,
M.MV(ty, rd, e)::t, m)
else
gather(fmls, acts, cpRd, cpRs, f,
t, M.MV(ty, rd, e)::m)
(*esac*))
| gather(M.GPR(M.LOAD(ty,ea,r))::fmls,act::acts,cpRd,cpRs,f,t,m) =
(* Always store them early! *)
gather(fmls,acts,cpRd,cpRs,f,
M.STORE(ty,ea,regbind act,r)::t, m)
| gather(M.FPR(M.FREG(ty,fd))::fmls,act::acts,cpRd,cpRs,f,t,m) =
(case fregbind act
of M.FREG(_,fs) =>
gather(fmls,acts,cpRd,cpRs,(fd,fs)::f,t,m)
| e =>
if isTreeified act then
gather(fmls,acts,cpRd,cpRs,f,M.FMV(ty, fd, e)::t,m)
else
gather(fmls,acts,cpRd,cpRs,f,t,M.FMV(ty, fd, e)::m)
(*esac*))
| gather _ = error "callSetup.gather"
in gather(formals, actuals, [], [], [], [], [])
end
(* scale-and-add *)
fun scale1(a, CPS.INT 0) = a
| scale1(a, CPS.INT k) = M.ADD(ity, a, LI(k))
| scale1(a, i) = M.ADD(ity, a, untagSigned(i))
fun scale4(a, CPS.INT 0) = a
| scale4(a, CPS.INT i) = M.ADD(ity, a, LI(i*4))
| scale4(a, i) = M.ADD(ity, a, M.SLL(ity, untagSigned(i), two))
fun scale8(a, CPS.INT 0) = a
| scale8(a, CPS.INT i) = M.ADD(ity, a, LI(i*8))
| scale8(a, i) = M.ADD(ity, a, M.SLL(ity, stripTag(regbind i),
LI(2)))
(* zero-extend and sign-extend *)
fun ZX32 (sz, e) = M.ZX (32, sz, e)
(* M.SRL (32, M.SLL (32, e, LI (32 - sz)), LI (32 - sz)) *)
fun SX32 (sz, e) = M.SX (32, sz, e)
(* M.SRA (32, M.SLL (32, e, LI (32 - sz)), LI (32 - sz)) *)
(* add to storelist, the address where a boxed update has occured *)
fun recordStore(tmp, hp) =
(emit(M.STORE(pty,M.ADD(addrTy,C.allocptr,LI(hp)),
tmp,R.storelist));
emit(M.STORE(pty,M.ADD(addrTy,C.allocptr,LI(hp+4)),
C.storeptr,R.storelist));
emit(assign(C.storeptr, M.ADD(addrTy, C.allocptr, LI(hp)))))
fun unsignedCmp oper =
case oper
of P.> => M.GTU | P.>= => M.GEU
| P.< => M.LTU | P.<= => M.LEU
| P.eql => M.EQ | P.neq => M.NE
fun signedCmp oper =
case oper
of P.> => M.GT | P.>= => M.GE
| P.< => M.LT | P.<= => M.LE
| P.neq => M.NE | P.eql => M.EQ
fun branchToLabel(lab) = M.JMP(M.LABEL lab,[])
local
open CPS
in
(*
* This function initializes a CPS function before we generate
* code for it. Its tasks include:
* 1. Add type bindings for each definition. This is used to determine
* the parameter passing convention for standard functions.
* 2. Compute the number of uses for each variable. This is
* used in the forward propagation logic.
* 3. Check whether the base pointer is needed.
* It is needed iff
* a. There is a reference to LABEL
* b. It uses SWITCH (the jumptable requires the basepointer)
* 4. Generate the gc tests for STANDARD and KNOWN functions
* 5. Check to see if floating point allocation is being performed
* in the function. If so, we will align the allocptr.
*)
fun genCPSFunction(lab, kind, f, params, formals, tys, e) =
let val add = addTypBinding
fun addUse v =
case treeify v of
DEAD => addCntTbl(v, TREEIFY)
| TREEIFY => addCntTbl(v, COMPUTE)
| COMPUTE => ()
| _ => error "addUse"
val hasFloats = ref false (* default is no *)
val needBasePtr = ref false
fun addValue(VAR v) = addUse v
| addValue(LABEL _) = needBasePtr := true
| addValue _ = ()
fun addValues [] = ()
| addValues(VAR v::vs) = (addUse v; addValues vs)
| addValues(LABEL _::vs) = (needBasePtr := true; addValues vs)
| addValues(_::vs) = addValues vs
fun addRecValues [] = ()
| addRecValues((VAR v,_)::l) = (addUse v; addRecValues l)
| addRecValues((LABEL v,_)::l) =
(needBasePtr := true; addRecValues l)
| addRecValues(_::l) = addRecValues l
fun init e =
case e
of RECORD(k,vl,x,e) =>
(case k of
(RK_FCONT | RK_FBLOCK) => hasFloats := true
| _ => ();
addRecValues vl; add(x,BOGt); init e
)
| SELECT(_,v,x,t,e) => (addValue v; add(x,t); init e)
| OFFSET(_,v,x,e) => (addValue v; add(x,BOGt); init e)
| SWITCH(v,_,el) =>
(needBasePtr := true; addValue v; app init el)
| SETTER(_,vl,e) => (addValues vl; init e)
| LOOKER(looker,vl,x,t,e) =>
(addValues vl;
(* floating subscript cannot move past a floating update.
* For now subscript operations cannot be treeified.
* This is hacked by making it (falsely) used
* more than once.
*)
case looker of
(P.numsubscript{kind=P.FLOAT _} |
P.rawload {kind=P.FLOAT _}) =>
addCntTbl(x,COMPUTE)
| _ => ();
add(x,t); init e
)
| ARITH(_,vl,x,t,e) => (addValues vl; add(x,t); init e)
| RCC(_,vl,x,t,e) => (addValues vl; add(x,t); init e)
| PURE(p,vl,x,t,e) =>
(case p of
P.fwrap => hasFloats := true
| _ => ();
addValues vl; add(x,t); init e
)
| BRANCH(_,vl,_,e1,e2) => (addValues vl; init e1; init e2)
| APP(v,vl) => (addValue v; addValues vl)
| _ => error "genCPSFunction"
in (* Print debugging information *)
if !CG.printit then printCPSFun(kind,f,params,tys,e) else ();
(* Move parameters *)
case kind of
KNOWN =>
(defineLabel lab;
init e;
initialRegBindingsEscaping(params, formals, tys)
)
| KNOWN_CHECK =>
(defineLabel lab;
(* gc test *)
(if !mlrisc andalso !gcsafety then
InvokeGC.optimizedKnwCheckLimit else
InvokeGC.knwCheckLimit)
stream
{maxAlloc=4*maxAlloc f, regfmls=formals, regtys=tys,
return=branchToLabel(lab)};
init e;
initialRegBindingsEscaping(params, formals, tys)
)
| _ =>
(* Standard function *)
let val regfmls as (M.GPR linkreg::regfmlsTl) = formals
val entryLab =
if splitEntry then functionLabel(~f-1) else lab
in
if splitEntry then
(entryLabel entryLab;
annotation EMPTY_BLOCK;
defineLabel lab
)
else
entryLabel lab;
clearTables();
init e;
if !needBasePtr then
let val baseval =
M.ADD(addrTy,linkreg,
M.LABEXP(M.SUB(addrTy,
constBaseRegOffset,
M.LABEL entryLab)))
in emit(assign(C.baseptr, baseval)) end
else ();
InvokeGC.stdCheckLimit stream
{maxAlloc=4 * maxAlloc f, regfmls=regfmls,
regtys=tys, return=M.JMP(linkreg,[])};
initialRegBindingsEscaping
(List.tl params, regfmlsTl, List.tl tys)
end
;
(* Align the allocation pointer if necessary *)
if !hasFloats then
emit(M.MV(pty,allocptrR, M.ORB(pty,C.allocptr, LI 4)))
else ();
(* Generate code *)
advancedHP := 0;
gen(e, 0)
end
(*
* Generate code for x := e; k
*)
and define(r, x, e, k, hp) =
(addRegBinding(x, r);
emit(M.MV(ity, r, e));
gen(k, hp)
)
and def(gc, x, e, k, hp) = define(newReg gc,x,e,k,hp)
and defWithCty(cty, x, e, k, hp) = define(newRegWithCty cty,x,e,k,hp)
and defWithKind(kind, x, e, k, hp) =
define(newRegWithKind kind,x,e,k,hp)
and defI31(x, e, k, hp) = def(I31, x, e, k, hp)
and defI32(x, e, k, hp) = def(I32, x, e, k, hp)
and defBoxed(x, e, k, hp) = def(PTR, x, e, k, hp)
(*
* Generate code for x : cty := e; k
*)
and treeifyDef(x, e, cty, k, hp) =
case treeify x of
COMPUTE => defWithCty(cty, x, e, k, hp)
| TREEIFY => (markAsTreeified x;
addExpBinding(x, markGC(e, cty)); gen(k, hp))
| DEAD => gen(k, hp)
| _ => error "treeifyDef"
(*
* Generate code for
* x := allocptr + offset; k
* where offset is the address offset of a newly allocated record.
* If x is only used once, we try to propagate that to its use.
*)
and defAlloc(x, offset, k, hp) =
defBoxed(x, M.ADD(addrTy, C.allocptr, LI offset), k, hp)
(* Generate code for
* x := allocptr + offset; k
* If there is only one reference then we delay the computation
* until it is used.
*)
and treeifyAlloc(x, offset, k, hp) =
(case treeify x of
COMPUTE => defAlloc(x, offset, k, hp)
| TREEIFY =>
(* Note, don't mark this as treeified since it has low
* register pressure.
*)
let val absoluteAllocOffset = offset + !advancedHP
in addExpBinding(x, M.CONST(absoluteAllocOffset));
gen(k, hp)
end
| DEAD => gen(k, hp)
| _ => error "treeifyAlloc"
)
and computef64(x, e, k, hp) = let
val f = newFreg REAL64
in
addFregBinding(x, M.FREG(fty, f));
emit(M.FMV(fty, f, e));
gen(k, hp)
end
(*
* x <- e where e contains an floating-point value
*)
and treeifyDefF64(x, e, k, hp) =
(case treeify x
of DEAD => gen(k, hp)
| TREEIFY => (markAsTreeified x;
addFregBinding(x,e); gen(k, hp))
| COMPUTE => computef64(x, e, k, hp)
| _ => error "treeifyDefF64"
(*esac*))
and nop(x, v, e, hp) = defI31(x, regbind v, e, hp)
and copy(gc, x, v, k, hp) =
let val dst = newReg gc
in addRegBinding(x, dst);
case regbind v
of M.REG(_,src) => emit(M.COPY(ity, [dst], [src]))
| e => emit(M.MV(ity, dst, e))
(*esac*);
gen(k, hp)
end
and copyM(31, x, v, k, hp) = copy(I31, x, v, k, hp)
| copyM(_, x, v, k, hp) = copy(I32, x, v, k, hp)
and eqVal(VAR x,VAR y) = x = y
| eqVal(LABEL x,LABEL y) = x = y
| eqVal(INT x, INT y) = x = y
| eqVal _ = false
(* Perform conditional move folding *)
(*
and branch(cmp, [v,w], yes, no, hp) =
case (yes, no) of
(APP(f,fs), APP(g,gs)) =>
if eqVal(f,g) then
let val cmp = M.CMP(32, cmp, regbind v, regbind w)
fun condMove([],[]) = []
| condMove(x::xs,y::ys) =
if eqVal(x,y) then x::condMove(xs,ys)
else
let val v = LambdaVar.mkLvar()
val tmp = newReg PTR
in emit(M.MV(32, tmp,
M.COND(32, cmp, regbind x, regbind y)));
addRegBinding(v, tmp);
addTypBinding(v, grabty x);
VAR v::condMove(xs, ys)
end
| condMove _ = error "condMove"
val e = APP(f,condMove(fs, gs))
in gen(e, hp)
end
else normalBranch(cmp, v, w, yes, no, hp)
| _ => normalBranch(cmp, v, w, yes, no, hp)
*)
(* normal branches *)
and branch (cmp, [v, w], yes, no, hp) =
let val trueLab = Label.newLabel""
in (* is single assignment great or what! *)
emit(M.BCC(M.CMP(32, cmp, regbind v, regbind w), trueLab));
genCont(no, hp);
genlab(trueLab, yes, hp)
end
(* branch if x is boxed *)
and branchOnBoxed(x, yes, no, hp) =
let val lab = Label.newLabel ""
val cmp = M.CMP(32, M.NE, M.ANDB(ity, regbind x, one), zero)
in emit(M.BCC(cmp, lab));
genCont(yes, hp);
genlab(lab, no, hp)
end
(* branch if are identical strings v, w of length n *)
and branchStreq(n, v, w, yes, no, hp) =
let val n' = ((n+3) div 4) * 4
val false_lab = Label.newLabel ""
val r1 = newReg I32
val r2 = newReg I32
fun cmpWord(i) =
M.CMP(32, M.NE,
M.LOAD(ity,M.ADD(ity,M.REG(ity, r1),i),R.readonly),
M.LOAD(ity,M.ADD(ity,M.REG(ity, r2),i),R.readonly))
fun unroll i =
if i=n' then ()
else (emit(M.BCC(cmpWord(LI(i)), false_lab));
unroll (i+4))
in emit(M.MV(ity, r1, M.LOAD(ity, regbind v, R.readonly)));
emit(M.MV(ity, r2, M.LOAD(ity, regbind w, R.readonly)));
unroll 0;
genCont(yes, hp);
genlab(false_lab, no, hp)
end
and arith(gc, oper, v, w, x, e, hp) =
def(gc, x, oper(ity, regbind v, regbind w), e, hp)
and arith32(oper, v, w, x, e, hp) =
arith(I32, oper, v, w, x, e, hp)
and logical(gc, oper, v, w, x, e, hp) =
def(gc, x, oper(ity, regbind v, untagUnsigned(w)), e, hp)
and logical31(oper, v, w, x, e, hp) =
logical(I31, oper, v, w, x, e, hp)
and logical32(oper, v, w, x, e, hp) =
logical(I32, oper, v, w, x, e, hp)
and genCont(e, hp) =
let val save = !advancedHP
in gen(e, hp); advancedHP := save end
and genlab(lab, e, hp) = (defineLabel lab; gen(e, hp))
and genlabCont(lab, e, hp) = (defineLabel lab; genCont(e, hp))
(* Allocate a normal record *)
and mkRecord(vl, w, e, hp) =
let val len = length vl
val desc = dtoi(D.makeDesc (len, D.tag_record))
in treeifyAlloc(w,
allocRecord(markPTR, memDisambig w, LI desc, vl, hp),
e, hp+4+len*4)
end
(* Allocate a record with I32 components *)
and mkI32block(vl, w, e, hp) =
let val len = length vl
val desc = dtoi(D.makeDesc (len, D.tag_raw32))
in treeifyAlloc(w,
allocRecord(markI32, memDisambig w, LI desc, vl, hp),
e, hp+4+len*4)
end
(* Allocate a floating point record *)
and mkFblock(vl, w, e, hp) =
let val len = List.length vl
val desc = dtoi(D.makeDesc(len+len, D.tag_raw64))
(* At initialization the allocation pointer is aligned on
* an odd-word boundary, and the heap offset set to zero. If an
* odd number of words have been allocated then the heap pointer
* is misaligned for this record creation.
*)
val hp =
if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then hp+4 else hp
in (* The components are floating point *)
treeifyAlloc(w,
allocFrecord(memDisambig w, LI desc, vl, hp),
e, hp+4+len*8)
end
(* Allocate a vector *)
and mkVector(vl, w, e, hp) =
let val len = length vl
val hdrDesc = dtoi(D.desc_polyvec)
val dataDesc = dtoi(D.makeDesc(len, D.tag_vec_data))
val dataPtr = newReg PTR
val mem = memDisambig w
val hp' = hp + 4 + len*4
in (* The components are boxed *)
(* Allocate the data *)
allocRecord(markPTR, mem, LI dataDesc, vl, hp);
emit(M.MV(pty, dataPtr, ea(C.allocptr, hp+4)));
(* Now allocate the header pair *)
treeifyAlloc(w,
allocHeaderPair(hdrDesc, mem, dataPtr, len, hp+4+len*4),
e, hp'+12)
end
(*
* Floating point select
*)
and fselect(i, v, x, e, hp) =
treeifyDefF64(x,
M.FLOAD(fty, scale8(regbind v, INT i), R.real),
e, hp)
(*
* Non-floating point select
*)
and select(i, v, x, t, e, hp) =
treeifyDef(x,
M.LOAD(ity,scale4(regbind v,INT i),getRegionPi(v,i)),
t, e, hp)
(*
* Funny select; I don't know that this does
*)
and funnySelect(i, k, x, t, e, hp) =
let val unboxedfloat = MS.unboxedFloats
fun isFlt t =
if unboxedfloat then (case t of FLTt => true | _ => false)
else false
fun fallocSp(x,e,hp) =
(addFregBinding(x,M.FREG(fty,newFreg REAL64));gen(e, hp))
(* warning: the following generated code should never be
executed; its semantics is completely screwed up !
*)
in if isFlt t then fallocSp(x, e, hp)
else defI32(x, LI k, e, hp)(* BOGUS *)
end
(*
* Call an external function
*)
and externalApp(f, args, hp) =
let val ctys = map grabty args
val formals as (M.GPR dest::_) = ArgP.standard(typmap f, ctys)
in callSetup(formals, args);
if gctypes then
annotation(gcAnnotation(#create GCCells.GCLIVEOUT,
formals, ctys))
else ();
testLimit hp;
emit(M.JMP(dest, []));
exitBlock(formals @ dedicated)
end
(*
* Call an internal function
*)
and internalApp(f, args, hp) =
(case lookupGenTbl f
of Frag.KNOWNFUN(ref(Frag.GEN formals)) =>
(updtHeapPtr(hp);
callSetup(formals, args);
emit(branchToLabel(functionLabel f)))
| Frag.KNOWNFUN(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
let val formals = known tl
val lab = functionLabel f
in r := Frag.GEN formals;
updtHeapPtr(hp);
callSetup(formals, args);
genCPSFunction(lab, KNOWN, f, vl, formals, tl, e)
end
| Frag.KNOWNCHK(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
let val formals =
if MS.fixedArgPassing then ArgP.fixed tl
else known tl
val lab = functionLabel f
in r := Frag.GEN formals;
callSetup(formals, args);
testLimit hp;
genCPSFunction(lab, KNOWN_CHECK, f, vl, formals, tl, e)
end
| Frag.KNOWNCHK(ref(Frag.GEN formals)) =>
(callSetup(formals, args);
testLimit hp;
emit(branchToLabel(functionLabel f)))
| Frag.STANDARD{fmlTyps, ...} =>
let val formals = ArgP.standard(typmap f, fmlTyps)
in callSetup(formals, args);
testLimit hp;
emit(branchToLabel(functionLabel f))
end
(*esac*))
and rawload ((P.INT 32 | P.UINT 32), i, x, e, hp) =
defI32 (x, M.LOAD (32, regbind i, R.memory), e, hp)
| rawload (P.INT (sz as (8 | 16)), i, x, e, hp) =
defI32 (x, SX32 (sz, M.LOAD (sz, regbind i, R.memory)), e, hp)
| rawload (P.UINT (sz as (8 | 16)), i, x, e, hp) =
defI32 (x, ZX32 (sz, M.LOAD (sz, regbind i, R.memory)), e, hp)
| rawload ((P.UINT sz | P.INT sz), _, _, _, _) =
error ("rawload: unsupported size: " ^ Int.toString sz)
| rawload (P.FLOAT (sz as (32 | 64)), i, x, e, hp) =
treeifyDefF64 (x, M.FLOAD (sz, regbind i, R.memory), e, hp)
| rawload (P.FLOAT sz, _, _, _, _) =
error ("rawload: unsupported float size: " ^ Int.toString sz)
and rawstore ((P.UINT (sz as (8 | 16 | 32)) |
P.INT (sz as (8 | 16 | 32))), i, x) =
(* both address and value are 32-bit values; only sz bits
* of the value are being stored *)
emit (M.STORE (sz, regbind i, regbind x, R.memory))
| rawstore ((P.UINT sz | P.INT sz), _, _) =
error ("rawstore: unsupported int size: " ^ Int.toString sz)
| rawstore (P.FLOAT (sz as (32 | 64)) , i, x) =
emit (M.FSTORE (sz, regbind i, fregbind x, R.memory))
| rawstore (P.FLOAT sz, _, _) =
error ("rawstore: unsupported float size: " ^ Int.toString sz)
(*
* Generate code
*)
(** RECORD **)
and gen(RECORD(RK_FCONT, vl, w, e), hp) = mkFblock(vl, w, e, hp)
| gen(RECORD(RK_FBLOCK, vl, w, e), hp) = mkFblock(vl, w, e, hp)
| gen(RECORD(RK_VECTOR, vl, w, e), hp) = mkVector(vl, w, e, hp)
| gen(RECORD(RK_I32BLOCK, vl, w, e), hp) = mkI32block(vl, w, e, hp)
| gen(RECORD(_, vl, w, e), hp) = mkRecord(vl, w, e, hp)
(*** SELECT ***)
| gen(SELECT(i, INT k, x, t, e), hp) = funnySelect(i,k,x,t,e,hp)
| gen(SELECT(i, v, x, FLTt, e), hp) = fselect(i, v, x, e, hp)
| gen(SELECT(i, v, x, t, e), hp) = select(i, v, x, t, e, hp)
(*** OFFSET ***)
| gen(OFFSET(i, v, x, e), hp) =
defBoxed(x, scale4(regbind v, INT i), e, hp)
(*** APP ***)
| gen(APP(INT k, args), hp) = updtHeapPtr(hp)
| gen(APP(VAR f, args), hp) = externalApp(f, args, hp)
| gen(APP(LABEL f, args), hp) = internalApp(f, args, hp)
(*** SWITCH ***)
| gen(SWITCH(INT _, _, _), hp) = error "SWITCH"
| gen(SWITCH(v, _, l), hp) =
let val lab = Label.newLabel""
val labs = map (fn _ => Label.newLabel"") l
val tmpR = newReg I32 val tmp = M.REG(ity,tmpR)
in emit(M.MV(ity, tmpR, laddr(lab, 0)));
emit(M.JMP(M.ADD(addrTy, tmp, M.LOAD(pty, scale4(tmp, v),
R.readonly)), labs));
pseudoOp(PseudoOp.JUMPTABLE{base=lab, targets=labs});
ListPair.app (fn (lab, e) => genlabCont(lab, e, hp)) (labs, l)
end
(*** PURE ***)
| gen(PURE(P.real{fromkind=P.INT 31, tokind=P.FLOAT 64},
[v], x, _, e), hp) =
treeifyDefF64(x,M.CVTI2F(fty,ity,untagSigned(v)), e, hp)
| gen(PURE(P.pure_arith{oper, kind=P.FLOAT 64}, [v], x, _, e), hp) = let
val r = fregbind v
in
case oper
of P.~ => treeifyDefF64(x, M.FNEG(fty,r), e, hp)
| P.abs => treeifyDefF64(x, M.FABS(fty,r), e, hp)
| P.fsqrt => treeifyDefF64(x, M.FSQRT(fty,r), e, hp)
| P.fsin => computef64(x, M.FEXT(fty, E.FSINE r), e, hp)
| P.fcos => computef64(x, M.FEXT(fty, E.FCOSINE r), e, hp)
| P.ftan => computef64(x, M.FEXT(fty, E.FTANGENT r), e, hp)
end
| gen(PURE(P.pure_arith{oper, kind=P.FLOAT 64}, [v,w], x, _, e), hp) =
let val v = fregbind v
val w = fregbind w
val t =
case oper
of P.+ => M.FADD(fty, v, w)
| P.* => M.FMUL(fty, v, w)
| P.- => M.FSUB(fty, v, w)
| P./ => M.FDIV(fty, v, w)
in treeifyDefF64(x, t, e, hp)
end
| gen(PURE(P.pure_arith{oper=P.orb, kind}, [v,w], x, _, e), hp) =
defWithKind(kind, x, M.ORB(ity, regbind v, regbind w), e, hp)
| gen(PURE(P.pure_arith{oper=P.andb, kind}, [v,w], x, _, e), hp) =
defWithKind(kind, x, M.ANDB(ity, regbind v, regbind w), e, hp)
| gen(PURE(P.pure_arith{oper, kind}, [v,w], x, ty, e), hp) =
(case kind
of P.INT 31 => (case oper
of P.xorb => defI31(x, int31xor(v,w), e, hp)
| P.lshift => defI31(x, int31lshift(v,w), e, hp)
| P.rshift => defI31(x, int31rshift(M.SRA,v,w),e,hp)
| _ => error "gen:PURE INT 31"
(*esac*))
| P.INT 32 => (case oper
of P.xorb => arith32(M.XORB, v, w, x, e, hp)
| P.lshift => logical32(M.SLL, v, w, x, e, hp)
| P.rshift => logical32(M.SRA, v, w, x, e, hp)
| _ => error "gen:PURE INT 32"
(*esac*))
| P.UINT 31 => (case oper
of P.+ => defI31(x, int31add(M.ADD, v, w), e, hp)
| P.- => defI31(x, int31sub(M.SUB, v, w), e, hp)
| P.* => defI31(x, int31mul(false, v, w), e, hp)
| P./ => (* This is not really a pure
operation -- oh well *)
(updtHeapPtr hp;
defI31(x, int31div(false, v, w), e, 0))
| P.xorb => defI31(x, int31xor(v, w), e, hp)
| P.lshift => defI31(x,int31lshift(v, w), e, hp)
| P.rshift => defI31(x,int31rshift(M.SRA,v, w),e,hp)
| P.rshiftl => defI31(x,int31rshift(M.SRL,v, w),e,hp)
| _ => error "gen:PURE UINT 31"
(*esac*))
| P.UINT 32 => (case oper
of P.+ => arith32(M.ADD, v, w, x, e, hp)
| P.- => arith32(M.SUB, v, w, x, e, hp)
| P.* => arith32(M.MULU, v, w, x, e, hp)
| P./ => (updtHeapPtr hp;
arith32(M.DIVU, v, w, x, e, 0))
| P.xorb => arith32(M.XORB, v, w, x, e, hp)
| P.lshift => logical32(M.SLL, v, w, x, e, hp)
| P.rshift => logical32(M.SRA, v, w, x, e, hp)
| P.rshiftl=> logical32(M.SRL, v, w, x, e, hp)
| _ => error "gen:PURE UINT 32"
(*esac*))
(*esac*))
| gen(PURE(P.pure_arith{oper=P.notb, kind}, [v], x, _, e), hp) =
(case kind
of P.UINT 32 => defI32(x,M.XORB(ity, regbind v,
LW 0wxFFFFFFFF), e, hp)
| P.INT 32 => defI32(x,M.XORB(ity, regbind v,
LW 0wxFFFFFFFF), e, hp)
| P.UINT 31 => defI31(x,M.SUB(ity, zero, regbind v), e, hp)
| P.INT 31 => defI31(x,M.SUB(ity, zero, regbind v), e, hp)
(*esac*))
| gen(PURE(P.copy ft, [v], x, _, e), hp) =
(case ft
of (31, 32) => defI32(x, M.SRL(ity, regbind v, one), e, hp)
| (8, 31) => copy(I31, x, v, e, hp)
| (8, 32) => defI32(x, M.SRL(ity, regbind v, one), e, hp)
| (n,m) => if n = m then copyM(m, x, v, e, hp)
else error "gen:PURE:copy"
(*esac*))
| gen(PURE(P.extend ft, [v], x, _ ,e), hp) =
(case ft
of (8,31) =>
defI31(x,
M.SRA(ity, M.SLL(ity, regbind v,LI 23), LI 23),
e, hp)
| (8,32) =>
defI32(x,
M.SRA(ity, M.SLL(ity, regbind v, LI 23), LI 24),
e, hp)
| (31,32) => defI32(x, M.SRA(ity, regbind v, one), e, hp)
| (n, m) => if n = m then copyM(m, x, v, e, hp)
else error "gen:PURE:extend"
(*esac*))
| gen(PURE(P.trunc ft, [v], x, _, e), hp) =
(case ft
of (32, 31) =>
defI31(x, M.ORB(ity, M.SLL(ity, regbind v, one), one), e, hp)
| (31,8) => defI32(x, M.ANDB(ity, regbind v, LI 0x1ff), e, hp)
| (32,8) => defI32(x, tagUnsigned(M.ANDB(ity, regbind v,
LI 0xff)), e, hp)
| (n, m) => if n = m then copyM(m, x, v, e, hp)
else error "gen:PURE:trunc"
(*esac*))
| gen(PURE(P.objlength, [v], x, _, e), hp) =
defI31(x, orTag(getObjLength(v)), e, hp)
| gen(PURE(P.length, [v], x, t, e), hp) = select(1, v, x, t, e, hp)
| gen(PURE(P.subscriptv, [v, INT i], x, t, e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val mem' = arrayRegion mem
in defBoxed(x, M.LOAD(ity, scale4(a, INT i), mem'), e, hp)
end
| gen(PURE(P.subscriptv, [v, w], x, _, e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val mem' = arrayRegion mem
in defBoxed(x, M.LOAD(ity, scale4(a, w), mem'), e, hp)
end
| gen(PURE(P.pure_numsubscript{kind=P.INT 8}, [v,i], x, _, e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val mem' = arrayRegion mem
in defI31(x,tagUnsigned(M.LOAD(8,scale1(a, i), mem')), e, hp)
end
| gen(PURE(P.gettag, [v], x, _, e), hp) =
defI31(x, tagUnsigned(M.ANDB(ity,
getObjDescriptor(v), LI(D.powTagWidth-1))),
e, hp)
| gen(PURE(P.mkspecial, [i, v], x, _, e), hp) =
let val desc = case i
of INT n => LI(dtoi(D.makeDesc(n, D.tag_special)))
| _ => M.ORB(ity, M.SLL(ity, untagSigned(i),LI D.tagWidth),
LI(dtoi D.desc_special))
in (* What gc types are the components? *)
treeifyAlloc(x,
allocRecord(markNothing, memDisambig x,
desc, [(v, offp0)], hp),
e, hp+8)
end
| gen(PURE(P.makeref, [v], x, _, e), hp) =
let val tag = LI(dtoi D.desc_ref)
val mem = memDisambig x
in emit(M.STORE(ity,M.ADD(addrTy,C.allocptr,LI hp),tag,mem));
emit(M.STORE(ity,M.ADD(addrTy,C.allocptr,LI(hp+4)),
regbind' v, mem));
treeifyAlloc(x, hp+4, e, hp+8)
end
| gen(PURE(P.fwrap,[u],w,_,e), hp) = mkFblock([(u, offp0)],w,e,hp)
| gen(PURE(P.funwrap,[u],w,_,e), hp) = fselect(0,u,w,e,hp)
| gen(PURE(P.iwrap,[u],w,_,e), _) = error "iwrap not implemented"
| gen(PURE(P.iunwrap,[u],w,_,e), _) = error "iunwrap not implemented"
| gen(PURE(P.i32wrap,[u],w,_,e), hp) =
mkI32block([(u, offp0)], w, e, hp)
| gen(PURE(P.i32unwrap,[u],w,_,e), hp) =
select(0, u, w, INT32t, e, hp)
| gen(PURE(P.wrap,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
| gen(PURE(P.unwrap,[u],w,_,e), hp) = copy(I32, w, u, e, hp)
(* Note: the gc type is unsafe! XXX *)
| gen(PURE(P.cast,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
| gen(PURE(P.getcon,[u],w,t,e), hp) = select(0,u,w,t,e,hp)
| gen(PURE(P.getexn,[u],w,t,e), hp) = select(0,u,w,t,e,hp)
| gen(PURE(P.getseqdata, [u], x, t, e), hp) = select(0,u,x,t,e,hp)
| gen(PURE(P.recsubscript, [v, INT w], x, t, e), hp) =
select(w,v,x,t,e,hp)
| gen(PURE(P.recsubscript, [v, w], x, _, e), hp) =
(* no indirection! *)
let val mem = arrayRegion(getRegion v)
in defI31(x, M.LOAD(ity, scale4(regbind v, w), mem), e, hp)
end
| gen(PURE(P.raw64subscript, [v, i], x, _, e), hp) =
let val mem = arrayRegion(getRegion v)
in treeifyDefF64(x, M.FLOAD(fty,scale8(regbind v, i), mem),
e, hp)
end
| gen(PURE(P.newarray0, [_], x, t, e), hp) =
let val hdrDesc = dtoi(D.desc_polyarr)
val dataDesc = dtoi D.desc_ref
val dataPtr = newReg PTR
val hdrM = memDisambig x
val (tagM, valM) = (hdrM, hdrM) (* Allen *)
in (* gen code to allocate "ref()" for array data *)
emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, LI hp),
LI dataDesc, tagM));
emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, LI(hp+4)),
mlZero, valM));
emit(M.MV(pty, dataPtr, M.ADD(addrTy,C.allocptr,LI(hp+4))));
(* gen code to allocate array header *)
treeifyAlloc(x,
allocHeaderPair(hdrDesc, hdrM, dataPtr, 0, hp+8),
e, hp+20)
end
(*** ARITH ***)
| gen(ARITH(P.arith{kind=P.INT 31, oper=P.~}, [v], x, _, e), hp) =
(updtHeapPtr hp;
defI31(x, M.SUBT(ity, LI 2, regbind v), e, 0)
)
| gen(ARITH(P.arith{kind=P.INT 31, oper}, [v, w], x, _, e), hp) =
(updtHeapPtr hp;
let val t =
case oper
of P.+ => int31add(M.ADDT, v, w)
| P.- => int31sub(M.SUBT, v, w)
| P.* => int31mul(true, v, w)
| P./ => int31div(true, v, w)
| _ => error "gen:ARITH INT 31"
in defI31(x, t, e, 0) end
(*esac*))
| gen(ARITH(P.arith{kind=P.INT 32, oper}, [v,w], x, _, e), hp) =
(updtHeapPtr hp;
case oper
of P.+ => arith32(M.ADDT, v, w, x, e, 0)
| P.- => arith32(M.SUBT, v, w, x, e, 0)
| P.* => arith32(M.MULT, v, w, x, e, 0)
| P./ => arith32(M.DIVT, v, w, x, e, 0)
| _ => error "P.arith{kind=INT 32, oper}, [v,w], ..."
(*esac*))
| gen(ARITH(P.arith{kind=P.INT 32, oper=P.~ }, [v], x, _, e), hp) =
(updtHeapPtr hp;
defI32(x, M.SUBT(ity, zero, regbind v), e, 0))
(* Note: for testu operations we use a somewhat arcane method
* to generate traps on overflow conditions. A better approach
* would be to generate a trap-if-negative instruction available
* on a variety of machines, e.g. mips and sparc (maybe others).
*)
| gen(ARITH(P.testu(32, 32), [v], x, _, e), hp) =
let val xreg = newReg I32
val vreg = regbind v
in updtHeapPtr hp;
emit(M.MV(ity, xreg, M.ADDT(ity, vreg,
regbind(INT32 0wx80000000))));
defI32(x, vreg, e, 0)
end
| gen(ARITH(P.testu(31, 31), [v], x, _, e), hp) =
let val xreg = newReg I31
val vreg = regbind v
in updtHeapPtr hp;
emit(M.MV(ity,xreg,M.ADDT(ity, vreg,
regbind(INT32 0wx80000000))));
defI31(x, vreg, e, 0)
end
| gen(ARITH(P.testu(32,31), [v], x, _, e), hp) =
let val vreg = regbind v
val tmp = newReg I32
val tmpR = M.REG(ity,tmp)
val lab = Label.newLabel ""
in emit(M.MV(ity, tmp, regbind(INT32 0wx3fffffff)));
updtHeapPtr hp;
emit(M.BCC(M.CMP(32, M.LEU, vreg, tmpR),lab));
emit(M.MV(ity, tmp, M.SLL(ity, tmpR, one)));
emit(M.MV(ity, tmp, M.ADDT(ity, tmpR, tmpR)));
defineLabel lab;
defI31(x, tagUnsigned(vreg), e, 0)
end
| gen(ARITH(P.test(32,31), [v], x, _, e), hp) =
(updtHeapPtr hp; defI31(x, tagSigned(regbind v), e, 0))
| gen(ARITH(P.test(n, m), [v], x, _, e), hp) =
if n = m then copyM(m, x, v, e, hp) else error "gen:ARITH:test"
| gen(ARITH(P.arith{oper, kind=P.FLOAT 64}, [v,w], x, _, e), hp) =
let val v = fregbind v
val w = fregbind w
val t =
case oper
of P.+ => M.FADD(fty, v, w)
| P.* => M.FMUL(fty, v, w)
| P.- => M.FSUB(fty, v, w)
| P./ => M.FDIV(fty, v, w)
in treeifyDefF64(x, t, e, hp)
end
(*** LOOKER ***)
| gen(LOOKER(P.!, [v], x, _, e), hp) =
let val mem = arrayRegion(getRegion v)
in defBoxed (x, M.LOAD(ity, regbind v, mem), e, hp)
end
| gen(LOOKER(P.subscript, [v,w], x, _, e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val mem' = arrayRegion mem
in defBoxed (x, M.LOAD(ity, scale4(a, w), mem'), e, hp)
end
| gen(LOOKER(P.numsubscript{kind=P.INT 8},[v,i],x,_,e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val mem' = arrayRegion mem
in defI31(x, tagUnsigned(M.LOAD(8,scale1(a, i), mem')), e, hp)
end
| gen(LOOKER(P.numsubscript{kind=P.FLOAT 64}, [v,i], x, _, e), hp)=
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val mem' = arrayRegion mem
in treeifyDefF64(x, M.FLOAD(fty,scale8(a, i), mem'), e, hp)
end
| gen(LOOKER(P.gethdlr,[],x,_,e), hp) = defBoxed(x, C.exnptr, e, hp)
| gen(LOOKER(P.getvar, [], x, _, e), hp)= defBoxed(x, C.varptr, e, hp)
| gen(LOOKER(P.deflvar, [], x, _, e), hp)= defBoxed(x, zero, e, hp)
| gen(LOOKER(P.getspecial, [v], x, _, e), hp) =
defBoxed(x, orTag(M.SRA(ity, getObjDescriptor(v),
LI (D.tagWidth-1))),
e, hp)
| gen(LOOKER(P.getpseudo, [i], x, _, e), hp) =
(print "getpseudo not implemented\n"; nop(x, i, e, hp))
| gen( LOOKER(P.rawload { kind }, [i], x, _, e), hp) =
rawload (kind, i, x, e, hp)
(*** SETTER ***)
| gen(SETTER(P.assign, [a as VAR arr, v], e), hp) =
let val ea = regbind a
val mem = arrayRegion(getRegion a)
in recordStore(ea, hp);
emit(M.STORE(ity, ea, regbind v, mem));
gen(e, hp+8)
end
| gen(SETTER(P.unboxedassign, [a, v], e), hp) =
let val mem = arrayRegion(getRegion a)
in emit(M.STORE(ity, regbind a, regbind v, mem));
gen(e, hp)
end
| gen(SETTER(P.update, [v,i,w], e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val tmpR = Cells.newReg() (* derived pointer! *)
val tmp = M.REG(ity, tmpR)
val ea = scale4(a, i) (* address of updated cell *)
val mem' = arrayRegion(mem)
in emit(M.MV(ity, tmpR, ea));
recordStore(tmp, hp);
emit(M.STORE(ity, tmp, regbind w, mem'));
gen(e, hp+8)
end
| gen(SETTER(P.boxedupdate, args, e), hp) =
gen(SETTER(P.update, args, e), hp)
| gen(SETTER(P.unboxedupdate, [v, i, w], e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val mem' = arrayRegion mem
in emit(M.STORE(ity, scale4(a, i), regbind w, mem'));
gen(e, hp)
end
| gen(SETTER(P.numupdate{kind=P.INT 8}, [s,i,v], e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind s, mem))
val ea = scale1(a, i)
val mem' = arrayRegion mem
in emit(M.STORE(8, ea, untagUnsigned(v), mem'));
gen(e, hp)
end
| gen(SETTER(P.numupdate{kind=P.FLOAT 64},[v,i,w],e), hp) =
let (* get data pointer *)
val mem = dataptrRegion v
val a = markPTR(M.LOAD(ity, regbind v, mem))
val mem' = arrayRegion mem
in emit(M.FSTORE(fty,scale8(a, i), fregbind w, mem'));
gen(e, hp)
end
| gen(SETTER(P.setspecial, [v, i], e), hp) =
let val ea = M.SUB(ity, regbind v, LI 4)
val i' =
case i
of INT k => LI(dtoi(D.makeDesc(k, D.tag_special)))
| _ => M.ORB(ity, M.SLL(ity, untagSigned(i),
LI D.tagWidth),
LI(dtoi D.desc_special))
val mem = getRegionPi(v, 0)
in emit(M.STORE(ity, ea, i', mem));
gen(e, hp)
end
| gen(SETTER(P.sethdlr,[x],e), hp) =
(emit(assign(C.exnptr, regbind x)); gen(e, hp))
| gen(SETTER(P.setvar,[x],e), hp) =
(emit(assign(C.varptr, regbind x)); gen(e, hp))
| gen(SETTER(P.uselvar,[x],e), hp) = gen(e, hp)
| gen(SETTER(P.acclink,_,e), hp) = gen(e, hp)
| gen(SETTER(P.setmark,_,e), hp) = gen(e, hp)
| gen(SETTER(P.free,[x],e), hp) = gen(e, hp)
| gen(SETTER(P.setpseudo,_,e), hp) =
(print "setpseudo not implemented\n"; gen(e, hp))
| gen (SETTER (P.rawstore { kind }, [i, x], e), hp) =
(rawstore (kind, i, x); gen (e, hp))
| gen (RCC (p, vl, w, _, e), hp) = let
val { retTy, paramTys, ... } = p
fun build_args vl = let
open CTypes
fun m ((C_float | C_double), v :: vl) =
(CCalls.FARG (fregbind v), vl)
| m ((C_unsigned (I_char | I_short | I_int | I_long) |
C_signed (I_char | I_short | I_int | I_long) |
C_PTR),
v :: vl) =
(CCalls.ARG (regbind v), vl)
| m (C_STRUCT tl, vl) = let val (al, vl') = ml (tl, vl)
in (CCalls.ARGS al, vl') end
| m (_, []) = error "RCC: not enough ML args"
| m _ = error "RCC: unexpected C-type"
and ml (tl, vl) = let
fun one (t, (ral, vl)) = let val (a, vl') = m (t, vl)
in (a :: ral, vl') end
val (ral, vl') = foldl one ([], vl) tl
in
(rev ral, vl')
end
in
case ml (paramTys, vl) of
(al, []) => al
| _ => error "RCC: too many ML args"
end
val (f, sr, a) =
case (retTy, vl) of
(CTypes.C_STRUCT _, fv :: srv :: avl) =>
let val s = regbind srv
in (regbind fv, fn _ => s, build_args avl)
end
| (_, fv :: avl) =>
(regbind fv,
fn _ => error "RCC: unexpected struct return",
build_args avl)
| _ => error "RCC: prototype/arglist mismatch"
val { callseq, result } =
CCalls.genCall
{ name = f, proto = p, structRet = sr, args = a }
in
(* just for testing... *)
print ("$$$ RCC: " ^ CProto.pshow p ^ "\n");
(* now do it! *)
app emit callseq;
case (result, retTy) of
(([] | [_]), (CTypes.C_void | CTypes.C_STRUCT _)) =>
defI31 (w, mlZero, e, hp)
| ([], _) => error "RCC: unexpectedly few results"
| ([M.FPR x], (CTypes.C_float | CTypes.C_double)) =>
treeifyDefF64 (w, x, e, hp)
| ([M.FPR _], _) => error "RCC: unexpected FP result"
| ([M.GPR x], _) => (* more sanity checking here ? *)
defI32 (w, x, e, hp)
| _ => error "RCC: unexpectedly many results"
end
(*** BRANCH ***)
| gen(BRANCH(P.cmp{oper,kind=P.INT 31},[INT v, INT k],_,e,d), hp) =
if (case oper
of P.> => v>k
| P.>= => v>=k
| P.< => v<k
| P.<= => v<=k
| P.eql => v=k
| P.neq => v<>k
(*esac*))
then gen(e, hp)
else gen(d, hp)
| gen(BRANCH(P.cmp{oper, kind=P.INT 31}, vw, _, e, d), hp) =
branch(signedCmp oper, vw, e, d, hp)
| gen(BRANCH(P.cmp{oper,kind=P.UINT 31},[INT v', INT k'],_,e,d),hp)=
let open Word
val v = fromInt v'
val k = fromInt k'
in if (case oper
of P.> => v>k
| P.>= => v>=k
| P.< => v<k
| P.<= => v<=k
| P.eql => v=k
| P.neq => v<>k
(*esac*))
then gen(e, hp)
else gen(d, hp)
end
| gen(BRANCH(P.cmp{oper, kind=P.UINT 31}, vw, _, e, d), hp) =
branch(unsignedCmp oper, vw, e, d, hp)
| gen(BRANCH(P.cmp{oper,kind=P.UINT 32},[INT32 v,INT32 k],_,e,d),
hp) =
let open Word32
in if (case oper
of P.> => v>k
| P.>= => v>=k
| P.< => v<k
| P.<= => v<=k
| P.eql => v=k
| P.neq => v<>k
(*esac*))
then gen(e, hp)
else gen(d, hp)
end
| gen(BRANCH(P.cmp{oper, kind=P.UINT 32}, vw, _, e, d), hp) =
branch(unsignedCmp oper, vw, e, d, hp)
| gen(BRANCH(P.cmp{oper, kind=P.INT 32}, vw, _, e, d), hp) =
branch(signedCmp oper, vw, e, d, hp)
| gen(BRANCH(P.fcmp{oper,size=64}, [v,w], _, d, e), hp) =
let val trueLab = Label.newLabel""
val fcond =
case oper
of P.fEQ => M.==
| P.fULG => M.?<>
| P.fUN => M.?
| P.fLEG => M.<=>
| P.fGT => M.>
| P.fGE => M.>=
| P.fUGT => M.?>
| P.fUGE => M.?>=
| P.fLT => M.<
| P.fLE => M.<=
| P.fULT => M.?<
| P.fULE => M.?<=
| P.fLG => M.<>
| P.fUE => M.?=
val cmp = M.FCMP(64, fcond, fregbind v, fregbind w)
in emit(M.BCC(cmp, trueLab));
genCont(e, hp);
genlab(trueLab, d, hp)
end
| gen(BRANCH(P.peql, vw, _,e,d), hp) = branch(M.EQ, vw, e, d, hp)
| gen(BRANCH(P.pneq, vw, _, e, d), hp) = branch(M.NE, vw, e, d, hp)
| gen(BRANCH(P.strneq, [INT n,v,w], _, d, e), hp) =
branchStreq(n,v,w,e,d,hp)
| gen(BRANCH(P.streq, [INT n,v,w],_,d,e), hp) =
branchStreq(n,v,w,d,e,hp)
| gen(BRANCH(P.boxed, [x], _, a, b), hp) = branchOnBoxed(x,a,b,hp)
| gen(BRANCH(P.unboxed, [x], _, a, b), hp) = branchOnBoxed(x,b,a,hp)
| gen(e, hp) = (PPCps.prcps e; print "\n"; error "genCluster.gen")
end (*local*)
fun fragComp() =
let fun continue() = fcomp (Frag.next())
and fcomp(NONE) = ()
| fcomp(SOME(_, Frag.KNOWNFUN _)) = continue()
| fcomp(SOME(_, Frag.KNOWNCHK _)) = continue()
| fcomp(SOME(_, Frag.STANDARD{func=ref NONE, ...})) = continue()
| fcomp(SOME(lab,
Frag.STANDARD{func as ref(SOME (zz as (k,f,vl,tl,e))),
...})) =
let val formals = ArgP.standard(typmap f, tl)
in func := NONE;
pseudoOp PseudoOp.ALIGN4;
genCPSFunction(lab, k, f, vl, formals, tl, e);
continue()
end
in fcomp (Frag.next())
end (* fragComp *)
(*
* execution starts at the first CPS function -- the frag
* is maintained as a queue.
*)
fun initFrags (start::rest : CPS.function list) =
let fun init(func as (fk, f, _, _, _)) =
addGenTbl (f, Frag.makeFrag(func, functionLabel f))
in app init rest;
init start
end
(*
* Create cluster annotations.
* Currently, we only need to enter the appropriate
* gc map information.
*)
fun clusterAnnotations() =
if gctypes then
let fun enter(M.REG(_,r),ty) = enterGC(r, ty)
| enter _ = ()
in enterGC(allocptrR, SMLGCType.ALLOCPTR);
enter(C.limitptr, SMLGCType.LIMITPTR);
enter(C.baseptr, PTR);
enter(C.stdlink, PTR);
[#create MLRiscAnnotations.PRINT_CELLINFO(GCCells.printType)
]
end
else []
in
initFrags cluster;
beginCluster 0;
fragComp();
InvokeGC.emitLongJumpsToGCInvocation stream;
endCluster(clusterAnnotations())
end (* genCluster *)
fun emitMLRiscUnit f =
(Cells.reset();
beginCluster 0;
f stream;
endCluster NO_OPT
)
in app mkGlobalTables funcs;
app genCluster (Cluster.cluster funcs);
emitMLRiscUnit InvokeGC.emitModuleGC
end (* codegen *)
end (* MLRiscGen *)
| root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
| Powered by ViewVC 1.0.0 |
