CVS: sml-dist/src/compiler/CodeGen/amd64 amd64-mltreeext.sml, NONE, 1.1 amd64CG.sml, NONE, 1.1 amd64CpsRegs.sml, NONE, 1.1 amd64MLTree.sml, NONE, 1.1 amd64MLTreeExtComp.sml, NONE, 1.1 amd64MemRegs.sml, NONE, 1.1 amd64Runtime.sml, NONE, 1.1 amd64StackSpills.sml, NONE, 1.1 amd64gen.sml, NONE, 1.1 amd64spec.sml, NONE, 1.1
Matthias Blume <[email protected]> Thu, 05 Oct 2006 09:26:31 -0700
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/compiler/CodeGen/amd64
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv30638/src/compiler/CodeGen/amd64
Added Files:
amd64-mltreeext.sml amd64CG.sml amd64CpsRegs.sml
amd64MLTree.sml amd64MLTreeExtComp.sml amd64MemRegs.sml
amd64Runtime.sml amd64StackSpills.sml amd64gen.sml
amd64spec.sml
Log Message:
merged amd64 code from Mike Rainey
--- NEW FILE: amd64-mltreeext.sml ---
structure AMD64_SMLNJMLTreeExt : SMLNJ_MLTREE_EXT =
struct
type ('s,'r,'f,'c) sx = ('s,'r,'f,'c) AMD64InstrExt.sext
type ('s,'r,'f,'c) rx = unit
type ('s,'r,'f,'c) ccx = unit
datatype ('s,'r,'f,'c) fx =
FSINE of 'f
| FCOSINE of 'f
| FTANGENT of 'f
end
--- NEW FILE: amd64CG.sml ---
(*
* AMD64 specific backend. This one uses the new RA8 scheme.
*)
local
val fast_floating_point =
MLRiscControl.mkFlag ("amd64-fast-fp",
"whether to use the fast-fp backend (amd64)")
in
functor AMD64CG (structure CCallParams: sig val frameAlign : int
val returnSmallStructsInRegs : bool
end
val abi_variant: string option) =
MachineGen
( structure I = AMD64Instr
structure C = I.C
structure F = AMD64CFG
structure R = AMD64CpsRegs
structure CG = Control.CG
structure MachSpec = AMD64Spec
val abi_variant = abi_variant
structure ClientPseudoOps = AMD64ClientPseudoOps
structure PseudoOps = AMD64PseudoOps
structure Ext = AMD64_SMLNJMLTreeExt(* amd64-specific *)
structure CpsRegs = AMD64CpsRegs
structure InsnProps = AMD64Props
structure Asm = AMD64AsmEmitter
structure Shuffle = AMD64Shuffle
val fast_floating_point = fast_floating_point
structure CCalls = UnimplementedCCallsFn
(structure T = AMD64MLTree
val impossible = ErrorMsg.impossible)
(*
structure CCalls = IA32SVID_CCalls (
structure T = AMD64MLTree
fun ix x = x
val fast_floating_point = fast_floating_point
(* NOTE: the following need to be changed for MacOS X on Intel *)
val frameAlign = CCallParams.frameAlign
val returnSmallStructsInRegs = CCallParams.returnSmallStructsInRegs)
*)
(* for the time being... *)
structure OmitFramePtr = struct
structure CFG=AMD64CFG
structure I=AMD64Instr
val vfp = CpsRegs.vfp
(* no rewriting necessary, backend uses %fp instead of %sp *)
fun omitframeptr _ = ()
end
(*
structure OmitFramePtr =
AMD64OmitFramePointer(structure I=AMD64Instr
structure MemRegs=AMD64MemRegs
structure CFG=AMD64CFG
val memRegBase = SOME(AMD64CpsRegs.vfp))
*)
val spill = CPSRegions.spill
val stack = CPSRegions.stack
fun error msg = MLRiscErrorMsg.error("AMD64CG",msg)
fun base() = (* XXXX *)
if !ClusterAnnotation.useVfp then AMD64CpsRegs.vfp else I.C.rsp
structure MLTreeComp=
AMD64(val defaultIntTy = 64
structure AMD64Instr=AMD64Instr
structure MLTreeUtils = MLTreeUtils
(structure T = AMD64MLTree
fun hashSext _ _ = 0w0
fun hashRext _ _ = 0w0
fun hashFext _ _ = 0w0
fun hashCCext _ _ = 0w0
(* Equality extensions *)
fun eqSext _ _ = false
fun eqRext _ _ = false
fun eqFext _ _ = false
fun eqCCext _ _ = false
(* Pretty printing extensions *)
fun showSext _ _ = ""
fun showRext _ _ = ""
fun showFext _ _ = ""
fun showCCext _ _ = ""
)
structure ExtensionComp = AMD64MLTreeExtComp
(structure I = AMD64Instr
structure T = AMD64MLTree
structure CFG = AMD64CFG
structure TS = AMD64MLTreeStream
val fast_fp = fast_floating_point
)
structure MLTreeStream = AMD64MLTreeStream
fun cvti2f{src,ty,an} = let
val tempMem = I.Displace{base=base(), disp=I.Immed 304, mem=stack}
in
{instrs = [I.move{mvOp=I.MOVQ, src=src, dst=tempMem}],
tempMem = tempMem,
cleanup = []
}
end
val fast_floating_point = fast_floating_point
)
structure Jumps =
AMD64Jumps(structure Instr=AMD64Instr
structure AsmEmitter=AMD64AsmEmitter
structure Eval=AMD64MLTreeEval
structure Shuffle=AMD64Shuffle
structure MCEmitter=AMD64MCEmitter)
structure BackPatch =
BackPatch(structure Jumps=Jumps
structure Emitter=AMD64MCEmitter
structure Props=InsnProps
structure CFG = AMD64CFG
structure Asm=AMD64AsmEmitter
structure CodeString=CodeString)
structure RA =
AMD64RA
(structure I = AMD64Instr
structure CB = CellsBasis
structure InsnProps = InsnProps
structure Asm = AMD64AsmEmitter
structure CFG = AMD64CFG
structure SpillHeur = ChowHennessySpillHeur
structure Spill = RASpill
(structure Asm = AMD64AsmEmitter
structure InsnProps = InsnProps
)
type spill_info = unit
fun beforeRA _ = AMD64StackSpills.init()
val fast_floating_point = fast_floating_point
val toInt32 = Int32.fromInt
fun cacheOffset r = I.Immed(toInt32(AMD64Runtime.vregStart +
Word.toIntX(Word.<<(Word.fromInt(r-8),0w2))))
fun cacheFPOffset f = I.Immed(toInt32(AMD64Runtime.vFpStart +
Word.toIntX(Word.<<(Word.fromInt(f-40),0w3))))
datatype raPhase = SPILL_PROPAGATION | SPILL_COLORING
datatype spillOperandKind = SPILL_LOC | CONST_VAL
structure Int =
struct
val avail = R.availR
val dedicated = R.dedicatedR
val memRegs = []
val phases = [SPILL_PROPAGATION,SPILL_COLORING]
(* We try to make unused memregs available for spilling
* This is necessary because of the stupid SML code generator
* doesn't keep track of which are being used.
*)
fun spillInit(RAGraph.GRAPH{nodes, ...}) =
let val lookup = IntHashTable.lookup nodes
fun find(r, free) =
if r >= 10 then (* note, %8 and %9 are reserved! *)
let val free =
case lookup r of
RAGraph.NODE{uses=ref [], defs=ref [], ...} =>
cacheOffset r::free
| _ => free
in find(r-1, free) end
else
free
val free = find(31 (* AMD64Runtime.numVregs+8-1 *), [])
in (*AMD64StackSpills.setAvailableOffsets free*) ()
end
val getRegLoc' = AMD64StackSpills.getRegLoc
fun spillLoc{info, an, cell, id} =
{opnd=I.Displace{base=base(), disp=getRegLoc' id, mem=spill},
kind=SPILL_LOC
}
end
structure Float =
struct
val avail = R.availF
val dedicated = R.dedicatedF
val memRegs = []
val phases = [SPILL_PROPAGATION]
fun spillInit(RAGraph.GRAPH{nodes, ...}) =
if !fast_floating_point then
let val lookup = IntHashTable.lookup nodes
fun find(r, free) =
if r >= 32+8 then
let val free =
case lookup r of
RAGraph.NODE{uses=ref [], defs=ref [],...} =>
cacheFPOffset r::free
| _ => free
in find(r-1, free) end
else
free
val free = find(63, [])
in AMD64StackSpills.setAvailableFPOffsets free
end
else ()
fun spillLoc(S, an, loc) =
I.Displace{base=base(), disp=AMD64StackSpills.getFregLoc loc, mem=spill}
val fastMemRegs = C.Regs CB.FP {from=8, to=31, step=1}
val fastPhases = [SPILL_PROPAGATION,SPILL_COLORING]
end
) (* AMD64RA *)
) (* AMD64CG *)
end
--- NEW FILE: amd64CpsRegs.sml ---
(* AMD64CpsRegs.sml --- CPS registers used on the Intel AMD64
*
* COPYRIGHT (c) 1997 Bell Laboratories.
*
*)
signature AMD64CPSREGS = sig
include CPSREGS
end
structure AMD64CpsRegs : CPSREGS = struct
structure T = AMD64MLTree
structure C = AMD64Cells
fun upto(from, to) = if from>to then [] else from::(upto (from+1,to))
infix upto
val GP = C.GPReg
val FP = C.FPReg
val rax = T.REG(32, C.rax) val rsp = T.REG(32, C.rsp)
val rcx = T.REG(32, C.rcx) val rbp = T.REG(32, C.rbp)
val rdx = T.REG(32, C.rdx) val rsi = T.REG(32, C.rsi)
val rbx = T.REG(32, C.rbx) val rdi = T.REG(32, C.rdi)
val vfp = C.newDedicatedCell CellsBasis.GP ()
val vfptr = T.REG(64, vfp)
fun frameptr which = if which then vfptr else rsp
fun regInMem(which, i) = let
val fp = frameptr which
in T.LOAD(64, T.ADD(64, fp, T.LI(T.I.fromInt(32, i))), CPSRegions.memory)
end
val allocptr = rdi
val stackptr = rsp
fun stdarg _ = rbp
fun stdcont _ = rsi
fun limitptr vfp = regInMem(vfp, 12)
fun baseptr vfp = regInMem(vfp, 4)
fun exnptr vfp = regInMem(vfp, 8)
fun gcLink vfp = regInMem(vfp, 16)
fun storeptr vfp = regInMem(vfp, 24)
fun varptr vfp = regInMem(vfp, 28)
fun stdlink _ = T.REG(64, GP 8)
fun stdclos _ = T.REG(64, GP 9)
fun mkRegList(n, 0) = []
| mkRegList(n, cnt) = T.REG(64, GP n)::mkRegList(n+1, cnt-1)
(* miscregs = {rbx,rcx,rdx,r10,r11,...r15} *)
val miscregs =
rbx::rcx::rdx::mkRegList(10, 16)
val calleesave = Array.fromList miscregs
val exhausted = NONE
val floatregs = map (fn f => T.FREG(64,FP f)) (8 upto 31)
val savedfpregs = []
local
fun unREG (T.REG (_, r)) = r
| unREG _ = raise Fail "amd64CpsRegs:unREG"
in
val availR = map GP (10 upto 15) @ (map unREG [rbp, rsi, rbx, rcx, rdx, rax])
val dedicatedR = GP 8 :: GP 9 :: (map unREG [rdi, rsp, vfptr])
val availF = map FP (8 upto 31)
val dedicatedF = [] (* map FP [0,1,2,3,4,5,6,7] *)
val signedGCTest = false
val addressWidth = 64
val ccallCallerSaveR = [unREG rdi]
val ccallCallerSaveF = []
end (*local*)
end
--- NEW FILE: amd64MLTree.sml ---
(* MLTree specialization *)
structure AMD64MLTree =
MLTreeF(structure Constant = SMLNJConstant
structure Region=CPSRegions
structure Extension=AMD64_SMLNJMLTreeExt)
structure AMD64MLTreeEval =
MLTreeEval
(structure T = AMD64MLTree
fun eq _ _ = false
val eqRext = eq val eqFext = eq
val eqCCext = eq val eqSext = eq)
structure AMD64MLTreeHash =
MLTreeHash
(structure T = AMD64MLTree
fun h _ _ = 0w0
val hashRext = h val hashFext = h
val hashCCext = h val hashSext = h)
structure AMD64GasPseudoOps =
AMD64GasPseudoOps(structure T=AMD64MLTree
structure MLTreeEval=AMD64MLTreeEval)
structure AMD64ClientPseudoOps =
SMLNJPseudoOps(structure Asm=AMD64GasPseudoOps)
structure AMD64PseudoOps = PseudoOps(structure Client = AMD64ClientPseudoOps)
structure AMD64Stream = InstructionStream(AMD64PseudoOps)
structure AMD64MLTreeStream =
MLTreeStream
(structure T = AMD64MLTree
structure S = AMD64Stream)
(* specialised AMD64 instruction set *)
structure AMD64Instr = AMD64Instr(AMD64MLTree)
structure AMD64MemRegs = AMD64MemRegs(AMD64Instr)
structure AMD64Props =
AMD64Props
(structure Instr=AMD64Instr
structure MLTreeHash = AMD64MLTreeHash
structure MLTreeEval = AMD64MLTreeEval)
structure AMD64Rewrite = AMD64Rewrite(AMD64Instr)
structure AMD64Shuffle = AMD64Shuffle(AMD64Instr)
(* Assembly code emmitter *)
structure AMD64AsmEmitter=
AMD64AsmEmitter(structure Instr=AMD64Instr
structure Shuffle=AMD64Shuffle
structure MemRegs=AMD64MemRegs
structure MLTreeEval=AMD64MLTreeEval
structure S = AMD64Stream
val memRegBase=SOME(AMD64Instr.C.rsp))
(* Machine code emitter *)
structure AMD64MCEmitter =
AMD64MCEmitter(structure Instr=AMD64Instr
structure Shuffle=AMD64Shuffle
structure AsmEmitter=AMD64AsmEmitter
structure MemRegs=AMD64MemRegs
structure MLTreeEval=AMD64MLTreeEval
val memRegBase=SOME(AMD64Instr.C.rsp))
(* Flowgraph data structure specialized to AMD64 instructions *)
structure AMD64CFG =
ControlFlowGraph
(structure I = AMD64Instr
structure PseudoOps = AMD64PseudoOps
structure GraphImpl = DirectedGraph
structure InsnProps = AMD64Props
structure Asm = AMD64AsmEmitter)
--- NEW FILE: amd64MLTreeExtComp.sml ---
functor AMD64MLTreeExtComp
( structure T : MLTREE where Extension = AMD64_SMLNJMLTreeExt
structure I : AMD64INSTR where T = T
structure TS : MLTREE_STREAM
where T = T
structure CFG : CONTROL_FLOW_GRAPH
where I=I
and P = TS.S.P
val fast_fp : bool ref
) : MLTREE_EXTENSION_COMP =
struct
structure T = T
structure I = I
structure C = I.C
structure CB = CellsBasis
structure Ext = AMD64_SMLNJMLTreeExt
structure CFG = CFG
structure TS = TS
structure AMD64CompInstrExt =
AMD64CompInstrExt
(structure I=I
structure TS = TS
structure CFG = CFG)
type reducer =
(I.instruction,C.cellset,I.operand,I.addressing_mode,CFG.cfg) TS.reducer
fun unimplemented _ = MLRiscErrorMsg.impossible "AMD64MLTreeExtComp"
val compileSext = AMD64CompInstrExt.compileSext
val compileRext = unimplemented
val compileCCext = unimplemented
fun compileFext (TS.REDUCER{reduceFexp, emit, ...}:reducer) = let
fun comp{e=(64, fexp), fd:CB.cell, an:T.an list} = let
fun trig(f, foper) =
(reduceFexp f; emit(I.funary foper, an))
in
case fexp
of Ext.FSINE f => trig(f, I.FSIN)
| Ext.FCOSINE f => trig(f, I.FCOS)
| Ext.FTANGENT f =>
(trig(f, I.FPTAN);
emit(I.fstpl(I.ST(C.ST 0)), [])
)
end
| comp _ = MLRiscErrorMsg.impossible "compileFext"
fun fastComp{e=(64, fexp), fd:CB.cell, an:T.an list} =
let fun Freg f = let val fx = CB.registerNum f
in if fx >= 8 andalso fx < 32 (* hardwired! *)
then I.FDirect f else I.FPR f
end
val (unOp, f) =
case fexp of
Ext.FSINE f => (I.FSIN, f)
| Ext.FCOSINE f => (I.FCOS, f)
| Ext.FTANGENT f => (I.FPTAN, f)
in emit(I.funop{fsize=I.FP64,
unOp=unOp,src=Freg(reduceFexp f),dst=Freg fd}, an)
end
| fastComp _ = MLRiscErrorMsg.impossible "compileFext"
in if !fast_fp then fastComp else comp
end
end
--- NEW FILE: amd64MemRegs.sml ---
functor AMD64MemRegs(AMD64Instr:AMD64INSTR) = struct
structure I = AMD64Instr
fun memReg{reg, base} = raise Fail "AMD64: memReg not yet implemented"
end
--- NEW FILE: amd64Runtime.sml ---
structure AMD64Runtime = struct
(* stack offsets *)
val vFpStart = 184 (* floating point registers *)
val vregStart = 72 (* virtual regs *)
val regStart = 40 (* area for physcial registers *)
val spillStart = AMD64Spec.initialSpillOffset (* spill area *)
val spillAreaSz = AMD64Spec.spillAreaSz
val fpTempMemOff = 376 : Int32.int
end
--- NEW FILE: amd64StackSpills.sml ---
signature AMD64STACKSPILLS = sig
structure I : AMD64INSTR
val init : unit -> unit
(* FIXME: this should be removed *)
val setAvailableOffsets : I.operand list -> unit
val setAvailableFPOffsets : I.operand list -> unit
val getRegLoc : int -> I.operand
val getFregLoc : int -> I.operand
end
structure AMD64StackSpills : AMD64STACKSPILLS =
struct
exception RegSpills
structure I = AMD64Instr
fun error msg = ErrorMsg.impossible ("AMD64StackSpills." ^ msg)
val initialSpillOffset = AMD64Runtime.spillStart
val spillOffset = ref initialSpillOffset
val spillAreaSz = AMD64Runtime.spillAreaSz
val availableOffsets = ref [] : I.operand list ref
val availableFPOffsets = ref [] : I.operand list ref
(* Indicate that some memory registers are not used and
* can be used for spilling.
*)
fun setAvailableOffsets offsets = availableOffsets := offsets
fun setAvailableFPOffsets offsets = availableFPOffsets := offsets
fun newOffset n =
if (n > spillAreaSz) then error "newOffset - spill area is too small"
else spillOffset := n
val spillTbl : I.operand IntHashTable.hash_table =
IntHashTable.mkTable(0, RegSpills)
val lookupTbl = IntHashTable.lookup spillTbl
val addTbl = IntHashTable.insert spillTbl
fun init () =
(spillOffset:=initialSpillOffset;
availableOffsets := [];
availableFPOffsets := [];
IntHashTable.clear spillTbl
)
val toInt32 = Int32.fromInt
fun getRegLoc reg =
lookupTbl reg
handle _ =>
let val operand =
case !availableOffsets of
[] => let val offset = !spillOffset
val i32 = toInt32 offset
in newOffset(offset+4); I.Immed i32 end
| off::offs => (availableOffsets := offs; off)
in addTbl (reg,operand);
operand
end
fun getFregLoc freg =
lookupTbl freg
handle _ =>
let val operand =
case !availableFPOffsets of
[] =>
let val offset = !spillOffset
val fromInt = Word.fromInt
val aligned = Word.toIntX(Word.andb(fromInt offset+0w7, fromInt ~8))
in newOffset(aligned+8); I.Immed(toInt32 aligned)
end
| off::offs => (availableFPOffsets := offs; off)
in addTbl (freg, operand);
operand
end
end
--- NEW FILE: amd64gen.sml ---
(* amd64gen.sml
*
* Copyright (c) 2006 by The Fellowship of SML/NJ
*)
functor AMD64MC (structure CCallParams : sig val frameAlign : int
val returnSmallStructsInRegs : bool
end
val abi_variant: string option) =
FLINTComp(
structure Gen=AMD64CG (structure CCallParams = CCallParams
val abi_variant = abi_variant)
fun collect epthunk = (Gen.finish ();
CodeString.getCodeString (epthunk ())))
--- NEW FILE: amd64spec.sml ---
structure AMD64Spec : MACH_SPEC =
struct
open DefaultMachSpec
val architecture = "amd64"
val bigEndian = false
val spillAreaSz = 8192
val initialSpillOffset = 512
val numRegs = length AMD64CpsRegs.availR (* can be |AMD64CpsRegs.availR|= + |vregs|=0 *)
val numFloatRegs = 21 (* can be |8 upto 31| *)
val numFloatCalleeSaves = 0
val startgcOffset = 32
val pseudoRegOffset = 136
val constBaseRegOffset = 0
(* probably should be true *)
val fixedArgPassing = false
val ML_STATE_OFFSET = 176
val VProcOffMSP = 4
val InMLOffVSP = 8
val LimitPtrMaskOffVSP = 200
end
-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys -- and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV