[MLton-devel] cvs commit: mark compact GC and x86-codegen changes
Matthew Fluet
fluet@users.sourceforge.net
Wed, 10 Jul 2002 19:16:50 -0700
fluet 02/07/10 19:16:50
Modified: bin regression
mlton/backend c-function.fun runtime.fun runtime.sig
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-codegen.fun
x86-entry-transfer.fun x86-generate-transfers.fun
x86-jump-info.fun x86-live-transfers.fun
x86-loop-info.fun x86-mlton-basic.fun
x86-mlton-basic.sig x86-mlton.fun x86-pseudo.sig
x86-simplify.fun x86-translate.fun x86.fun x86.sig
runtime/basis Thread.c
Log:
Here is a working checkin of the native codegen with the mark compact
GC. Passes all regressions (with -debug true -gc-check first) and a
self compile, both with MARK_VERIFY=TRUE. I've left the mark compact
GC disabled for now.
I added an additional check to CFunction.isOK that asserts
maySwitchThreads => returnTy = NONE
Nothing currently violates this check, but I was getting a headache
trying to figure out the right caching of values across a thread
switching function that returns a value, not to mention which thread
should receive the returned value.
The new CFunction interface is nice; it lets me express a (trivial)
optimization of GC calls. In particular, when a program doesn't
handle signals, then a GC won't ever change threads. Therefore, we
don't need to do an indirect jump to stackTop on return, since we know
that that will be the same return address that we pushed before the
call. Overall, I doubt it will make any performance difference, but
it was easily added.
There are a couple of outstanding issues with threads, but nothing
that inhibits compilation. My straightforward port of ccodegen.h's
Thread_switchTo to native assembly is busted, but peforming
Thread_switchTo via a C-call into Thread.c works fine. (Really don't
know why.) There is also some extraneous shuffling of the return
value from a C-call that mayGC; this is a side-effect of having
previously assumed that runtime calls don't return. The basic issue
is that the way the return value is cached was partially relying on
the fact that a CCall was always followed by a unique CReturn to which
the code generator could just fall thru, thereby never needing to move
the return value anywere. While a mayGC call that returns will also
have a unique CReturn, we can't fall thru, because the frame layouts
data is prefixed to that code in order to GC the top frame. So, we
need to do an explicit jump, and I need to go back to
x86-live-transfers.fun to instruct it to cache the returned value in a
register over that jump. Right now we spill it and reload it, which
is semantically correct, and since it is a write followed by a read,
probably always hits the cache, but it shouldn't be too hard to fix.
Other than that, every thing seems to be in order. I also just
started a regression with -debug true -gc-check first -inline-array
false, and I didn't get any failures through "list".
Revision Changes Path
1.46 +2 -2 mlton/bin/regression
Index: regression
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/regression,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- regression 6 Jul 2002 16:30:14 -0000 1.45
+++ regression 11 Jul 2002 02:16:48 -0000 1.46
@@ -6,7 +6,7 @@
name=`basename $0`
function usage {
- echo >&2 "usage: $name [-cross host] [-run-only] [mlton flag ...]"
+ echo >&2 "usage: $name [-cross host] [-run-only] [mlton flags ...]"
exit 1
}
@@ -77,7 +77,7 @@
$mlton $flags $extraFlags $f.sml
if [ $? -ne 0 ]; then
compFail $f
- exit 1
+# exit 1
fi
fi
if [ ! -r $f.nonterm -a $cross = 'no' ]; then
1.2 +16 -8 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- c-function.fun 6 Jul 2002 17:22:05 -0000 1.1
+++ c-function.fun 11 Jul 2002 02:16:49 -0000 1.2
@@ -49,17 +49,25 @@
fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
modifiesStackTop, needsArrayInit, returnTy, ...}): bool =
+ (if maySwitchThreads
+ then (case returnTy of
+ NONE => true
+ | SOME t => false)
+ else true)
+ andalso
(if ensuresBytesFree orelse maySwitchThreads
then mayGC
else true)
- andalso (if mayGC
- then modifiesFrontier andalso modifiesStackTop
- else true)
- andalso (if needsArrayInit
- then (case returnTy of
- NONE => false
- | SOME t => Type.equals (t, Type.pointer))
- else true)
+ andalso
+ (if mayGC
+ then modifiesFrontier andalso modifiesStackTop
+ else true)
+ andalso
+ (if needsArrayInit
+ then (case returnTy of
+ NONE => false
+ | SOME t => Type.equals (t, Type.pointer))
+ else true)
val isOk = Trace.trace ("CFunction.isOk", layout, Bool.layout) isOk
1.2 +1 -0 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- runtime.fun 6 Jul 2002 17:22:05 -0000 1.1
+++ runtime.fun 11 Jul 2002 02:16:49 -0000 1.2
@@ -143,6 +143,7 @@
val wordSize: int = 4
val arrayHeaderSize = 3 * wordSize
+val intInfOverheadSize = arrayHeaderSize + wordSize (* for the sign *)
val labelSize = wordSize
val limitSlop: int = 512
val normalHeaderSize = wordSize
1.11 +1 -0 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- runtime.sig 6 Jul 2002 17:22:05 -0000 1.10
+++ runtime.sig 11 Jul 2002 02:16:49 -0000 1.11
@@ -73,6 +73,7 @@
val array0Size: int
val headerToTypeIndex: word -> int
val isWordAligned: int -> bool
+ val intInfOverheadSize: int
val labelSize: int
(* Same as LIMIT_SLOP from gc.c. *)
val limitSlop: int
1.23 +7 -15 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- c-codegen.fun 6 Jul 2002 17:22:06 -0000 1.22
+++ c-codegen.fun 11 Jul 2002 02:16:49 -0000 1.23
@@ -53,12 +53,6 @@
val traceGotoLabel = Trace.trace ("gotoLabel", Label.layout, Unit.layout)
-val wordSize: int = 4
-val pointerSize = wordSize
-val objectHeaderSize = wordSize
-val arrayHeaderSize = 2 * wordSize
-val intInfOverhead = arrayHeaderSize + wordSize (* for the sign *)
-
val overhead = "**C overhead**"
structure C =
@@ -217,8 +211,8 @@
C.call ("Globals",
List.map (List.map (let open Type
in [char, double, int, pointer, uint]
- end,
- globals) @ [globalsNonRoot],
+ end,
+ globals) @ [globalsNonRoot],
C.int),
print)
fun locals ty =
@@ -228,12 +222,10 @@
else max)
fun declareLocals () =
C.call ("Locals",
- List.map (List.map (let
- open Type
- in
- [char, double, int, pointer, uint]
+ List.map (List.map (let open Type
+ in [char, double, int, pointer, uint]
end,
- locals),
+ locals),
C.int),
print)
fun declareIntInfs () =
@@ -294,11 +286,11 @@
let
val stringSizes =
List.fold (strings, 0, fn ((_, s), n) =>
- n + arrayHeaderSize
+ n + Runtime.arrayHeaderSize
+ Type.align (Type.pointer, String.size s))
val intInfSizes =
List.fold (intInfs, 0, fn ((_, s), n) =>
- n + intInfOverhead
+ n + Runtime.intInfOverheadSize
+ Type.align (Type.pointer, String.size s))
val bytesLive = intInfSizes + stringSizes
val (usedFixedHeap, fromSize) =
1.27 +15 -41 mlton/mlton/codegen/x86-codegen/x86-codegen.fun
Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- x86-codegen.fun 6 Jul 2002 17:22:06 -0000 1.26
+++ x86-codegen.fun 11 Jul 2002 02:16:49 -0000 1.27
@@ -9,12 +9,6 @@
struct
open S
- val wordSize: int = 4
- val pointerSize = wordSize
- val objectHeaderSize = wordSize
- val arrayHeaderSize = 2 * wordSize
- val intInfOverhead = arrayHeaderSize + wordSize (* for the sign *)
-
structure x86
= x86(structure Label = Machine.Label
structure Runtime = Machine.Runtime)
@@ -163,18 +157,6 @@
| SOME fi => (label, fi) :: l))
local
- val shift = let
- val w = Word.fromInt (maxFrameSize div 4)
- fun loop i
- = if i = Word.wordSize
- orelse
- Word.nthBitIsSet(w, i)
- then Word.wordSize - i
- else loop (i + 1)
- val shift = loop 0
- in
- Word.fromInt (maxFrameSize div 4)
- end
val hash' = fn {size, offsetIndex} => Word.fromInt (offsetIndex)
val hash = fn {size, offsetIndex, frameLayoutsIndex}
=> hash' {size = size, offsetIndex = offsetIndex}
@@ -186,26 +168,25 @@
val _
= List.foreach
(return_labels,
- fn (label,
- Machine.FrameInfo.T {size, frameOffsetsIndex = offsetIndex})
+ fn (label, Machine.FrameInfo.T {size, frameOffsetsIndex = offsetIndex})
=> let
- val info = {size = size, offsetIndex = offsetIndex}
+ val info = {size = size, offsetIndex = offsetIndex}
val {frameLayoutsIndex, ...}
= HashSet.lookupOrInsert
(table,
hash' info,
- fn {size = size', offsetIndex = offsetIndex', ...}
- => size = size' andalso offsetIndex = offsetIndex',
- fn ()
- => let
- val _ = List.push(frameLayoutsData', info)
- val frameLayoutsIndex = !maxFrameLayoutIndex'
- val _ = Int.inc maxFrameLayoutIndex'
- in
- {size = size,
- offsetIndex = offsetIndex,
- frameLayoutsIndex = frameLayoutsIndex}
- end)
+ fn {size = size', offsetIndex = offsetIndex', ...} =>
+ size = size' andalso offsetIndex = offsetIndex',
+ fn () =>
+ let
+ val _ = List.push(frameLayoutsData', info)
+ val frameLayoutsIndex = !maxFrameLayoutIndex'
+ val _ = Int.inc maxFrameLayoutIndex'
+ in
+ {size = size,
+ offsetIndex = offsetIndex,
+ frameLayoutsIndex = frameLayoutsIndex}
+ end)
in
setFrameLayoutIndex
(label,
@@ -220,13 +201,6 @@
fun outputC ()
= let
val {file, print, done} = makeC ()
- fun locals ty
- = List.fold(chunks,
- 0,
- fn (Machine.Chunk.T {regMax, ...},max)
- => if regMax ty > max
- then regMax ty
- else max)
fun make(name, l, pr)
= (print (concat["static ", name, " = {"]);
List.foreachi(l,
@@ -252,7 +226,7 @@
| Control.Linux => mainLabel
in
[mainLabel,
- if reserveEsp then "TRUE" else "FALSE"]
+ if reserveEsp then C.truee else C.falsee]
end
fun rest () =
declareFrameLayouts()
1.7 +33 -29 mlton/mlton/codegen/x86-codegen/x86-entry-transfer.fun
Index: x86-entry-transfer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-entry-transfer.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- x86-entry-transfer.fun 6 Jul 2002 17:22:06 -0000 1.6
+++ x86-entry-transfer.fun 11 Jul 2002 02:16:49 -0000 1.7
@@ -39,36 +39,40 @@
fun isHandler l = case get l
of SOME (Block.T {entry = Entry.Handler _, ...}) => true
| _ => false
- fun isCReturn l = case get l
- of SOME (Block.T {entry = Entry.CReturn _, ...}) => true
- | _ => false
+ fun isCReturn l f = case get l
+ of SOME (Block.T {entry = Entry.CReturn {func, ...}, ...})
+ => Runtime.CFunction.equals (f, func)
+ | _ => false
+ val b = List.forall
+ (blocks,
+ fn block as Block.T {entry, transfer, ...}
+ => (case transfer
+ of Transfer.Goto {target, ...}
+ => isJump target
+ | Transfer.Iff {truee, falsee, ...}
+ => isJump truee andalso isJump falsee
+ | Transfer.Switch {cases, default, ...}
+ => isJump default andalso
+ Transfer.Cases.forall(cases, isJump)
+ | Transfer.Tail {target, ...}
+ => isFunc target
+ | Transfer.NonTail {target, return, handler, ...}
+ => isFunc target andalso
+ isCont return andalso
+ (case handler
+ of SOME handler => isHandler handler
+ | NONE => true)
+ | Transfer.Return {...} => true
+ | Transfer.Raise {...} => true
+ | Transfer.CCall {return, func, ...}
+ => (case return
+ of NONE => true
+ | SOME l => isCReturn l func)))
+ val _ = destroy ()
+ val _ = if b then ()
+ else List.foreach(blocks, Block.printBlock)
in
- List.forall
- (blocks,
- fn block as Block.T {entry, transfer, ...}
- => (case transfer
- of Transfer.Goto {target, ...}
- => isJump target
- | Transfer.Iff {truee, falsee, ...}
- => isJump truee andalso isJump falsee
- | Transfer.Switch {cases, default, ...}
- => isJump default andalso
- Transfer.Cases.forall(cases, isJump)
- | Transfer.Tail {target, ...}
- => isFunc target
- | Transfer.NonTail {target, return, handler, ...}
- => isFunc target andalso
- isCont return andalso
- (case handler
- of SOME handler => isHandler handler
- | NONE => true)
- | Transfer.Return {...} => true
- | Transfer.Raise {...} => true
- | Transfer.CCall {return, ...} =>
- (case return of
- NONE => true
- | SOME l => isCReturn l)))
- before destroy ()
+ b
end
val (verifyEntryTranfer, verifyEntryTransfer_msg)
1.30 +500 -253 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.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- x86-generate-transfers.fun 6 Jul 2002 17:22:06 -0000 1.29
+++ x86-generate-transfers.fun 11 Jul 2002 02:16:49 -0000 1.30
@@ -155,6 +155,28 @@
else l}
end
+ fun runtimeTransfer live setup trans
+ = AppendList.appends
+ [AppendList.single
+ (Assembly.directive_force
+ {commit_memlocs = removeHoldMemLocs live,
+ commit_classes = ClassSet.empty,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = MemLocSet.empty,
+ dead_classes = ClassSet.empty}),
+ setup,
+ AppendList.fromList
+ [(Assembly.directive_clearflt ()),
+ (Assembly.directive_force
+ {commit_memlocs = MemLocSet.empty,
+ commit_classes = farflushClasses,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = MemLocSet.empty,
+ dead_classes = ClassSet.empty})],
+ trans]
+
fun runtimeEntry l = AppendList.cons (blockAssumes [], l)
fun farEntry l = AppendList.cons (blockAssumes [], l)
@@ -268,10 +290,7 @@
jumpInfo = jumpInfo,
loopInfo = loopInfo}
handle exn
- => Error.bug ("x86LiveTransfers.computeLiveTransfers::" ^
- (case exn
- of Fail s => s
- | _ => "?"))
+ => Error.reraise (exn, "x86LiveTransfers.computeLiveTransfers")
val getLiveRegsTransfers
= #1 o x86LiveTransfers.getLiveTransfers
@@ -351,7 +370,27 @@
label'
end
+ val c_stackP = x86MLton.c_stackPContentsOperand
+
+ fun cacheEsp () =
+ if reserveEsp
+ then AppendList.empty
+ else
+ AppendList.single
+ ((* explicit cache in case there are no args *)
+ Assembly.directive_cache
+ {caches = [{register = Register.esp,
+ memloc = valOf (Operand.deMemloc c_stackP),
+ reserve = true}]})
+
+ fun unreserveEsp () =
+ if reserveEsp
+ then AppendList.empty
+ else AppendList.single (Assembly.directive_unreserve
+ {registers = [Register.esp]})
+
datatype z = datatype Entry.t
+ datatype z = datatype Transfer.t
fun generateAll (gef as GEF {generate,effect,fall})
{label, falling, unique} :
Assembly.t AppendList.t
@@ -426,65 +465,95 @@
= case entry
of Jump {label}
=> near label
- | CReturn {dst, 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 = x86MLton.cReturnTempContentsOperand dstsize,
- size = dstsize})
- | Size.FLT
- => AppendList.single
- (x86.Assembly.instruction_pfmov
- {dst = dst,
- src = x86MLton.cReturnTempContentsOperand dstsize,
- size = dstsize})
- | _ => Error.bug "CReturn")
+ | CReturn {dst,
+ frameInfo,
+ func = CFunction.T {mayGC,
+ maySwitchThreads,
+ name, ...},
+ 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.cReturnTempContents
+ dstsize),
+ size = dstsize})
+ | Size.FLT
+ => AppendList.single
+ (x86.Assembly.instruction_pfmov
+ {dst = dst,
+ src = Operand.memloc
+ (MemLoc.cReturnTempContents
+ dstsize),
+ size = dstsize})
+ | _ => Error.bug "CReturn")
in
- if not (CFunction.mayGC func)
- then
- AppendList.append
- (near label, getReturn ())
- else
- let
- val FrameInfo.T {size, frameLayoutsIndex} =
- valOf frameInfo
- in
- AppendList.append
- (AppendList.fromList
- [Assembly.pseudoop_p2align
- (Immediate.const_int 4, NONE, NONE),
- Assembly.pseudoop_long
- [Immediate.const_int frameLayoutsIndex],
- Assembly.label label],
- (* entry from far assumptions *)
- (farEntry
- (AppendList.appends
- [profile_assembly,
- let
- val stackTop
- = x86MLton.gcState_stackTopContentsOperand ()
- val bytes
- = x86.Operand.immediate_const_int (~ size)
- in
- (* stackTop += bytes *)
- AppendList.single
- (x86.Assembly.instruction_binal
- {oper = x86.Instruction.ADD,
- dst = stackTop,
- src = bytes,
- size = pointerSize})
- end,
- (* assignTo dst *)
- getReturn ()])))
- end
+ if mayGC orelse maySwitchThreads
+ then let
+ val FrameInfo.T {size, frameLayoutsIndex}
+ = valOf frameInfo
+ val finish
+ = AppendList.appends
+ [profile_assembly,
+ let
+ val stackTop
+ = x86MLton.gcState_stackTopContentsOperand ()
+ val bytes
+ = x86.Operand.immediate_const_int (~ size)
+ in
+ (* stackTop += bytes *)
+ AppendList.single
+ (x86.Assembly.instruction_binal
+ {oper = x86.Instruction.ADD,
+ dst = stackTop,
+ src = bytes,
+ size = pointerSize})
+ end,
+ (* assignTo dst *)
+ getReturn ()]
+ in
+ AppendList.append
+ (AppendList.fromList
+ [Assembly.pseudoop_p2align
+ (Immediate.const_int 4, NONE, NONE),
+ Assembly.pseudoop_long
+ [Immediate.const_int frameLayoutsIndex],
+ Assembly.label label],
+ if maySwitchThreads
+ then (* entry from far assumptions *)
+ farEntry finish
+ else (* near entry & live transfer assumptions *)
+ AppendList.append
+ (AppendList.fromList
+ [(blockAssumes
+ (List.map
+ (getLiveRegsTransfers
+ (liveTransfers, label),
+ fn (memloc,register,sync)
+ => {register = register,
+ memloc = memloc,
+ sync = sync,
+ weight = 1024,
+ reserve = false}))),
+ (Assembly.directive_fltassume
+ {assumes
+ = (List.map
+ (getLiveFltRegsTransfers
+ (liveTransfers, label),
+ fn (memloc,sync)
+ => {memloc = memloc,
+ sync = sync,
+ weight = 1024}))})],
+ finish))
+ end
+ else AppendList.append (near label, getReturn ())
end
| Func {label,...}
=> AppendList.append
@@ -604,27 +673,7 @@
transfer]
end)
- val c_stackP = x86MLton.c_stackPContentsOperand
-
- fun cacheEsp () =
- if reserveEsp
- then AppendList.empty
- else
- AppendList.single
- ((* explicit cache in case there are no args *)
- Assembly.directive_cache
- {caches = [{register = Register.esp,
- memloc = valOf (Operand.deMemloc c_stackP),
- reserve = true}]})
-
- fun unreserveEsp () =
- if reserveEsp
- then AppendList.empty
- else AppendList.single (Assembly.directive_unreserve
- {registers = [Register.esp]})
-
- datatype z = datatype Transfer.t
- fun effectDefault (gef as GEF {generate,effect,fall})
+ and effectDefault (gef as GEF {generate,effect,fall})
{label, transfer} : Assembly.t AppendList.t
= AppendList.append
(if !Control.Native.commented > 1
@@ -918,6 +967,161 @@
{target = stackTopDeref,
absolute = true})))
end
+(*
+ | CCall {args, dstsize,
+ frameInfo,
+ func = CFunction.T {mayGC,
+ maySwitchThreads,
+ modifiesFrontier,
+ modifiesStackTop,
+ name = "Thread_switchTo", ...},
+ return, target}
+ => let
+ val return = valOf return
+ val _ = enque return
+ val FrameInfo.T {size, ...} = valOf frameInfo
+ val bytes = x86.Operand.immediate_const_int size
+
+ val live = x86Liveness.LiveInfo.getLive(liveInfo, return)
+
+ val (thread,threadsize)
+ = case args
+ of [(thread,threadsize)] => (thread,threadsize)
+ | _ => Error.bug "x86GenerateTransfers::CCall: Thread_switchTo"
+ val threadTemp
+ = x86MLton.threadTempContentsOperand
+
+ val stackTop
+ = x86MLton.gcState_stackTopContentsOperand ()
+ val stackTopMinusWordDeref'
+ = x86MLton.gcState_stackTopMinusWordDeref ()
+ val stackTopMinusWordDeref
+ = x86MLton.gcState_stackTopMinusWordDerefOperand ()
+
+ val currentThread
+ = x86MLton.gcState_currentThreadContentsOperand ()
+ val stack
+ = x86MLton.gcState_currentThread_stackContentsOperand ()
+ val stack_used
+ = x86MLton.gcState_currentThread_stack_usedContentsOperand ()
+ val stack_reserved
+ = x86MLton.gcState_currentThread_stack_reservedContentsOperand ()
+ val stackBottom
+ = x86MLton.gcState_stackBottomContentsOperand ()
+ val stackLimit
+ = x86MLton.gcState_stackLimitContentsOperand ()
+ val maxFrameSize
+ = x86MLton.gcState_maxFrameSizeContentsOperand ()
+ val canHandle
+ = x86MLton.gcState_canHandleContentsOperand ()
+ val signalIsPending
+ = x86MLton.gcState_signalIsPendingContentsOperand ()
+ val limit
+ = x86MLton.gcState_limitContentsOperand ()
+ val base
+ = x86MLton.gcState_baseContentsOperand ()
+ in
+ AppendList.append
+ (AppendList.fromList
+ [(* threadTemp = thread *)
+ Assembly.instruction_mov
+ {dst = threadTemp,
+ src = thread,
+ size = pointerSize},
+ (* stackTop += bytes *)
+ x86.Assembly.instruction_binal
+ {oper = x86.Instruction.ADD,
+ dst = stackTop,
+ src = bytes,
+ size = pointerSize},
+ (* *(stackTop - WORD_SIZE) = return *)
+ x86.Assembly.instruction_mov
+ {dst = stackTopMinusWordDeref,
+ src = Operand.immediate_label return,
+ size = pointerSize},
+ (* flushing at Runtime *)
+ Assembly.directive_force
+ {commit_memlocs = LiveSet.toMemLocSet live,
+ commit_classes = threadflushClasses,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = MemLocSet.empty,
+ dead_classes = ClassSet.empty},
+ Assembly.directive_force
+ {commit_memlocs = MemLocSet.empty,
+ commit_classes = ClassSet.empty,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = MemLocSet.empty,
+ dead_classes = threadflushClasses},
+ (* currentThread->stack->used = stackTop - stackBottom *)
+ Assembly.instruction_mov
+ {dst = stack_used,
+ src = stackTop,
+ size = pointerSize},
+ Assembly.instruction_binal
+ {oper = Instruction.SUB,
+ dst = stack_used,
+ src = stackBottom,
+ size = pointerSize},
+ (* currentThread = threadTemp *)
+ Assembly.instruction_mov
+ {src = threadTemp,
+ dst = currentThread,
+ size = pointerSize},
+ (* stackBottom = currentThread->stack + sizeOf(GC_stack) *)
+ Assembly.instruction_mov
+ {dst = stackBottom,
+ src = stack,
+ size = pointerSize},
+ Assembly.instruction_binal
+ {oper = Instruction.ADD,
+ dst = stackBottom,
+ src = Operand.immediate_const_int 16,
+ size = pointerSize},
+ (* stackTop = stackBottom + currentThread->stack->used *)
+ Assembly.instruction_mov
+ {dst = stackTop,
+ src = stackBottom,
+ size = pointerSize},
+ Assembly.instruction_binal
+ {oper = Instruction.ADD,
+ dst = stackTop,
+ src = stack_used,
+ size = pointerSize},
+ (* stackLimit
+ * = stackBottom + currentThread->stack->reserved
+ * - 2 * maxFrameSize
+ *)
+ Assembly.instruction_mov
+ {dst = stackLimit,
+ src = stackBottom,
+ size = pointerSize},
+ Assembly.instruction_binal
+ {oper = Instruction.ADD,
+ dst = stackLimit,
+ src = stack_reserved,
+ size = pointerSize},
+ Assembly.instruction_binal
+ {oper = Instruction.SUB,
+ dst = stackLimit,
+ src = maxFrameSize,
+ size = pointerSize},
+ Assembly.instruction_binal
+ {oper = Instruction.SUB,
+ dst = stackLimit,
+ src = maxFrameSize,
+ size = pointerSize}],
+ (* flushing at far transfer *)
+ (farTransfer MemLocSet.empty
+ AppendList.empty
+ (AppendList.single
+ (* jmp *(stackTop - WORD_SIZE) *)
+ (x86.Assembly.instruction_jmp
+ {target = stackTopMinusWordDeref,
+ absolute = true}))))
+ end
+*)
| CCall {args, dstsize,
frameInfo,
func = CFunction.T {mayGC,
@@ -926,176 +1130,219 @@
modifiesStackTop,
name, ...},
return, target}
- => let
- val stackTopMinusWordDeref =
- x86MLton.gcState_stackTopMinusWordDerefOperand ()
- val {dead, ...} =
- livenessTransfer {transfer = transfer,
- liveInfo = liveInfo}
- val c_stackP = x86MLton.c_stackPContentsOperand
- val c_stackPDerefDouble =
- x86MLton.c_stackPDerefDoubleOperand
- val applyFFTemp = x86MLton.applyFFTempContentsOperand
- val (pushArgs, size_args) =
- List.fold
- (args, (AppendList.empty, 0),
- fn ((arg, size), (assembly_args, size_args)) =>
- (AppendList.append
- (if Size.eq (size, Size.DBLE)
- then AppendList.fromList
- [Assembly.instruction_binal
- {oper = Instruction.SUB,
- dst = c_stackP,
- src = Operand.immediate_const_int 8,
+ => let
+ val stackTopMinusWordDeref
+ = x86MLton.gcState_stackTopMinusWordDerefOperand ()
+ val {dead, ...}
+ = livenessTransfer {transfer = transfer,
+ liveInfo = liveInfo}
+ val c_stackP = x86MLton.c_stackPContentsOperand
+ val c_stackPDerefDouble = x86MLton.c_stackPDerefDoubleOperand
+ val applyFFTemp = x86MLton.applyFFTempContentsOperand
+
+ val (pushArgs, size_args)
+ = List.fold
+ (args, (AppendList.empty, 0),
+ fn ((arg, size), (assembly_args, size_args)) =>
+ (AppendList.append
+ (if Size.eq (size, Size.DBLE)
+ then AppendList.fromList
+ [Assembly.instruction_binal
+ {oper = Instruction.SUB,
+ dst = c_stackP,
+ src = Operand.immediate_const_int 8,
+ size = pointerSize},
+ Assembly.instruction_pfmov
+ {src = arg,
+ dst = c_stackPDerefDouble,
+ size = size}]
+ else if Size.eq (size, Size.BYTE)
+ then AppendList.fromList
+ [Assembly.instruction_movx
+ {oper = Instruction.MOVZX,
+ dst = applyFFTemp,
+ src = arg,
+ dstsize = wordSize,
+ srcsize = size},
+ Assembly.instruction_ppush
+ {src = applyFFTemp,
+ base = c_stackP,
+ size = wordSize}]
+ else AppendList.single
+ (Assembly.instruction_ppush
+ {src = arg,
+ base = c_stackP,
+ size = size}),
+ assembly_args),
+ (Size.toBytes size) + size_args))
+ val flush
+ = if mayGC orelse maySwitchThreads
+ then (* Entering runtime *)
+ let
+ val return = valOf return
+ val _ = enque return
+
+ val stackTop
+ = x86MLton.gcState_stackTopContentsOperand ()
+ val stackTopMinusWordDeref'
+ = x86MLton.gcState_stackTopMinusWordDeref ()
+ val stackTopMinusWordDeref
+ = x86MLton.gcState_stackTopMinusWordDerefOperand ()
+ val FrameInfo.T {size, ...} = valOf frameInfo
+ val bytes = x86.Operand.immediate_const_int size
+
+ val live
+ = x86Liveness.LiveInfo.getLive(liveInfo, return)
+ in
+ (runtimeTransfer (LiveSet.toMemLocSet live)
+ (AppendList.fromList
+ [(* stackTop += bytes *)
+ x86.Assembly.instruction_binal
+ {oper = x86.Instruction.ADD,
+ dst = stackTop,
+ src = bytes,
size = pointerSize},
- Assembly.instruction_pfmov
- {src = arg,
- dst = c_stackPDerefDouble,
- size = size}]
- else if Size.eq (size, Size.BYTE)
- then AppendList.fromList
- [Assembly.instruction_movx
- {oper = Instruction.MOVZX,
- dst = applyFFTemp,
- src = arg,
- dstsize = wordSize,
- srcsize = size},
- Assembly.instruction_ppush
- {src = applyFFTemp,
- base = c_stackP,
- size = wordSize}]
- else AppendList.single
- (Assembly.instruction_ppush
- {src = arg,
- base = c_stackP,
- size = size}),
- assembly_args),
- (Size.toBytes size) + size_args))
- val flush =
- if not mayGC
- then
- AppendList.single
- (Assembly.directive_force
- {commit_memlocs = MemLocSet.empty,
- commit_classes = ccallflushClasses,
- remove_memlocs = MemLocSet.empty,
- remove_classes = ClassSet.empty,
- dead_memlocs = LiveSet.toMemLocSet dead,
- dead_classes = ClassSet.empty})
- else
- let
- val return = valOf return
- val _ = enque return
- val FrameInfo.T {size, ...} = valOf frameInfo
- val stackTop' =
- x86MLton.gcState_stackTopContents ()
- val stackTop =
- x86MLton.gcState_stackTopContentsOperand ()
- val bytes =
- x86.Operand.immediate_const_int size
- val live =
- x86Liveness.LiveInfo.getLive
- (liveInfo, return)
- val target = Label.fromString name
- in
- AppendList.fromList
- [x86.Assembly.directive_force
- {commit_memlocs = MemLocSet.empty,
- commit_classes = ClassSet.empty,
- remove_memlocs = MemLocSet.empty,
- remove_classes = ClassSet.empty,
- dead_memlocs = LiveSet.toMemLocSet dead,
- dead_classes = ClassSet.empty},
- (* stackTop += bytes *)
- x86.Assembly.instruction_binal
- {oper = x86.Instruction.ADD,
- dst = stackTop,
- src = bytes,
- size = pointerSize},
- (* *(stackTop - WORD_SIZE) = return *)
- x86.Assembly.instruction_mov
- {dst = stackTopMinusWordDeref,
- src = Operand.immediate_label return,
- size = pointerSize},
- Assembly.directive_force
- {commit_memlocs = LiveSet.toMemLocSet live,
- commit_classes = runtimeClasses,
- remove_memlocs = MemLocSet.empty,
- remove_classes = ClassSet.empty,
- dead_memlocs = MemLocSet.empty,
- dead_classes = ClassSet.empty}]
- end
- val kill =
- AppendList.single
- (Assembly.directive_force
- {commit_memlocs = MemLocSet.empty,
- commit_classes = ClassSet.empty,
- remove_memlocs = MemLocSet.empty,
- remove_classes = ClassSet.empty,
- dead_memlocs = MemLocSet.empty,
- dead_classes = if mayGC
- then runtimeClasses
- else ccallflushClasses})
- val call =
- AppendList.fromList
- [Assembly.directive_ccall (),
- Assembly.instruction_call
- {target = Operand.label target,
- absolute = false}]
- val getResult =
- case dstsize of
- NONE => AppendList.empty
- | SOME dstsize =>
- (case Size.class dstsize of
- Size.INT =>
- AppendList.single
- (Assembly.directive_return
- {memloc =
- x86MLton.cReturnTempContents dstsize})
- | Size.FLT =>
- AppendList.single
- (Assembly.directive_fltreturn
- {memloc = x86MLton.cReturnTempContents dstsize})
+ (* *(stackTop - WORD_SIZE) = return *)
+ x86.Assembly.instruction_mov
+ {dst = stackTopMinusWordDeref,
+ src = Operand.immediate_label return,
+ size = pointerSize},
+ x86.Assembly.directive_force
+ {commit_memlocs = MemLocSet.singleton
+ stackTopMinusWordDeref',
+ commit_classes = ClassSet.empty,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = MemLocSet.empty,
+ dead_classes = ClassSet.empty}])
+ (AppendList.single
+ (Assembly.directive_force
+ {commit_memlocs = LiveSet.toMemLocSet live,
+ commit_classes = runtimeClasses,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = MemLocSet.empty,
+ dead_classes = ClassSet.empty})))
+ end
+ else AppendList.single
+ (Assembly.directive_force
+ {commit_memlocs = let
+ val s = MemLocSet.empty
+ val s = if modifiesFrontier
+ then MemLocSet.add
+ (s, frontier ())
+ else s
+ val s = if modifiesStackTop
+ then MemLocSet.add
+ (s, stackTop ())
+ else s
+ in
+ s
+ end,
+ commit_classes = ccallflushClasses,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = LiveSet.toMemLocSet dead,
+ dead_classes = ClassSet.empty})
+ val call
+ = AppendList.fromList
+ [Assembly.directive_ccall (),
+ Assembly.instruction_call
+ {target = Operand.label target,
+ absolute = false}]
+ val kill
+ = if mayGC orelse maySwitchThreads
+ then AppendList.single
+ (Assembly.directive_force
+ {commit_memlocs = MemLocSet.empty,
+ commit_classes = ClassSet.empty,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = MemLocSet.empty,
+ dead_classes = runtimeClasses})
+ else AppendList.single
+ (Assembly.directive_force
+ {commit_memlocs = MemLocSet.empty,
+ commit_classes = ClassSet.empty,
+ remove_memlocs = MemLocSet.empty,
+ remove_classes = ClassSet.empty,
+ dead_memlocs = let
+ val s = MemLocSet.empty
+ val s = if modifiesFrontier
+ then MemLocSet.add
+ (s, frontier ())
+ else s
+ val s = if modifiesStackTop
+ then MemLocSet.add
+ (s, stackTop ())
+ else s
+ in
+ 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.cReturnTempContents dstsize})
+ | Size.FLT
+ => AppendList.single
+ (Assembly.directive_fltreturn
+ {memloc = MemLoc.cReturnTempContents dstsize})
| _ => Error.bug "CCall")
- val fixCStack =
- if size_args > 0
- then (AppendList.single
- (Assembly.instruction_binal
- {oper = Instruction.ADD,
- dst = c_stackP,
- src = Operand.immediate_const_int size_args,
- size = pointerSize}))
+ val fixCStack
+ = if size_args > 0
+ then (AppendList.single
+ (Assembly.instruction_binal
+ {oper = Instruction.ADD,
+ dst = c_stackP,
+ src = Operand.immediate_const_int size_args,
+ size = pointerSize}))
else AppendList.empty
- val continue =
- if mayGC
- then
- (* flushing at far transfer *)
- (farTransfer MemLocSet.empty
- AppendList.empty
- (AppendList.single
- (* jmp *(stackTop - WORD_SIZE) *)
- (x86.Assembly.instruction_jmp
- {target = stackTopMinusWordDeref,
- absolute = true})))
- else
- case return of
- NONE => AppendList.empty
- | SOME l =>
- fall gef {label = l,
+ val continue
+ = if maySwitchThreads
+ then (* Returning from runtime *)
+ (farTransfer MemLocSet.empty
+ AppendList.empty
+ (AppendList.single
+ (* jmp *(stackTop - WORD_SIZE) *)
+ (x86.Assembly.instruction_jmp
+ {target = stackTopMinusWordDeref,
+ absolute = true})))
+ else case return
+ of NONE => AppendList.empty
+ | SOME l => (if mayGC
+ then (* Don't need to trampoline,
+ * since didn't switch threads,
+ * but can't fall because
+ * frame layout data is prefixed
+ * to l's code; use fallNone
+ * to force a jmp with near
+ * jump assumptions.
+ *)
+ fallNone
+ else fall)
+ gef
+ {label = l,
live = getLive (liveInfo, l)}
- in
- AppendList.appends
- [cacheEsp (),
- pushArgs,
- flush,
- call,
- kill,
- getResult,
- fixCStack,
- unreserveEsp (),
- continue]
- end)
- fun effectJumpTable (gef as GEF {generate,effect,fall})
+ in
+ AppendList.appends
+ [cacheEsp (),
+ pushArgs,
+ flush,
+ call,
+ kill,
+ getResult,
+ fixCStack,
+ unreserveEsp (),
+ continue]
+ end)
+
+ and effectJumpTable (gef as GEF {generate,effect,fall})
{label, transfer} : Assembly.t AppendList.t
= case transfer
of Switch {test, cases, default}
@@ -1480,7 +1727,7 @@
{label = label,
transfer = transfer}
- fun fallNone (gef as GEF {generate,effect,fall})
+ and fallNone (gef as GEF {generate,effect,fall})
{label, live} : Assembly.t AppendList.t
= let
val liveRegsTransfer = getLiveRegsTransfers
@@ -1553,10 +1800,10 @@
default ())
end
- datatype z = datatype x86JumpInfo.status
- fun fallDefault (gef as GEF {generate,effect,fall})
+ and fallDefault (gef as GEF {generate,effect,fall})
{label, live} : Assembly.t AppendList.t
- = let
+ = let
+ datatype z = datatype x86JumpInfo.status
val liveRegsTransfer = getLiveRegsTransfers
(liveTransfers, label)
val liveFltRegsTransfer = getLiveFltRegsTransfers
1.10 +7 -1 mlton/mlton/codegen/x86-codegen/x86-jump-info.fun
Index: x86-jump-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-jump-info.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- x86-jump-info.fun 6 Jul 2002 17:22:06 -0000 1.9
+++ x86-jump-info.fun 11 Jul 2002 02:16:49 -0000 1.10
@@ -65,7 +65,13 @@
| Entry.Func {label, ...} => forceNear (jumpInfo, label)
| Entry.Cont {label, ...} => forceNear (jumpInfo, label)
| Entry.Handler {label, ...} => forceNear (jumpInfo, label)
- | Entry.CReturn {label, ...} => ();
+ | Entry.CReturn {label,
+ func = Runtime.CFunction.T {maySwitchThreads,
+ ...},
+ ...}
+ => if maySwitchThreads
+ then forceNear (jumpInfo, label)
+ else ();
List.foreach
(Transfer.nearTargets transfer,
fn label
1.11 +12 -18 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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-live-transfers.fun 6 Jul 2002 17:22:06 -0000 1.10
+++ x86-live-transfers.fun 11 Jul 2002 02:16:49 -0000 1.11
@@ -261,7 +261,7 @@
of Entry.Func _ => label::funcs
| _ => funcs
in
- (labels, funcs)
+ (labels, funcs)
end)
val labels = Vector.fromList labels
@@ -273,13 +273,7 @@
fn label
=> let
val {block, ...} = getInfo label
- fun doit' target
- = let
- val {pred = pred', ...} = getInfo target
- in
- List.push (pred', label)
- end
- fun doit'' target
+ fun doit target
= let
val {pred = pred', ...} = getInfo target
in
@@ -291,26 +285,26 @@
in
case transfer
of Goto {target, ...}
- => doit' target
+ => doit target
| Iff {truee, falsee, ...}
- => (doit' truee;
- doit' falsee)
+ => (doit truee;
+ doit falsee)
| Switch {cases, default, ...}
- => (doit' default;
- Transfer.Cases.foreach(cases, doit'))
+ => (doit default;
+ Transfer.Cases.foreach(cases, doit))
| Tail {...}
=> ()
| NonTail {return, handler, ...}
- => (doit'' return;
+ => (doit return;
case handler
- of SOME handler => doit'' handler
+ of SOME handler => doit handler
| NONE => ())
| Return {...}
=> ()
| Raise {...}
=> ()
| CCall {return, ...}
- => Option.app (return, doit')
+ => Option.app (return, doit)
end)
val _
@@ -928,8 +922,8 @@
=> ()
| CCall {func, return, ...}
=> if CFunction.mayGC func
- then Option.app (return, doit'')
- else Option.app (return, doit')
+ then Option.app (return, doit'')
+ else Option.app (return, doit')
end
in
case !defed
1.12 +4 -2 mlton/mlton/codegen/x86-codegen/x86-loop-info.fun
Index: x86-loop-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-loop-info.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- x86-loop-info.fun 6 Jul 2002 17:22:06 -0000 1.11
+++ x86-loop-info.fun 11 Jul 2002 02:16:49 -0000 1.12
@@ -112,8 +112,10 @@
=> ()
| Raise {...}
=> ()
- | CCall {return, ...}
- => Option.app (return, doit')
+ | CCall {return, func, ...}
+ => Option.app (return, if Runtime.CFunction.mayGC func
+ then doit''
+ else doit')
end)
val lf = Graph.loopForestSteensgaard (G, {root = root})
1.2 +12 -48 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.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- x86-mlton-basic.fun 6 Jul 2002 17:22:06 -0000 1.1
+++ x86-mlton-basic.fun 11 Jul 2002 02:16:49 -0000 1.2
@@ -16,17 +16,17 @@
(*
* x86.Size.t equivalents
*)
- val wordSize = Size.LONG
- val wordBytes = Size.toBytes wordSize
- val wordScale = Scale.Four
- val pointerSize = Size.LONG
- val pointerBytes = Size.toBytes pointerSize
- val pointerScale = Scale.Four
+ val wordBytes = Runtime.wordSize
+ val wordSize = Size.fromBytes wordBytes
+ val wordScale = Scale.fromBytes wordBytes
+ val pointerBytes = Runtime.pointerSize
+ val pointerSize = Size.fromBytes pointerBytes
+ val pointerScale = Scale.fromBytes pointerBytes
val floatSize = Size.DBLE
val floatBytes = Size.toBytes floatSize
- val objectHeaderBytes = wordBytes
+ val normalHeaderBytes = Runtime.normalHeaderSize
val arrayHeaderBytes = Runtime.arrayHeaderSize
- val intInfOverheadBytes = arrayHeaderBytes + wordBytes
+ val intInfOverheadBytes = Runtime.intInfOverheadSize
local
open Machine.Type
@@ -62,12 +62,12 @@
val Locals = new "Locals"
val Globals = new "Globals"
- val Temp = MemLoc.Class.Temp
+ val Temp = MemLoc.Class.Temp
+ val StaticTemp = MemLoc.Class.StaticTemp
val CStack = MemLoc.Class.CStack
val Code = MemLoc.Class.Code
val CStatic = new "CStatic"
- val StaticTemp = new "StaticTemp"
val StaticNonTemp = new "StaticNonTemp"
val GCState = new "GCState"
@@ -94,10 +94,10 @@
Locals::
Globals::
Temp::
+ StaticTemp::
CStack::
Code::
CStatic::
- StaticTemp::
StaticNonTemp::
GCState::
GCStateHold::
@@ -154,16 +154,7 @@
end
end
- (*
- * Static memory locations
- *)
- fun makeContents {base, size, class}
- = MemLoc.imm {base = base,
- index = Immediate.const_int 0,
- scale = wordScale,
- size = size,
- class = class}
-
+ val makeContents = x86.MemLoc.makeContents
val c_stackP = Label.fromString "c_stackP"
val c_stackPContents
= makeContents {base = Immediate.label c_stackP,
@@ -187,33 +178,6 @@
class = Classes.CStack}
val c_stackPDerefDoubleOperand
= Operand.memloc c_stackPDerefDouble
-
- local
- open Machine.Type
- val cReturnTempBYTE = Label.fromString "cReturnTempB"
- val cReturnTempBYTEContents
- = makeContents {base = Immediate.label cReturnTempBYTE,
- size = x86.Size.BYTE,
- class = Classes.StaticTemp}
- val cReturnTempDBLE = Label.fromString "cReturnTempD"
- val cReturnTempDBLEContents
- = makeContents {base = Immediate.label cReturnTempDBLE,
- size = x86.Size.DBLE,
- class = Classes.StaticTemp}
- val cReturnTempLONG = Label.fromString "cReturnTempL"
- val cReturnTempLONGContents
- = makeContents {base = Immediate.label cReturnTempLONG,
- size = x86.Size.LONG,
- class = Classes.StaticTemp}
- in
- fun cReturnTempContents size
- = case size
- of x86.Size.BYTE => cReturnTempBYTEContents
- | x86.Size.DBLE => cReturnTempDBLEContents
- | x86.Size.LONG => cReturnTempLONGContents
- | _ => Error.bug "cReturnTempContents: size"
- val cReturnTempContentsOperand = Operand.memloc o cReturnTempContents
- end
val intInfTemp = Label.fromString "intInfTemp"
val intInfTempContents
1.12 +4 -14 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.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- x86-mlton-basic.sig 6 Jul 2002 17:22:06 -0000 1.11
+++ x86-mlton-basic.sig 11 Jul 2002 02:16:49 -0000 1.12
@@ -25,13 +25,13 @@
(*
* x86.Size.t equivalents
*)
- val wordSize : x86.Size.t
val wordBytes : int
+ val wordSize : x86.Size.t
val wordScale : x86.Scale.t
- val pointerSize : x86.Size.t
val pointerBytes : int
+ val pointerSize : x86.Size.t
val pointerScale : x86.Scale.t
- val objectHeaderBytes : int
+ val normalHeaderBytes : int
val arrayHeaderBytes : int
val intInfOverheadBytes : int
@@ -49,11 +49,11 @@
val Globals : x86.MemLoc.Class.t
val Temp : x86.MemLoc.Class.t
+ val StaticTemp : x86.MemLoc.Class.t
val CStack : x86.MemLoc.Class.t
val Code : x86.MemLoc.Class.t
val CStatic : x86.MemLoc.Class.t
- val StaticTemp : x86.MemLoc.Class.t
val StaticNonTemp : x86.MemLoc.Class.t
val GCState : x86.MemLoc.Class.t
@@ -70,21 +70,11 @@
val cstaticClasses : x86.ClassSet.t ref
end
- (*
- * Static memory locations
- *)
- val makeContents : {base: x86.Immediate.t,
- size: x86.Size.t,
- class: x86.MemLoc.Class.t} -> x86.MemLoc.t
(* CStack locations *)
val c_stackPContents : x86.MemLoc.t
val c_stackPContentsOperand : x86.Operand.t
val c_stackPDerefOperand : x86.Operand.t
val c_stackPDerefDoubleOperand : x86.Operand.t
-
- (* CReturn locations *)
- val cReturnTempContents : x86.Size.t -> x86.MemLoc.t
- val cReturnTempContentsOperand : x86.Size.t -> x86.Operand.t
(* Static temps defined in x86codegen.h *)
val applyFFTempContentsOperand : x86.Operand.t
1.35 +6 -7 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.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- x86-mlton.fun 6 Jul 2002 17:22:06 -0000 1.34
+++ x86-mlton.fun 11 Jul 2002 02:16:49 -0000 1.35
@@ -746,7 +746,7 @@
val (dst,dstsize) = getDst ()
val memloc
- = makeContents
+ = x86.MemLoc.makeContents
{base = Immediate.label (Label.fromString s),
size = dstsize,
class = Classes.CStatic}
@@ -1424,7 +1424,7 @@
label: x86.Label.t,
transInfo as {live, liveInfo, ...}: transInfo}
= let
- val name = CFunction.name func
+ val name = CFunction.name func
fun getDst ()
= case dst
of SOME dst => dst
@@ -1432,7 +1432,7 @@
fun default ()
= let
val _ = x86Liveness.LiveInfo.setLiveOperands
- (liveInfo, label, live label)
+ (liveInfo, label, live label)
in
AppendList.single
(x86.Block.T'
@@ -1449,11 +1449,10 @@
then (AppendList.single
(x86.Block.T' {entry = NONE,
profileInfo = x86.ProfileInfo.none,
- statements
- = [x86.Assembly.comment
- ("end creturn: " ^ name)],
+ statements = [x86.Assembly.comment
+ ("end creturn: " ^ name)],
transfer = NONE}))
- else AppendList.empty
+ else AppendList.empty
in
AppendList.appends [default (), comment_end]
end
1.12 +8 -0 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.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- x86-pseudo.sig 6 Jul 2002 17:22:06 -0000 1.11
+++ x86-pseudo.sig 11 Jul 2002 02:16:50 -0000 1.12
@@ -25,6 +25,7 @@
= BYTE | WORD | LONG
| SNGL | DBLE | EXTD
| FPIS | FPIL | FPIQ
+ val fromBytes : int -> t
val toBytes : t -> int
val class : t -> class
val eq : t * t -> bool
@@ -80,6 +81,7 @@
type t
val new : {name: string} -> t
val Temp : t
+ val StaticTemp : t
val CStack : t
val Code : t
@@ -111,6 +113,12 @@
val class : t -> Class.t
val compare : t * t -> order
+ (*
+ * Static memory locations
+ *)
+ val makeContents : {base: Immediate.t,
+ size: Size.t,
+ class: Class.t} -> t
end
structure ClassSet : SET
1.22 +0 -8 mlton/mlton/codegen/x86-codegen/x86-simplify.fun
Index: x86-simplify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-simplify.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86-simplify.fun 6 Jul 2002 17:22:06 -0000 1.21
+++ x86-simplify.fun 11 Jul 2002 02:16:50 -0000 1.22
@@ -2511,14 +2511,6 @@
(cases,
fn target => update target),
default = update default}
- | Transfer.CCall {args, dstsize, frameInfo, func, return,
- target}
- => Transfer.CCall {args = args,
- dstsize = dstsize,
- frameInfo = frameInfo,
- func = func,
- return = Option.map (return, update),
- target = target}
| transfer => transfer
val blocks
1.26 +13 -57 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.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- x86-translate.fun 6 Jul 2002 17:22:06 -0000 1.25
+++ x86-translate.fun 11 Jul 2002 02:16:50 -0000 1.26
@@ -15,7 +15,7 @@
val wordBytes = x86MLton.wordBytes
val pointerBytes = x86MLton.pointerBytes
- val objectHeaderBytes = x86MLton.objectHeaderBytes
+ val normalHeaderBytes = x86MLton.normalHeaderBytes
val arrayHeaderBytes = x86MLton.arrayHeaderBytes
val intInfOverheadBytes = x86MLton.intInfOverheadBytes
@@ -96,7 +96,7 @@
=> x86.Operand.immediate_const_word w
| IntInf ii
=> x86.Operand.immediate_const_word ii
- | File => x86MLton.fileLine ()
+ | File => x86MLton.fileName
| Float f
=> Error.bug "toX86Operand: Float, unimplemented"
| GCState => x86.Operand.label x86MLton.gcState_label
@@ -234,10 +234,7 @@
val toX86Operand
= fn operand => (toX86Operand operand)
handle exn
- => Error.bug ("x86Translate.Operand.toX86Operand::" ^
- (case exn
- of Fail s => s
- | _ => "?"))
+ => Error.reraise (exn, "x86Translate.Operand.toX86Operand")
end
type transInfo = x86MLton.transInfo
@@ -559,7 +556,7 @@
val frontierPlusOHW
= (x86.Operand.memloc o x86.MemLoc.simple)
{base = x86MLton.gcState_frontierContents (),
- index = x86.Immediate.const_int objectHeaderBytes,
+ index = x86.Immediate.const_int normalHeaderBytes,
scale = x86.Scale.One,
size = x86MLton.pointerSize,
class = x86MLton.Classes.Heap}
@@ -606,8 +603,7 @@
= ((* *(frontier) = header *)
x86.Assembly.instruction_mov
{dst = frontierDeref,
- src = (x86.Operand.immediate
- (x86.Immediate.const_word header)),
+ src = x86.Operand.immediate_const_word header,
size = x86MLton.pointerSize})::
((* dst = frontier + objectHeaderSize *)
x86.Assembly.instruction_lea
@@ -615,50 +611,19 @@
src = frontierPlusOHW,
size = x86MLton.pointerSize})::
(Vector.foldr(stores,
- [(* frontier += objectHeaderSize + size *)
+ [(* frontier += size *)
x86.Assembly.instruction_binal
{oper = x86.Instruction.ADD,
dst = frontier,
- src = (x86.Operand.immediate_const_int
- size),
+ src = x86.Operand.immediate_const_int size,
size = x86MLton.pointerSize}],
stores_toX86Assembly)),
-(*
- = List.concat
- [[(* *(frontier)
- * = gcObjectHeader(numWordsNonPointers,
- * numPointers)
- *)
- x86.Assembly.instruction_mov
- {dst = frontierDeref,
- src = gcObjectHeaderWord,
- size = x86MLton.pointerSize},
- (* dst = frontier + objectHeaderSize *)
- x86.Assembly.instruction_lea
- {dst = dst,
- src = frontierPlusOHW,
- size = x86MLton.pointerSize}],
- (Vector.foldr(stores,
- [],
- stores_toX86Assembly)),
- [(* frontier += objectHeaderSize + size *)
- x86.Assembly.instruction_binal
- {oper = x86.Instruction.ADD,
- dst = frontier,
- src = x86.Operand.immediate_const_int
- (objectHeaderSize + size),
- size = x86MLton.pointerSize}]],
-*)
transfer = NONE}),
comment_end]
- end
+ end)
handle exn
- => Error.bug (concat ["x86Translate.Statement.toX86Blocks::",
- Layout.toString (layout statement),
- "::",
- (case exn
- of Fail s => s
- | _ => "?")]))
+ => Error.reraise (exn, concat ["x86Translate.Statement.toX86Blocks::",
+ Layout.toString (layout statement)])
end
structure Transfer =
@@ -984,10 +949,7 @@
=> x86.MemLocSet.add(live, memloc)
| NONE => live)})}))))
handle exn
- => Error.bug ("x86Translate.Transfer.toX86Blocks::" ^
- (case exn
- of Fail s => s
- | _ => "?"))
+ => Error.reraise (exn, "x86Translate.Transfer.toX86Blocks")
end
structure Block =
@@ -1080,10 +1042,7 @@
blocks
end
handle exn
- => Error.bug ("x86Translate.Block.toX86Blocks::" ^
- (case exn
- of Fail s => s
- | _ => "?"))
+ => Error.reraise (exn, "x86Translate.Block.toX86Blocks")
end
structure Chunk =
@@ -1127,10 +1086,7 @@
x86.Chunk.T {data = data, blocks = x86Blocks}
end
handle exn
- => Error.bug ("x86Translate.Chunk.toX86Chunk::" ^
- (case exn
- of Fail s => s
- | _ => "?"))
+ => Error.reraise (exn, "x86Translate.Chunk.toX86Chunk")
end
structure Program =
1.29 +56 -8 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.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86.fun 6 Jul 2002 17:22:06 -0000 1.28
+++ x86.fun 11 Jul 2002 02:16:50 -0000 1.29
@@ -111,6 +111,11 @@
end
val toString' = Layout.toString o layout'
+ val fromBytes : int -> t
+ = fn 1 => BYTE
+ | 2 => WORD
+ | 4 => LONG
+ | _ => Error.bug "Size.fromBytes"
val toBytes : t -> int
= fn BYTE => 1
| WORD => 2
@@ -759,6 +764,7 @@
val mayAlias = eq
val Temp = new {name = "Temp"}
+ val StaticTemp = new {name = "StaticTemp"}
val CStack = new {name = "CStack"}
val Code = new {name = "Code"}
end
@@ -1171,6 +1177,42 @@
size = size,
class = Class.Temp})
end
+
+ (*
+ * Static memory locations
+ *)
+ fun makeContents {base, size, class}
+ = imm {base = base,
+ index = Immediate.const_int 0,
+ scale = Scale.Four,
+ size = size,
+ class = class}
+ local
+ open Runtime.Type
+ val cReturnTempBYTE = Label.fromString "cReturnTempB"
+ val cReturnTempBYTEContents
+ = makeContents {base = Immediate.label cReturnTempBYTE,
+ size = Size.BYTE,
+ class = Class.StaticTemp}
+ val cReturnTempDBLE = Label.fromString "cReturnTempD"
+ val cReturnTempDBLEContents
+ = makeContents {base = Immediate.label cReturnTempDBLE,
+ size = Size.DBLE,
+ class = Class.StaticTemp}
+ val cReturnTempLONG = Label.fromString "cReturnTempL"
+ val cReturnTempLONGContents
+ = makeContents {base = Immediate.label cReturnTempLONG,
+ size = Size.LONG,
+ class = Class.StaticTemp}
+ in
+ fun cReturnTempContents size
+ = case size
+ of Size.BYTE => cReturnTempBYTEContents
+ | Size.DBLE => cReturnTempDBLEContents
+ | Size.LONG => cReturnTempLONGContents
+ | _ => Error.bug "cReturnTempContents: size"
+ end
+
end
local
@@ -3630,8 +3672,9 @@
val layout = Layout.str o toString
val uses_defs_kills
- = fn CReturn {dst = SOME (dst, _), ...}
- => {uses = [], defs = [dst], kills = []}
+ = fn CReturn {dst = SOME (dst, dstsize), ...}
+ => {uses = [Operand.memloc (MemLoc.cReturnTempContents dstsize)],
+ defs = [dst], kills = []}
| _ => {uses = [], defs = [], kills = []}
val label
@@ -3655,7 +3698,8 @@
val creturn = CReturn
val isNear = fn Jump _ => true
- | CReturn _ => true
+ | CReturn {func = CFunction.T {maySwitchThreads, ... }, ...}
+ => not maySwitchThreads
| _ => false
end
@@ -4002,9 +4046,12 @@
val uses_defs_kills
= fn Switch {test, cases, default}
=> {uses = [test], defs = [], kills = []}
- | CCall {args, ...}
+ | CCall {args, dstsize, ...}
=> {uses = List.map(args, fn (oper,_) => oper),
- defs = [],
+ defs = case dstsize
+ of NONE => []
+ | SOME dstsize
+ => [Operand.memloc (MemLoc.cReturnTempContents dstsize)],
kills = []}
| _ => {uses = [], defs = [], kills = []}
@@ -4021,9 +4068,10 @@
| NonTail {return,handler,...} => return::(case handler
of NONE => nil
| SOME handler => [handler])
- | CCall {return,...} => (case return of
- NONE => []
- | SOME l => [l])
+ | CCall {return, func = CFunction.T {maySwitchThreads, ...}, ...}
+ => (case return of
+ NONE => []
+ | SOME l => [l])
| _ => []
val live
1.19 +11 -0 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.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- x86.sig 6 Jul 2002 17:22:06 -0000 1.18
+++ x86.sig 11 Jul 2002 02:16:50 -0000 1.19
@@ -35,6 +35,7 @@
val toString : t -> string
val toString' : t -> string
+ val fromBytes : int -> t
val toBytes : t -> int
val class : t -> class
val toFPI : t -> t
@@ -180,6 +181,7 @@
val new : {name: string} -> t
val Temp : t
+ val StaticTemp : t
val CStack : t
val Code : t
@@ -233,6 +235,15 @@
val mayAliasOrd : t * t -> order option
val replace : (t -> t) -> t -> t
+
+ (*
+ * Static memory locations
+ *)
+ val makeContents : {base: Immediate.t,
+ size: Size.t,
+ class: Class.t} -> t
+ (* CReturn locations *)
+ val cReturnTempContents : Size.t -> t
end
structure ClassSet : SET
1.3 +11 -1 mlton/runtime/basis/Thread.c
Index: Thread.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Thread.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- Thread.c 3 Mar 2002 04:41:10 -0000 1.2
+++ Thread.c 11 Jul 2002 02:16:50 -0000 1.3
@@ -21,5 +21,15 @@
}
void Thread_setHandler(Thread t) {
- gcState.signalHandler = (GC_thread)t;
+ gcState.signalHandler = (GC_thread)t;
+}
+
+void Thread_switchTo(Thread thread) {
+ GC_thread t = (GC_thread)thread;
+ gcState.currentThread->stack->used = gcState.stackTop - gcState.stackBottom;
+ gcState.currentThread = t;
+ gcState.stackBottom = ((pointer)t->stack) + sizeof(struct GC_stack);
+ gcState.stackTop = gcState.stackBottom + t->stack->used;
+ gcState.stackLimit =
+ gcState.stackBottom + t->stack->reserved - 2 * gcState.maxFrameSize;
}
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Two, two, TWO treats in one.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel