[MLton-devel] cvs commit: int64 support in x86-codegen
Matthew Fluet
fluet@users.sourceforge.net
Thu, 31 Jul 2003 16:10:33 -0700
fluet 03/07/31 16:10:33
Modified: include x86-main.h
mlton/backend ssa-to-rssa.fun
mlton/codegen/x86-codegen x86-allocate-registers.fun
x86-generate-transfers.fun x86-live-transfers.fun
x86-mlton-basic.fun x86-mlton-basic.sig
x86-mlton.fun x86-mlton.sig x86-pseudo.sig
x86-translate.fun x86.fun x86.sig
Log:
This commit adds support for int64 types in the x86-codgen,
using the _import functions used by the C codegen.
I modified the ssaToRssa pass to do two things:
1) convert Prim.Int_equal IntSize.I64 to a CFunction call,
(similar to the way Prim.IntInf_equal is converted)
2) unroll swtiches on int64's into if-then-else cascades,
using the CFunction for comparisons.
Revision Changes Path
1.8 +2 -0 mlton/include/x86-main.h
Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- x86-main.h 25 Jul 2003 20:14:46 -0000 1.7
+++ x86-main.h 31 Jul 2003 23:10:32 -0000 1.8
@@ -9,6 +9,8 @@
word cReturnTemp[16];
word c_stackP;
word divTemp;
+word eq1Temp;
+word eq2Temp;
word fileTemp;
word fildTemp;
word fpswTemp;
1.43 +58 -1 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- ssa-to-rssa.fun 19 Jul 2003 01:23:26 -0000 1.42
+++ ssa-to-rssa.fun 31 Jul 2003 23:10:32 -0000 1.43
@@ -34,6 +34,7 @@
open CType
in
val Int32 = Int I32
+ val Int64 = Int I64
val Word32 = Word W32
end
@@ -119,6 +120,14 @@
val intInfEqual = make "IntInf_equal"
end
+ local
+ fun make name = vanilla {args = Vector.new2 (Int64, Int64),
+ name = name,
+ return = SOME CType.defaultInt}
+ in
+ val int64Equal = make "Int64_equal"
+ end
+
val getPointer =
vanilla {args = Vector.new1 Int32,
name = "MLton_FFI_getPointer",
@@ -616,7 +625,51 @@
testRep = tyconRep tycon}
else Error.bug "strange type in case"
end)
- | S.Cases.Int (s, cs) => simple (s, cs, Switch.Int, id, IntX.<=)
+ | S.Cases.Int (s, cs) =>
+ if s = IntSize.I64 andalso !Control.Native.native
+ then let
+ val defaultLabel =
+ case default of
+ SOME default => default
+ | NONE => Error.bug "case has no default"
+ val firstLabel =
+ Vector.foldr
+ (cs, defaultLabel, fn ((i, l), nextLabel) =>
+ let
+ val b = (Var.newNoname (), Type.bool)
+ val transfer =
+ Transfer.ifInt
+ (Operand.Var {var = #1 b, ty = #2 b},
+ {truee = l, falsee = nextLabel})
+ val return =
+ newBlock
+ {args = Vector.new1 b,
+ kind = Kind.CReturn {func = CFunction.int64Equal},
+ statements = Vector.new0 (),
+ transfer = transfer}
+ val args =
+ Vector.new2
+ (Operand.Var {var = test,
+ ty = Type.int IntSize.I64},
+ Operand.Const (Const.int i))
+ val transfer =
+ Transfer.CCall
+ {args = args,
+ func = CFunction.int64Equal,
+ return = SOME return}
+ val label =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.Jump,
+ statements = Vector.new0 (),
+ transfer = transfer}
+ in
+ label
+ end)
+ in
+ ([], Transfer.Goto {args = Vector.new0 (), dst = firstLabel})
+ end
+ else simple (s, cs, Switch.Int, id, IntX.<=)
| S.Cases.Word (s, cs) => simple (s, cs, Switch.Word, id, WordX.<=)
end
val {get = labelInfo: (Label.t ->
@@ -1157,6 +1210,10 @@
| GC_unpack =>
ccall {args = Vector.new1 Operand.GCState,
func = CFunction.unpack}
+ | Int_equal s =>
+ if s = IntSize.I64 andalso !Control.Native.native
+ then simpleCCall CFunction.int64Equal
+ else normal ()
| IntInf_add => simpleCCall CFunction.intInfAdd
| IntInf_andb => simpleCCall CFunction.intInfAndb
| IntInf_arshift =>
1.31 +66 -11 mlton/mlton/codegen/x86-codegen/x86-allocate-registers.fun
Index: x86-allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-allocate-registers.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- x86-allocate-registers.fun 25 Jul 2003 20:14:46 -0000 1.30
+++ x86-allocate-registers.fun 31 Jul 2003 23:10:33 -0000 1.31
@@ -529,10 +529,8 @@
andalso
(Size.class (MemLoc.size memloc) <> Size.INT)))::
future
- | Directive.Return {memloc}
- => (M (FDEF, memloc))::future
- | Directive.FltReturn {memloc}
- => (M (FDEF, memloc))::future
+ | Directive.Return {returns}
+ => (List.map(returns, fn {dst, ...} => M (FDEF, dst))) @ future
| Directive.ClearFlt
=> (MP (FMREMOVEP,
fn memloc
@@ -6020,6 +6018,67 @@
registerAllocation = registerAllocation}
end
+ fun return {returns: {src: Operand.t, dst: MemLoc.t} list,
+ info: Liveness.t,
+ registerAllocation: t} =
+ let
+ val killed_values =
+ valueFilter {filter = fn value as {memloc, ...} =>
+ List.exists
+ (returns, fn {dst = return_memloc, ...} =>
+ List.exists(MemLoc.utilized memloc,
+ fn memloc' =>
+ MemLoc.eq(memloc', return_memloc))
+ orelse
+ MemLoc.mayAlias(return_memloc, memloc)),
+ registerAllocation = registerAllocation}
+ val killed_memlocs = List.revMap(killed_values, #memloc)
+
+ val registerAllocation =
+ removes {memlocs = killed_memlocs,
+ registerAllocation = registerAllocation}
+
+ val registerAllocation =
+ List.fold
+ (returns, registerAllocation, fn ({src = operand,
+ dst = return_memloc}, registerAllocation) =>
+ case operand of
+ Operand.Register return_register =>
+ update {value = {register = return_register,
+ memloc = return_memloc,
+ weight = 1024,
+ sync = false,
+ commit = NO},
+ registerAllocation = registerAllocation}
+ | Operand.FltRegister return_register =>
+ #registerAllocation
+ (fltpush {value = {fltregister = return_register,
+ memloc = return_memloc,
+ weight = 1024,
+ sync = false,
+ commit = NO},
+ registerAllocation = registerAllocation})
+ | _ => Error.bug "return")
+
+ val (final_defs, defs) =
+ List.fold
+ (returns, ([],[]), fn ({src,dst},(final_defs,defs)) =>
+ (src::final_defs,(Operand.memloc dst)::defs))
+ val {assembly = assembly_post,
+ registerAllocation}
+ = post {uses = [],
+ final_uses = [],
+ defs = defs,
+ final_defs = final_defs,
+ kills = [],
+ info = info,
+ registerAllocation = registerAllocation}
+ in
+ {assembly = assembly_post,
+ registerAllocation = registerAllocation}
+ end
+
+(*
fun return {memloc = return_memloc,
info: Liveness.t,
registerAllocation: t}
@@ -6095,6 +6154,7 @@
{assembly = assembly_post,
registerAllocation = registerAllocation}
end
+*)
fun clearflt {info: Liveness.t,
registerAllocation: t}
@@ -10709,16 +10769,11 @@
=> RegisterAllocation.ccall
{info = info,
registerAllocation = registerAllocation}
- | Return {memloc}
+ | Return {returns}
=> RegisterAllocation.return
- {memloc = memloc,
+ {returns = returns,
info = info,
registerAllocation = registerAllocation}
- | FltReturn {memloc}
- => RegisterAllocation.fltreturn
- {memloc = memloc,
- info = info,
- registerAllocation = registerAllocation}
| Reserve {registers}
=> RegisterAllocation.reserve
{registers = registers,
1.44 +38 -39 mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun
Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- x86-generate-transfers.fun 25 Jul 2003 20:14:47 -0000 1.43
+++ x86-generate-transfers.fun 31 Jul 2003 23:10:33 -0000 1.44
@@ -506,30 +506,35 @@
= case entry
of Jump {label}
=> near label
- | CReturn {dst, frameInfo, func, label}
+ | CReturn {dsts, frameInfo, func, label}
=> let
- fun getReturn ()
- = case dst
- of NONE => AppendList.empty
- | SOME (dst, dstsize)
- => (case Size.class dstsize
- of Size.INT
- => AppendList.single
- (x86.Assembly.instruction_mov
- {dst = dst,
- src = Operand.memloc
- (MemLoc.cReturnTempContent
- dstsize),
- size = dstsize})
- | Size.FLT
- => AppendList.single
- (x86.Assembly.instruction_pfmov
- {dst = dst,
- src = Operand.memloc
- (MemLoc.cReturnTempContent
- dstsize),
- size = dstsize})
- | _ => Error.bug "CReturn")
+ fun getReturn () =
+ if Vector.length dsts = 0
+ then AppendList.empty
+ else let
+ val srcs =
+ case CFunction.return func of
+ NONE => Vector.new0 ()
+ | SOME ty =>
+ (Vector.fromList o List.map)
+ (Operand.cReturnTemps ty,
+ fn {src, dst} => dst)
+ in
+ (AppendList.fromList o Vector.fold2)
+ (dsts, srcs, [], fn ((dst,dstsize),src,stmts) =>
+ case Size.class dstsize of
+ Size.INT =>
+ (x86.Assembly.instruction_mov
+ {dst = dst,
+ src = Operand.memloc src,
+ size = dstsize})::stmts
+ | Size.FLT =>
+ (x86.Assembly.instruction_pfmov
+ {dst = dst,
+ src = Operand.memloc src,
+ size = dstsize})::stmts
+ | _ => Error.bug "CReturn")
+ end
in
case frameInfo of
SOME fi =>
@@ -1073,12 +1078,13 @@
{target = x86MLton.gcState_stackTopMinusWordDerefOperand (),
absolute = true})))
end
- | CCall {args, dstsize, frameInfo, func, return, target}
+ | CCall {args, frameInfo, func, return, target}
=> let
val CFunction.T {convention,
maySwitchThreads,
modifiesFrontier,
- modifiesStackTop, ...} = func
+ modifiesStackTop,
+ return = returnTy, ...} = func
val stackTopMinusWordDeref
= x86MLton.gcState_stackTopMinusWordDerefOperand ()
val {dead, ...}
@@ -1284,20 +1290,13 @@
s
end,
dead_classes = ccallflushClasses})
- val getResult
- = case dstsize
- of NONE => AppendList.empty
- | SOME dstsize
- => (case Size.class dstsize
- of Size.INT
- => AppendList.single
- (Assembly.directive_return
- {memloc = MemLoc.cReturnTempContent dstsize})
- | Size.FLT
- => AppendList.single
- (Assembly.directive_fltreturn
- {memloc = MemLoc.cReturnTempContent dstsize})
- | _ => Error.bug "CCall")
+ val getResult =
+ case returnTy of
+ NONE => AppendList.empty
+ | SOME ty =>
+ AppendList.single
+ (Assembly.directive_return
+ {returns = Operand.cReturnTemps ty})
val fixCStack =
if size_args > 0
andalso convention = CFunction.Convention.Cdecl
1.14 +15 -19 mlton/mlton/codegen/x86-codegen/x86-live-transfers.fun
Index: x86-live-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-live-transfers.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- x86-live-transfers.fun 25 Jul 2003 20:14:47 -0000 1.13
+++ x86-live-transfers.fun 31 Jul 2003 23:10:33 -0000 1.14
@@ -861,24 +861,20 @@
liveFltRegsTransfers)}
fun doit'' label = enque {label = label,
hints = ([],[])}
- fun doit''' dstsize label
+ fun doit''' func label
= enque {label = label,
- hints = case dstsize
- of NONE => ([],[])
- | SOME dstsize
- => (case Size.class dstsize
- of Size.INT
- => ([(MemLoc.cReturnTempContent
- dstsize,
- Register.return dstsize,
- ref true)],
- [])
- | Size.FLT
- => ([],
- [(MemLoc.cReturnTempContent
- dstsize,
- ref true)])
- | _ => Error.bug "CCall")}
+ hints = case CFunction.return func of
+ NONE => ([],[])
+ | SOME ty =>
+ List.fold
+ (Operand.cReturnTemps ty,
+ ([],[]), fn ({src, dst}, (regHints, fltregHints)) =>
+ case src of
+ Operand.Register reg =>
+ ((dst, reg, ref true)::regHints, fltregHints)
+ | Operand.FltRegister reg =>
+ (regHints, (dst, ref true)::fltregHints)
+ | _ => (regHints, fltregHints))}
datatype z = datatype Transfer.t
in
case transfer
@@ -901,10 +897,10 @@
=> ()
| Raise {...}
=> ()
- | CCall {dstsize, func, return, ...}
+ | CCall {func, return, ...}
=> if CFunction.maySwitchThreads func
then Option.app (return, doit'')
- else Option.app (return, doit''' dstsize)
+ else Option.app (return, doit''' func)
end
end
1.22 +17 -39 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86-mlton-basic.fun 25 Jul 2003 20:14:47 -0000 1.21
+++ x86-mlton-basic.fun 31 Jul 2003 23:10:33 -0000 1.22
@@ -36,44 +36,6 @@
val normalHeaderBytes = Runtime.normalHeaderSize
val arrayHeaderBytes = Runtime.arrayHeaderSize
val intInfOverheadBytes = Runtime.intInfOverheadSize
-
- local
- datatype z = datatype CType.t
- datatype z = datatype x86.Size.t
- in
- fun toX86Size' t =
- case t of
- Int s =>
- let
- datatype z = datatype IntSize.t
- in
- case s of
- I8 => BYTE
- | I16 => WORD
- | I32 => LONG
- | I64 => Error.bug "FIXME"
- end
- | Pointer => LONG
- | Real s =>
- let
- datatype z = datatype RealSize.t
- in
- case s of
- R32 => SNGL
- | R64 => DBLE
- end
- | Word s =>
- let
- datatype z = datatype WordSize.t
- in
- case s of
- W8 => BYTE
- | W16 => WORD
- | W32 => LONG
- end
- val toX86Size = toX86Size'
- fun toX86Scale t = x86.Scale.fromBytes (CType.size t)
- end
(*
* Memory classes
@@ -327,6 +289,22 @@
val fildTempContentsOperand
= Operand.memloc fildTempContents
+ val eq1Temp = Label.fromString "eq1Temp"
+ val eq1TempContents
+ = makeContents {base = Immediate.label eq1Temp,
+ size = wordSize,
+ class = Classes.StaticTemp}
+ val eq1TempContentsOperand
+ = Operand.memloc eq1TempContents
+ val eq2Temp = Label.fromString "eq2Temp"
+ val eq2TempContents
+ = makeContents {base = Immediate.label eq2Temp,
+ size = wordSize,
+ class = Classes.StaticTemp}
+ val eq2TempContentsOperand
+ = Operand.memloc eq2TempContents
+
+
local
val localI_base =
IntSize.memoize
@@ -510,7 +488,7 @@
fun gcState_offset {offset, ty} =
let
val (_,_,operand) =
- make' (offset, toX86Size ty, Classes.GCState)
+ make' (offset, Vector.sub(x86.Size.fromCType ty, 0), Classes.GCState)
in
operand ()
end
1.27 +2 -3 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- x86-mlton-basic.sig 25 Jul 2003 20:14:47 -0000 1.26
+++ x86-mlton-basic.sig 31 Jul 2003 23:10:33 -0000 1.27
@@ -37,9 +37,6 @@
val arrayHeaderBytes : int
val intInfOverheadBytes : int
- val toX86Size : x86.CFunction.CType.t -> x86.Size.t
- val toX86Scale : x86.CFunction.CType.t -> x86.Scale.t
-
(*
* Memory classes
*)
@@ -88,6 +85,8 @@
val fildTempContentsOperand : x86.Operand.t
val fpswTempContentsOperand : x86.Operand.t
val statusTempContentsOperand : x86.Operand.t
+ val eq1TempContentsOperand : x86.Operand.t
+ val eq2TempContentsOperand : x86.Operand.t
(* Static arrays defined in main.h and x86-main.h *)
val local_base : x86.CFunction.CType.t -> x86.Label.t
1.49 +96 -75 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- x86-mlton.fun 31 Jul 2003 20:32:59 -0000 1.48
+++ x86-mlton.fun 31 Jul 2003 23:10:33 -0000 1.49
@@ -30,16 +30,18 @@
fun prim {prim : Prim.t,
args : (Operand.t * Size.t) vector,
- dst : (Operand.t * Size.t) option,
+ dsts : (Operand.t * Size.t) vector,
transInfo as {live, liveInfo, ...} : transInfo}
= let
val primName = Prim.toString prim
datatype z = datatype Prim.Name.t
- fun getDst ()
- = case dst
- of SOME dst => dst
- | NONE => Error.bug "applyPrim: getDst"
+ fun getDst1 ()
+ = Vector.sub (dsts, 0)
+ handle _ => Error.bug "applyPrim: getDst1"
+ fun getDst2 ()
+ = (Vector.sub (dsts, 0), Vector.sub (dsts, 1))
+ handle _ => Error.bug "applyPrim: getDst2"
fun getSrc1 ()
= Vector.sub (args, 0)
handle _ => Error.bug "applyPrim: getSrc1"
@@ -49,6 +51,10 @@
fun getSrc3 ()
= (Vector.sub (args, 0), Vector.sub (args, 1), Vector.sub (args, 2))
handle _ => Error.bug "applyPrim: getSrc3"
+ fun getSrc4 ()
+ = (Vector.sub (args, 0), Vector.sub (args, 1),
+ Vector.sub (args, 2), Vector.sub (args, 3))
+ handle _ => Error.bug "applyPrim: getSrc4"
fun unimplemented s
= AppendList.fromList
@@ -59,7 +65,7 @@
fun mov ()
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -79,7 +85,7 @@
fun movx oper
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -101,7 +107,7 @@
fun xvom ()
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -124,7 +130,7 @@
= let
val ((src1,src1size),
(src2,src2size)) = getSrc2 ()
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val _
= Assert.assert
("applyPrim: binal, dstsize/src1size/src2size",
@@ -174,7 +180,7 @@
= let
val ((src1,src1size),
(src2,src2size)) = getSrc2 ()
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val _
= Assert.assert
("applyPrim: pmd, dstsize/src1size/src2size",
@@ -218,7 +224,7 @@
= let
val ((src1,src1size),
(src2,src2size)) = getSrc2 ()
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val _
= Assert.assert
("applyPrim: pmd, dstsize/src1size/src2size",
@@ -256,7 +262,7 @@
fun unal oper
= let
val (src,srcsize) = getSrc1 ()
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val _
= Assert.assert
("applyPrim: unal, dstsize/srcsize",
@@ -279,7 +285,7 @@
fun sral oper
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size)) = getSrc2 ()
val _
@@ -309,7 +315,7 @@
fun cmp condition
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size)) = getSrc2 ()
val _
@@ -356,7 +362,7 @@
fun test condition
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size)) = getSrc2 ()
val _
@@ -403,7 +409,7 @@
fun fbina oper
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size)) = getSrc2 ()
val _
@@ -442,7 +448,7 @@
fun fbina_fmul oper
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size),
(src3,src3size)) = getSrc3 ()
@@ -476,7 +482,7 @@
fun funa oper
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -500,7 +506,7 @@
fun flogarithm oper
= let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -551,7 +557,7 @@
(case Prim.name prim of
Cpointer_isNull
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
in
AppendList.fromList
@@ -570,7 +576,7 @@
end
| FFI_Symbol {name, ...}
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val memloc
= x86.MemLoc.makeContents
{base = Immediate.label (Label.fromString name),
@@ -683,7 +689,7 @@
=> let
fun default () =
let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
in
AppendList.fromList
@@ -699,7 +705,7 @@
end
fun default' () =
let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val (tmp,tmpsize) =
(fildTempContentsOperand, Size.WORD)
@@ -749,7 +755,7 @@
| MLton_eq => cmp Instruction.E
| Real_Math_acos _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -802,7 +808,7 @@
end
| Real_Math_asin _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -851,7 +857,7 @@
end
| Real_Math_atan _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -882,7 +888,7 @@
end
| Real_Math_atan2 _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size))= getSrc2 ()
val _
@@ -909,7 +915,7 @@
| Real_Math_cos _ => funa Instruction.FCOS
| Real_Math_exp _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -971,7 +977,7 @@
| Real_Math_sqrt _ => funa Instruction.FSQRT
| Real_Math_tan _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val _
= Assert.assert
@@ -999,7 +1005,7 @@
| Real_div _ => fbina Instruction.FDIV
| Real_lt _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size))= getSrc2 ()
val _
@@ -1030,7 +1036,7 @@
end
| Real_le _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size))= getSrc2 ()
val _
@@ -1061,7 +1067,7 @@
end
| Real_equal _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size))= getSrc2 ()
val _
@@ -1097,7 +1103,7 @@
end
| Real_gt _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size))= getSrc2 ()
val _
@@ -1128,7 +1134,7 @@
end
| Real_ge _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size))= getSrc2 ()
val _
@@ -1159,7 +1165,7 @@
end
| Real_qequal _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size))= getSrc2 ()
val _
@@ -1193,7 +1199,7 @@
=> let
fun default () =
let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
in
AppendList.fromList
@@ -1209,7 +1215,7 @@
end
fun default' () =
let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
val (tmp,tmpsize) =
(fildTempContentsOperand, Size.WORD)
@@ -1243,7 +1249,7 @@
end
| Real_toReal (s, s')
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val (src,srcsize) = getSrc1 ()
fun mov () =
AppendList.fromList
@@ -1286,7 +1292,7 @@
end
| Real_ldexp _
=> let
- val (dst,dstsize) = getDst ()
+ val (dst,dstsize) = getDst1 ()
val ((src1,src1size),
(src2,src2size)) = getSrc2 ()
val _
@@ -1403,7 +1409,7 @@
return: x86.Label.t option,
transInfo: transInfo}
= let
- val CFunction.T {convention, name, return = returnTy, ...} = func
+ val CFunction.T {convention, name, ...} = func
val name =
if convention = CFunction.Convention.Stdcall
then
@@ -1415,7 +1421,6 @@
concat [name, "@", Int.toString argsSize]
end
else name
- val dstsize = Option.map (returnTy, toX86Size)
val comment_begin
= if !Control.Native.commented > 0
then AppendList.single (x86.Block.mkBlock'
@@ -1434,24 +1439,19 @@
statements = [],
transfer = SOME (Transfer.ccall
{args = Vector.toList args,
- dstsize = dstsize,
frameInfo = frameInfo,
func = func,
return = return,
target = Label.fromString name})})]
end
- fun creturn {dst: (x86.Operand.t * x86.Size.t) option,
+ fun creturn {dsts: (x86.Operand.t * x86.Size.t) vector,
frameInfo: x86.FrameInfo.t option,
func: CFunction.t,
label: x86.Label.t,
transInfo as {live, liveInfo, ...}: transInfo}
= let
val name = CFunction.name func
- fun getDst ()
- = case dst
- of SOME dst => dst
- | NONE => Error.bug "creturn: getDst"
fun default ()
= let
val _ = x86Liveness.LiveInfo.setLiveOperands
@@ -1459,7 +1459,7 @@
in
AppendList.single
(x86.Block.mkBlock'
- {entry = SOME (Entry.creturn {dst = dst,
+ {entry = SOME (Entry.creturn {dsts = dsts,
frameInfo = frameInfo,
func = func,
label = label}),
@@ -1480,7 +1480,7 @@
fun arith {prim : Prim.t,
args : (Operand.t * Size.t) vector,
- dst : (Operand.t * Size.t),
+ dsts : (Operand.t * Size.t) vector,
overflow : Label.t,
success : Label.t,
transInfo as {live, liveInfo, ...} : transInfo}
@@ -1488,21 +1488,34 @@
val primName = Prim.toString prim
datatype z = datatype Prim.Name.t
- fun arg i = Vector.sub (args, i)
-
- val (src1, src1size) = arg 0
- val (dst, dstsize) = dst
- val _ = Assert.assert
- ("arith: dstsize/srcsize",
- fn () => src1size = dstsize)
- fun check (src, statement, condition)
+ fun getDst1 ()
+ = Vector.sub (dsts, 0)
+ handle _ => Error.bug "arith: getDst1"
+ fun getDst2 ()
+ = (Vector.sub (dsts, 0), Vector.sub (dsts, 1))
+ handle _ => Error.bug "arith: getDst2"
+ fun getSrc1 ()
+ = Vector.sub (args, 0)
+ handle _ => Error.bug "arith: getSrc1"
+ fun getSrc2 ()
+ = (Vector.sub (args, 0), Vector.sub (args, 1))
+ handle _ => Error.bug "arith: getSrc2"
+ fun getSrc3 ()
+ = (Vector.sub (args, 0), Vector.sub (args, 1), Vector.sub (args, 2))
+ handle _ => Error.bug "arith: getSrc3"
+ fun getSrc4 ()
+ = (Vector.sub (args, 0), Vector.sub (args, 1),
+ Vector.sub (args, 2), Vector.sub (args, 3))
+ handle _ => Error.bug "arith: getSrc4"
+
+ fun check (dst, src, size, statement, condition)
= AppendList.single
(x86.Block.mkBlock'
{entry = NONE,
statements = [x86.Assembly.instruction_mov
{dst = dst,
src = src,
- size = src1size},
+ size = size},
statement],
transfer = SOME (x86.Transfer.iff
{condition = condition,
@@ -1510,10 +1523,11 @@
falsee = success})})
fun binal (oper: x86.Instruction.binal, condition)
= let
- val (src2, src2size) = arg 1
+ val (dst, dstsize) = getDst1 ()
+ val ((src1, src1size), (src2, src2size)) = getSrc2 ()
val _ = Assert.assert
- ("arith: binal, dstsize/src2size",
- fn () => src2size = dstsize)
+ ("arith: binal, dstsize/src1size/src2size",
+ fn () => src1size = dstsize andalso src2size = dstsize)
(* Reverse src1/src2 when src1 and src2 are
* temporaries and the oper is commutative.
*)
@@ -1530,7 +1544,7 @@
| _ => (src1,src2)
else (src1,src2)
in
- check (src1,
+ check (dst, src1, dstsize,
x86.Assembly.instruction_binal
{oper = oper,
dst = dst,
@@ -1540,10 +1554,11 @@
end
fun pmd (oper: x86.Instruction.md, condition)
= let
- val (src2, src2size) = arg 1
- val _ = Assert.assert
- ("arith: pmd, dstsize/src2size",
- fn () => src2size = dstsize)
+ val (dst, dstsize) = getDst1 ()
+ val ((src1, src1size), (src2, src2size)) = getSrc2 ()
+ val _ = Assert.assert
+ ("arith: pmd, dstsize/src1size/src2size",
+ fn () => src1size = dstsize andalso src2size = dstsize)
(* Reverse src1/src2 when src1 and src2 are
* temporaries and the oper is commutative.
*)
@@ -1560,7 +1575,7 @@
| _ => (src1,src2)
else (src1,src2)
in
- check (src1,
+ check (dst, src1, dstsize,
x86.Assembly.instruction_pmd
{oper = oper,
dst = dst,
@@ -1570,20 +1585,26 @@
end
fun unal (oper: x86.Instruction.unal, condition)
= let
+ val (dst, dstsize) = getDst1 ()
+ val (src1, src1size) = getSrc1 ()
+ val _ = Assert.assert
+ ("arith: unal, dstsize/src1size",
+ fn () => src1size = dstsize)
in
- check (src1,
+ check (dst, src1, dstsize,
x86.Assembly.instruction_unal
{oper = oper,
dst = dst,
size = dstsize},
condition)
end
- fun imul2_check condition
+ fun imul2 condition
= let
- val (src2, src2size) = arg 1
+ val (dst, dstsize) = getDst1 ()
+ val ((src1, src1size), (src2, src2size)) = getSrc2 ()
val _ = Assert.assert
- ("arith: imul2_check, dstsizesrc2size",
- fn () => src2size = dstsize)
+ ("arith: imul2, dstsize/src1size/src2size",
+ fn () => src1size = dstsize andalso src2size = dstsize)
(* Reverse src1/src2 when src1 and src2 are
* temporaries and the oper is commutative.
*)
@@ -1598,7 +1619,7 @@
else (src1,src2)
| _ => (src1,src2)
in
- check (src1,
+ check (dst, src1, dstsize,
x86.Assembly.instruction_imul2
{dst = dst,
src = src2,
@@ -1637,8 +1658,8 @@
| Int_mulCheck s =>
(case s of
I8 => pmd (x86.Instruction.IMUL, x86.Instruction.O)
- | I16 => imul2_check x86.Instruction.O
- | I32 => imul2_check x86.Instruction.O
+ | I16 => imul2 x86.Instruction.O
+ | I32 => imul2 x86.Instruction.O
| I64 => Error.bug "FIXME")
| Int_negCheck _ => unal (x86.Instruction.NEG, x86.Instruction.O)
| Word_addCheck _ => binal (x86.Instruction.ADD, x86.Instruction.C)
1.15 +10 -10 mlton/mlton/codegen/x86-codegen/x86-mlton.sig
Index: x86-mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- x86-mlton.sig 19 Dec 2002 23:43:34 -0000 1.14
+++ x86-mlton.sig 31 Jul 2003 23:10:33 -0000 1.15
@@ -31,24 +31,24 @@
liveInfo: x86Liveness.LiveInfo.t}
(* arith, c call, and primitive assembly sequences. *)
- val arith: {prim : Machine.Prim.t,
- args : (x86.Operand.t * x86.Size.t) vector,
- dst : (x86.Operand.t * x86.Size.t),
- overflow : x86.Label.t,
- success : x86.Label.t,
+ val arith: {prim: Machine.Prim.t,
+ args: (x86.Operand.t * x86.Size.t) vector,
+ dsts: (x86.Operand.t * x86.Size.t) vector,
+ overflow: x86.Label.t,
+ success: x86.Label.t,
transInfo : transInfo} -> x86.Block.t' AppendList.t
val ccall: {args: (x86.Operand.t * x86.Size.t) vector,
frameInfo: x86.FrameInfo.t option,
func: Machine.CFunction.t,
return: x86.Label.t option,
transInfo: transInfo} -> x86.Block.t' AppendList.t
- val creturn: {dst: (x86.Operand.t * x86.Size.t) option,
+ val creturn: {dsts: (x86.Operand.t * x86.Size.t) vector,
frameInfo: x86.FrameInfo.t option,
func: Machine.CFunction.t,
label: x86.Label.t,
transInfo: transInfo} -> x86.Block.t' AppendList.t
- val prim: {prim : Machine.Prim.t,
- args : (x86.Operand.t * x86.Size.t) vector,
- dst : (x86.Operand.t * x86.Size.t) option,
- transInfo : transInfo} -> x86.Block.t' AppendList.t
+ val prim: {prim: Machine.Prim.t,
+ args: (x86.Operand.t * x86.Size.t) vector,
+ dsts: (x86.Operand.t * x86.Size.t) vector,
+ transInfo: transInfo} -> x86.Block.t' AppendList.t
end
1.20 +7 -2 mlton/mlton/codegen/x86-codegen/x86-pseudo.sig
Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- x86-pseudo.sig 25 Jul 2003 20:14:47 -0000 1.19
+++ x86-pseudo.sig 31 Jul 2003 23:10:33 -0000 1.20
@@ -29,6 +29,7 @@
| FPIS | FPIL | FPIQ
val fromBytes : int -> t
val toBytes : t -> int
+ val fromCType : CFunction.CType.t -> t vector
val class : t -> class
val eq : t * t -> bool
val lt : t * t -> bool
@@ -74,6 +75,7 @@
sig
datatype t = One | Two | Four | Eight
val fromBytes : int -> t
+ val fromCType : CFunction.CType.t -> t
end
structure MemLoc :
@@ -113,6 +115,10 @@
scale: Scale.t,
size: Size.t,
class: Class.t} -> t
+ val shift : {origin: t,
+ disp: Immediate.t,
+ scale: Scale.t,
+ size: Size.t} -> t
val class : t -> Class.t
val compare : t * t -> order
@@ -416,7 +422,7 @@
val cont: {label: Label.t,
live: MemLocSet.t,
frameInfo: FrameInfo.t} -> t
- val creturn: {dst: (Operand.t * Size.t) option,
+ val creturn: {dsts: (Operand.t * Size.t) vector,
frameInfo: FrameInfo.t option,
func: CFunction.t,
label: Label.t} -> t
@@ -459,7 +465,6 @@
val return : {live: MemLocSet.t} -> t
val raisee : {live: MemLocSet.t} -> t
val ccall : {args: (Operand.t * Size.t) list,
- dstsize: Size.t option,
frameInfo: FrameInfo.t option,
func: CFunction.t,
return: Label.t option,
1.47 +315 -153 mlton/mlton/codegen/x86-codegen/x86-translate.fun
Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- x86-translate.fun 25 Jul 2003 20:14:47 -0000 1.46
+++ x86-translate.fun 31 Jul 2003 23:10:33 -0000 1.47
@@ -53,20 +53,31 @@
struct
open Machine.Global
- fun toX86MemLoc (g: t) =
+ fun toX86Operand (g: t) : (x86.Operand.t * x86.Size.t) vector =
let
val ty = Machine.Type.toCType (ty g)
+ val index = index g
val base =
x86.Immediate.label
(if isRoot g
then x86MLton.global_base ty
else x86MLton.globalPointerNonRoot_base)
+ val origin =
+ x86.MemLoc.imm
+ {base = base,
+ index = x86.Immediate.const_int index,
+ scale = x86.Scale.fromCType ty,
+ size = x86.Size.BYTE,
+ class = x86MLton.Classes.Globals}
+ val sizes = x86.Size.fromCType ty
in
- x86.MemLoc.imm {base = base,
- index = x86.Immediate.const_int (index g),
- scale = x86MLton.toX86Scale ty,
- size = x86MLton.toX86Size ty,
- class = x86MLton.Classes.Globals}
+ (#1 o Vector.mapAndFold)
+ (sizes, 0, fn (size,offset) =>
+ (((x86.Operand.memloc o x86.MemLoc.shift)
+ {origin = origin,
+ disp = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = size}, size), offset + x86.Size.toBytes size))
end
val toString = Layout.toString o layout
@@ -76,15 +87,26 @@
struct
open Machine.Operand
- val toX86Size = x86MLton.toX86Size o Type.toCType o ty
-
- val rec toX86Operand =
- fn ArrayOffset {base, index, ty} =>
- let
+ fun get (f: ('a * 'b) -> 'c) (i: int) (v: ('a * 'b) vector) =
+ f (Vector.sub (v, i))
+ handle _ => Error.bug (concat ["toX86Operand: get"])
+ fun getOp0 v =
+ get #1 0 v
+
+ val rec toX86Operand : t -> (x86.Operand.t * x86.Size.t) vector =
+ fn ArrayOffset {base, index, ty}
+ => let
val base = toX86Operand base
+ val _ = Assert.assert("x86Translate.Operand.toX86Operand: Array/base",
+ fn () => Vector.length base = 1)
+ val base = getOp0 base
val index = toX86Operand index
+ val _ = Assert.assert("x86Translate.Operand.toX86Operand: Array/index",
+ fn () => Vector.length index = 1)
+ val index = getOp0 index
+
val ty = Type.toCType ty
- val memloc =
+ val origin =
case (x86.Operand.deMemloc base,
x86.Operand.deImmediate index,
x86.Operand.deMemloc index) of
@@ -92,126 +114,258 @@
x86.MemLoc.simple
{base = base,
index = index,
- scale = x86MLton.toX86Scale ty,
- size = x86MLton.toX86Size ty,
+ scale = x86.Scale.fromCType ty,
+ size = x86.Size.BYTE,
class = x86MLton.Classes.Heap}
| (SOME base, _, SOME index) =>
x86.MemLoc.complex
{base = base,
index = index,
- scale = x86MLton.toX86Scale ty,
- size = x86MLton.toX86Size ty,
+ scale = x86.Scale.fromCType ty,
+ size = x86.Size.BYTE,
class = x86MLton.Classes.Heap}
| _ => Error.bug (concat ["toX86Operand: strange Offset:",
" base: ",
x86.Operand.toString base,
" index: ",
x86.Operand.toString index])
+ val sizes = x86.Size.fromCType ty
in
- x86.Operand.memloc memloc
+ (#1 o Vector.mapAndFold)
+ (sizes, 0, fn (size,offset) =>
+ (((x86.Operand.memloc o x86.MemLoc.shift)
+ {origin = origin,
+ disp = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = size}, size), offset + x86.Size.toBytes size))
end
| Cast (z, _) => toX86Operand z
| Contents {oper, ty} =>
let
val ty = Type.toCType ty
val base = toX86Operand oper
+ val _ = Assert.assert("x86Translate.Operand.toX86Operand: Contents/base",
+ fn () => Vector.length base = 1)
+ val base = getOp0 base
val offset = x86.Immediate.const_int 0
- val size = x86MLton.toX86Size ty
- val memloc =
+ val origin =
case x86.Operand.deMemloc base of
SOME base =>
x86.MemLoc.simple
{base = base,
index = x86.Immediate.const_int 0,
scale = x86.Scale.One,
- size = x86MLton.toX86Size ty,
+ size = x86.Size.BYTE,
class = x86MLton.Classes.Heap}
| _ => Error.bug (concat
["toX86Operand: strange Contents",
" base: ",
- x86.Operand.toString base])
+ x86.Operand.toString base])
+ val sizes = x86.Size.fromCType ty
+ in
+ (#1 o Vector.mapAndFold)
+ (sizes, 0, fn (size,offset) =>
+ (((x86.Operand.memloc o x86.MemLoc.shift)
+ {origin = origin,
+ disp = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = size}, size), offset + x86.Size.toBytes size))
+ end
+ | File => Vector.new1 (x86MLton.fileName, x86MLton.pointerSize)
+ | Frontier =>
+ let
+ val frontier = x86MLton.gcState_frontierContentsOperand ()
in
- x86.Operand.memloc memloc
+ Vector.new1 (frontier, valOf (x86.Operand.size frontier))
end
- | File => x86MLton.fileName
- | Frontier => x86MLton.gcState_frontierContentsOperand ()
- | GCState => x86.Operand.label x86MLton.gcState_label
- | Global g => x86.Operand.memloc (Global.toX86MemLoc g)
+ | GCState =>
+ Vector.new1 (x86.Operand.label x86MLton.gcState_label,
+ x86MLton.pointerSize)
+ | Global g => Global.toX86Operand g
| Int i =>
let
- val i' = IntX.toIntInf i
+ val i'' = fn () => x86.Operand.immediate_const_int (IntX.toInt i)
in
- x86.Operand.immediate_const_int (IntInf.toInt i')
+ case IntX.size i of
+ I8 => Vector.new1 (i'' (), x86.Size.BYTE)
+ | I16 => Vector.new1 (i'' (), x86.Size.WORD)
+ | I32 => Vector.new1 (i'' (), x86.Size.LONG)
+ | I64 => let
+ fun convert1 (ii: IntInf.t): Word.t * Word.t =
+ let
+ val lo = Word.fromIntInf ii
+ val ii = IntInf.~>> (ii, 0w32)
+ val hi = Word.fromIntInf ii
+ in
+ (lo, hi)
+ end
+(*
+ fun convert2 (ii: IntInf.t): Word.t * Word.t =
+ let
+ fun finish (iis: String.t, c: Char.t) =
+ let
+ val s =
+ String.concat
+ [String.tabulate
+ (16 - String.size iis, fn _ => c),
+ iis]
+ fun cvt s = valOf (Word.fromString s)
+ val lo = cvt(String.extract(s, 8, SOME 8))
+ val hi = cvt(String.extract(s, 0, SOME 8))
+ in
+ (lo, hi)
+ end
+ in
+ if IntInf.<(ii, IntInf.fromInt 0)
+ then let
+ val ii = IntInf.-(IntInf.~ ii, IntInf.fromInt 1)
+ val iis =
+ String.translate
+ (IntInf.format(ii, StringCvt.HEX),
+ fn #"0" => "F"
+ | #"1" => "E"
+ | #"2" => "D"
+ | #"3" => "C"
+ | #"4" => "B"
+ | #"5" => "A"
+ | #"6" => "9"
+ | #"7" => "8"
+ | #"8" => "7"
+ | #"9" => "6"
+ | #"A" => "5"
+ | #"B" => "4"
+ | #"C" => "3"
+ | #"D" => "2"
+ | #"E" => "1"
+ | #"F" => "0"
+ | #"a" => "5"
+ | #"b" => "4"
+ | #"c" => "3"
+ | #"d" => "2"
+ | #"e" => "1"
+ | #"f" => "0"
+ | c => "")
+ in
+ finish (iis, #"F")
+ end
+ else finish (IntInf.format(ii, StringCvt.HEX), #"0")
+ end
+*)
+ val ii = IntX.toIntInf i
+ val (lo, hi) = convert1 ii
+ in
+ Vector.new2
+ ((x86.Operand.immediate_const_word lo, x86.Size.LONG),
+ (x86.Operand.immediate_const_word hi, x86.Size.LONG))
+ end
end
- | Label l => x86.Operand.immediate_label l
- | Line => x86MLton.fileLine ()
+ | Label l =>
+ Vector.new1 (x86.Operand.immediate_label l, x86MLton.pointerSize)
+ | Line =>
+ Vector.new1 (x86MLton.fileLine (), x86MLton.wordSize)
| Offset {base = GCState, offset, ty} =>
let
- val ty = Type.toCType ty
+ val ty = Type.toCType ty
+ val offset = x86MLton.gcState_offset {offset = offset, ty = ty}
in
- x86MLton.gcState_offset {offset = offset, ty = ty}
+ Vector.new1 (offset, valOf (x86.Operand.size offset))
end
| Offset {base, offset, ty} =>
let
- val base = toX86Operand base
val ty = Type.toCType ty
- val memloc =
+ val base = toX86Operand base
+ val _ = Assert.assert("x86Translate.Operand.toX86Operand: Contents/base",
+ fn () => Vector.length base = 1)
+ val base = getOp0 base
+ val origin =
case x86.Operand.deMemloc base of
SOME base =>
x86.MemLoc.simple
{base = base,
index = x86.Immediate.const_int offset,
scale = x86.Scale.One,
- size = x86MLton.toX86Size ty,
+ size = x86.Size.BYTE,
class = x86MLton.Classes.Heap}
| _ => Error.bug (concat ["toX86Operand: strange Offset:",
" base: ",
x86.Operand.toString base])
+ val sizes = x86.Size.fromCType ty
in
- x86.Operand.memloc memloc
+ (#1 o Vector.mapAndFold)
+ (sizes, 0, fn (size,offset) =>
+ (((x86.Operand.memloc o x86.MemLoc.shift)
+ {origin = origin,
+ disp = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = size}, size), offset + x86.Size.toBytes size))
end
| Real _ => Error.bug "toX86Operand: Real unimplemented"
| Register r =>
let
val ty = Machine.Type.toCType (Register.ty r)
+ val index = Machine.Register.index r
val base = x86.Immediate.label (x86MLton.local_base ty)
+ val sizes = x86.Size.fromCType ty
+ val origin =
+ x86.MemLoc.imm
+ {base = base,
+ index = x86.Immediate.const_int index,
+ scale = x86.Scale.fromCType ty,
+ size = x86.Size.BYTE,
+ class = x86MLton.Classes.Locals}
+ val sizes = x86.Size.fromCType ty
in
- x86.Operand.memloc
- (x86.MemLoc.imm {base = base,
- index = (x86.Immediate.const_int
- (Register.index r)),
- scale = x86MLton.toX86Scale ty,
- size = x86MLton.toX86Size ty,
- class = x86MLton.Classes.Locals})
+ (#1 o Vector.mapAndFold)
+ (sizes, 0, fn (size,offset) =>
+ (((x86.Operand.memloc o x86.MemLoc.shift)
+ {origin = origin,
+ disp = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = size}, size), offset + x86.Size.toBytes size))
end
- | SmallIntInf ii => x86.Operand.immediate_const_word ii
+ | SmallIntInf ii =>
+ Vector.new1 (x86.Operand.immediate_const_word ii,x86.Size.LONG)
| StackOffset {offset, ty} =>
let
val ty = Type.toCType ty
- val memloc =
+ val origin =
x86.MemLoc.simple
{base = x86MLton.gcState_stackTopContents (),
index = x86.Immediate.const_int offset,
scale = x86.Scale.One,
- size = x86MLton.toX86Size ty,
+ size = x86.Size.BYTE,
class = x86MLton.Classes.Stack}
+ val sizes = x86.Size.fromCType ty
in
- x86.Operand.memloc memloc
+ (#1 o Vector.mapAndFold)
+ (sizes, 0, fn (size,offset) =>
+ (((x86.Operand.memloc o x86.MemLoc.shift)
+ {origin = origin,
+ disp = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = size}, size), offset + x86.Size.toBytes size))
+ end
+ | StackTop =>
+ let
+ val stackTop = x86MLton.gcState_stackTopContentsOperand ()
+ in
+ Vector.new1 (stackTop, valOf (x86.Operand.size stackTop))
end
- | StackTop => x86MLton.gcState_stackTopContentsOperand ()
| Word w =>
let
val w' = WordX.toWord w
+ val w'' = x86.Operand.immediate_const_word w'
in
- x86.Operand.immediate_const_word w'
+ case WordX.size w of
+ W8 => Vector.new1 (w'', x86.Size.BYTE)
+ | W16 => Vector.new1 (w'', x86.Size.WORD)
+ | W32 => Vector.new1 (w'', x86.Size.LONG)
end
val toX86Operand =
fn operand =>
toX86Operand operand
handle exn => Error.reraise (exn, "x86Translate.Operand.toX86Operand")
-
- fun convert x = (toX86Operand x, toX86Size x)
end
type transInfo = x86MLton.transInfo
@@ -257,15 +411,16 @@
| Kind.Cont {args, frameInfo, ...}
=> let
val frameInfo = frameInfoToX86 frameInfo
- val args
- = Vector.fold
- (args,
- x86.MemLocSet.empty,
- fn (operand, args)
- => case x86.Operand.deMemloc
- (Operand.toX86Operand operand)
- of SOME memloc => x86.MemLocSet.add(args, memloc)
- | NONE => args)
+ val args =
+ Vector.fold
+ (args, x86.MemLocSet.empty,
+ fn (operand,args) =>
+ Vector.fold
+ (Operand.toX86Operand operand, args,
+ fn ((operand,size),args) =>
+ case x86.Operand.deMemloc operand of
+ SOME memloc => x86.MemLocSet.add(args, memloc)
+ | NONE => args))
in
AppendList.single
(x86.Block.mkBlock'
@@ -289,10 +444,13 @@
end
| Kind.CReturn {dst, frameInfo, func}
=> let
- val dst = Option.map (dst, Operand.convert)
+ val dsts =
+ case dst of
+ NONE => Vector.new0 ()
+ | SOME dst => Operand.toX86Operand dst
in
x86MLton.creturn
- {dst = dst,
+ {dsts = dsts,
frameInfo = Option.map (frameInfo, frameInfoToX86),
func = func,
label = label,
@@ -336,16 +494,8 @@
val (comment_begin,
comment_end) = comments statement
- val dstsize = Operand.toX86Size dst
- val dst = Operand.toX86Operand dst
-
- val srcsize = Operand.toX86Size src
- val src = Operand.toX86Operand src
-
- val _
- = Assert.assert
- ("toX86Blocks: Move",
- fn () => srcsize = dstsize)
+ val dsts = Operand.toX86Operand dst
+ val srcs = Operand.toX86Operand src
in
AppendList.appends
[comment_begin,
@@ -353,31 +503,37 @@
(x86.Block.mkBlock'
{entry = NONE,
statements
- = [(* dst = src *)
+ = (Vector.toList o Vector.map2)
+ (dsts,srcs,fn ((dst,dstsize),(src,srcsize)) =>
+ (* dst = src *)
case x86.Size.class srcsize
- of x86.Size.INT => x86.Assembly.instruction_mov
- {dst = dst,
- src = src,
- size = srcsize}
- | x86.Size.FLT => x86.Assembly.instruction_pfmov
- {dst = dst,
- src = src,
- size = srcsize}
- | _ => Error.bug "toX86Blocks: Move"],
+ of x86.Size.INT => x86.Assembly.instruction_mov
+ {dst = dst,
+ src = src,
+ size = srcsize}
+ | x86.Size.FLT => x86.Assembly.instruction_pfmov
+ {dst = dst,
+ src = src,
+ size = srcsize}
+ | _ => Error.bug "toX86Blocks: Move"),
transfer = NONE}),
comment_end]
end
| PrimApp {dst, prim, args}
=> let
val (comment_begin, comment_end) = comments statement
- val args = Vector.map (args, Operand.convert)
- val dst = Option.map (dst, Operand.convert)
+ val args = (Vector.concatV o Vector.map)
+ (args, Operand.toX86Operand)
+ val dsts =
+ case dst of
+ NONE => Vector.new0 ()
+ | SOME dst => Operand.toX86Operand dst
in
AppendList.appends
[comment_begin,
(x86MLton.prim {prim = prim,
args = args,
- dst = dst,
+ dsts = dsts,
transInfo = transInfo}),
comment_end]
end
@@ -389,16 +545,10 @@
=> let
val (comment_begin,
comment_end) = comments statement
-
- val dstsize = Operand.toX86Size dst
- val dst = Operand.toX86Operand dst
+ val (dst,dstsize) = Vector.sub(Operand.toX86Operand dst, 0)
val dst' = case x86.Operand.deMemloc dst
of SOME dst' => dst'
| NONE => Error.bug "Allocate: strange dst"
- val _
- = Assert.assert
- ("toX86Assembly: Allocate, dstsize",
- fn () => dstsize = x86MLton.pointerSize)
val frontier = x86MLton.gcState_frontierContentsOperand ()
val frontierDeref = x86MLton.gcState_frontierDerefOperand ()
@@ -412,36 +562,39 @@
fun stores_toX86Assembly ({offset, value}, l)
= let
- val size =
- x86MLton.toX86Size
- (Type.toCType (Operand.ty value))
- val value = Operand.toX86Operand value
- val dst
- = let
- val index = x86.Immediate.const_int offset
- val memloc
- = x86.MemLoc.simple
- {base = dst',
- index = index,
- scale = x86.Scale.One,
- size = size,
- class = x86MLton.Classes.Heap}
- in
- x86.Operand.memloc memloc
- end
+ val origin =
+ x86.MemLoc.simple
+ {base = dst',
+ index = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = x86.Size.BYTE,
+ class = x86MLton.Classes.Heap}
in
- (case x86.Size.class size
- of x86.Size.INT
- => x86.Assembly.instruction_mov
- {dst = dst,
- src = value,
- size = size}
- | x86.Size.FLT
- => x86.Assembly.instruction_pfmov
- {dst = dst,
- src = value,
- size = size}
- | _ => Error.bug "toX86Blocks: Allocate")::l
+ (
+ (Vector.toList o #1 o Vector.mapAndFold)
+ (Operand.toX86Operand value, 0, fn ((src,srcsize),offset) =>
+ let
+ val dst =
+ (x86.Operand.memloc o x86.MemLoc.shift)
+ {origin = origin,
+ disp = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = srcsize}
+ in
+ (case x86.Size.class srcsize of
+ x86.Size.INT =>
+ x86.Assembly.instruction_mov
+ {dst = dst,
+ src = src,
+ size = srcsize}
+ | x86.Size.FLT =>
+ x86.Assembly.instruction_pfmov
+ {dst = dst,
+ src = src,
+ size = srcsize}
+ | _ => Error.bug "toX86Blocks: Allocate",
+ offset + x86.Size.toBytes srcsize)
+ end)) @ l
end
in
AppendList.appends
@@ -490,8 +643,8 @@
fun iff (test, a, b)
= let
- val size = Operand.toX86Size test
- val test = Operand.toX86Operand test
+ val (test,testsize) =
+ Vector.sub (Operand.toX86Operand test, 0)
in
if Label.equals(a, b)
then AppendList.single
@@ -509,7 +662,7 @@
= [x86.Assembly.instruction_test
{src1 = test,
src2 = test,
- size = size}],
+ size = testsize}],
transfer
= SOME (x86.Transfer.iff
{condition = x86.Instruction.NZ,
@@ -519,8 +672,8 @@
fun cmp (test, k, a, b)
= let
- val size = Operand.toX86Size test
- val test = Operand.toX86Operand test
+ val (test,testsize) =
+ Vector.sub (Operand.toX86Operand test, 0)
in
if Label.equals(a, b)
then AppendList.single
@@ -538,7 +691,7 @@
= [x86.Assembly.instruction_cmp
{src1 = test,
src2 = x86.Operand.immediate k,
- size = size}],
+ size = testsize}],
transfer
= SOME (x86.Transfer.iff
{condition = x86.Instruction.E,
@@ -549,6 +702,7 @@
fun switch(test, cases, default)
= let
val test = Operand.toX86Operand test
+ val (test,testsize) = Vector.sub(test, 0)
in
AppendList.single
(x86.Block.mkBlock'
@@ -560,7 +714,7 @@
default = default})})
end
- fun doSwitchChar (test, cases, default)
+ fun doSwitchChar (test, cases, default)
= (case (cases, default)
of ([], NONE)
=> Error.bug "toX86Blocks: doSwitchChar"
@@ -630,21 +784,23 @@
= (case transfer
of Arith {prim, args, dst, overflow, success, ty}
=> let
- val args = Vector.map (args, Operand.convert)
- val dst = Operand.convert dst
+ val args = (Vector.concatV o Vector.map)
+ (args, Operand.toX86Operand)
+ val dsts = Operand.toX86Operand dst
in
AppendList.append
(comments transfer,
x86MLton.arith {prim = prim,
args = args,
- dst = dst,
+ dsts = dsts,
overflow = overflow,
success = success,
transInfo = transInfo})
end
| CCall {args, frameInfo, func, return}
=> let
- val args = Vector.map (args, Operand.convert)
+ val args = (Vector.concatV o Vector.map)
+ (args, Operand.toX86Operand)
in
AppendList.append
(comments transfer,
@@ -670,11 +826,13 @@
NONE => Error.bug "strange Return"
| SOME zs => zs),
x86.MemLocSet.empty,
- fn (operand, live)
- => case x86.Operand.deMemloc
- (Operand.toX86Operand operand)
- of SOME memloc => x86.MemLocSet.add(live, memloc)
- | NONE => live)})}))
+ fn (operand, live) =>
+ Vector.fold
+ (Operand.toX86Operand operand, live,
+ fn ((operand,size),live) =>
+ case x86.Operand.deMemloc operand of
+ SOME memloc => x86.MemLocSet.add(live, memloc)
+ | NONE => live))})}))
| Raise
=> AppendList.append
(comments transfer,
@@ -702,8 +860,8 @@
case switch of
EnumPointers {enum, pointers, test} =>
let
- val size = Operand.toX86Size test
- val test = Operand.toX86Operand test
+ val (test,testsize) =
+ Vector.sub(Operand.toX86Operand test, 0)
in
AppendList.append
(comments transfer,
@@ -717,7 +875,7 @@
= [x86.Assembly.instruction_test
{src1 = test,
src2 = x86.Operand.immediate_const_word 0wx3,
- size = size}],
+ size = testsize}],
transfer
= SOME (x86.Transfer.iff
{condition = x86.Instruction.NZ,
@@ -725,12 +883,14 @@
falsee = pointers})}))
end
| Int {cases, default, size, test} =>
- simple ({cases = (Vector.map
- (cases, fn (i, l) =>
- (IntX.toInt i, l))),
- default = default,
- test = test},
- doSwitchInt)
+ (Assert.assert("x86Translate.Transfer.toX86Blocks: Switch/Int",
+ fn () => size <> IntSize.I64)
+ ; simple ({cases = (Vector.map
+ (cases, fn (i, l) =>
+ (IntX.toInt i, l))),
+ default = default,
+ test = test},
+ doSwitchInt))
| Pointer {cases, default, tag, ...} =>
simple ({cases = (Vector.map
(cases, fn {dst, tag, ...} =>
@@ -756,15 +916,15 @@
statements = [],
transfer = SOME (x86.Transfer.goto {target = label})})))
| Call {label, live, return, ...}
- =>
- let
+ => let
val live =
Vector.fold
(live, x86.MemLocSet.empty, fn (operand, live) =>
- case (x86.Operand.deMemloc
- (Operand.toX86Operand operand)) of
- NONE => live
- | SOME memloc => x86.MemLocSet.add (live, memloc))
+ Vector.fold
+ (Operand.toX86Operand operand, live, fn ((operand,size),live) =>
+ case x86.Operand.deMemloc operand of
+ NONE => live
+ | SOME memloc => x86.MemLocSet.add (live, memloc)))
val com = comments transfer
val transfer =
case return of
@@ -862,7 +1022,9 @@
val _ = Vector.foreach
(blocks, fn Block.T {label, live, ...} =>
setLive (label,
- Vector.toListMap (live, Operand.toX86Operand)))
+ (Vector.toList o #1 o Vector.unzip o
+ Vector.concatV o Vector.map)
+ (live, Operand.toX86Operand)))
val transInfo = {addData = addData,
frameInfoToX86 = frameInfoToX86,
live = live,
1.41 +231 -63 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- x86.fun 25 Jul 2003 20:14:47 -0000 1.40
+++ x86.fun 31 Jul 2003 23:10:33 -0000 1.41
@@ -43,13 +43,19 @@
open S
- local
- open Runtime
- in
- structure CFunction = CFunction
- end
-
- structure CType = CFunction.CType
+ local
+ open Runtime
+ in
+ structure CFunction = CFunction
+ end
+ structure CType = CFunction.CType
+ local
+ open CType
+ in
+ structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize
+ end
structure Label =
struct
@@ -131,6 +137,35 @@
| FPIL => 4
| FPIQ => 8
+ local
+ datatype z = datatype CType.t
+ in
+ fun fromCType t =
+ case t of
+ Int s =>
+ let datatype z = datatype IntSize.t
+ in case s of
+ I8 => Vector.new1 BYTE
+ | I16 => Vector.new1 WORD
+ | I32 => Vector.new1 LONG
+ | I64 => Vector.new2 (LONG, LONG)
+ end
+ | Pointer => Vector.new1 LONG
+ | Real s =>
+ let datatype z = datatype RealSize.t
+ in case s of
+ R32 => Vector.new1 SNGL
+ | R64 => Vector.new1 DBLE
+ end
+ | Word s =>
+ let datatype z = datatype WordSize.t
+ in case s of
+ W8 => Vector.new1 BYTE
+ | W16 => Vector.new1 WORD
+ | W32 => Vector.new1 LONG
+ end
+ end
+
val class
= fn BYTE => INT
| WORD => INT
@@ -206,17 +241,19 @@
fun eq(T r1, T r2) = r1 = r2
+(*
fun return size
= T {reg = EAX, part = case size
of Size.BYTE => L
| Size.WORD => X
| Size.LONG => E
| _ => Error.bug "Register.return"}
-
+*)
val eax = T {reg = EAX, part = E}
val ebx = T {reg = EBX, part = E}
val ecx = T {reg = ECX, part = E}
val edx = T {reg = EDX, part = E}
+ val ax = T {reg= EAX, part = X}
val al = T {reg = EAX, part = L}
val bl = T {reg = EBX, part = L}
val cl = T {reg = ECX, part = L}
@@ -377,7 +414,9 @@
fun pop (T i) = T (i - 1)
fun id (T i) = T i
+(*
val return = T 0
+*)
val top = T 0
val one = T 1
val total = 8 : int
@@ -676,6 +715,34 @@
| Two => 2
| Four => 4
| Eight => 8
+ local
+ datatype z = datatype CType.t
+ in
+ fun fromCType t =
+ case t of
+ Int s =>
+ let datatype z = datatype IntSize.t
+ in case s of
+ I8 => One
+ | I16 => Two
+ | I32 => Four
+ | I64 => Eight
+ end
+ | Pointer => Four
+ | Real s =>
+ let datatype z = datatype RealSize.t
+ in case s of
+ R32 => Four
+ | R64 => Eight
+ end
+ | Word s =>
+ let datatype z = datatype WordSize.t
+ in case s of
+ W8 => One
+ | W16 => Two
+ | W32 => Four
+ end
+ end
fun eq(s1, s2) = s1 = s2
val compare = fn (s1, s2) => Int.compare (toBytes s1, toBytes s2)
@@ -1179,6 +1246,33 @@
scale = scale,
size = size,
class = class})
+ val shift = fn {origin, disp, scale, size}
+ => let
+ val disp =
+ Immediate.binexp
+ {oper = Immediate.Multiplication,
+ exp1 = disp,
+ exp2 = Scale.toImmediate scale}
+ val U {immBase, memBase,
+ immIndex, memIndex,
+ scale, class, ...} =
+ destruct origin
+ in
+ construct (U {immBase = immBase,
+ memBase = memBase,
+ immIndex =
+ case immIndex of
+ NONE => SOME disp
+ | SOME immIndex => SOME (Immediate.binexp
+ {oper = Immediate.Addition,
+ exp1 = immIndex,
+ exp2 = disp}),
+ memIndex = memIndex,
+ scale = scale,
+ size = size,
+ class = class})
+ end
+
local
val num : int ref = ref 0
in
@@ -1199,15 +1293,10 @@
scale = Scale.Four,
size = size,
class = class}
+(*
local
- val cReturnTemp = Label.fromString "cReturnTemp"
- fun cReturnTempContent (index, size) =
- imm
- {base = Immediate.label cReturnTemp,
- index = Immediate.const_int index,
- scale = Scale.One,
- size = size,
- class = Class.StaticTemp}
+ datatype z = datatype CType.t
+ datatype z = datatype Size.t
in
fun cReturnTempContents sizes =
(List.rev o #1)
@@ -1217,7 +1306,30 @@
index + Size.toBytes size)))
fun cReturnTempContent size =
List.first(cReturnTempContents [size])
+ val cReturnTempContents = fn size =>
+ cReturnTempContents (
+ case size of
+ Int s => let datatype z = datatype IntSize.t
+ in case s of
+ I8 => [BYTE]
+ | I16 => [WORD]
+ | I32 => [LONG]
+ | I64 => [LONG, LONG]
+ end
+ | Pointer => [LONG]
+ | Real s => let datatype z = datatype RealSize.t
+ in case s of
+ R32 => [SNGL]
+ | R64 => [DBLE]
+ end
+ | Word s => let datatype z = datatype WordSize.t
+ in case s of
+ W8 => [BYTE]
+ | W16 => [WORD]
+ | W32 => [LONG]
+ end)
end
+*)
end
local
@@ -1342,6 +1454,53 @@
val deMemloc
= fn MemLoc x => SOME x
| _ => NONE
+
+ local
+ val cReturnTemp = Label.fromString "cReturnTemp"
+ fun cReturnTempContent (index, size) =
+ MemLoc.imm
+ {base = Immediate.label cReturnTemp,
+ index = Immediate.const_int index,
+ scale = Scale.One,
+ size = size,
+ class = MemLoc.Class.StaticTemp}
+ datatype z = datatype CType.t
+ datatype z = datatype Size.t
+ in
+ fun cReturnTemps ty =
+ case ty of
+ Int s => let datatype z = datatype IntSize.t
+ in case s of
+ I8 => [{src = register Register.al,
+ dst = cReturnTempContent (0, BYTE)}]
+ | I16 => [{src = register Register.ax,
+ dst = cReturnTempContent (0, WORD)}]
+ | I32 => [{src = register Register.eax,
+ dst = cReturnTempContent (0, LONG)}]
+ | I64 => [{src = register Register.eax,
+ dst = cReturnTempContent (0, LONG)},
+ {src = register Register.edx,
+ dst = cReturnTempContent (4, LONG)}]
+ end
+ | Pointer => [{src = register Register.eax,
+ dst = cReturnTempContent (0, LONG)}]
+ | Real s => let datatype z = datatype RealSize.t
+ in case s of
+ R32 => [{src = fltregister FltRegister.top,
+ dst = cReturnTempContent (0, SNGL)}]
+ | R64 => [{src = fltregister FltRegister.top,
+ dst = cReturnTempContent (0, DBLE)}]
+ end
+ | Word s => let datatype z = datatype WordSize.t
+ in case s of
+ W8 => [{src = register Register.al,
+ dst = cReturnTempContent (0, BYTE)}]
+ | W16 => [{src = register Register.ax,
+ dst = cReturnTempContent (0, WORD)}]
+ | W32 => [{src = register Register.eax,
+ dst = cReturnTempContent (0, LONG)}]
+ end
+ end
end
structure Instruction =
@@ -3023,14 +3182,10 @@
* used before C calls.
*)
| CCall
- (* Assert that the return value is in a register;
- * used after C calls.
- *)
- | Return of {memloc: MemLoc.t}
- (* Assert that the return value is in a float register;
- * used after C calls.
- *)
- | FltReturn of {memloc: MemLoc.t}
+ (* Assert the return value;
+ * used after C calls.
+ *)
+ | Return of {returns: {src: Operand.t, dst: MemLoc.t} list}
(* Misc. *)
(* Assert that the register is not free for the allocator;
* used ???
@@ -3151,10 +3306,10 @@
=> concat["Reset"]
| CCall
=> concat["CCall"]
- | Return {memloc}
- => concat["Return: ", MemLoc.toString memloc]
- | FltReturn {memloc}
- => concat["FltReturn: ", MemLoc.toString memloc]
+ | Return {returns}
+ => concat["Return: ", List.toString (fn {src,dst} =>
+ concat ["(", Operand.toString src,
+ ",", MemLoc.toString dst, ")"]) returns]
| Reserve {registers}
=> concat["Reserve: ",
"registers: ",
@@ -3235,10 +3390,13 @@
defs = [],
kills = []}
| CCall => {uses = [], defs = [], kills = []}
- | Return {memloc}
- => {uses = [], defs = [Operand.memloc memloc], kills = []}
- | FltReturn {memloc}
- => {uses = [], defs = [Operand.memloc memloc], kills = []}
+ | Return {returns}
+ => let
+ val uses = List.map(returns, fn {src, ...} => src)
+ val defs = List.map(returns, fn {dst, ...} => Operand.memloc dst)
+ in
+ {uses = uses, defs = defs, kills = []}
+ end
| Reserve {registers} => {uses = [], defs = [], kills = []}
| Unreserve {registers} => {uses = [], defs = [], kills = []}
| ClearFlt => {uses = [], defs = [], kills = []}
@@ -3331,16 +3489,15 @@
| _ => Error.bug "Directive.replace"),
dead_classes = dead_classes}
| CCall => CCall
- | Return {memloc}
- => Return {memloc = case replacer {use = true, def = false}
- (Operand.memloc memloc)
- of Operand.MemLoc memloc => memloc
- | _ => Error.bug "Directive.replace"}
- | FltReturn {memloc}
- => FltReturn {memloc = case replacer {use = true, def = false}
- (Operand.memloc memloc)
- of Operand.MemLoc memloc => memloc
- | _ => Error.bug "Directive.replace"}
+ | Return {returns}
+ => Return {returns = List.map
+ (returns, fn {src,dst} =>
+ {src = src,
+ dst =
+ case replacer {use = true, def = false}
+ (Operand.memloc dst)
+ of Operand.MemLoc memloc => memloc
+ | _ => Error.bug "Directive.replace"})}
| Reserve {registers} => Reserve {registers = registers}
| Unreserve {registers} => Unreserve {registers = registers}
| ClearFlt => ClearFlt
@@ -3355,7 +3512,6 @@
val force = Force
val ccall = fn () => CCall
val return = Return
- val fltreturn = FltReturn
val reserve = Reserve
val unreserve = Unreserve
val saveregalloc = SaveRegAlloc
@@ -3557,7 +3713,6 @@
val directive_force = Directive o Directive.force
val directive_ccall = Directive o Directive.ccall
val directive_return = Directive o Directive.return
- val directive_fltreturn = Directive o Directive.fltreturn
val directive_reserve = Directive o Directive.reserve
val directive_unreserve = Directive o Directive.unreserve
val directive_saveregalloc = Directive o Directive.saveregalloc
@@ -3661,7 +3816,7 @@
| Handler of {frameInfo: FrameInfo.t,
label: Label.t,
live: MemLocSet.t}
- | CReturn of {dst: (Operand.t * Size.t) option,
+ | CReturn of {dsts: (Operand.t * Size.t) vector,
frameInfo: FrameInfo.t option,
func: CFunction.t,
label: Label.t}
@@ -3705,13 +3860,11 @@
"] (",
FrameInfo.toString frameInfo,
")"]
- | CReturn {dst, frameInfo, func, label}
+ | CReturn {dsts, frameInfo, func, label}
=> concat ["CReturn::",
Label.toString label,
" ",
- case dst
- of SOME (dst, _) => Operand.toString dst
- | NONE => "",
+ Vector.toString (fn (dst,dstsize) => Operand.toString dst) dsts,
" ",
CFunction.name func,
" ",
@@ -3721,9 +3874,20 @@
val layout = Layout.str o toString
val uses_defs_kills
- = fn CReturn {dst = SOME (dst, dstsize), ...}
- => {uses = [Operand.memloc (MemLoc.cReturnTempContent dstsize)],
- defs = [dst], kills = []}
+ = fn CReturn {dsts, func, ...}
+ => let
+ val uses =
+ case CFunction.return func of
+ NONE => []
+ | SOME ty =>
+ List.map
+ (Operand.cReturnTemps ty,
+ fn {src, dst} => Operand.memloc dst)
+ in
+ {uses = uses,
+ defs = Vector.toListMap(dsts, fn (dst, dstsize) => dst),
+ kills = []}
+ end
| _ => {uses = [], defs = [], kills = []}
val label
@@ -3938,7 +4102,6 @@
| Return of {live: MemLocSet.t}
| Raise of {live: MemLocSet.t}
| CCall of {args: (Operand.t * Size.t) list,
- dstsize: Size.t option,
frameInfo: FrameInfo.t option,
func: CFunction.t,
return: Label.t option,
@@ -4020,7 +4183,7 @@
fn (memloc, l) => (MemLoc.toString memloc)::l),
", "),
"]"]
- | CCall {args, dstsize, frameInfo, func, return, target}
+ | CCall {args, frameInfo, func, return, target}
=> concat ["CCALL ",
Label.toString target,
"(",
@@ -4035,13 +4198,19 @@
val uses_defs_kills
= fn Switch {test, cases, default}
=> {uses = [test], defs = [], kills = []}
- | CCall {args, dstsize, ...}
- => {uses = List.map(args, fn (oper,_) => oper),
- defs = case dstsize
- of NONE => []
- | SOME dstsize
- => [Operand.memloc (MemLoc.cReturnTempContent dstsize)],
- kills = []}
+ | CCall {args, func, ...}
+ => let
+ val defs =
+ case CFunction.return func of
+ NONE => []
+ | SOME ty =>
+ List.map
+ (Operand.cReturnTemps ty,
+ fn {src, dst} => Operand.memloc dst)
+ in
+ {uses = List.map(args, fn (oper,_) => oper),
+ defs = defs, kills = []}
+ end
| _ => {uses = [], defs = [], kills = []}
val nearTargets
@@ -4075,13 +4244,12 @@
=> Switch {test = replacer {use = true, def = false} test,
cases = cases,
default = default}
- | CCall {args, dstsize, frameInfo, func, return, target}
+ | CCall {args, frameInfo, func, return, target}
=> CCall {args = List.map(args,
fn (oper,size) => (replacer {use = true,
def = false}
oper,
size)),
- dstsize = dstsize,
frameInfo = frameInfo,
func = func,
return = return,
1.29 +23 -16 mlton/mlton/codegen/x86-codegen/x86.sig
Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86.sig 25 Jul 2003 20:14:47 -0000 1.28
+++ x86.sig 31 Jul 2003 23:10:33 -0000 1.29
@@ -43,6 +43,7 @@
val toString' : t -> string
val fromBytes : int -> t
val toBytes : t -> int
+ val fromCType : CFunction.CType.t -> t vector
val class : t -> class
val toFPI : t -> t
val eq : t * t -> bool
@@ -69,7 +70,9 @@
val coincident' : reg -> t list
val coincident : t -> t list
+(*
val return : Size.t -> t
+*)
val eax : t
val ebx : t
val ecx : t
@@ -99,7 +102,9 @@
datatype t = T of int
val toString : t -> string
val eq: t * t -> bool
+(*
val return : t
+*)
val top : t
val one : t
val total : int
@@ -167,6 +172,7 @@
val eq : t * t -> bool
val toImmediate : t -> Immediate.t
val fromBytes : int -> t
+ val fromCType : CFunction.CType.t -> t
end
structure Address :
@@ -230,6 +236,10 @@
scale: Scale.t,
size: Size.t,
class: Class.t} -> t
+ val shift : {origin: t,
+ disp: Immediate.t,
+ scale: Scale.t,
+ size: Size.t} -> t
val destruct : t -> u
val clearAll : unit -> unit
@@ -251,7 +261,10 @@
size: Size.t,
class: Class.t} -> t
(* CReturn locations *)
+(*
val cReturnTempContent : Size.t -> t
+ val cReturnTempContents : CFunction.CType.t -> t list
+*)
end
structure ClassSet : SET
@@ -291,6 +304,8 @@
val size : t -> Size.t option
val eq : t * t -> bool
+
+ val cReturnTemps: CFunction.CType.t -> {src: t, dst: MemLoc.t} list
end
structure Instruction :
@@ -716,14 +731,10 @@
* used before C calls.
*)
| CCall
- (* Assert that the return value is in a register;
- * used after C calls.
- *)
- | Return of {memloc: MemLoc.t}
- (* Assert that the return value is in a float register;
- * used after C calls.
- *)
- | FltReturn of {memloc: MemLoc.t}
+ (* Assert the return value;
+ * used after C calls.
+ *)
+ | Return of {returns: {src:Operand.t, dst: MemLoc.t} list}
(* Misc. *)
(* Assert that the register is not free for the allocator;
* used ???
@@ -780,8 +791,7 @@
dead_memlocs: MemLocSet.t,
dead_classes: ClassSet.t} -> t
val ccall : unit -> t
- val return : {memloc: MemLoc.t} -> t
- val fltreturn : {memloc: MemLoc.t} -> t
+ val return : {returns: {src: Operand.t, dst: MemLoc.t} list} -> t
val reserve : {registers: Register.t list} -> t
val unreserve : {registers: Register.t list} -> t
val clearflt : unit -> t
@@ -864,8 +874,7 @@
dead_memlocs: MemLocSet.t,
dead_classes: ClassSet.t} -> t
val directive_ccall : unit -> t
- val directive_return : {memloc: MemLoc.t} -> t
- val directive_fltreturn : {memloc: MemLoc.t} -> t
+ val directive_return : {returns: {src: Operand.t, dst: MemLoc.t} list} -> t
val directive_reserve : {registers: Register.t list} -> t
val directive_unreserve : {registers: Register.t list} -> t
val directive_saveregalloc : {live: MemLocSet.t,
@@ -1060,7 +1069,7 @@
| Handler of {frameInfo: FrameInfo.t,
label: Label.t,
live: MemLocSet.t}
- | CReturn of {dst: (Operand.t * Size.t) option,
+ | CReturn of {dsts: (Operand.t * Size.t) vector,
frameInfo: FrameInfo.t option,
func: CFunction.t,
label: Label.t}
@@ -1068,7 +1077,7 @@
val cont : {label: Label.t,
live: MemLocSet.t,
frameInfo: FrameInfo.t} -> t
- val creturn: {dst: (Operand.t * Size.t) option,
+ val creturn: {dsts: (Operand.t * Size.t) vector,
frameInfo: FrameInfo.t option,
func: CFunction.t,
label: Label.t} -> t
@@ -1149,7 +1158,6 @@
| Return of {live: MemLocSet.t}
| Raise of {live: MemLocSet.t}
| CCall of {args: (Operand.t * Size.t) list,
- dstsize: Size.t option,
frameInfo: FrameInfo.t option,
func: CFunction.t,
return: Label.t option,
@@ -1182,7 +1190,6 @@
val return : {live: MemLocSet.t} -> t
val raisee : {live: MemLocSet.t} -> t
val ccall: {args: (Operand.t * Size.t) list,
- dstsize: Size.t option,
frameInfo: FrameInfo.t option,
func: CFunction.t,
return: Label.t option,
-------------------------------------------------------
This SF.Net email sponsored by: Free pre-built ASP.NET sites including
Data Reports, E-commerce, Portals, and Forums are available now.
Download today and enter to win an XBOX or Visual Studio .NET.
http://aspnet.click-url.com/go/psa00100003ave/direct;at.aspnet_072303_01/01
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel