[MLton-devel] cvs commit: mark compact GC and backend/codegen changes
Stephen Weeks
sweeks@users.sourceforge.net
Sat, 06 Jul 2002 10:22:09 -0700
sweeks 02/07/06 10:22:08
Modified: doc CHANGES
include ccodegen.h x86codegen.h
mlton mlton-stubs.cm mlton.cm
mlton/atoms const.fun const.sig prim.fun prim.sig
mlton/backend allocate-registers.fun array-init.fun
backend.fun chunkify.fun limit-check.fun
limit-check.sig machine.fun machine.sig rssa.fun
rssa.sig runtime.sig signal-check.fun sources.cm
ssa-to-rssa.fun
mlton/codegen sources.cm
mlton/codegen/c-codegen c-codegen.fun c-codegen.sig
sources.cm
mlton/codegen/x86-codegen sources.cm x86-codegen.fun
x86-codegen.sig x86-entry-transfer.fun
x86-generate-transfers.fun x86-jump-info.fun
x86-live-transfers.fun x86-loop-info.fun
x86-mlton-basic.sig x86-mlton.fun x86-mlton.sig
x86-pseudo.sig x86-simplify.fun x86-translate.fun
x86.fun x86.sig
mlton/control control.sig control.sml
mlton/main compile.sml main.sml
mlton/ssa shrink.fun
runtime GC_world.c IntInf.h Makefile gc.c gc.h
runtime/basis IntInf.c
runtime/basis/Int quot.c
runtime/basis/MLton exit.c
Added: mlton/backend c-function.fun c-function.sig runtime.fun
mlton/codegen/x86-codegen x86-mlton-basic.fun
Removed: mlton/backend gc-field.sig runtime.sml
runtime GC_size.c
Log:
This is the first checkin of the mark compact GC. It is disabled for now, but
has passed all the regressions and a self compile with the C codegen. There
were also a number of backend and codegen changes, which I'll try to highlight
below. I've got everything completely working with the C codegen, but it's
broken with the native codegen for now. Matthew, if you could take a look, that
would be great.
For the mark compact GC, new header words have been introduced. For details of
the header word layout, see the comment at the top of gc.h. A counter word was
added to arrays for use during marking. To integrate the mark compact with the
GC, I still need to handle heap resizing and decide when to switch between
stop-and-copy and mark-compact.
At the high level, the backend/codegen changes were motivated by moving as much
knowledge as possible from the codegens into the backend, do avoid duplication
across codegens. The biggest change to the backend is that I eliminated the
Runtime Transfer from Rssa and Machine. What used to be implemented with
Runtime is now implemented as a CCall. CCall now has more information about the
function that is being called, including whether it may GC, whether it modifies
the frontier or the stackTop, whether it may return, whether they need bytes
free in the heap, and more. See backend/c-function.sig. I also modified the
IntInf_ calls to use the normal C calling convention (although the codegen must
use the fact that they modify the frontier) and modified the backend to
recognize which primitives are directly implementable as CCalls. The upshot of
these changes is that a lot of primitives do not have to be handled specially by
the codegens anymore. Instead, the codegens need to implement a more
complicated version of CCall. As I mentioned above, this all works with the C
codegen, but not yet with the x86 codegen.
I added a new option, -inline-array {true|false}. When true, arrays are
allocated inline, as they used to be. When false, they are allocated and
initialized by a C routine, GC_arrayAllocate. This routine could be used as a
hook in the future to special treatment by the runtime of large or pinned
arrays. As soon as x86 codegen is working again, I'll run tests and see if
it hurts performance to switch the default to false.
Revision Changes Path
1.72 +10 -0 mlton/doc/CHANGES
Index: CHANGES
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/CHANGES,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -r1.71 -r1.72
--- CHANGES 27 Jun 2002 17:29:27 -0000 1.71
+++ CHANGES 6 Jul 2002 17:22:04 -0000 1.72
@@ -1,7 +1,17 @@
Here are the changes from version 20020410 to version VERSION.
+* 2002-06 and 2002-07
+ - Added mark compact GC.
+ - Changed array layout so that arrays have three, not two header words.
+ The new word is a counter word that preceeds the array length and header.
+ - Changed all header words to be indices into an array of object descriptors.
+
* 2002-06-27
- Added patches from Michael Neumann to port runtime to FreeBSD 4.5.
+
+* 2002-06-05
+ - Output file and intermediate file are now saved in the current directory
+ instead of in the directory containing the input file.
* 2002-05-31
- Fixed bug in overloading of / so that the following now type checks:
1.28 +112 -192 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- ccodegen.h 23 Jun 2002 01:37:52 -0000 1.27
+++ ccodegen.h 6 Jul 2002 17:22:04 -0000 1.28
@@ -17,6 +17,15 @@
static pointer globalpointer[p]; \
static uint globaluint[u]; \
static pointer globalpointerNonRoot[nr]; \
+ /* The CReturn's must be globals and cannot be per chunk because \
+ * they may be assigned in one chunk and read in another. See \
+ * Array_allocate. \
+ */ \
+ static char CReturnC; \
+ static double CReturnD; \
+ static int CReturnI; \
+ static char *CReturnP; \
+ static uint CReturnU; \
void saveGlobals(int fd) { \
swrite(fd, globaluchar, sizeof(char) * c); \
swrite(fd, globaldouble, sizeof(double) * d); \
@@ -32,16 +41,12 @@
sfread(globaluint, sizeof(uint), u, file); \
}
-#ifdef GLOBAL_REGS
#define Locals(c, d, i, p, u) \
- static char localc[c]; \
- static double locald[d]; \
- static int locali[i]; \
- static pointer localp[p]; \
- static uint localu[u]
-#else
-#define Locals(c, d, i, p, u)
-#endif
+ char localuchar[c]; \
+ double localdouble[d]; \
+ int localint[i]; \
+ pointer localpointer[p]; \
+ uint localuint[u]
#define BeginIntInfs static struct intInfInit intInfInits[] = {
#define IntInf(g, n) { g, n },
@@ -87,15 +92,11 @@
struct cont cont; \
int l_nextFun = nextFun; \
char *stackTop; \
- pointer frontier;
- char CReturnC;
- double CReturnD;
- int CReturnI;
- char *CReturnP;
- uint CReturnU;
+ pointer frontier; \
#define ChunkSwitch \
- CacheGC(); \
+ CacheFrontier(); \
+ CacheStackTop(); \
while (1) { \
top: \
switch (l_nextFun) {
@@ -106,7 +107,8 @@
nextFun = l_nextFun; \
cont.nextChunk = (void*)nextChunks[nextFun]; \
leaveChunk: \
- FlushGC(); \
+ FlushFrontier(); \
+ FlushStackTop(); \
return(cont); \
} /* end switch (l_nextFun) */ \
} /* end while (1) */ \
@@ -116,28 +118,31 @@
/* main */
/* ------------------------------------------------- */
-#define Main(ufh, fs, bl, mfs, mfi, mg, mc, ml) \
+#define Main(ufh, fs, bl, mfs, mfi, mot, mg, mc, ml) \
int main(int argc, char **argv) { \
struct cont cont; \
int l_nextFun; \
- gcState.useFixedHeap = ufh; \
- gcState.fromSize = fs; \
gcState.bytesLive = bl; \
- gcState.maxFrameSize = mfs; \
- gcState.magic = mg; \
- gcState.numGlobals = cardof(globalpointer); \
+ gcState.frameLayouts = frameLayouts; \
+ gcState.fromSize = fs; \
gcState.globals = globalpointer; \
+ gcState.magic = mg; \
gcState.maxFrameIndex = mfi; \
- gcState.frameLayouts = frameLayouts; \
+ gcState.maxFrameSize = mfs; \
+ gcState.maxObjectTypeIndex = mot; \
gcState.native = FALSE; \
+ gcState.numGlobals = cardof(globalpointer); \
+ gcState.objectTypes = objectTypes; \
+ gcState.saveGlobals = &saveGlobals; \
+ gcState.useFixedHeap = ufh; \
MLton_init(argc, argv, &loadGlobals); \
if (gcState.isOriginal) { \
/* The (> 1) check is so that the C compiler can \
* eliminate the call if there are no IntInfs and we \
* then won't have to link in with the IntInf stuff. \
*/ \
- if (cardof(intInfInits) > 1) \
- IntInf_init(&gcState, intInfInits); \
+ if (cardof (intInfInits) > 1) \
+ IntInf_init (&gcState, intInfInits); \
GC_createStrings(&gcState, stringInits); \
float_Init(); \
PrepFarJump(mc, ml); \
@@ -191,6 +196,7 @@
#define Slot(ty, i) *(ty*)(stackTop + (i))
+
#define SC(i) Slot(uchar, i)
#define SD(i) Slot(double, i)
#define SI(i) Slot(int, i)
@@ -240,11 +246,13 @@
goto top; \
} while (0)
-#define Raise() \
- do { \
- stackTop = StackBottom + ExnStack; \
- l_nextFun = *(int*)stackTop; \
- goto top; \
+#define Raise() \
+ do { \
+ if (FALSE) \
+ fprintf (stderr, "%d Raise\n", __LINE__); \
+ stackTop = StackBottom + ExnStack; \
+ l_nextFun = *(int*)stackTop; \
+ goto top; \
} while (0)
#define SetExnStackLocal(offset) \
@@ -266,55 +274,49 @@
/* Runtime */
/* ------------------------------------------------- */
-#define CacheGC() \
- do { \
- stackTop = gcState.stackTop; \
- frontier = gcState.frontier; \
+#define CheckPointer(p) \
+ do { \
+ assert (not GC_isPointer (p) or \
+ (gcState.base <= p and p < frontier)); \
} while (0)
-#define FlushGC() \
+#define FlushFrontier() \
do { \
- gcState.stackTop = stackTop; \
gcState.frontier = frontier; \
} while (0)
-/* Be very careful when using this macro, since the "call" is moved to after
- * the stackTop change. Thus, the call should not refer to stuff on the stack.
- */
-#define InvokeRuntime(call, frameSize, ret) \
- do { \
- stackTop += (frameSize); \
- *(uint*)(stackTop - WORD_SIZE) = ret; \
- FlushGC(); \
- call; \
- CacheGC(); \
- Return(); \
+#define FlushStackTop() \
+ do { \
+ gcState.stackTop = stackTop; \
} while (0)
-#define GC_collect(frameSize, ret, amount, force) \
- do { \
- Word a = amount; \
- InvokeRuntime(GC_gc(&gcState, a, force, \
- __FILE__, __LINE__), \
- frameSize, ret); \
+#define CacheFrontier() \
+ do { \
+ frontier = gcState.frontier; \
+ } while (0)
+
+#define CacheStackTop() \
+ do { \
+ stackTop = gcState.stackTop; \
} while (0)
#define SmallIntInf(n) ((pointer)(n))
#define IntAsPointer(n) ((pointer)(n))
#define PointerToInt(p) ((int)(p))
-#define Object(x, np, p) \
+#define Object(x, h) \
do { \
- *(word*)frontier = GC_objectHeader(np, p); \
- x = frontier + GC_OBJECT_HEADER_SIZE; \
+ *(word*)frontier = (h); \
+ x = frontier + GC_NORMAL_HEADER_SIZE; \
if (FALSE) \
- fprintf(stderr, "%d 0x%x = Object(%d, %d)\n", \
- __LINE__, x, np, p); \
+ fprintf (stderr, "%d 0x%x = Object(%d)\n", \
+ __LINE__, x, h); \
+ assert (frontier <= gcState.limitPlusSlop); \
} while (0)
#define Assign(ty, o, v) \
do { \
- *(ty*)(frontier + GC_OBJECT_HEADER_SIZE + (o)) = (v); \
+ *(ty*)(frontier + GC_NORMAL_HEADER_SIZE + (o)) = (v); \
} while (0)
#define AC(o, x) Assign(uchar, o, x)
@@ -342,17 +344,18 @@
#define XP(b, i) ArrayOffset(pointer, b, i)
#define XU(b, i) ArrayOffset(uint, b, i)
-#define Array_allocate(numElts, numBytes, header) ( \
- assert(numBytes > 0), \
- assert(isWordAligned(numBytes)), \
- *(word*)(frontier) = (numElts), \
- *(word*)((frontier) + WORD_SIZE) = (header), \
- (FALSE) \
- ? fprintf(stderr, "%d Array(%d)\n", \
- __LINE__, numElts) \
- : 0, \
- arrayAllocateRes = (frontier) + 2 * WORD_SIZE, \
- frontier += (numBytes), \
+#define Array_allocate(numElts, numBytes, header) ( \
+ assert(numBytes > 0), \
+ assert(isWordAligned(numBytes)), \
+ *(word*)(frontier) = 0, \
+ *(word*)(frontier + WORD_SIZE) = (numElts), \
+ *(word*)((frontier) + 2 * WORD_SIZE) = (header), \
+ (FALSE) \
+ ? fprintf(stderr, "%d Array(%d)\n", \
+ __LINE__, numElts) \
+ : 0, \
+ arrayAllocateRes = (frontier) + 3 * WORD_SIZE, \
+ frontier += (numBytes), \
arrayAllocateRes)
/* ------------------------------------------------- */
@@ -501,62 +504,9 @@
/* ------------------------------------------------- */
#define IntInf_fromVector(x) x
+#define IntInf_fromWord(w) ((pointer)(w))
#define IntInf_toVector(x) x
#define IntInf_toWord(i) ((uint)(i))
-#define IntInf_fromWord(w) ((pointer)(w))
-
-/*
- * Check if an IntInf.int is small (i.e., a fixnum).
- */
-#define IntInf_isSmall(arg) \
- (((uint)(arg) & 0x1) != 0)
-
-/*
- * Check if two IntInf.int's are both small (i.e., fixnums).
- * This is a gross hack, but uses only one test.
- */
-#define IntInf_areSmall(lhs, rhs) \
- (((uint)(lhs) & (uint)(rhs) & 0x1) != 0)
-
-#define IntInf_add(lhs, rhs, space) ( \
- intInfRes = IntInf_do_add((lhs), (rhs), (space), frontier), \
- frontier = intInfRes->frontier, \
- intInfRes->value)
-
-#define IntInf_sub(lhs, rhs, space) ( \
- intInfRes = IntInf_do_sub((lhs), (rhs), (space), frontier), \
- frontier = intInfRes->frontier, \
- intInfRes->value)
-
-#define IntInf_toString(arg, base, str) ( \
- intInfRes = IntInf_do_toString(arg, base, str, frontier), \
- frontier = intInfRes->frontier, \
- intInfRes->value)
-
-#define IntInf_mul(lhs, rhs, space) ( \
- intInfRes = IntInf_do_mul((lhs), (rhs), (space), frontier), \
- frontier = intInfRes->frontier, \
- intInfRes->value)
-
-#define IntInf_neg(arg, space) ( \
- intInfRes = IntInf_do_neg(arg, (space), frontier), \
- frontier = intInfRes->frontier, \
- intInfRes->value)
-
-#define IntInf_quot(num, den, space) ( \
- intInfRes = IntInf_do_quot((num), (den), (space), frontier), \
- frontier = intInfRes->frontier, \
- intInfRes->value)
-
-#define IntInf_rem(num, den, space) ( \
- intInfRes = IntInf_do_rem((num), (den), (space), frontier), \
- frontier = intInfRes->frontier, \
- intInfRes->value)
-
-#define IntInf_gcd(lhs, rhs, space) ( \
- intInfRes = IntInf_do_gcd((lhs), (rhs), (space), frontier), \
- frontier = intInfRes->frontier, \
- intInfRes->value)
/* ------------------------------------------------- */
/* MLton */
@@ -568,12 +518,6 @@
*/
#define MLton_eq(x, y) ((x) == (y))
-#define MLton_halt(frameSize, ret, status) \
- do { \
- int x = status; \
- InvokeRuntime(MLton_exit(x), frameSize, ret); \
- } while (0)
-
/* #define MLton_deserialize(z) ( \ */
/* FlushGCExp, \ */
/* deserializeRes = GC_deserialize(&gcState, (z)), \ */
@@ -608,9 +552,9 @@
#define Real_Math_tanh tanh
#define Real_abs fabs
-#define Real_add(x,y) ((x) + (y))
+#define Real_add(x, y) ((x) + (y))
#define Real_copysign copysign
-#define Real_div(x,y) ((x) / (y))
+#define Real_div(x, y) ((x) / (y))
#define Real_equal(x1, x2) ((x1) == (x2))
#define Real_frexp frexp
#define Real_fromInt(n) ((double)(n))
@@ -620,11 +564,11 @@
#define Real_le(x1, x2) ((x1) <= (x2))
#define Real_lt(x1, x2) ((x1) < (x2))
#define Real_modf modf
-#define Real_mul(x,y) ((x) * (y))
-#define Real_muladd(x,y,z) ((x) * (y) + (z))
-#define Real_mulsub(x,y,z) ((x) * (y) - (z))
+#define Real_mul(x, y) ((x) * (y))
+#define Real_muladd(x, y, z) ((x) * (y) + (z))
+#define Real_mulsub(x, y, z) ((x) * (y) - (z))
#define Real_neg(x) (-(x))
-#define Real_sub(x,y) ((x) - (y))
+#define Real_sub(x, y) ((x) - (y))
#define Real_toInt(x) ((int)(x))
/* ------------------------------------------------- */
@@ -641,22 +585,9 @@
/* Thread */
/* ------------------------------------------------- */
-#define Thread_copy(frameSize, ret, thread) \
+#define Thread_switchTo(thread) \
do { \
GC_thread t = thread; \
- InvokeRuntime(GC_copyThread(&gcState, t), frameSize, ret); \
- } while (0)
-
-#define Thread_copyCurrent(frameSize, ret) \
- do { \
- InvokeRuntime(GC_copyCurrentThread(&gcState), frameSize, ret); \
- } while (0)
-
-#define Thread_switchTo(frameSize, ret, thread) \
- do { \
- GC_thread t = thread; \
- stackTop += (frameSize); \
- *(uint*)(stackTop - WORD_SIZE) = ret; \
gcState.currentThread->stack->used = stackTop - StackBottom; \
gcState.currentThread = t; \
StackBottom = ((pointer)t->stack) + sizeof(struct GC_stack); \
@@ -677,35 +608,35 @@
/* Word8 */
/* ------------------------------------------------- */
-#define Word8_add(w1,w2) ((w1) + (w2))
-#define Word8_andb(w1,w2) ((w1) & (w2))
+#define Word8_add(w1, w2) ((w1) + (w2))
+#define Word8_andb(w1, w2) ((w1) & (w2))
/* The macro for Word8_arshift isn't ANSI C, because ANSI doesn't guarantee
* sign extension. We use it anyway cause it always seems to work.
*/
#define Word8_arshift(w, s) ((signed char)(w) >> (s))
/*#define Word8_arshift Word8_arshiftAsm */
-#define Word8_div(w1,w2) ((w1) / (w2))
+#define Word8_div(w1, w2) ((w1) / (w2))
#define Word8_fromInt(x) ((uchar)(x))
#define Word8_fromLargeWord(w) ((uchar)(w))
-#define Word8_ge(w1,w2) ((w1) >= (w2))
-#define Word8_gt(w1,w2) ((w1) > (w2))
-#define Word8_le(w1,w2) ((w1) <= (w2))
-#define Word8_lshift(w,s) ((w) << (s))
-#define Word8_lt(w1,w2) ((w1) < (w2))
-#define Word8_mod(w1,w2) ((w1) % (w2))
-#define Word8_mul(w1,w2) ((w1) * (w2))
+#define Word8_ge(w1, w2) ((w1) >= (w2))
+#define Word8_gt(w1, w2) ((w1) > (w2))
+#define Word8_le(w1, w2) ((w1) <= (w2))
+#define Word8_lshift(w, s) ((w) << (s))
+#define Word8_lt(w1, w2) ((w1) < (w2))
+#define Word8_mod(w1, w2) ((w1) % (w2))
+#define Word8_mul(w1, w2) ((w1) * (w2))
#define Word8_neg(w) (-(w))
#define Word8_notb(w) (~(w))
-#define Word8_orb(w1,w2) ((w1) | (w2))
-#define Word8_ror(x,y) ((x)>>(y) | ((x)<<(8-(y))))
-#define Word8_rol(x,y) ((x)>>(8-(y)) | ((x)<<(y)))
-#define Word8_rshift(w,s) ((w) >> (s))
-#define Word8_sub(w1,w2) ((w1) - (w2))
+#define Word8_orb(w1, w2) ((w1) | (w2))
+#define Word8_ror(x, y) ((x)>>(y) | ((x)<<(8-(y))))
+#define Word8_rol(x, y) ((x)>>(8-(y)) | ((x)<<(y)))
+#define Word8_rshift(w, s) ((w) >> (s))
+#define Word8_sub(w1, w2) ((w1) - (w2))
#define Word8_toInt(w) ((int)(w))
#define Word8_toIntX(x) ((int)(signed char)(x))
#define Word8_toLargeWord(w) ((uint)(w))
#define Word8_toLargeWordX(x) ((uint)(signed char)(x))
-#define Word8_xorb(w1,w2) ((w1) ^ (w2))
+#define Word8_xorb(w1, w2) ((w1) ^ (w2))
/* ------------------------------------------------- */
/* Word8Array */
@@ -732,34 +663,23 @@
*/
#define Word32_arshift(w, s) ((int)(w) >> (s))
/*#define Word32_arshift Word32_arshiftAsm */
-#define Word32_div(w1,w2) ((w1) / (w2))
+#define Word32_div(w1, w2) ((w1) / (w2))
#define Word32_fromInt(x) ((uint)(x))
-#define Word32_ge(w1,w2) ((w1) >= (w2))
-#define Word32_gt(w1,w2) ((w1) > (w2))
-#define Word32_le(w1,w2) ((w1) <= (w2))
-#define Word32_lshift(w,s) ((w) << (s))
-#define Word32_lt(w1,w2) ((w1) < (w2))
-#define Word32_mod(w1,w2) ((w1) % (w2))
-#define Word32_mul(w1,w2) ((w1) * (w2))
+#define Word32_ge(w1, w2) ((w1) >= (w2))
+#define Word32_gt(w1, w2) ((w1) > (w2))
+#define Word32_le(w1, w2) ((w1) <= (w2))
+#define Word32_lshift(w, s) ((w) << (s))
+#define Word32_lt(w1, w2) ((w1) < (w2))
+#define Word32_mod(w1, w2) ((w1) % (w2))
+#define Word32_mul(w1, w2) ((w1) * (w2))
#define Word32_neg(w) (-(w))
#define Word32_notb(w) (~(w))
-#define Word32_orb(w1,w2) ((w1) | (w2))
-#define Word32_ror(x,y) ((x)>>(y) | ((x)<<(32-(y))))
-#define Word32_rol(x,y) ((x)>>(32-(y)) | ((x)<<(y)))
-#define Word32_rshift(w,s) ((w) >> (s))
-#define Word32_sub(w1,w2) ((w1) - (w2))
+#define Word32_orb(w1, w2) ((w1) | (w2))
+#define Word32_ror(x, y) ((x)>>(y) | ((x)<<(32-(y))))
+#define Word32_rol(x, y) ((x)>>(32-(y)) | ((x)<<(y)))
+#define Word32_rshift(w, s) ((w) >> (s))
+#define Word32_sub(w1, w2) ((w1) - (w2))
#define Word32_toIntX(x) ((int)(x))
-#define Word32_xorb(w1,w2) ((w1) ^ (w2))
-
-/* ------------------------------------------------- */
-/* World */
-/* ------------------------------------------------- */
-
-#define World_save(frameSize, ret, file) \
- do { \
- pointer f = (file); \
- InvokeRuntime(GC_saveWorld(&gcState, f, &saveGlobals), \
- frameSize, ret); \
- } while (0)
+#define Word32_xorb(w1, w2) ((w1) ^ (w2))
#endif /* #ifndef _CCODEGEN_H_ */
1.12 +10 -7 mlton/include/x86codegen.h
Index: x86codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86codegen.h,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- x86codegen.h 26 Mar 2002 17:27:30 -0000 1.11
+++ x86codegen.h 6 Jul 2002 17:22:04 -0000 1.12
@@ -64,20 +64,23 @@
#define Float(c, f) globaldouble[c] = f;
#define EndFloats }
-#define Main(ufh, fs, bl, mfs, mfi, mg, ml, reserveEsp) \
+#define Main(ufh, fs, bl, mfs, mfi, mot, mg, ml, reserveEsp) \
extern pointer ml; \
int main(int argc, char **argv) { \
pointer jump; \
- gcState.useFixedHeap = ufh; \
- gcState.fromSize = fs; \
gcState.bytesLive = bl; \
- gcState.maxFrameSize = mfs; \
- gcState.magic = mg; \
- gcState.numGlobals = cardof(globalpointer); \
+ gcState.frameLayouts = frameLayouts; \
+ gcState.fromSize = fs; \
gcState.globals = globalpointer; \
+ gcState.magic = mg; \
gcState.maxFrameIndex = mfi; \
- gcState.frameLayouts = frameLayouts; \
+ gcState.maxFrameSize = mfs; \
+ gcState.maxObjectTypeIndex = mot; \
gcState.native = TRUE; \
+ gcState.numGlobals = cardof(globalpointer); \
+ gcState.objectTypes = objectTypes; \
+ gcState.saveGlobals = &saveGlobals; \
+ gcState.useFixedHeap = ufh; \
MLton_init(argc, argv, &loadGlobals); \
if (gcState.isOriginal) { \
/* The (> 1) check is so that the C compiler can \
1.3 +8 -6 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mlton-stubs.cm 24 Mar 2002 07:54:49 -0000 1.2
+++ mlton-stubs.cm 6 Jul 2002 17:22:05 -0000 1.3
@@ -310,12 +310,13 @@
atoms/cases.fun
ssa/ssa-tree.fun
ssa/ssa.fun
-backend/gc-field.sig
-backend/runtime.sig
-backend/runtime.sml
-backend/err.sml
backend/mtype.sig
+backend/c-function.sig
+backend/runtime.sig
backend/mtype.fun
+backend/c-function.fun
+backend/runtime.fun
+backend/err.sml
backend/machine-cases.sig
backend/machine.sig
backend/machine-cases.fun
@@ -399,9 +400,8 @@
codegen/x86-codegen/x86.fun
codegen/x86-codegen/x86-pseudo.sig
codegen/x86-codegen/x86-mlton-basic.sig
+codegen/x86-codegen/x86-mlton-basic.fun
codegen/x86-codegen/x86-liveness.sig
-codegen/x86-codegen/x86-mlton.sig
-codegen/x86-codegen/x86-mlton.fun
codegen/x86-codegen/x86-liveness.fun
codegen/x86-codegen/x86-jump-info.sig
codegen/x86-codegen/x86-jump-info.fun
@@ -409,6 +409,8 @@
codegen/x86-codegen/x86-loop-info.fun
codegen/x86-codegen/x86-entry-transfer.sig
codegen/x86-codegen/x86-entry-transfer.fun
+codegen/x86-codegen/x86-mlton.sig
+codegen/x86-codegen/x86-mlton.fun
codegen/x86-codegen/x86-translate.sig
codegen/x86-codegen/x86-translate.fun
codegen/x86-codegen/x86-simplify.sig
1.53 +8 -6 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -r1.52 -r1.53
--- mlton.cm 24 Mar 2002 07:54:49 -0000 1.52
+++ mlton.cm 6 Jul 2002 17:22:05 -0000 1.53
@@ -286,12 +286,13 @@
atoms/cases.fun
ssa/ssa-tree.fun
ssa/ssa.fun
-backend/gc-field.sig
-backend/runtime.sig
-backend/runtime.sml
-backend/err.sml
backend/mtype.sig
+backend/c-function.sig
+backend/runtime.sig
backend/mtype.fun
+backend/c-function.fun
+backend/runtime.fun
+backend/err.sml
backend/machine-cases.sig
backend/machine.sig
backend/machine-cases.fun
@@ -375,9 +376,8 @@
codegen/x86-codegen/x86.fun
codegen/x86-codegen/x86-pseudo.sig
codegen/x86-codegen/x86-mlton-basic.sig
+codegen/x86-codegen/x86-mlton-basic.fun
codegen/x86-codegen/x86-liveness.sig
-codegen/x86-codegen/x86-mlton.sig
-codegen/x86-codegen/x86-mlton.fun
codegen/x86-codegen/x86-liveness.fun
codegen/x86-codegen/x86-jump-info.sig
codegen/x86-codegen/x86-jump-info.fun
@@ -385,6 +385,8 @@
codegen/x86-codegen/x86-loop-info.fun
codegen/x86-codegen/x86-entry-transfer.sig
codegen/x86-codegen/x86-entry-transfer.fun
+codegen/x86-codegen/x86-mlton.sig
+codegen/x86-codegen/x86-mlton.fun
codegen/x86-codegen/x86-translate.sig
codegen/x86-codegen/x86-translate.fun
codegen/x86-codegen/x86-simplify.sig
1.5 +9 -3 mlton/mlton/atoms/const.fun
Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- const.fun 10 Apr 2002 07:02:18 -0000 1.4
+++ const.fun 6 Jul 2002 17:22:05 -0000 1.5
@@ -139,11 +139,17 @@
in minSmall <= i andalso i <= maxSmall
end
- fun toWord (i: IntInf.t): word =
- Word.orb (0w1, Word.<< (Word.fromInt (IntInf.toInt i), 0w1))
+ fun toWord (i: IntInf.t): word option =
+ if isSmall i
+ then SOME (Word.orb (0w1,
+ Word.<< (Word.fromInt (IntInf.toInt i),
+ 0w1)))
+ else NONE
fun fromWord (w: word): IntInf.t =
- IntInf.fromInt (Word.toIntX (Word.~>> (w, 0w1)))
+ (Assert.assert ("SmallIntInf.fromWord", fn () =>
+ w < 0wx80000000)
+ ; IntInf.fromInt (Word.toIntX (Word.~>> (w, 0w1))))
end
end
1.4 +1 -1 mlton/mlton/atoms/const.sig
Index: const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- const.sig 10 Apr 2002 07:02:18 -0000 1.3
+++ const.sig 6 Jul 2002 17:22:05 -0000 1.4
@@ -22,7 +22,7 @@
structure SmallIntInf:
sig
val isSmall: IntInf.t -> bool
- val toWord: IntInf.t -> word
+ val toWord: IntInf.t -> word option
val fromWord: word -> IntInf.t
end
1.28 +11 -83 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- prim.fun 23 Jun 2002 01:37:52 -0000 1.27
+++ prim.fun 6 Jul 2002 17:22:05 -0000 1.28
@@ -61,13 +61,11 @@
| FFI of string
| GC_collect
| IntInf_add
- | IntInf_areSmall
| IntInf_compare
| IntInf_equal
| IntInf_fromVector
| IntInf_fromWord
| IntInf_gcd
- | IntInf_isSmall
| IntInf_mul
| IntInf_neg
| IntInf_quot
@@ -214,8 +212,7 @@
val equals: t * t -> bool = op =
val isCommutative =
- fn IntInf_areSmall => true
- | IntInf_equal => true
+ fn IntInf_equal => true
| Int_add => true
| Int_addCheck => true
| Int_mul => true
@@ -251,51 +248,6 @@
val mayRaise = mayOverflow
- val entersRuntime =
- fn GC_collect => true
- | MLton_halt => true
- | Thread_copy => true
- | Thread_copyCurrent => true
- | Thread_switchTo => true
- | World_save => true
- | _ => false
-
- val impCall
- = fn FFI _ => true
- | MLton_bug => true
- | MLton_size => true
- | String_equal => true
- | IntInf_compare => true
- | IntInf_equal => true
- | IntInf_add => true
- | IntInf_gcd => true
- | IntInf_sub => true
- | IntInf_mul => true
- | IntInf_quot => true
- | IntInf_rem => true
- | IntInf_neg => true
- | IntInf_toString => true
- | Real_Math_cosh => true
- | Real_Math_sinh => true
- | Real_Math_tanh => true
- | Real_Math_pow => true
- | Real_copysign => true
- | Real_frexp => true
- | Real_modf => true
- | _ => false
-
- val bytesNeeded
- = fn Array_allocate => SOME (fn args => Vector.sub(args, 1))
- | IntInf_add => SOME (fn args => Vector.sub (args, 2))
- | IntInf_gcd => SOME (fn args => Vector.sub (args, 2))
- | IntInf_mul => SOME (fn args => Vector.sub (args, 2))
- | IntInf_neg => SOME (fn args => Vector.sub (args, 1))
- | IntInf_quot => SOME (fn args => Vector.sub (args, 2))
- | IntInf_rem => SOME (fn args => Vector.sub (args, 2))
- | IntInf_sub => SOME (fn args => Vector.sub (args, 2))
- | IntInf_toString => SOME (fn args => Vector.sub (args, 2))
- | _ => NONE
-
datatype z = datatype Kind.t
(* The values of these strings are important since they are referred to
@@ -329,13 +281,11 @@
(Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
(GC_collect, SideEffect, "GC_collect"),
(IntInf_add, Functional, "IntInf_add"),
- (IntInf_areSmall, Functional, "IntInf_areSmall"),
(IntInf_compare, Functional, "IntInf_compare"),
(IntInf_equal, Functional, "IntInf_equal"),
(IntInf_fromVector, Functional, "IntInf_fromVector"),
(IntInf_fromWord, Functional, "IntInf_fromWord"),
(IntInf_gcd, Functional, "IntInf_gcd"),
- (IntInf_isSmall, Functional, "IntInf_isSmall"),
(IntInf_mul, Functional, "IntInf_mul"),
(IntInf_neg, Functional, "IntInf_neg"),
(IntInf_quot, Functional, "IntInf_quot"),
@@ -522,15 +472,7 @@
val isCommutative = Name.isCommutative o name
val mayOverflow = Name.mayOverflow o name
val mayRaise = Name.mayRaise o name
-fun impCall p = case name p
- of Name.FFI _ => isSome (numArgs p)
- | p => Name.impCall p
-fun bytesNeeded p = Name.bytesNeeded (name p)
-
-val entersRuntime = Name.entersRuntime o name
-val entersRuntime =
- Trace.trace ("entersRuntime", layout, Bool.layout) entersRuntime
-
+
structure Scheme =
struct
open Scheme
@@ -585,8 +527,9 @@
end
val tuple = tuple o Vector.fromList
in
- val array_allocate =
- new (Name.Array_allocate, make1 (fn a => tuple [int,word,word] --> array a))
+ val arrayAllocate =
+ new (Name.Array_allocate,
+ make1 (fn a => tuple [int, word, word] --> array a))
val array0 = new (Name.Array_array0, make1 (fn a => unit --> array a))
val array = new (Name.Array_array, make1 (fn a => int --> array a))
val assign = new (Name.Ref_assign, make1 (fn a => tuple [reff a, a] --> unit))
@@ -606,7 +549,6 @@
fun new0 (name, ty) = new (name, make0 ty)
- val intInfIsSmall = new0 (Name.IntInf_isSmall, intInf --> bool)
val intNeg = new0 (Name.Int_neg, int --> int)
val intNegCheck = new0 (Name.Int_negCheck, int --> int)
val intInfNeg =
@@ -891,25 +833,18 @@
| (Int_negCheck, [Int i]) => int (~ i)
| (Int_quot, [Int i1, Int i2]) => io (Int.quot, i1, i2)
| (Int_rem, [Int i1, Int i2]) => io (Int.rem, i1, i2)
- | (IntInf_areSmall, [IntInf i1, IntInf i2]) =>
- bool (SmallIntInf.isSmall i1 andalso SmallIntInf.isSmall i2)
| (IntInf_compare, [IntInf i1, IntInf i2]) =>
int (case IntInf.compare (i1, i2) of
Relation.LESS => ~1
| Relation.EQUAL => 0
| Relation.GREATER => 1)
- | (IntInf_equal, [IntInf i1, IntInf i2]) => bool (i1 = i2)
+ | (IntInf_equal, [IntInf i1, IntInf i2]) =>
+ bool (IntInf.equals (i1, i2))
| (IntInf_fromWord, [Word w]) => intInf (SmallIntInf.fromWord w)
-(*
- | (IntInf_fromString, [String s]) =>
- (case IntInf.fromString s of
+ | (IntInf_toWord, [IntInf i]) =>
+ (case SmallIntInf.toWord i of
NONE => ApplyResult.Unknown
- | SOME i => intInf i)
- | (IntInf_fromStringIsPossible, [String s]) =>
- bool (isSome (IntInf.fromString s))
-*)
- | (IntInf_isSmall, [IntInf i]) => bool (SmallIntInf.isSmall i)
- | (IntInf_toWord, [IntInf i]) => word (SmallIntInf.toWord i)
+ | SOME w => word w)
| (MLton_eq, [c1, c2]) => eq (c1, c2)
| (MLton_equal, [c1, c2]) => equal (c1, c2)
| (String_equal, [String s1, String s2]) =>
@@ -1170,16 +1105,10 @@
else Apply (intNegCheck, [x])
else Unknown
| _ => Unknown
- fun areSmall (x, i) =
- if Const.SmallIntInf.isSmall i
- then Apply (intInfIsSmall, [x])
- else ApplyResult.falsee
datatype z = datatype ApplyArg.t
in
case (name, args) of
- (IntInf_areSmall, [Const (IntInf i), Var x]) => areSmall (x, i)
- | (IntInf_areSmall, [Var x, Const (IntInf i)]) => areSmall (x, i)
- | (IntInf_neg, [Const (IntInf i), _]) => intInf (IntInf.~ i)
+ (IntInf_neg, [Const (IntInf i), _]) => intInf (IntInf.~ i)
| (IntInf_toString, [Const (IntInf i), _, _]) =>
string (IntInf.toString i)
| (_, [Con {con = c, hasArg = h}, Con {con = c', hasArg = h'}]) =>
@@ -1235,7 +1164,6 @@
| Int_quot => int 1
| Int_rem => int 0
| Int_sub => int 0
- | IntInf_areSmall => Apply (intInfIsSmall, [x])
| IntInf_compare => int 0
| IntInf_equal => t
| MLton_eq => t
1.24 +3 -16 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- prim.sig 23 Jun 2002 01:37:52 -0000 1.23
+++ prim.sig 6 Jul 2002 17:22:05 -0000 1.24
@@ -23,7 +23,7 @@
structure Name:
sig
datatype t =
- Array_allocate (* implemented in backend *)
+ Array_allocate (* created and implemented in backend *)
| Array_array (* implemented in backend *)
| Array_array0 (* implemented in backend *)
| Array_array0Const (* implemented in constant-propagation.fun *)
@@ -67,13 +67,11 @@
| Int_neg
| Int_negCheck
| IntInf_add
- | IntInf_areSmall
| IntInf_compare
| IntInf_equal
| IntInf_fromVector
| IntInf_fromWord
| IntInf_gcd
- | IntInf_isSmall
| IntInf_mul
| IntInf_neg
| IntInf_quot
@@ -251,19 +249,13 @@
val allocTooLarge: t
val apply: t * 'a ApplyArg.t list * ('a * 'a -> bool) -> 'a ApplyResult.t
- val array_allocate: t
- val array: t
val array0: t
+ val arrayAllocate: t
+ val array: t
val assign: t
val bogus: t
val bug: t
val buildConstant: string * Scheme.t -> t
- (* bytesNeeded p = SOME f iff p takes a (variable) argument that indicates
- * a minimum number of heap bytes needed to make the call.
- * bytesNeeded implies impCall.
- * examples: IntInf_add
- *)
- val bytesNeeded : t -> ('a vector -> 'a) option
val checkApp: {
prim: t,
targs: 'a vector,
@@ -277,7 +269,6 @@
val constant: string * Scheme.t -> t
val deref: t
val deserialize: t
- val entersRuntime: t -> bool
val eq: t (* pointer equality *)
val equal: t (* polymorphic equality *)
val equals: t * t -> bool (* equality of names *)
@@ -289,11 +280,7 @@
deref: 'a -> 'a,
devector: 'a -> 'a} -> 'a vector
val ffi: string * Scheme.t -> t
- (* impCall p = true iff p is implemented in the codegen as a call to a C function
- * examples: FFI, MLton_size, String_equal, IntInf_*,
- *)
val gcCollect: t
- val impCall: t -> bool
val intInfEqual: t
val intAdd: t
val intAddCheck: t
1.21 +6 -2 mlton/mlton/backend/allocate-registers.fun
Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- allocate-registers.fun 10 Apr 2002 07:02:19 -0000 1.20
+++ allocate-registers.fun 6 Jul 2002 17:22:05 -0000 1.21
@@ -16,6 +16,7 @@
open Rssa
in
structure Block = Block
+ structure CFunction = CFunction
structure Func = Func
structure Function = Function
structure Kind = Kind
@@ -29,6 +30,7 @@
in
structure Operand = Operand
structure Register = Register
+ structure Runtime = Runtime
end
val traceForceStack =
@@ -350,8 +352,10 @@
; List.foreach (beginNoFormals, forceStack))
| Kind.Handler =>
List.foreach (beginNoFormals, forceStack)
- | Kind.Runtime _ =>
- List.foreach (beginNoFormals, forceStack)
+ | Kind.CReturn {func = CFunction.T {mayGC, ...}} =>
+ if mayGC
+ then List.foreach (beginNoFormals, forceStack)
+ else ()
| _ => ()
val _ =
Vector.foreach
1.8 +40 -97 mlton/mlton/backend/array-init.fun
Index: array-init.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/array-init.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- array-init.fun 23 Jun 2002 01:37:52 -0000 1.7
+++ array-init.fun 6 Jul 2002 17:22:05 -0000 1.8
@@ -15,83 +15,10 @@
let
val {args, blocks, name, start} = Function.dest f
val extra = ref []
- fun needsInit s =
- case s of
- Statement.PrimApp {prim, args, ...} =>
- (case Prim.name prim of
- Prim.Name.Array_allocate =>
- let
- fun error () = Error.bug "Array_allocate without header"
- val header = case (Vector.sub (args, 2)) of
- Operand.Const c =>
- (case Const.node c of
- Const.Node.Word w => w
- | _ => error ())
- | _ => error ()
- val {numPointers, ...} = Runtime.splitArrayHeader header
- in
- numPointers > 0
- end
- | _ => false)
- | _ => false
- fun needsSplit s =
- case s of
- Statement.PrimApp {prim, ...} =>
- isSome (Prim.bytesNeeded prim) andalso (Prim.impCall prim)
- | _ => false
- fun needsRewrite s =
- (needsInit s, needsSplit s)
- fun needsRewrite' s = let val (b1, b2) = needsRewrite s in b1 orelse b2 end
-
- fun insertSplit (s,
- profileInfo,
- statements, transfer) =
+ fun init {array: Var.t,
+ numElts: Operand.t,
+ profileInfo, statements, transfer}: Transfer.t =
let
- fun error () = Error.bug "non PrimApp to insertSplit"
- val (prim, dst, args) =
- case s of
- Statement.PrimApp {prim, dst, args} => (prim, dst, args)
- | _ => error ()
- val continue = Label.newNoname ()
- val _ =
- extra :=
- Block.T {args = case dst
- of SOME dst => Vector.new1 dst
- | NONE => Vector.new0 (),
- kind = Kind.CReturn {prim = prim},
- label = continue,
- profileInfo = profileInfo,
- statements = Vector.fromList statements,
- transfer = transfer}
- :: !extra
-
- in
- ([],
- Transfer.CCall {args = args,
- prim = prim,
- return = continue,
- returnTy = Option.map (dst, #2)})
- end
- fun insertInit (s,
- profileInfo,
- statements, transfer) =
- let
- fun error () = Error.bug "non Array_allocate to insertInit"
- val (array, numElts) =
- case s of
- Statement.PrimApp {prim, dst, args, ...} =>
- let
- val _ = case Prim.name prim of
- Prim.Name.Array_allocate => ()
- | _ => error ()
- val array = case dst of
- SOME (array, _) => array
- | _ => error ()
- val numElts = Vector.sub(args, 0)
- in
- (array, numElts)
- end
- | _ => error ()
val continue = Label.newNoname ()
val loop = Label.newString "initLoop"
val loopi' = Label.newNoname ()
@@ -125,7 +52,7 @@
kind = Kind.Jump,
label = continue,
profileInfo = profileInfo,
- statements = Vector.fromList statements,
+ statements = statements,
transfer = transfer}
:: Block.T {args = Vector.new1 (i, Type.int),
kind = Kind.Jump,
@@ -145,34 +72,50 @@
dst = loop}}
:: !extra
in
- ([s],
- Transfer.Goto {args = Vector.new1 (Operand.int 0),
- dst = loop})
+ Transfer.Goto {args = Vector.new1 (Operand.int 0),
+ dst = loop}
end
val blocks =
Vector.map
(blocks,
fn block as Block.T {args, kind, label, profileInfo,
statements, transfer} =>
- if not (Vector.exists (statements, needsRewrite'))
+ if 0 = Vector.length statements
then block
else
- let
- val (statements, transfer) =
- Vector.foldr
- (statements, ([], transfer), fn (s, (statements, transfer)) =>
- case needsRewrite s of
- (true, false) => insertInit (s, profileInfo, statements, transfer)
- | (false, true) => insertSplit (s, profileInfo, statements, transfer)
- | _ => (s :: statements, transfer))
- in
- Block.T {args = args,
- kind = kind,
- label = label,
- profileInfo = profileInfo,
- statements = Vector.fromList statements,
- transfer = transfer}
- end)
+ case Vector.sub (statements, 0) of
+ s as Statement.PrimApp {args = arrayArgs, dst, prim, ...} =>
+ let
+ fun doit () =
+ let
+ val transfer =
+ init {array = #1 (valOf dst),
+ numElts = Vector.sub (arrayArgs, 0),
+ profileInfo = profileInfo,
+ statements = (Vector.dropPrefix
+ (statements, 1)),
+ transfer = transfer}
+ in
+ Block.T {args = args,
+ kind = kind,
+ label = label,
+ profileInfo = profileInfo,
+ statements = Vector.new1 s,
+ transfer = transfer}
+ end
+ in
+ case Prim.name prim of
+ Prim.Name.Array_allocate =>
+ (case Vector.sub (arrayArgs, 2) of
+ Operand.ArrayHeader {numPointers, ...} =>
+ if numPointers > 0
+ then doit ()
+ else block
+ | _ =>
+ Error.bug "ArrayInit: strange Array_allocate")
+ | _ => block
+ end
+ | _ => block)
val blocks = Vector.concat [blocks, Vector.fromList (!extra)]
in
Function.new {args = args,
1.32 +228 -92 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- backend.fun 23 Jun 2002 01:37:52 -0000 1.31
+++ backend.fun 6 Jul 2002 17:22:05 -0000 1.32
@@ -15,11 +15,20 @@
open Machine
in
structure Chunk = Chunk
+ structure Runtime = Runtime
end
-
+local
+ open Runtime
+in
+ structure CFunction = CFunction
+ structure GCField = GCField
+ structure ObjectType = ObjectType
+end
+val wordSize = Runtime.wordSize
+
structure Rssa = Rssa (open Ssa
structure Cases = Machine.Cases
- structure RuntimeOperand = M.RuntimeOperand
+ structure Runtime = Runtime
structure Type = Machine.Type)
structure R = Rssa
local
@@ -49,9 +58,7 @@
nonfix ^
fun ^ r = valOf (!r)
-val wordSize: int = 4
-val labelSize = Type.size Type.label
-
+
structure VarOperand =
struct
datatype t =
@@ -118,6 +125,27 @@
Label.layout o R.Block.label,
Unit.layout)
+fun eliminateDeadCode (f: R.Function.t): R.Function.t =
+ let
+ val {args, blocks, name, start} = R.Function.dest f
+ val {get, set, ...} =
+ Property.getSetOnce (Label.plist, Property.initConst false)
+ val get = Trace.trace ("Backend.labelIsReachable",
+ Label.layout,
+ Bool.layout) get
+ val _ =
+ R.Function.dfs (f, fn R.Block.T {label, ...} =>
+ (set (label, true)
+ ; fn () => ()))
+ val blocks =
+ Vector.keepAll (blocks, fn R.Block.T {label, ...} => get label)
+ in
+ R.Function.new {args = args,
+ blocks = blocks,
+ name = name,
+ start = start}
+ end
+
fun toMachine (program: Ssa.Program.t) =
let
fun pass (name, doit, program) =
@@ -252,9 +280,9 @@
Char n => M.Operand.Char n
| Int n => M.Operand.Int n
| IntInf i =>
- if Const.SmallIntInf.isSmall i
- then M.Operand.IntInf (Const.SmallIntInf.toWord i)
- else globalIntInf i
+ (case Const.SmallIntInf.toWord i of
+ NONE => globalIntInf i
+ | SOME w => M.Operand.IntInf w)
| Real f =>
if !Control.Native.native
then globalFloat f
@@ -270,6 +298,50 @@
end
end
end
+ (* Hash table for uniqifying object types. *)
+ local
+ val table = HashSet.new {hash = #hash}
+ val arrayHash = Random.word ()
+ val normalHash = Random.word ()
+ fun hash1 (w: word, i: int): word =
+ Word.fromInt i + Word.* (w, 0w31)
+ fun hash (i1: int, i2: int, w: word) = hash1 (hash1 (w, i1), i2)
+ (* Start the counter at 1 because index 0 is reserved for the stack
+ * object type.
+ *)
+ val counter = Counter.new 1
+ fun getIndex (hash: word, ty: ObjectType.t): int =
+ #index
+ (HashSet.lookupOrInsert
+ (table, hash, fn r => ObjectType.equals (ty, #ty r),
+ fn () => {hash = hash,
+ index = Counter.next counter,
+ ty = ty}))
+ in
+ fun arrayTypeIndex (z as {numBytesNonPointers = nbnp,
+ numPointers = np}): int =
+ getIndex (hash (nbnp, np, arrayHash), ObjectType.Array z)
+ fun normalTypeIndex (z as {numPointers = np,
+ numWordsNonPointers = nwnp}): int =
+ getIndex (hash (np, nwnp, normalHash), ObjectType.Normal z)
+ fun objectTypes () =
+ let
+ val a = Array.new (Counter.value counter, ObjectType.Stack)
+ val _ = HashSet.foreach (table, fn {index, ty, ...} =>
+ Array.update (a, index, ty))
+ in
+ Vector.fromArray a
+ end
+ (* The GC requires some hardwired type indices -- see gc.h. *)
+ val stackTypeIndex = 0
+ val stringTypeIndex = (* 1 *)
+ arrayTypeIndex {numBytesNonPointers = 1, numPointers = 0}
+ val threadTypeIndex = (* 2 *)
+ normalTypeIndex {numPointers = 1, numWordsNonPointers = 2}
+ val word8VectorTypeIndex = (* 1 *) stringTypeIndex
+ val wordVectorTypeIndex = (* 3 *)
+ arrayTypeIndex {numBytesNonPointers = 4, numPointers = 0}
+ end
fun parallelMove {chunk,
dsts: M.Operand.t vector,
srcs: M.Operand.t vector}: M.Statement.t vector =
@@ -294,12 +366,20 @@
datatype z = datatype R.Operand.t
in
case oper of
- ArrayOffset {base, index, ty} =>
+ ArrayHeader z =>
+ M.Operand.Uint (Runtime.typeIndexToHeader (arrayTypeIndex z))
+ | ArrayOffset {base, index, ty} =>
M.Operand.ArrayOffset {base = varOperand base,
index = varOperand index,
ty = ty}
- | CastInt x => M.Operand.CastInt (varOperand x)
+ | CastInt z => M.Operand.CastInt (translateOperand z)
+ | CastWord z => M.Operand.CastWord (translateOperand z)
| Const c => constOperand c
+ | EnsuresBytesFree =>
+ Error.bug "backend translateOperand saw EnsuresBytesFree"
+ | File => M.Operand.File
+ | GCState => M.Operand.GCState
+ | Line => M.Operand.Line
| Offset {base, bytes, ty} =>
M.Operand.Offset {base = varOperand base,
offset = bytes,
@@ -311,69 +391,115 @@
fun translateOperands ops = Vector.map (ops, translateOperand)
fun genStatement (s: R.Statement.t,
handlerLinkOffset: {handler: int,
- link: int} option): M.Statement.t =
+ link: int} option)
+ : M.Statement.t vector =
let
fun handlerOffset () = #handler (valOf handlerLinkOffset)
fun linkOffset () = #link (valOf handlerLinkOffset)
datatype z = datatype R.Statement.t
in
case s of
-(*
- Array {dst, numBytes, numBytesNonPointers, numElts, numPointers,
- ...} =>
- M.Statement.Array
- {dst = varOperand dst,
- header = (Runtime.arrayHeader
- {numBytesNonPointers = numBytesNonPointers,
- numPointers = numPointers}),
- numBytes = translateOperand numBytes,
- numElts = translateOperand numElts}
- |
-*)
Bind {isMutable, oper, var} =>
if isMutable
orelse (case #operand (varInfo var) of
VarOperand.Const _ => false
| _ => true)
- then M.Statement.move {dst = varOperand var,
- src = translateOperand oper}
- else M.Statement.Noop
+ then (Vector.new1
+ (M.Statement.move {dst = varOperand var,
+ src = translateOperand oper}))
+ else Vector.new0 ()
| Move {dst, src} =>
- M.Statement.move {dst = translateOperand dst,
- src = translateOperand src}
+ Vector.new1
+ (M.Statement.move {dst = translateOperand dst,
+ src = translateOperand src})
| Object {dst, numPointers, numWordsNonPointers, stores} =>
- M.Statement.Object
- {dst = varOperand dst,
- numPointers = numPointers,
- numWordsNonPointers = numWordsNonPointers,
- stores = Vector.map (stores, fn {offset, value} =>
- {offset = offset,
- value = translateOperand value})}
+ Vector.new1
+ (M.Statement.Object
+ {dst = varOperand dst,
+ header = (Runtime.typeIndexToHeader
+ (normalTypeIndex
+ {numPointers = numPointers,
+ numWordsNonPointers = numWordsNonPointers})),
+ size = (Runtime.normalHeaderSize
+ + (Runtime.normalSize
+ {numPointers = numPointers,
+ numWordsNonPointers = numWordsNonPointers})),
+ stores = Vector.map (stores, fn {offset, value} =>
+ {offset = offset,
+ value = translateOperand value})})
| PrimApp {dst, prim, args} =>
- (case Prim.name prim of
- Prim.Name.MLton_installSignalHandler =>
- M.Statement.Noop
- | _ =>
- M.Statement.PrimApp
- {args = translateOperands args,
- dst = Option.map (dst, varOperand o #1),
- prim = prim})
+ let
+ datatype z = datatype Prim.Name.t
+ in
+ case Prim.name prim of
+ Array_allocate =>
+ let
+ val frontier =
+ M.Operand.Runtime GCField.Frontier
+ fun arg i =
+ translateOperand (Vector.sub (args, i))
+ in Vector.new5
+ (M.Statement.Move
+ {dst = M.Operand.Contents {oper = frontier,
+ ty = Type.word},
+ src = M.Operand.Uint 0w0},
+ M.Statement.Move
+ {dst = M.Operand.Offset {base = frontier,
+ offset = wordSize,
+ ty = Type.int},
+ src = translateOperand (Vector.sub (args, 0))},
+ M.Statement.Move
+ {dst = M.Operand.Offset {base = frontier,
+ offset = 2 * wordSize,
+ ty = Type.uint},
+ src = translateOperand (Vector.sub (args, 2))},
+ M.Statement.PrimApp
+ {args = Vector.new2 (frontier,
+ M.Operand.Uint
+ (Word.fromInt
+ (3 * wordSize))),
+ dst = SOME (varOperand (#1 (valOf dst))),
+ prim = Prim.word32Add},
+ M.Statement.PrimApp
+ {args = Vector.new2 (frontier, arg 1),
+ dst = SOME frontier,
+ prim = Prim.word32Add})
+ end
+ | MLton_installSignalHandler => Vector.new0 ()
+ | _ =>
+ Vector.new1
+ (M.Statement.PrimApp
+ {args = translateOperands args,
+ dst = Option.map (dst, varOperand o #1),
+ prim = prim})
+ end
| SetExnStackLocal =>
- M.Statement.SetExnStackLocal {offset = handlerOffset ()}
+ Vector.new1
+ (M.Statement.SetExnStackLocal {offset = handlerOffset ()})
| SetExnStackSlot =>
- M.Statement.SetExnStackSlot {offset = linkOffset ()}
+ Vector.new1
+ (M.Statement.SetExnStackSlot {offset = linkOffset ()})
| SetHandler h =>
- M.Statement.move
- {dst = M.Operand.StackOffset {offset = handlerOffset (),
- ty = Type.label},
- src = M.Operand.Label h}
+ Vector.new1
+ (M.Statement.move
+ {dst = M.Operand.StackOffset {offset = handlerOffset (),
+ ty = Type.label},
+ src = M.Operand.Label h})
| SetSlotExnStack =>
- M.Statement.SetSlotExnStack {offset = linkOffset ()}
+ Vector.new1
+ (M.Statement.SetSlotExnStack {offset = linkOffset ()})
end
val genStatement =
Trace.trace ("Backend.genStatement",
- R.Statement.layout o #1, M.Statement.layout)
+ R.Statement.layout o #1, Vector.layout M.Statement.layout)
genStatement
+ val bugTransfer =
+ M.Transfer.CCall
+ {args = (Vector.new1
+ (globalString "backend thought control shouldn't reach here")),
+ frameInfo = NONE,
+ func = CFunction.bug,
+ return = NONE}
val {get = labelInfo: Label.t -> {args: (Var.t * Type.t) vector},
set = setLabelInfo, ...} =
Property.getSetOnce
@@ -384,6 +510,7 @@
setLabelInfo
fun genFunc (f: Function.t, isMain: bool): unit =
let
+ val f = eliminateDeadCode f
val {args, blocks, name, start, ...} = Function.dest f
val chunk = funcChunk name
fun labelArgOperands (l: R.Label.t): M.Operand.t vector =
@@ -501,19 +628,24 @@
prim = prim,
success = success,
ty = ty})
- | R.Transfer.Bug => simple M.Transfer.Bug
- | R.Transfer.CCall {args, prim, return, returnTy} =>
- simple (M.Transfer.CCall {args = translateOperands args,
- prim = prim,
- return = return,
- returnTy = returnTy})
+ | R.Transfer.CCall {args, func, return} =>
+ simple (M.Transfer.CCall
+ {args = translateOperands args,
+ frameInfo = if CFunction.mayGC func
+ then SOME M.FrameInfo.bogus
+ else NONE,
+ func = func,
+ return = return})
| R.Transfer.Call {func, args, return} =>
let
val (frameSize, return, handlerLive) =
case return of
- R.Return.Dead => (0, NONE, Vector.new0 ())
- | R.Return.Tail => (0, NONE, Vector.new0 ())
- | R.Return.HandleOnly => (0, NONE, Vector.new0 ())
+ R.Return.Dead =>
+ (0, NONE, Vector.new0 ())
+ | R.Return.Tail =>
+ (0, NONE, Vector.new0 ())
+ | R.Return.HandleOnly =>
+ (0, NONE, Vector.new0 ())
| R.Return.NonTail {cont, handler} =>
let
val {size, adjustSize, ...} =
@@ -585,18 +717,12 @@
dsts = dsts},
M.Transfer.Return {live = dsts})
end
- | R.Transfer.Runtime {prim, args, return} =>
- simple
- (M.Transfer.Runtime
- {args = Vector.map (args, translateOperand),
- prim = prim,
- return = return})
| R.Transfer.Switch {cases, default, test} =>
let
fun doit l =
simple
(case (l, default) of
- ([], NONE) => M.Transfer.Bug
+ ([], NONE) => bugTransfer
| ([(_, dst)], NONE) => M.Transfer.Goto dst
| ([], SOME dst) => M.Transfer.Goto dst
| _ =>
@@ -643,13 +769,13 @@
transfer = M.Transfer.Goto start})
end
else ()
-
val {adjustSize, live, liveNoFormals, size, ...} =
labelRegInfo label
val chunk = labelChunk label
val statements =
- Vector.map (statements, fn s =>
- genStatement (s, handlerLinkOffset))
+ Vector.concatV
+ (Vector.map (statements, fn s =>
+ genStatement (s, handlerLinkOffset)))
val (preTransfer, transfer) =
genTransfer (transfer, chunk, label)
fun frame () =
@@ -671,7 +797,7 @@
end
val (kind, live, pre) =
case kind of
- R.Kind.Cont {handler} =>
+ R.Kind.Cont _ =>
let
val _ = frame ()
val srcs = callReturnOperands (args, #2, size)
@@ -684,16 +810,26 @@
dsts = Vector.map (args, varOperand o #1),
srcs = srcs})
end
- | R.Kind.CReturn {prim} =>
+ | R.Kind.CReturn {func as CFunction.T {mayGC, ...}} =>
let
val dst =
if 0 < Vector.length args
then SOME (varOperand
(#1 (Vector.sub (args, 0))))
else NONE
+ val frameInfo =
+ if mayGC
+ then
+ let
+ val _ = frame ()
+ in
+ SOME M.FrameInfo.bogus
+ end
+ else NONE
in
(M.Kind.CReturn {dst = dst,
- prim = prim},
+ frameInfo = frameInfo,
+ func = func},
liveNoFormals,
Vector.new0 ())
end
@@ -714,15 +850,6 @@
(Vector.map (dsts, M.Operand.ty)))})
end
| R.Kind.Jump => (M.Kind.Jump, live, Vector.new0 ())
- | R.Kind.Runtime {prim} =>
- let
- val _ = frame ()
- in
- (M.Kind.Runtime {frameInfo = M.FrameInfo.bogus,
- prim = prim},
- liveNoFormals,
- Vector.new0 ())
- end
val statements = Vector.concat [pre, statements, preTransfer]
in
Chunk.newBlock (chunk,
@@ -795,9 +922,22 @@
case kind of
Cont {args, ...} => Cont {args = args,
frameInfo = frameInfo label}
- | Runtime {prim, ...} => Runtime {frameInfo = frameInfo label,
- prim = prim}
+ | CReturn {dst, frameInfo = f, func} =>
+ CReturn {dst = dst,
+ frameInfo = Option.map (f, fn _ =>
+ frameInfo label),
+ func = func}
| _ => kind
+ val transfer =
+ case transfer of
+ M.Transfer.CCall {args, frameInfo = f, func, return} =>
+ M.Transfer.CCall
+ {args = args,
+ frameInfo = Option.map (f, fn _ =>
+ frameInfo (valOf return)),
+ func = func,
+ return = return}
+ | _ => transfer
in
M.Block.T {kind = kind,
label = label,
@@ -825,8 +965,6 @@
Vector.fold
(blocks, max, fn (M.Block.T {kind, statements, transfer, ...}, max) =>
let
- fun doFrameInfo (M.FrameInfo.T {size, ...}, max) =
- Int.max (max, size)
fun doOperand (z: M.Operand.t, max) =
let
datatype z = datatype M.Operand.t
@@ -842,12 +980,9 @@
| _ => max
end
val max =
- case kind of
- M.Kind.Cont {frameInfo, ...} =>
- doFrameInfo (frameInfo, max)
- | M.Kind.Runtime {frameInfo, ...} =>
- doFrameInfo (frameInfo, max)
- | _ => max
+ case M.Kind.frameInfoOpt kind of
+ NONE => max
+ | SOME (M.FrameInfo.T {size, ...}) => Int.max (max, size)
val max =
Vector.fold
(statements, max, fn (s, max) =>
@@ -869,6 +1004,7 @@
intInfs = allIntInfs (),
main = main,
maxFrameSize = maxFrameSize,
+ objectTypes = objectTypes (),
strings = allStrings ()}
end
1.11 +1 -1 mlton/mlton/backend/chunkify.fun
Index: chunkify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/chunkify.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- chunkify.fun 10 Apr 2002 07:02:19 -0000 1.10
+++ chunkify.fun 6 Jul 2002 17:22:05 -0000 1.11
@@ -134,7 +134,7 @@
case transfer of
Arith {overflow, success, ...} =>
(same overflow; same success)
- | CCall {return, ...} => same return
+ | CCall {return, ...} => Option.app (return, same)
| Goto {dst, ...} => same dst
| Switch {cases, default, ...} =>
(Cases.foreach (cases, same)
1.25 +176 -155 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- limit-check.fun 23 Jun 2002 01:37:54 -0000 1.24
+++ limit-check.fun 6 Jul 2002 17:22:05 -0000 1.25
@@ -66,70 +66,93 @@
open S
open Rssa
-fun reduceSlop (n: int): int =
- if n < Runtime.limitSlop
- then 0
- else n - Runtime.limitSlop
-
structure Statement =
struct
open Statement
- fun error () = Error.bug "Primitive with non-constant bytesNeeded"
- fun objectBytesAllocated s =
+ fun caseBytes (s: Statement.t,
+ {big: Operand.t -> 'a,
+ small: word -> 'a}): 'a =
case s of
- Statement.Object {numPointers = p, numWordsNonPointers = np, ...} =>
- Runtime.objectHeaderSize
- + Runtime.objectSize {numPointers = p, numWordsNonPointers = np}
- | Statement.PrimApp {prim, args, ...} =>
- (case Prim.bytesNeeded prim of
- SOME f => (case f args of
- Operand.Const c =>
- (case Const.node c of
- Const.Node.Word w => Word.toInt w
- | _ => error ())
- | _ => 0)
- | NONE => 0)
- | _ => 0
+ Object {numPointers = np, numWordsNonPointers = nwnp, ...} =>
+ small (Word.fromInt
+ (Runtime.normalHeaderSize
+ + Runtime.normalSize {numPointers = np,
+ numWordsNonPointers = nwnp}))
+ | PrimApp {args, prim, ...} =>
+ (case Prim.name prim of
+ Prim.Name.Array_allocate =>
+ Operand.caseBytes (Vector.sub (args, 1),
+ {big = big,
+ small = small})
+ | _ => small 0w0)
+ | _ => small 0w0
+ end
+
+structure Transfer =
+ struct
+ open Transfer
+
+ fun caseBytes (t: t, {big: Operand.t -> 'a,
+ small: word -> 'a}): 'a =
+ case t of
+ CCall {args, func = CFunction.T {bytesNeeded = SOME i, ...}, ...} =>
+ Operand.caseBytes (Vector.sub (args, i),
+ {big = big,
+ small = small})
+ | _ => small 0w0
end
-structure BlockInfo =
+structure Block =
struct
- datatype t = T of {heap: {bytes: int} option,
- stack: bool}
-
- fun layout (T {heap, stack}) =
- Layout.record
- [("heap", Option.layout
- (fn {bytes, ...} =>
- Layout.record
- [("bytes", Int.layout bytes)])
- heap),
- ("stack", Bool.layout stack)]
-
+ open Block
+
+ fun objectBytesAllocated (T {statements, transfer, ...}): word =
+ Vector.fold (statements, 0w0, fn (s, ac) =>
+ ac + Statement.caseBytes (s,
+ {big = fn _ => 0w0,
+ small = fn w => w}))
+ + Transfer.caseBytes (transfer,
+ {big = fn _ => 0w0,
+ small = fn w => w})
end
val extraGlobals: Var.t list ref = ref []
fun insertFunction (f: Function.t,
handlesSignals: bool,
- blockInfo: {blockIndex: int} -> BlockInfo.t) =
+ blockCheckAmount: {blockIndex: int} -> word,
+ ensureBytesFree: Label.t -> word) =
let
val {args, blocks, name, start} = Function.dest f
val newBlocks = ref []
val (_, allocTooLarge) = Block.allocTooLarge newBlocks
val _ =
Vector.foreachi
- (blocks, fn (i, block as Block.T {args, kind, label, profileInfo,
- statements, transfer}) =>
+ (blocks, fn (i, Block.T {args, kind, label, profileInfo,
+ statements, transfer}) =>
let
- val BlockInfo.T {heap, stack} = blockInfo {blockIndex = i}
- val _ = Assert.assert
- ("LimitCheck.insertFunction: stack", fn () =>
- if Label.equals (start, label)
- then stack
- else not stack)
- fun insert (amount: Operand.t) =
+ val transfer =
+ case transfer of
+ Transfer.CCall {args,
+ func as CFunction.T {ensuresBytesFree, ...},
+ return} =>
+ (if ensuresBytesFree
+ then
+ Transfer.CCall
+ {args = (Vector.map
+ (args, fn z =>
+ case z of
+ Operand.EnsuresBytesFree =>
+ Operand.word
+ (ensureBytesFree (valOf return))
+ | _ => z)),
+ func = func,
+ return = return}
+ else transfer)
+ | _ => transfer
+ val stack = Label.equals (start, label)
+ fun insert (amount: Operand.t (* of type word *)) =
let
val collect = Label.newNoname ()
val collectReturn = Label.newNoname ()
@@ -167,6 +190,7 @@
(dontCollect, Vector.new0 (), Operand.bool false)
| Control.Every =>
(collect, Vector.new0 (), Operand.bool true)
+ val func = CFunction.gc {maySwitchThreads = handlesSignals}
val _ =
newBlocks :=
Block.T {args = Vector.new0 (),
@@ -174,18 +198,22 @@
label = collect,
profileInfo = profileInfo,
statements = Vector.new0 (),
- transfer = (Transfer.Runtime
- {args = Vector.new2 (amount, force),
- prim = Prim.gcCollect,
- return = collectReturn})}
- :: Block.T {args = Vector.new0 (),
- kind = Kind.Runtime {prim = Prim.gcCollect},
- label = collectReturn,
- profileInfo = profileInfo,
- statements = collectReturnStatements,
- transfer =
- Transfer.Goto {dst = dontCollect,
- args = Vector.new0 ()}}
+ transfer = (Transfer.CCall
+ {args = Vector.new5 (Operand.GCState,
+ amount,
+ force,
+ Operand.File,
+ Operand.Line),
+ func = func,
+ return = SOME collectReturn})}
+ :: (Block.T
+ {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ label = collectReturn,
+ profileInfo = profileInfo,
+ statements = collectReturnStatements,
+ transfer = Transfer.Goto {dst = dontCollect,
+ args = Vector.new0 ()}})
:: Block.T {args = Vector.new0 (),
kind = Kind.Jump,
label = dontCollect,
@@ -230,7 +258,7 @@
in
(Vector.new1 s, transfer)
end
- datatype z = datatype RuntimeOperand.t
+ datatype z = datatype Runtime.GCField.t
fun stackCheck (maybeFirst, z): Label.t =
let
val (statements, transfer) =
@@ -243,10 +271,16 @@
end
fun maybeStack (): Label.t =
if stack
- then stackCheck (true, insert (Operand.int 0))
+ then stackCheck (true, insert (Operand.word 0w0))
else
(* No limit check, just keep the block around. *)
- (List.push (newBlocks, block)
+ (List.push (newBlocks,
+ Block.T {args = args,
+ kind = kind,
+ label = label,
+ profileInfo = profileInfo,
+ statements = statements,
+ transfer = transfer})
; label)
fun frontierCheck (isFirst,
prim, op1, op2,
@@ -261,7 +295,8 @@
dontCollect = l})
else l
end
- fun heapCheck (isFirst: bool, amount: Operand.t): Label.t =
+ fun heapCheck (isFirst: bool,
+ amount: Operand.t (* of type word *)): Label.t =
let
val z as {collect, dontCollect} = insert amount
val res = Var.newNoname ()
@@ -306,23 +341,21 @@
Prim.word32Gt,
Operand.Runtime Frontier,
Operand.Runtime Limit,
- insert (Operand.int 0))
+ insert (Operand.word 0w0))
else heapCheck (true, Operand.word bytes)
- fun noPrimitiveAllocation () =
- case heap of
- NONE => maybeStack ()
- | SOME {bytes} =>
- if bytes = 0
- then maybeStack ()
- else heapCheckNonZero (Word.fromInt bytes)
- fun primitiveAllocation (bytesNeeded: Operand.t) =
+ fun smallAllocation _ =
+ let
+ val w = blockCheckAmount {blockIndex = i}
+ in
+ if w = 0w0
+ then maybeStack ()
+ else heapCheckNonZero w
+ end
+ fun bigAllocation (bytesNeeded: Operand.t) =
let
val extraBytes =
- Word.fromInt
- (Runtime.arrayHeaderSize
- + (case heap of
- NONE => 0
- | SOME {bytes} => bytes))
+ Word.fromInt Runtime.arrayHeaderSize
+ + blockCheckAmount {blockIndex = i}
in
case bytesNeeded of
Operand.Const c =>
@@ -352,15 +385,12 @@
ty = Type.word})
end
end
+ val bs = {big = bigAllocation,
+ small = smallAllocation}
val _ =
if 0 < Vector.length statements
- then case Vector.sub (statements, 0) of
- Statement.PrimApp {prim, args, ...} =>
- (case Prim.bytesNeeded prim of
- SOME f => primitiveAllocation (f args)
- | _ => noPrimitiveAllocation ())
- | _ => noPrimitiveAllocation ()
- else noPrimitiveAllocation ()
+ then Statement.caseBytes (Vector.sub (statements, 0), bs)
+ else Transfer.caseBytes (transfer, bs)
in
()
end)
@@ -374,23 +404,10 @@
fun insertPerBlock (f: Function.t, handlesSignals) =
let
val {start, blocks, ...} = Function.dest f
- fun blockInfo {blockIndex} =
- let
- val block as Block.T {label, statements, ...} =
- Vector.sub (blocks, blockIndex)
- val bytes =
- Vector.fold
- (statements, 0, fn (s, ac) =>
- ac + Statement.objectBytesAllocated s)
- val heap = SOME {bytes = bytes}
- val stack = Label.equals (start, label)
- in
- BlockInfo.T
- {heap = heap,
- stack = Label.equals (start, label)}
- end
+ fun blockCheckAmount {blockIndex} =
+ Block.objectBytesAllocated (Vector.sub (blocks, blockIndex))
in
- insertFunction (f, handlesSignals, blockInfo)
+ insertFunction (f, handlesSignals, blockCheckAmount, fn _ => 0w0)
end
structure Graph = DirectedGraph
@@ -398,7 +415,7 @@
structure Edge = Graph.Edge
structure Forest = Graph.LoopForest
-val traceMaxPath = Trace.trace ("maxPath", Int.layout, Int.layout)
+val traceMaxPath = Trace.trace ("maxPath", Int.layout, Word.layout)
fun insertCoalesce (f: Function.t, handlesSignals) =
let
@@ -431,33 +448,41 @@
val root = Graph.newNode g
(* mayHaveCheck == E U D
* E = set of entry nodes
- * = start, Cont, Handler, Runtime, or
- * Jump that starts with a primitive with non-constant bytesNeeded
+ * = start, Cont, Handler,
+ * or CReturn that doesn't ensure bytesFree
+ * Jump that calls a cfunction with bytesneeded
* D = set of decycling nodes
*)
val mayHaveCheck =
Array.tabulate
(n, fn i =>
let
- val Block.T {kind, statements, ...} = Vector.sub (blocks, i)
+ val Block.T {kind, statements, transfer, ...} =
+ Vector.sub (blocks, i)
datatype z = datatype Kind.t
+ val bs = {big = fn _ => true,
+ small = fn _ => false}
+ fun isBigAlloc () =
+ if 0 < Vector.length statements
+ then Statement.caseBytes (Vector.sub (statements, 0), bs)
+ else Transfer.caseBytes (transfer, bs)
val b =
case kind of
Cont _ => true
- | CReturn _ => false
+ | CReturn {func = CFunction.T {ensuresBytesFree, mayGC, ...}} =>
+ mayGC andalso not ensuresBytesFree
| Handler => true
- | Jump => (0 < Vector.length statements
- andalso (case Vector.sub (statements, 0) of
- Statement.PrimApp {prim, args, ...} =>
- (case Prim.bytesNeeded prim of
- SOME f => (case f args of
- Operand.Const c => false
- | _ => true)
- | _ => false)
- | _ => false))
- | Runtime _ => true
+ | Jump =>
+ (case transfer of
+ Transfer.CCall
+ {args,
+ func = CFunction.T {bytesNeeded = SOME i, ...},
+ ...} => (case Vector.sub (args, i) of
+ Operand.Const c => false
+ | _ => true)
+ | _ => false)
in
- b
+ b orelse isBigAlloc ()
end)
val _ = Array.update (mayHaveCheck, labelIndex start, true)
(* Build cfg. *)
@@ -490,11 +515,7 @@
else addEdge from
end)
end)
- val objectBytesAllocated =
- Vector.map
- (blocks, fn Block.T {statements, ...} =>
- Vector.fold (statements, 0, fn (s, ac) =>
- ac + Statement.objectBytesAllocated s))
+ val objectBytesAllocated = Vector.map (blocks, Block.objectBytesAllocated)
fun insertCoalesceExtBasicBlocks () =
let
val preds = Array.new (n, 0)
@@ -513,11 +534,10 @@
in
()
end
-
fun insertCoalesceLoopHeaders loopExits =
let
- (* Set equivalence classes, where two nodes are equivalent if they are
- * in the same loop in the loop forest.
+ (* Set equivalence classes, where two nodes are equivalent if they
+ * are in the same loop in the loop forest.
* Also mark loop headers as mayHaveCheck.
*)
val classes = Array.array (n, ~1)
@@ -527,15 +547,17 @@
let
val class = Counter.next c
val _ =
- Vector.foreach (notInLoop, fn n =>
- if Node.equals (n, root)
- then ()
- else Array.update (classes, nodeIndex n, class))
+ Vector.foreach
+ (notInLoop, fn n =>
+ if Node.equals (n, root)
+ then ()
+ else Array.update (classes, nodeIndex n, class))
val _ =
Vector.foreach
(loops, fn {headers, child} =>
- (Vector.foreach (headers, fn n =>
- Array.update (mayHaveCheck, nodeIndex n, true))
+ (Vector.foreach
+ (headers, fn n =>
+ Array.update (mayHaveCheck, nodeIndex n, true))
; setClass child))
in
()
@@ -547,7 +569,8 @@
if loopExits
then let
(* Determine which classes allocate. *)
- val classDoesAllocate = Array.array (numClasses, false)
+ val classDoesAllocate =
+ Array.array (numClasses, false)
val _ =
List.foreach
(Graph.nodes g, fn n =>
@@ -557,7 +580,7 @@
let
val i = nodeIndex n
in
- if 0 < Vector.sub (objectBytesAllocated, i)
+ if 0w0 < Vector.sub (objectBytesAllocated, i)
then Array.update (classDoesAllocate,
indexClass i,
true)
@@ -596,14 +619,12 @@
in
()
end
-
datatype z = datatype Control.limitCheck
val _ =
case !Control.limitCheck of
ExtBasicBlocks => insertCoalesceExtBasicBlocks ()
| LoopHeaders {loopExits, ...} => insertCoalesceLoopHeaders loopExits
| _ => Error.bug "LimitCheck.insertCoalesce"
-
(* If we remove edges into nodes that are mayHaveCheck, we have an
* acyclic graph.
* So, we can compute a function, maxPath, inductively that for each node
@@ -613,7 +634,7 @@
local
val a = Array.array (n, NONE)
in
- fun maxPath arg = (* i is a node index *)
+ fun maxPath arg : word = (* i is a node index *)
traceMaxPath
(fn (i: int) =>
case Array.sub (a, i) of
@@ -623,13 +644,13 @@
val x = Vector.sub (objectBytesAllocated, i)
val max =
List.fold
- (Node.successors (indexNode i), 0, fn (e, max) =>
+ (Node.successors (indexNode i), 0w0, fn (e, max) =>
let
val i' = nodeIndex (Edge.to e)
in
if Array.sub (mayHaveCheck, i')
then max
- else Int.max (max, maxPath i')
+ else Word.max (max, maxPath i')
end)
val x = x + max
val _ = Array.update (a, i, SOME x)
@@ -638,20 +659,21 @@
end
) arg
end
- fun blockInfo {blockIndex} =
- let
- val block as Block.T {label, statements, ...} =
- Vector.sub (blocks, blockIndex)
- val heap = if Array.sub (mayHaveCheck, blockIndex)
- then SOME {bytes = maxPath blockIndex}
- else NONE
- val stack = Label.equals (start, label)
- in
- BlockInfo.T
- {heap = heap,
- stack = Label.equals (start, label)}
- end
- val f = insertFunction (f, handlesSignals, blockInfo)
+ fun blockCheckAmount {blockIndex} =
+ if Array.sub (mayHaveCheck, blockIndex)
+ then maxPath blockIndex
+ else 0w0
+ val f = insertFunction (f, handlesSignals, blockCheckAmount,
+ maxPath o labelIndex)
+ val _ =
+ Control.diagnostics
+ (fn display =>
+ Vector.foreach
+ (blocks, fn Block.T {label, ...} =>
+ display (let open Layout
+ in seq [Label.layout label, str " ",
+ Word.layout (maxPath (labelIndex label))]
+ end)))
val _ = Function.clear f
in
f
@@ -659,15 +681,15 @@
fun insert (p as Program.T {functions, main}) =
let
+ val _ = Control.diagnostic (fn () => Layout.str "Limit Check maxPaths")
datatype z = datatype Control.limitCheck
- val insertFunction =
- case !Control.limitCheck of
- PerBlock => insertPerBlock
- | _ => insertCoalesce
val handlesSignals = Program.handlesSignals p
- val insertFunction = fn f => insertFunction (f, handlesSignals)
- val functions = List.revMap (functions, insertFunction)
- val {args, blocks, name, start} = Function.dest (insertFunction main)
+ fun insert f =
+ case !Control.limitCheck of
+ PerBlock => insertPerBlock (f, handlesSignals)
+ | _ => insertCoalesce (f, handlesSignals)
+ val functions = List.revMap (functions, insert)
+ val {args, blocks, name, start} = Function.dest (insert main)
val newStart = Label.newNoname ()
val block =
Block.T {args = Vector.new0 (),
@@ -690,6 +712,5 @@
Program.T {functions = functions,
main = main}
end
-
end
1.8 +1 -0 mlton/mlton/backend/limit-check.sig
Index: limit-check.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- limit-check.sig 16 Apr 2002 12:10:52 -0000 1.7
+++ limit-check.sig 6 Jul 2002 17:22:05 -0000 1.8
@@ -6,6 +6,7 @@
* Please see the file MLton-LICENSE for license information.
*)
type int = Int.t
+type word = Word.t
signature LIMIT_CHECK_STRUCTS =
sig
1.24 +162 -112 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- machine.fun 23 Jun 2002 01:37:54 -0000 1.23
+++ machine.fun 6 Jul 2002 17:22:05 -0000 1.24
@@ -10,9 +10,15 @@
open S
+local
+ open Runtime
+in
+ structure CFunction = CFunction
+ structure GCField = GCField
+ structure Type = Type
+end
+
structure ChunkLabel = IntUniqueId ()
-structure Type = Mtype ()
-structure RuntimeOperand = Runtime.GCField
structure SmallIntInf =
struct
@@ -70,30 +76,35 @@
index: t,
ty: Type.t}
| CastInt of t
+ | CastWord of t
| Char of char
| Contents of {oper: t,
ty: Type.t}
+ | File
| Float of string
+ | GCState
| Global of Global.t
| GlobalPointerNonRoot of int
| Int of int
| IntInf of SmallIntInf.t
| Label of Label.t
+ | Line
| Offset of {base: t, offset: int, ty: Type.t}
| Pointer of int
| Register of Register.t
- | Runtime of RuntimeOperand.t
+ | Runtime of GCField.t
| StackOffset of {offset: int, ty: Type.t}
| Uint of Word.t
-
- val isLocation =
+
+ val rec isLocation =
fn ArrayOffset _ => true
+ | CastWord z => isLocation z
| Contents _ => true
| Global _ => true
| GlobalPointerNonRoot _ => true
| Offset _ => true
| Register _ => true
- | Runtime _ => true
+ | Runtime z => true
| StackOffset _ => true
| _ => false
@@ -101,46 +112,52 @@
fn ArrayOffset {base, index, ty} =>
concat ["X", Type.name ty,
"(", toString base, ",", toString index, ")"]
- | CastInt oper => concat ["PointerToInt (", toString oper, ")"]
+ | CastInt oper => concat ["(int) (", toString oper, ")"]
+ | CastWord oper => concat ["(word) (", toString oper, ")"]
| Char c => Char.escapeC c
| Contents {oper, ty} =>
concat ["C", Type.name ty, "(", toString oper, ")"]
+ | File => "<FILE>"
+ | Float s => s
+ | GCState => "gcState"
| Global g => Global.toString g
| GlobalPointerNonRoot n =>
concat ["globalpointerNonRoot [", Int.toString n, "]"]
| Int n => Int.toString n
| IntInf w => concat ["SmallIntInf (", Word.toString w, ")"]
| Label l => Label.toString l
+ | Line => "<LINE>"
| Offset {base, offset, ty} =>
concat ["O", Type.name ty,
"(", toString base, ",", Int.toString offset, ")"]
| Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
| Register r => Register.toString r
- | Runtime r => RuntimeOperand.toString r
+ | Runtime r => GCField.toString r
| StackOffset {offset, ty} =>
concat ["S", Type.name ty, "(", Int.toString offset, ")"]
- | Uint w => Word.toString w
- | Float s => s
+ | Uint w => concat ["0x", Word.toString w]
val layout = Layout.str o toString
val ty =
fn ArrayOffset {ty, ...} => ty
| CastInt _ => Type.int
+ | CastWord _ => Type.word
| Char _ => Type.char
| Contents {ty, ...} => ty
+ | File => Type.pointer
| Float _ => Type.double
+ | GCState => Type.pointer
| Global g => Global.ty g
| GlobalPointerNonRoot _ => Type.pointer
| Int _ => Type.int
| IntInf _ => Type.pointer
| Label _ => Type.label
+ | Line => Type.int
| Offset {ty, ...} => ty
| Pointer _ => Type.pointer
| Register r => Register.ty r
- | Runtime z => (case RuntimeOperand.ty z of
- RuntimeOperand.Int => Type.int
- | RuntimeOperand.Word => Type.word)
+ | Runtime z => GCField.ty z
| StackOffset {ty, ...} => ty
| Uint _ => Type.uint
@@ -149,12 +166,16 @@
ArrayOffset {base = b', index = i', ...}) =>
equals (b, b') andalso equals (i, i')
| (CastInt z, CastInt z') => equals (z, z')
+ | (CastWord z, CastWord z') => equals (z, z')
| (Char c, Char c') => c = c'
| (Contents {oper = z, ...}, Contents {oper = z', ...}) =>
equals (z, z')
+ | (File, File) => true
| (Float f, Float f') => f = f'
+ | (GCState, GCState) => true
| (Int n, Int n') => n = n'
| (IntInf w, IntInf w') => Word.equals (w, w')
+ | (Line, Line) => true
| (Offset {base = b, offset = i, ...},
Offset {base = b', offset = i', ...}) =>
equals (b, b') andalso i = i'
@@ -193,8 +214,8 @@
src: Operand.t}
| Noop
| Object of {dst: Operand.t,
- numPointers: int,
- numWordsNonPointers: int,
+ header: word,
+ size: int,
stores: {offset: int,
value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
@@ -211,10 +232,10 @@
fn Move {dst, src} =>
seq [Operand.layout dst, str " = ", Operand.layout src]
| Noop => str "Noop"
- | Object {dst, numPointers, numWordsNonPointers, stores} =>
+ | Object {dst, header, size, stores} =>
seq [Operand.layout dst, str " = Object ",
- tuple [Int.layout numWordsNonPointers,
- Int.layout numPointers],
+ record [("header", Word.layout header),
+ ("size", Int.layout size)],
str " ",
Vector.layout (fn {offset, value} =>
record [("offset", Int.layout offset),
@@ -257,20 +278,38 @@
structure Cases = MachineCases (structure Label = Label)
+structure FrameInfo =
+ struct
+ datatype t = T of {frameOffsetsIndex: int,
+ size: int}
+
+ local
+ fun make f (T r) = f r
+ in
+ val frameOffsetsIndex = make #frameOffsetsIndex
+ val size = make #size
+ end
+
+ fun layout (T {frameOffsetsIndex, size}) =
+ Layout.record [("frameOffsetsIndex", Int.layout frameOffsetsIndex),
+ ("size", Int.layout size)]
+
+ val bogus = T {frameOffsetsIndex = ~1, size = ~1}
+ end
+
structure Transfer =
struct
datatype t =
- Arith of {prim: Prim.t,
- args: Operand.t vector,
+ Arith of {args: Operand.t vector,
dst: Operand.t,
overflow: Label.t,
+ prim: Prim.t,
success: Label.t,
ty: Type.t}
- | Bug
| CCall of {args: Operand.t vector,
- prim: Prim.t,
- return: Label.t,
- returnTy: Type.t option}
+ frameInfo: FrameInfo.t option,
+ func: CFunction.t,
+ return: Label.t option}
| Call of {label: Label.t,
live: Operand.t vector,
return: {return: Label.t,
@@ -279,15 +318,12 @@
| Goto of Label.t
| Raise
| Return of {live: Operand.t vector}
- | Runtime of {args: Operand.t vector,
- prim: Prim.t,
- return: Label.t}
- | Switch of {test: Operand.t,
- cases: Cases.t,
- default: Label.t option}
- | SwitchIP of {test: Operand.t,
- int: Label.t,
- pointer: Label.t}
+ | Switch of {cases: Cases.t,
+ default: Label.t option,
+ test: Operand.t}
+ | SwitchIP of {int: Label.t,
+ pointer: Label.t,
+ test: Operand.t}
fun layout t =
let
@@ -301,13 +337,13 @@
("dst", Operand.layout dst),
("overflow", Label.layout overflow),
("success", Label.layout success)]]
- | Bug => str "Bug"
- | CCall {args, prim, return, returnTy} =>
+ | CCall {args, frameInfo, func, return} =>
seq [str "CCall ",
- record [("args", Vector.layout Operand.layout args),
- ("prim", Prim.layout prim),
- ("return", Label.layout return),
- ("returnTy", Option.layout Type.layout returnTy)]]
+ record
+ [("args", Vector.layout Operand.layout args),
+ ("frameInfo", Option.layout FrameInfo.layout frameInfo),
+ ("func", CFunction.layout func),
+ ("return", Option.layout Label.layout return)]]
| Call {label, live, return} =>
seq [str "Call ",
record [("label", Label.layout label),
@@ -324,11 +360,6 @@
| Return {live} =>
seq [str "Return ",
record [("live", Vector.layout Operand.layout live)]]
- | Runtime {args, prim, return} =>
- seq [str "Runtime ",
- record [("args", Vector.layout Operand.layout args),
- ("prim", Prim.layout prim),
- ("return", Label.layout return)]]
| Switch {test, cases, default} =>
seq [str "Switch ",
tuple [Operand.layout test,
@@ -344,44 +375,22 @@
case t of
Arith {args, dst, ...} => Vector.fold (args, f (dst, ac), f)
| CCall {args, ...} => Vector.fold (args, ac, f)
- | Runtime {args, ...} => Vector.fold (args, ac, f)
| Switch {test, ...} => f (test, ac)
| SwitchIP {test, ...} => f (test, ac)
| _ => ac
end
-structure FrameInfo =
- struct
- datatype t = T of {frameOffsetsIndex: int,
- size: int}
-
- local
- fun make f (T r) = f r
- in
- val frameOffsetsIndex = make #frameOffsetsIndex
- val size = make #size
- end
-
- fun layout (T {frameOffsetsIndex, size}) =
- Layout.record [("frameOffsetsIndex", Int.layout frameOffsetsIndex),
- ("size", Int.layout size)]
-
- val bogus = T {frameOffsetsIndex = ~1, size = ~1}
-
- end
-
structure Kind =
struct
datatype t =
Cont of {args: Operand.t vector,
frameInfo: FrameInfo.t}
| CReturn of {dst: Operand.t option,
- prim: Prim.t}
+ frameInfo: FrameInfo.t option,
+ func: CFunction.t}
| Func of {args: Operand.t vector}
| Handler of {offset: int}
| Jump
- | Runtime of {frameInfo: FrameInfo.t,
- prim: Prim.t}
fun layout k =
let
@@ -392,25 +401,23 @@
seq [str "Cont ",
record [("args", Vector.layout Operand.layout args),
("frameInfo", FrameInfo.layout frameInfo)]]
- | CReturn {dst, prim} =>
+ | CReturn {dst, frameInfo, func} =>
seq [str "CReturn ",
- record [("dst", Option.layout Operand.layout dst),
- ("prim", Prim.layout prim)]]
+ record
+ [("dst", Option.layout Operand.layout dst),
+ ("frameInfo", Option.layout FrameInfo.layout frameInfo),
+ ("func", CFunction.layout func)]]
| Func {args} =>
seq [str "Func ",
record [("args", Vector.layout Operand.layout args)]]
| Handler {offset} =>
seq [str "Handler", paren(Int.layout offset)]
| Jump => str "Jump"
- | Runtime {frameInfo, prim} =>
- seq [str "Runtime ",
- record [("frameInfo", FrameInfo.layout frameInfo),
- ("prim", Prim.layout prim)]]
end
val frameInfoOpt =
fn Cont {frameInfo, ...} => SOME frameInfo
- | Runtime {frameInfo, ...} => SOME frameInfo
+ | CReturn {frameInfo, ...} => frameInfo
| _ => NONE
end
@@ -492,11 +499,12 @@
main: {chunkLabel: ChunkLabel.t,
label: Label.t},
maxFrameSize: int,
+ objectTypes: Runtime.ObjectType.t vector,
strings: (Global.t * string) list}
fun layouts (p as T {chunks, frameOffsets, globals, globalsNonRoot,
handlesSignals, main = {label, ...}, maxFrameSize,
- ...},
+ objectTypes, ...},
output': Layout.t -> unit) =
let
open Layout
@@ -512,14 +520,18 @@
("handlesSignals", Bool.layout handlesSignals),
("main", Label.layout label),
("maxFrameSize", Int.layout maxFrameSize),
+ ("objectTypes",
+ Vector.layout Runtime.ObjectType.layout objectTypes),
("frameOffsets",
Vector.layout (Vector.layout Int.layout) frameOffsets)])
; List.foreach (chunks, fn chunk => Chunk.layouts (chunk, output))
end
fun typeCheck (T {chunks, floats, frameOffsets, globals, globalsNonRoot,
- intInfs, main, maxFrameSize, strings, ...}) =
+ intInfs, main, maxFrameSize, objectTypes, strings, ...})
+ =
let
+ val numTypeIndices = Vector.length objectTypes
open Layout
fun globals (name, gs, ty) =
List.foreach
@@ -560,17 +572,23 @@
| CastInt x =>
(checkOperand x
; Type.equals (Operand.ty x, Type.pointer))
+ | CastWord x =>
+ (checkOperand x
+ ; Type.equals (Operand.ty x, Type.pointer))
| Char _ => true
| Contents {oper, ...} =>
(checkOperand oper
; Type.equals (Operand.ty oper, Type.pointer))
+ | File => true
| Float _ => true
+ | GCState => true
| Global _ => true
| GlobalPointerNonRoot n =>
0 <= n andalso n < globalsNonRoot
| Int _ => true
| IntInf w => 0wx1 = Word.andb (w, 0wx1)
| Label l => (labelBlock l; true)
+ | Line => true
| Offset {base, ...} =>
(checkOperand base
; Type.equals (Operand.ty base, Type.pointer))
@@ -579,8 +597,7 @@
0 <= index andalso index < regMax ty
| Runtime _ => true
| StackOffset {offset, ty, ...} =>
- 0 <= offset
- andalso offset + Type.size ty <= maxFrameSize
+ offset + Type.size ty <= maxFrameSize
| Uint _ => true
in
Err.check ("operand", ok, fn () => Operand.layout x)
@@ -597,6 +614,40 @@
andalso 0 = Int.rem (size, 4)
fun checkFrameInfo i =
check' (i, "frame info", frameInfoOk, FrameInfo.layout)
+ fun isValidNormal ({numPointers = np,
+ numWordsNonPointers = nwnp},
+ stores): bool =
+ let
+ val pointerStart = nwnp * Runtime.wordSize
+ val pointerEnd = pointerStart + np * Runtime.pointerSize
+ val initPointers = Array.new (np, false)
+ in
+ (* Check that every store is valid *)
+ Vector.forall
+ (stores, fn {offset, value} =>
+ let
+ val _ = checkOperand value
+ val ty = Operand.ty value
+ in
+ if Type.isPointer ty
+ then
+ pointerStart <= offset
+ andalso offset < pointerEnd
+ andalso Runtime.isWordAligned offset
+ andalso (Array.update
+ (initPointers,
+ Int.quot (offset - pointerStart,
+ Runtime.pointerSize),
+ true)
+ ; true)
+ else
+ 0 <= offset
+ andalso (offset + Type.size ty <= pointerStart)
+ end)
+ andalso
+ (* Check that every pointer is initialized. *)
+ Array.forall (initPointers, fn b => b)
+ end
fun kindOk (k: Kind.t): bool =
let
datatype z = datatype Kind.t
@@ -605,13 +656,12 @@
Cont {args, frameInfo} =>
(checkOperands args
; checkFrameInfo frameInfo)
- | CReturn {dst, ...} =>
- Option.app (dst, checkOperand)
+ | CReturn {dst, frameInfo, ...} =>
+ (Option.app (dst, checkOperand)
+ ; Option.app (frameInfo, checkFrameInfo))
| Func {args, ...} => checkOperands args
| Handler _ => ()
| Jump => ()
- | Runtime {frameInfo, ...} =>
- checkFrameInfo frameInfo
in
true
end
@@ -626,14 +676,14 @@
; (Type.equals (Operand.ty dst, Operand.ty src)
andalso Operand.isLocation dst))
| Noop => true
- | Object {dst, numPointers, numWordsNonPointers,
- stores} =>
+ | Object {dst, header, size, stores} =>
(checkOperand dst
- ; Vector.foreach (stores, fn {offset, value} =>
- checkOperand value)
- ; (Runtime.isValidObjectHeader
- {numPointers = numPointers,
- numWordsNonPointers = numWordsNonPointers}))
+ ; (case Vector.sub (objectTypes,
+ Runtime.headerToTypeIndex
+ header) of
+ Runtime.ObjectType.Normal z =>
+ isValidNormal (z, stores)
+ | _ => false) handle Subscript => false)
| PrimApp {args, dst, prim} =>
(Option.app (dst, checkOperand)
; checkOperands args
@@ -647,10 +697,6 @@
case labelKind l of
Kind.Jump => true
| _ => false
- fun labelIsRuntime (l: Label.t, p: Prim.t): bool =
- case labelKind l of
- Kind.Runtime {prim, ...} => Prim.equals (p, prim)
- | _ => false
fun transferOk (t: Transfer.t): bool =
let
datatype z = datatype Transfer.t
@@ -662,22 +708,30 @@
; (Type.equals (ty, Operand.ty dst)
andalso labelIsJump overflow
andalso labelIsJump success))
- | Bug => true
- | CCall {args, prim = p, return, returnTy} =>
+ | CCall {args, frameInfo, func, return} =>
let
val _ = checkOperands args
- val Block.T {kind, ...} = labelBlock return
+ val _ = Option.app (frameInfo, checkFrameInfo)
in
- case labelKind return of
- Kind.CReturn {dst, prim = p'} =>
- Prim.equals (p, p')
- andalso (case (dst, returnTy) of
- (NONE, NONE) => true
- | (SOME x, SOME ty) =>
- Type.equals
- (ty, Operand.ty x)
- | _ => false)
- | _ => false
+ case return of
+ NONE => true
+ | SOME l =>
+ let
+ val Block.T {kind, ...} = labelBlock l
+ in
+ case labelKind l of
+ Kind.CReturn
+ {dst, func = f, ...} =>
+ CFunction.equals (func, f)
+ andalso
+ (case (dst, CFunction.returnTy f) of
+ (NONE, NONE) => true
+ | (SOME x, SOME ty) =>
+ Type.equals
+ (ty, Operand.ty x)
+ | _ => false)
+ | _ => false
+ end
end
| Call {label, live, return} =>
(case labelKind label of
@@ -701,10 +755,6 @@
| Goto l => labelIsJump l
| Raise => true
| Return {live} => (checkOperands live; true)
- | Runtime {args, prim, return} =>
- (checkOperands args
- ; (Prim.entersRuntime prim
- andalso labelIsRuntime (return, prim)))
| Switch {cases, default, test} =>
(checkOperand test
; (Cases.forall (cases, labelIsJump)
1.20 +39 -35 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- machine.sig 23 Jun 2002 01:37:54 -0000 1.19
+++ machine.sig 6 Jul 2002 17:22:05 -0000 1.20
@@ -12,14 +12,18 @@
sig
structure Label: HASH_ID
structure Prim: PRIM
+ structure Runtime: RUNTIME
end
signature MACHINE =
sig
include MACHINE_STRUCTS
-
+
+ structure CFunction: C_FUNCTION
+ sharing CFunction = Runtime.CFunction
structure ChunkLabel: UNIQUE_ID
structure Type: MTYPE
+ sharing Type = Runtime.Type
structure Register:
sig
@@ -45,8 +49,6 @@
val ty: t -> Type.t
end
- structure RuntimeOperand: GC_FIELD
-
structure Operand:
sig
datatype t =
@@ -54,21 +56,25 @@
index: t,
ty: Type.t}
| CastInt of t (* takes an IntOrPointer and makes it an int *)
+ | CastWord of t (* takes a pointer and makes it a word *)
| Char of char
| Contents of {oper: t,
ty: Type.t}
- | Float of string
+ | File (* expand by codegen into string constant *)
+ | Float of string
+ | GCState
| Global of Global.t
| GlobalPointerNonRoot of int
| Int of int
| IntInf of word
| Label of Label.t
+ | Line (* expand by codegen into int constant *)
| Offset of {base: t,
offset: int,
ty: Type.t}
| Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
| Register of Register.t
- | Runtime of RuntimeOperand.t
+ | Runtime of Runtime.GCField.t
| StackOffset of {offset: int,
ty: Type.t}
| Uint of Word.t
@@ -92,8 +98,8 @@
| Noop
(* Fixed-size allocation. *)
| Object of {dst: Operand.t,
- numPointers: int,
- numWordsNonPointers: int,
+ header: word,
+ size: int,
stores: {offset: int,
value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
@@ -113,6 +119,19 @@
structure Cases: MACHINE_CASES sharing Label = Cases.Label
+ structure FrameInfo:
+ sig
+ datatype t =
+ T of {(* Index into frameOffsets *)
+ frameOffsetsIndex: int,
+ (* Size of frame in bytes, including return address. *)
+ size: int}
+
+ val bogus: t
+ val layout: t -> Layout.t
+ val size: t -> int
+ end
+
structure Transfer:
sig
datatype t =
@@ -125,13 +144,14 @@
prim: Prim.t,
success: Label.t,
ty: Type.t} (* int or word *)
- | Bug
| CCall of {args: Operand.t vector,
- prim: Prim.t,
- (* return must be CReturn with matching prim. *)
- return: Label.t,
- (* returnTy must CReturn dst. *)
- returnTy: Type.t option}
+ frameInfo: FrameInfo.t option,
+ func: CFunction.t,
+ (* return is NONE iff the func doesn't return.
+ * Else, return must be SOME l, where l is of CReturn
+ * kind with a matching func.
+ *)
+ return: Label.t option}
| Call of {label: Label.t, (* label must be a Func *)
live: Operand.t vector,
return: {return: Label.t,
@@ -140,9 +160,6 @@
| Goto of Label.t (* label must be a Jump *)
| Raise
| Return of {live: Operand.t vector}
- | Runtime of {args: Operand.t vector,
- prim: Prim.t,
- return: Label.t} (* Must be of Runtime kind. *)
| Switch of {test: Operand.t,
cases: Cases.t,
default: Label.t option}
@@ -150,26 +167,13 @@
* Integer or a Pointer. Pointers are word aligned and integers
* are not.
*)
- | SwitchIP of {test: Operand.t,
- int: Label.t,
- pointer: Label.t}
+ | SwitchIP of {int: Label.t,
+ pointer: Label.t,
+ test: Operand.t}
val foldOperands: t * 'a * (Operand.t * 'a -> 'a) -> 'a
val layout: t -> Layout.t
end
-
- structure FrameInfo:
- sig
- datatype t =
- T of {(* Index into frameOffsets *)
- frameOffsetsIndex: int,
- (* Size of frame in bytes, including return address. *)
- size: int}
-
- val bogus: t
- val layout: t -> Layout.t
- val size: t -> int
- end
structure Kind:
sig
@@ -177,12 +181,11 @@
Cont of {args: Operand.t vector,
frameInfo: FrameInfo.t}
| CReturn of {dst: Operand.t option,
- prim: Prim.t}
+ frameInfo: FrameInfo.t option,
+ func: CFunction.t}
| Func of {args: Operand.t vector}
| Handler of {offset: int}
| Jump
- | Runtime of {frameInfo: FrameInfo.t,
- prim: Prim.t}
val frameInfoOpt: t -> FrameInfo.t option
end
@@ -226,6 +229,7 @@
main: {chunkLabel: ChunkLabel.t,
label: Label.t},
maxFrameSize: int,
+ objectTypes: Runtime.ObjectType.t vector,
strings: (Global.t * string) list}
val layouts: t * (Layout.t -> unit) -> unit
1.14 +113 -92 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- rssa.fun 23 Jun 2002 01:37:54 -0000 1.13
+++ rssa.fun 6 Jul 2002 17:22:05 -0000 1.14
@@ -9,20 +9,33 @@
struct
open S
+local
+ open Runtime
+in
+ structure CFunction = CFunction
+ structure GCField = GCField
+end
structure Operand =
struct
datatype t =
- ArrayOffset of {base: Var.t,
+ ArrayHeader of {numBytesNonPointers: int,
+ numPointers: int}
+ | ArrayOffset of {base: Var.t,
index: Var.t,
ty: Type.t}
- | CastInt of Var.t
+ | CastInt of t
+ | CastWord of t
| Const of Const.t
+ | EnsuresBytesFree
+ | File
+ | GCState
+ | Line
| Offset of {base: Var.t,
bytes: int,
ty: Type.t}
| Pointer of int
- | Runtime of RuntimeOperand.t
+ | Runtime of GCField.t
| Var of {var: Var.t,
ty: Type.t}
@@ -30,31 +43,45 @@
val word = Const o Const.fromWord
fun bool b = int (if b then 1 else 0)
- val toString =
- fn ArrayOffset {base, index, ty} =>
+ val rec toString =
+ fn ArrayHeader {numBytesNonPointers, numPointers} =>
+ concat ["AH (",
+ Int.toString numBytesNonPointers,
+ ", ",
+ Int.toString numPointers,
+ ")"]
+ | ArrayOffset {base, index, ty} =>
concat ["X", Type.name ty,
"(", Var.toString base, ",", Var.toString index, ")"]
- | CastInt x => concat [ "CastInt ", Var.toString x]
+ | CastInt z => concat ["CastInt ", toString z]
+ | CastWord z => concat ["CastWord ", toString z]
| Const c => Const.toString c
+ | EnsuresBytesFree => "<EnsuresBytesFree>"
+ | File => "<File>"
+ | GCState => "<GCState>"
+ | Line => "<Line>"
| Offset {base, bytes, ty} =>
concat ["O", Type.name ty,
"(", Var.toString base, ",", Int.toString bytes, ")"]
| Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
- | Runtime r => RuntimeOperand.toString r
+ | Runtime r => GCField.toString r
| Var {var, ...} => Var.toString var
val layout: t -> Layout.t = Layout.str o toString
- val isLocation =
+ val rec isLocation =
fn ArrayOffset _ => true
+ | CastWord z => isLocation z
| Offset _ => true
| Runtime _ => true
| Var _ => true
| _ => false
val ty =
- fn ArrayOffset {ty, ...} => ty
+ fn ArrayHeader _ => Type.word
+ | ArrayOffset {ty, ...} => ty
| CastInt _ => Type.int
+ | CastWord _ => Type.word
| Const c =>
let
datatype z = datatype Const.Node.t
@@ -76,25 +103,38 @@
else Error.bug "strange word"
end
end
+ | EnsuresBytesFree => Type.word
+ | File => Type.pointer
+ | GCState => Type.pointer
+ | Line => Type.int
| Offset {ty, ...} => ty
| Pointer _ => Type.pointer
- | Runtime z => (case RuntimeOperand.ty z of
- RuntimeOperand.Int => Type.int
- | RuntimeOperand.Word => Type.word)
+ | Runtime z => GCField.ty z
| Var {ty, ...} => ty
fun 'a foldVars (z: t, a: 'a, f: Var.t * 'a -> 'a): 'a =
case z of
ArrayOffset {base, index, ...} => f (index, f (base, a))
- | CastInt x => f (x, a)
- | Const _ => a
+ | CastInt z => foldVars (z, a, f)
+ | CastWord z => foldVars (z, a, f)
| Offset {base, ...} => f (base, a)
- | Pointer _ => a
- | Runtime _ => a
| Var {var, ...} => f (var, a)
+ | _ => a
fun foreachVar (z: t, f: Var.t -> unit): unit =
foldVars (z, (), f o #1)
+
+ fun caseBytes (z, {big: t -> 'a,
+ small: word -> 'a}): 'a =
+ case z of
+ Const c =>
+ (case Const.node c of
+ Const.Node.Word w =>
+ if w <= 0w512 (* pretty arbitrary *)
+ then small w
+ else big z
+ | _ => Error.bug "strangse numBytes")
+ | _ => big z
end
structure Statement =
@@ -203,11 +243,9 @@
prim: Prim.t,
success: Label.t,
ty: Type.t}
- | Bug
| CCall of {args: Operand.t vector,
- prim: Prim.t,
- return: Label.t,
- returnTy: Type.t option}
+ func: CFunction.t,
+ return: Label.t option}
| Call of {func: Func.t,
args: Operand.t vector,
return: Return.t}
@@ -215,9 +253,6 @@
args: Operand.t vector}
| Raise of Operand.t vector
| Return of Operand.t vector
- | Runtime of {args: Operand.t vector,
- prim: Prim.t,
- return: Label.t}
| Switch of {cases: Cases.t,
default: Label.t option,
test: Operand.t}
@@ -225,13 +260,6 @@
pointer: Label.t,
test: Operand.t}
- fun hasPrim (t, f) =
- case t of
- Arith {prim, ...} => f prim
- | CCall {prim, ...} => f prim
- | Runtime {prim, ...} => f prim
- | _ => false
-
fun layout t =
let
open Layout
@@ -245,13 +273,11 @@
("prim", Prim.layout prim),
("success", Label.layout success),
("ty", Type.layout ty)]]
- | Bug => str "Bug"
- | CCall {args, prim, return, returnTy} =>
+ | CCall {args, func, return} =>
seq [str "CCall ",
record [("args", Vector.layout Operand.layout args),
- ("prim", Prim.layout prim),
- ("return", Label.layout return),
- ("returnTy", Option.layout Type.layout returnTy)]]
+ ("func", CFunction.layout func),
+ ("return", Option.layout Label.layout return)]]
| Call {args, func, return, ...} =>
let
val call = seq [Func.layout func, str " ",
@@ -280,11 +306,6 @@
Vector.layout Operand.layout args]
| Raise xs => seq [str "Raise", Vector.layout Operand.layout xs]
| Return xs => seq [str "Return ", Vector.layout Operand.layout xs]
- | Runtime {args, prim, return} =>
- seq [str "Runtime ",
- record [("args", Vector.layout Operand.layout args),
- ("prim", Prim.layout prim),
- ("return", Label.layout return)]]
| Switch {test, cases, default} =>
seq [str "Switch ",
tuple [Operand.layout test,
@@ -296,6 +317,13 @@
Label.layout pointer]]
end
+ val bug =
+ CCall {args = (Vector.new1
+ (Operand.Const
+ (Const.fromString "control shouldn't reach here"))),
+ func = CFunction.bug,
+ return = NONE}
+
fun 'a foldDefLabelUse (t, a: 'a, {def: Var.t * Type.t * 'a -> 'a,
label: Label.t * 'a -> 'a,
use: Var.t * 'a -> 'a}): 'a =
@@ -316,15 +344,16 @@
in
a
end
- | Bug => a
- | CCall {args, return, ...} => useOperands (args, label (return, a))
+ | CCall {args, return, ...} =>
+ useOperands (args,
+ case return of
+ NONE => a
+ | SOME l => label (l, a))
| Call {args, return, ...} =>
useOperands (args, Return.foldLabel (return, a, label))
| Goto {args, dst, ...} => label (dst, useOperands (args, a))
| Raise zs => useOperands (zs, a)
| Return zs => useOperands (zs, a)
- | Runtime {args, return, ...} =>
- label (return, useOperands (args, a))
| Switch {cases, default, test, ...} =>
let
val a = useOperand (test, a)
@@ -374,10 +403,9 @@
struct
datatype t =
Cont of {handler: Label.t option}
- | CReturn of {prim: Prim.t}
+ | CReturn of {func: CFunction.t}
| Handler
| Jump
- | Runtime of {prim: Prim.t}
fun layout k =
let
@@ -387,22 +415,12 @@
Cont {handler} =>
seq [str "Cont ",
record [("handler", Option.layout Label.layout handler)]]
- | CReturn {prim} =>
+ | CReturn {func} =>
seq [str "CReturn ",
- record [("prim", Prim.layout prim)]]
+ record [("func", CFunction.layout func)]]
| Handler => str "Handler"
| Jump => str "Jump"
- | Runtime {prim} =>
- seq [str "Runtime ",
- record [("prim", Prim.layout prim)]]
- end
-
- val isOnStack =
- fn Cont _ => true
- | CReturn _ => false
- | Handler => true
- | Jump => false
- | Runtime _ => true
+ end
end
structure Block =
@@ -434,7 +452,6 @@
fun hasPrim (T {statements, transfer, ...}, f) =
Vector.exists (statements, fn s => Statement.hasPrim (s, f))
- orelse Transfer.hasPrim (transfer, f)
fun layout (T {args, kind, label, statements, transfer, ...}) =
let
@@ -466,11 +483,19 @@
let
val l = Label.newNoname ()
val _ = r := SOME l
- val return = Label.newNoname ()
val profileInfo =
{ssa = {func = "AllocTooLarge",
label = "AllocTooLarge"}}
- val prim = Prim.allocTooLarge
+ val cfunc =
+ CFunction.T {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = false,
+ modifiesStackTop = false,
+ name = "MLton_allocTooLarge",
+ needsArrayInit = false,
+ returnTy = NONE}
val _ =
newBlocks :=
T {args = Vector.new0 (),
@@ -480,15 +505,8 @@
statements = Vector.new0 (),
transfer =
Transfer.CCall {args = Vector.new0 (),
- prim = prim,
- return = return,
- returnTy = NONE}}
- :: T {args = Vector.new0 (),
- kind = Kind.CReturn {prim = prim},
- label = return,
- profileInfo = profileInfo,
- statements = Vector.new0 (),
- transfer = Transfer.Bug}
+ func = cfunc,
+ return = NONE}}
:: !newBlocks
in
l
@@ -755,11 +773,19 @@
datatype z = datatype Operand.t
fun ok () =
case x of
- ArrayOffset {base, index, ty} =>
+ ArrayHeader {numBytesNonPointers = nbnp, numPointers = np} =>
+ nbnp >= 0 andalso np >= 0
+
+ | ArrayOffset {base, index, ty} =>
Type.equals (varType base, Type.pointer)
andalso Type.equals (varType index, Type.int)
- | CastInt x => Type.equals (varType x, Type.pointer)
+ | CastInt z => Type.equals (Operand.ty z, Type.pointer)
+ | CastWord z => Type.equals (Operand.ty z, Type.pointer)
| Const _ => true
+ | EnsuresBytesFree => true
+ | File => true
+ | GCState => true
+ | Line => true
| Offset {base, ...} =>
Type.equals (varType base, Type.pointer)
| Pointer n => 0 < Int.rem (n, Runtime.wordSize)
@@ -790,9 +816,8 @@
| Object {dst, numPointers, numWordsNonPointers, stores} =>
(Vector.foreach (stores, fn {offset, value} =>
checkOperand value)
- ; (Runtime.isValidObjectHeader
- {numPointers = numPointers,
- numWordsNonPointers = numWordsNonPointers}))
+ ; (numPointers >= 0
+ andalso numWordsNonPointers >= 0))
| PrimApp {args, ...} =>
(Vector.foreach (args, checkOperand)
; true)
@@ -815,10 +840,6 @@
| _ => false)
end
fun labelIsNullaryJump l = goto {dst = l, args = Vector.new0 ()}
- fun labelIsRuntime (l: Label.t, p: Prim.t): bool =
- case labelKind l of
- Kind.Runtime {prim, ...} => Prim.equals (p, prim)
- | _ => false
fun transferOk (t: Transfer.t): bool =
let
datatype z = datatype Transfer.t
@@ -831,15 +852,19 @@
andalso
Vector.forall (args, fn x =>
Type.equals (ty, Operand.ty x))
- | Bug => true
- | CCall {args, prim = p, return, returnTy} =>
+ | CCall {args, func, return} =>
let
val _ = checkOperands args
- val Block.T {kind, ...} = labelBlock return
in
- case labelKind return of
- Kind.CReturn {prim = p'} => Prim.equals (p, p')
- | _ => false
+ CFunction.isOk func
+ andalso
+ case return of
+ NONE => true
+ | SOME l =>
+ case labelKind l of
+ Kind.CReturn {func = f} =>
+ CFunction.equals (func, f)
+ | _ => false
end
| Call {args, func, return} =>
let
@@ -867,9 +892,6 @@
| Goto z => goto z
| Raise _ => true
| Return _ => true
- | Runtime {args, prim, return} =>
- (Prim.entersRuntime prim
- andalso labelIsRuntime (return, prim))
| Switch {cases, default, test} =>
(Cases.forall (cases, labelIsNullaryJump)
andalso Option.forall (default, labelIsNullaryJump)
@@ -894,11 +916,10 @@
datatype z = datatype Kind.t
val _ =
case k of
- Cont {handler} => true
- | CReturn {prim} => true
+ Cont _ => true
+ | CReturn _ => true
| Handler => true
| Jump => true
- | Runtime {prim} => 0 = Vector.length args
in
true
end
1.12 +32 -24 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- rssa.sig 23 Jun 2002 01:37:54 -0000 1.11
+++ rssa.sig 6 Jul 2002 17:22:05 -0000 1.12
@@ -39,39 +39,55 @@
val foldLabel: t * 'a * (Label.t * 'a -> 'a) -> 'a
val foreachLabel: t * (Label.t -> unit) -> unit
end
- structure RuntimeOperand: GC_FIELD
+ structure Runtime: RUNTIME
structure Type: MTYPE
sharing Label = Cases.Label
+ sharing Type = Runtime.Type
end
signature RSSA =
sig
include RSSA_STRUCTS
+ structure CFunction: C_FUNCTION
+ sharing CFunction = Runtime.CFunction
+
structure Operand:
sig
datatype t =
- ArrayOffset of {base: Var.t,
+ ArrayHeader of {numBytesNonPointers: int,
+ numPointers: int}
+ | ArrayOffset of {base: Var.t,
index: Var.t,
ty: Type.t}
- | CastInt of Var.t
+ | CastInt of t
+ | CastWord of t
| Const of Const.t
+ (* EnsuresBytesFree is a pseudo-op used by GC_allocateArray, and
+ * is replaced by the limit check pass with a real operand.
+ *)
+ | EnsuresBytesFree
+ | File (* expand by codegen into string constant *)
+ | GCState
+ | Line (* expand by codegen into int constant *)
| Offset of {base: Var.t,
bytes: int,
ty: Type.t}
| Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
- | Runtime of RuntimeOperand.t
+ | Runtime of Runtime.GCField.t
| Var of {var: Var.t,
ty: Type.t}
val bool: bool -> t
+ val caseBytes: t * {big: t -> 'a,
+ small: word -> 'a} -> 'a
val int: int -> t
val layout: t -> Layout.t
val foreachVar: t * (Var.t -> unit) -> unit
val ty: t -> Type.t
val word: word -> t
end
-
+
structure Statement:
sig
datatype t =
@@ -105,7 +121,7 @@
val foreachUse: t * (Var.t -> unit) -> unit
val layout: t -> Layout.t
end
-
+
structure Transfer:
sig
datatype t =
@@ -115,17 +131,15 @@
prim: Prim.t,
success: Label.t, (* Must be nullary. *)
ty: Type.t}
- | Bug (* MLton thought control couldn't reach here. *)
| CCall of {args: Operand.t vector,
- prim: Prim.t,
- return: Label.t, (* return must be of CReturn kind.
- * It should be nullary if the C
- * function returns void. Else, should
- * be either nullary or unary with a
- * var of the appropriate type to
- * accept the result.
- *)
- returnTy: Type.t option}
+ func: CFunction.t,
+ (* return is NONE iff the CFunction doesn't return.
+ * Else, return must be SOME l, where l is of kind
+ * CReturn. The return should be nullary if the C
+ * function returns void. Else, it should be unary with
+ * a var of the appropriate type to accept the result.
+ *)
+ return: Label.t option}
| Call of {args: Operand.t vector,
func: Func.t,
return: Return.t}
@@ -136,9 +150,6 @@
*)
| Raise of Operand.t vector
| Return of Operand.t vector
- | Runtime of {args: Operand.t vector,
- prim: Prim.t,
- return: Label.t} (* Must be nullary, Runtime. *)
| Switch of {cases: Cases.t,
default: Label.t option, (* Must be nullary. *)
test: Operand.t}
@@ -146,6 +157,7 @@
pointer: Label.t,
test: Operand.t}
+ val bug: t
(* foldDef (t, a, f)
* If t defines a variable x, then return f (x, a), else return a.
*)
@@ -165,12 +177,9 @@
sig
datatype t =
Cont of {handler: Label.t option}
- | CReturn of {prim: Prim.t}
+ | CReturn of {func: CFunction.t}
| Handler
| Jump
- | Runtime of {prim: Prim.t}
-
- val isOnStack: t -> bool
end
structure Block:
@@ -228,7 +237,6 @@
val clear: t -> unit
val handlesSignals: t -> bool
- val hasPrim: t * (Prim.t -> bool) -> bool
val layouts: t * (Layout.t -> unit) -> unit
val typeCheck: t -> unit
end
1.10 +62 -17 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- runtime.sig 23 Jun 2002 01:37:54 -0000 1.9
+++ runtime.sig 6 Jul 2002 17:22:05 -0000 1.10
@@ -8,36 +8,81 @@
type int = Int.t
type word = Word.t
+signature RUNTIME_STRUCTS =
+ sig
+ end
+
signature RUNTIME =
sig
- structure GCField: GC_FIELD
-
+ include RUNTIME_STRUCTS
+
+ structure Type: MTYPE
+ structure CFunction: C_FUNCTION
+ sharing Type = CFunction.Type
+ structure GCField:
+ sig
+ datatype t =
+ Base
+ | CanHandle
+ | CurrentThread
+ | FromSize
+ | Frontier (* The place where the next object is allocated. *)
+ | Limit (* frontier + heapSize - LIMIT_SLOP *)
+ | LimitPlusSlop (* frontier + heapSize *)
+ | MaxFrameSize
+ | SignalIsPending
+ | StackBottom
+ | StackLimit (* Must have StackTop <= StackLimit *)
+ | StackTop (* Points at the next available word on the stack. *)
+
+ val layout: t -> Layout.t
+ val offset: t -> int (* Field offset in struct GC_state. *)
+ val setOffsets: {base: int,
+ canHandle: int,
+ currentThread: int,
+ fromSize: int,
+ frontier: int,
+ limit: int,
+ limitPlusSlop: int,
+ maxFrameSize: int,
+ signalIsPending: int,
+ stackBottom: int,
+ stackLimit: int,
+ stackTop: int} -> unit
+ val toString: t -> string
+ val ty: t -> Type.t
+ end
+ structure ObjectType:
+ sig
+ datatype t =
+ Array of {numBytesNonPointers: int,
+ numPointers: int}
+ | Normal of {numPointers: int,
+ numWordsNonPointers: int}
+ | Stack
+
+ val equals: t * t -> bool
+ val layout: t -> Layout.t
+ end
+
(* All sizes are in bytes, unless they explicitly say "pointers". *)
val allocTooLarge: word
- val arrayHeader: {numBytesNonPointers: int,
- numPointers: int} -> word
val arrayHeaderSize: int
+ val arrayLengthOffset: int
val array0Size: int
- val isValidObjectHeader: {numPointers: int,
- numWordsNonPointers: int} -> bool
- val isValidArrayHeader: {numBytesNonPointers: int,
- numPointers: int} -> bool
+ val headerToTypeIndex: word -> int
+ val isWordAligned: int -> bool
val labelSize: int
(* Same as LIMIT_SLOP from gc.c. *)
val limitSlop: int
val maxFrameSize: int
- val objectHeader: {numPointers: int,
- numWordsNonPointers: int} -> word
- val objectHeaderSize: int
- (* objectSize does not include the header. *)
- val objectSize: {numPointers: int,
+ val normalHeaderSize: int
+ (* normalSize does not include the header. *)
+ val normalSize: {numPointers: int,
numWordsNonPointers: int} -> int
val pointerSize: int
- val splitArrayHeader: word -> {numBytesNonPointers: int,
- numPointers: int}
- val splitObjectHeader: word -> {numPointers: int,
- numWordsNonPointers: int}
+ val typeIndexToHeader: int -> word
val wordAlign: word -> word (* Can raise Overflow. *)
val wordSize: int
end
1.9 +24 -17 mlton/mlton/backend/signal-check.fun
Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- signal-check.fun 16 Apr 2002 12:10:52 -0000 1.8
+++ signal-check.fun 6 Jul 2002 17:22:05 -0000 1.9
@@ -55,7 +55,8 @@
val from = indexNode i
in
if (case transfer of
- Transfer.Runtime _ => true
+ Transfer.CCall {func, ...} =>
+ CFunction.maySwitchThreads func
| _ => false)
then ()
else
@@ -91,8 +92,9 @@
val compare =
Vector.new1
(Statement.PrimApp
- {args = Vector.new2 (Operand.Runtime
- RuntimeOperand.Limit,
+ {args = Vector.new2 (Operand.CastInt
+ (Operand.Runtime
+ Runtime.GCField.Limit),
Operand.int 0),
dst = SOME (res, Type.bool),
prim = Prim.eq})
@@ -101,6 +103,7 @@
(Operand.Var {var = res, ty = Type.bool},
{falsee = dontCollect,
truee = collect})
+ val func = CFunction.gc {maySwitchThreads = true}
val _ =
extra :=
Block.T {args = args,
@@ -115,20 +118,24 @@
label = collect,
profileInfo = profileInfo,
statements = Vector.new0 (),
- transfer = (Transfer.Runtime
- {args = (Vector.new2
- (Operand.int 0,
- Operand.bool false)),
- prim = Prim.gcCollect,
- return = collectReturn})})
- :: Block.T {args = Vector.new0 (),
- kind = Kind.Runtime {prim = Prim.gcCollect},
- label = collectReturn,
- profileInfo = profileInfo,
- statements = Vector.new0 (),
- transfer =
- Transfer.Goto {dst = dontCollect,
- args = Vector.new0 ()}}
+ transfer =
+ Transfer.CCall
+ {args = Vector.new5 (Operand.GCState,
+ Operand.word 0w0,
+ Operand.bool false,
+ Operand.File,
+ Operand.Line),
+ func = func,
+ return = SOME collectReturn}})
+ :: (Block.T
+ {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ label = collectReturn,
+ profileInfo = profileInfo,
+ statements = Vector.new0 (),
+ transfer =
+ Transfer.Goto {dst = dontCollect,
+ args = Vector.new0 ()}})
:: Block.T {args = Vector.new0 (),
kind = Kind.Jump,
label = dontCollect,
1.10 +5 -4 mlton/mlton/backend/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.9
+++ sources.cm 6 Jul 2002 17:22:05 -0000 1.10
@@ -8,11 +8,11 @@
Group
signature MACHINE
+signature RUNTIME
-structure Runtime
-
functor Backend
functor Machine
+functor Runtime
is
@@ -27,12 +27,13 @@
array-init.sig
backend.fun
backend.sig
+c-function.fun
+c-function.sig
chunkify.fun
chunkify.sig
equivalence-graph.fun
equivalence-graph.sig
err.sml
-gc-field.sig
implement-handlers.fun
implement-handlers.sig
limit-check.fun
@@ -51,8 +52,8 @@
representation.sig
rssa.fun
rssa.sig
+runtime.fun
runtime.sig
-runtime.sml
signal-check.fun
signal-check.sig
ssa-to-rssa.fun
1.14 +499 -271 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.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- ssa-to-rssa.fun 23 Jun 2002 01:37:54 -0000 1.13
+++ ssa-to-rssa.fun 6 Jul 2002 17:22:05 -0000 1.14
@@ -13,6 +13,126 @@
structure S = Ssa
open Rssa
+local
+ open Runtime
+in
+ structure GCField = GCField
+end
+
+structure CFunction =
+ struct
+ open CFunction
+
+ local
+ fun make name = vanilla {name = name,
+ returnTy = SOME Type.double}
+ in
+ val cosh = make "cosh"
+ val sinh = make "sinh"
+ val tanh = make "tanh"
+ val pow = make "pow"
+ val copysign = make "copysign"
+ val frexp = make "frexp"
+ val modf = make "modf"
+ end
+
+ local
+ fun make (name, i) =
+ T {bytesNeeded = SOME i,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = false,
+ name = name,
+ needsArrayInit = false,
+ returnTy = SOME Type.pointer}
+ in
+ val intInfAdd = make ("IntInf_do_add", 2)
+ val intInfGcd = make ("IntInf_do_gcd", 2)
+ val intInfMul = make ("IntInf_do_mul", 2)
+ val intInfNeg = make ("IntInf_do_neg", 1)
+ val intInfQuot = make ("IntInf_do_quot", 2)
+ val intInfRem = make ("IntInf_do_rem", 2)
+ val intInfSub = make ("IntInf_do_sub", 2)
+ val intInfToString = make ("IntInf_do_toString", 2)
+ end
+
+ local
+ fun make name = vanilla {name = name,
+ returnTy = SOME Type.int}
+ in
+ val intInfCompare = make "IntInf_compare"
+ val intInfEqual = make "IntInf_equal"
+ end
+
+ val copyCurrentThread =
+ T {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_copyCurrentThread",
+ needsArrayInit = false,
+ returnTy = NONE}
+
+ val copyThread =
+ T {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_copyThread",
+ needsArrayInit = false,
+ returnTy = NONE}
+
+ val exit =
+ T {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "MLton_exit",
+ needsArrayInit = false,
+ returnTy = NONE}
+
+ val gcArrayAllocate =
+ T {bytesNeeded = NONE,
+ ensuresBytesFree = true,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_arrayAllocate",
+ needsArrayInit = false,
+ returnTy = SOME Type.pointer}
+
+ val threadSwitchTo =
+ T {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = true,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "Thread_switchTo",
+ needsArrayInit = false,
+ returnTy = NONE}
+
+ val worldSave =
+ T {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_saveWorld",
+ needsArrayInit = false,
+ returnTy = NONE}
+ end
+
datatype z = datatype Operand.t
datatype z = datatype Statement.t
datatype z = datatype Transfer.t
@@ -274,9 +394,11 @@
transfer = transfer}
fun switchIP (numEnum, pointer: Label.t): Transfer.t =
Transfer.SwitchIP
- {test = varOp test,
- int = transferToLabel (enum (CastInt test, numEnum)),
- pointer = pointer}
+ {int = transferToLabel (enum (CastInt (Var {var = test,
+ ty = Type.pointer}),
+ numEnum)),
+ pointer = pointer,
+ test = varOp test}
fun tail (l: Label.t, args: Operand.t vector): Label.t =
if 0 = Vector.length args
then l
@@ -378,7 +500,7 @@
| S.Cases.Word8 l => doit (l, Cases.Char, Word8.toChar)
| S.Cases.Con cases =>
(case (Vector.length cases, default) of
- (0, NONE) => Bug
+ (0, NONE) => Transfer.bug
| _ =>
let
val (tycon, tys) = S.Type.tyconArgs (varType test)
@@ -494,7 +616,7 @@
success = noOverflow,
ty = ty}
end
- | S.Transfer.Bug => Transfer.Bug
+ | S.Transfer.Bug => Transfer.bug
| S.Transfer.Call {func, args, return} =>
let
datatype z = datatype Return.t
@@ -522,11 +644,35 @@
| S.Transfer.Raise xs => Transfer.Raise (vos xs)
| S.Transfer.Return xs => Transfer.Return (vos xs)
| S.Transfer.Runtime {args, prim, return} =>
- Transfer.Runtime {args = vos args,
- prim = prim,
- return = eta (profileInfo,
- return,
- Kind.Runtime {prim = prim})}
+ let
+ datatype z = datatype Prim.Name.t
+ in
+ case Prim.name prim of
+ MLton_halt =>
+ Transfer.CCall {args = vos args,
+ func = CFunction.exit,
+ return = NONE}
+ | Thread_copyCurrent =>
+ let
+ val func = CFunction.copyCurrentThread
+ val l =
+ newBlock {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ profileInfo = profileInfo,
+ statements = Vector.new0 (),
+ transfer = Goto {args = Vector.new0 (),
+ dst = return}}
+ in
+ Transfer.CCall
+ {args = (Vector.concat
+ [Vector.new1 Operand.GCState, vos args]),
+ func = func,
+ return = SOME l}
+ end
+ | _ => Error.bug (concat
+ ["strange prim in SSA Runtime transfer ",
+ Prim.toString prim])
+ end
fun translateFormals v =
Vector.keepAllMap (v, fn (x, t) =>
Option.map (toType t, fn t => (x, t)))
@@ -625,24 +771,11 @@
add (PrimApp {dst = dst (),
prim = prim,
args = varOps args})
- fun array0 (numElts: Operand.t) =
- add
- (PrimApp
- {dst = dst (),
- prim = Prim.array_allocate,
- args = Vector.new3
- (numElts,
- Operand.word
- (Word.fromInt Runtime.array0Size),
- Operand.word
- (Runtime.arrayHeader
- {numBytesNonPointers = 0,
- numPointers = 0}))})
datatype z = datatype Prim.Name.t
fun bumpCanHandle n =
let
val canHandle =
- Operand.Runtime RuntimeOperand.CanHandle
+ Operand.Runtime GCField.CanHandle
val res = Var.newNoname ()
in
[Statement.PrimApp
@@ -655,53 +788,79 @@
src = Operand.Var {var = res,
ty = Type.int}}]
end
- in
- if isSome (Prim.bytesNeeded prim)
- then
- let
- in
- split (Vector.new0 (), Kind.Jump,
- PrimApp {dst = dst (),
- prim = prim,
- args = varOps args}
- :: ss,
- fn l =>
- ([], Transfer.Goto {dst = l,
- args = Vector.new0 ()}))
- end
- else if Prim.impCall prim
- then
- let
- val (formals, returnTy) =
- case dst () of
- NONE => (Vector.new0 (), NONE)
- | SOME (x, t) =>
- (Vector.new1 (x, t), SOME t)
- in
- split
- (formals,
- Kind.CReturn {prim = prim},
- ss,
- fn l =>
- ([],
- Transfer.CCall {args = vos args,
- prim = prim,
- return = l,
- returnTy = returnTy}))
- end
- else if Prim.entersRuntime prim
- then
+ fun ccallGen
+ {args: Operand.t vector,
+ func: CFunction.t,
+ prefix: Transfer.t -> (Statement.t list
+ * Transfer.t)} =
+ let
+ val (formals, returnTy) =
+ case dst () of
+ NONE => (Vector.new0 (), NONE)
+ | SOME (x, t) =>
+ (Vector.new1 (x, t), SOME t)
+ in
split
- (Vector.new0 (),
- Kind.Runtime {prim = prim},
- ss,
+ (formals, Kind.CReturn {func = func}, ss,
fn l =>
- ([], Transfer.Runtime {args = vos args,
- prim = prim,
- return = l}))
- else
- case Prim.name prim of
- Array_array =>
+ let
+ val t =
+ Transfer.CCall {args = args,
+ func = func,
+ return = SOME l}
+ fun isolate () =
+ (* Put the CCall in its own block
+ * so that limit check insertion
+ * can put a limit check just before
+ * it.
+ *)
+ let
+ val l =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.Jump,
+ profileInfo = profileInfo,
+ statements = Vector.new0 (),
+ transfer = t}
+ in
+ prefix
+ (Transfer.Goto
+ {args = Vector.new0 (),
+ dst = l})
+ end
+ in
+ case CFunction.bytesNeeded func of
+ NONE => prefix t
+ | SOME i =>
+ Operand.caseBytes
+ (Vector.sub (args, i),
+ {big = fn _ => isolate (),
+ small = fn _ => prefix t})
+ end)
+ end
+ fun ccall {args, func} =
+ ccallGen {args = args,
+ func = func,
+ prefix = fn t => ([], t)}
+ fun simpleCCall (f: CFunction.t) =
+ ccall {args = vos args,
+ func = f}
+ fun array0 (numElts: Operand.t) =
+ add
+ (PrimApp
+ {args = (Vector.new3
+ (numElts,
+ Operand.word
+ (Word.fromInt Runtime.array0Size),
+ Operand.ArrayHeader
+ {numBytesNonPointers = 0,
+ numPointers = 0})),
+ dst = dst (),
+ prim = Prim.arrayAllocate})
+ datatype z = datatype Prim.Name.t
+ in
+ case Prim.name prim of
+ Array_array =>
let
val numElts = a 0
val numEltsOp = Operand.Var {var = numElts, ty = Type.int}
@@ -720,46 +879,55 @@
in
if 0 = np andalso 0 = nbnp
then array0 numEltsOp
- else
+ else if not (!Control.inlineArrayAllocation)
+ then ccall {args = (Vector.new4
+ (Operand.GCState,
+ Operand.EnsuresBytesFree,
+ numEltsOp,
+ ArrayHeader {numBytesNonPointers = nbnp,
+ numPointers = np})),
+ func = CFunction.gcArrayAllocate}
+ else
let
- val (numBytes, numElts, continue) =
+ val (shouldSplit, numBytes, numElts, continue) =
case varInt numElts of
SOME n =>
- (* Compute the number of bytes in the array now, since
- * the number of elements is a known constant.
+ (* Compute the number of bytes in the array now,
+ * since the number of elements is a known constant.
*)
let
val numBytes =
Runtime.wordAlign
(MLton.Word.addCheck
(Word.fromInt Runtime.arrayHeaderSize,
- (MLton.Word.mulCheck (Word.fromInt n,
- Word.fromInt bytesPerElt))))
+ (MLton.Word.mulCheck
+ (Word.fromInt n,
+ Word.fromInt bytesPerElt))))
handle Overflow => Runtime.allocTooLarge
in
- (Operand.word numBytes,
+ (numBytes > 0w512,
+ Operand.word numBytes,
Operand.int n,
- fn alloc =>
- ([], Goto {args = Vector.new0 (),
- dst = alloc}))
+ fn l => ([], Goto {dst = l,
+ args = Vector.new0 ()}))
end
| NONE =>
let
- val numEltsOp =
- Operand.Var {var = numElts, ty = Type.int}
val numBytes = Var.newNoname ()
val numBytes' = Var.newNoname ()
val numBytesOp' =
Operand.Var {var = numBytes', ty = Type.word}
val numEltsWord = Var.newNoname ()
val numEltsWordOp =
- Operand.Var {var = numEltsWord, ty = Type.word}
+ Operand.Var {var = numEltsWord,
+ ty = Type.word}
val conv =
PrimApp {args = Vector.new1 numEltsOp,
dst = SOME (numEltsWord, Type.word),
prim = Prim.word32FromInt}
in
- (Operand.Var {var = numBytes, ty = Type.word},
+ (true,
+ Operand.Var {var = numBytes, ty = Type.word},
numEltsOp,
fn alloc =>
if 1 = nbnp
@@ -769,22 +937,25 @@
in
([conv,
PrimApp
- {args = (Vector.new2 (Operand.word 0w3,
- numEltsWordOp)),
+ {args = (Vector.new2
+ (Operand.word 0w3,
+ numEltsWordOp)),
dst = SOME (numEltsP3, Type.word),
prim = Prim.word32Add},
PrimApp
{args = (Vector.new2
- (Operand.word (Word.notb 0w3),
- Operand.Var {var = numEltsP3,
- ty = Type.word})),
+ (Operand.word
+ (Word.notb 0w3),
+ Operand.Var
+ {var = numEltsP3,
+ ty = Type.word})),
dst = SOME (numBytes', Type.word),
prim = Prim.word32Andb},
PrimApp
{args = (Vector.new2
(Operand.word
(Word.fromInt
- (Runtime.arrayHeaderSize)),
+ Runtime.arrayHeaderSize),
numBytesOp')),
dst = SOME (numBytes, Type.word),
prim = Prim.word32Add}],
@@ -813,9 +984,10 @@
in
([conv],
Transfer.Arith
- {args = Vector.new2 (Operand.word
- (Word.fromInt bytesPerElt),
- numEltsWordOp),
+ {args = (Vector.new2
+ (Operand.word
+ (Word.fromInt bytesPerElt),
+ numEltsWordOp)),
dst = numBytes',
overflow = allocTooLarge (),
prim = Prim.word32MulCheck,
@@ -823,190 +995,246 @@
ty = Type.word})
end)
end
+ val s =
+ PrimApp {args = (Vector.new3
+ (numElts,
+ numBytes,
+ Operand.ArrayHeader
+ {numBytesNonPointers = nbnp,
+ numPointers = np})),
+ dst = dst (),
+ prim = Prim.arrayAllocate}
in
- split (Vector.new0 (), Kind.Jump,
- PrimApp {dst = dst (),
- prim = Prim.array_allocate,
- args = Vector.new3
- (numElts,
- numBytes,
- Operand.word
- (Runtime.arrayHeader
- {numBytesNonPointers = nbnp,
- numPointers = np}))}
- :: ss,
- continue)
+ if shouldSplit
+ then split (Vector.new0 (), Kind.Jump, s :: ss, continue)
+ else add s
end
end
end
- | Array_array0 => array0 (Operand.int 0)
- | Array_sub =>
- (case targ () of
- NONE => none ()
- | SOME t => sub t)
- | Array_update =>
- (case targ () of
- NONE => none ()
- | SOME t =>
- add (Move {dst = arrayOffset t,
- src = varOp (a 2)}))
- | MLton_bogus =>
- (case toType ty of
- NONE => none ()
- | SOME t =>
- let
- val c = Operand.Const
- in
- move
- (case Type.dest t of
- Type.Char =>
- c (Const.fromChar #"\000")
- | Type.Double =>
- c (Const.fromReal "0.0")
- | Type.Int =>
- c (Const.fromInt 0)
- | Type.Pointer =>
- Operand.Pointer 1
- | Type.Uint =>
- c (Const.fromWord 0w0))
- end)
- | MLton_eq =>
- (case targ () of
- NONE => move (Operand.int 1)
- | SOME _ => normal ())
- | Ref_assign =>
- (case targ () of
- NONE => none ()
- | SOME ty =>
- add
- (Move {dst = Offset {base = a 0,
- bytes = 0,
- ty = ty},
- src = varOp (a 1)}))
- | Ref_deref =>
- (case targ () of
- NONE => none ()
- | SOME ty =>
- move (Offset {base = a 0,
- bytes = 0,
- ty = ty}))
- | Ref_ref =>
- let
- val (ys, ts) =
- case targ () of
- NONE => (Vector.new0 (),
- Vector.new0 ())
- | SOME t => (Vector.new1 (a 0),
- Vector.new1 (SOME t))
- in allocate (ys, sortTypes (0, ts))
- end
- | String_sub => sub Type.char
- | Thread_atomicBegin =>
- (* assert(gcState.canHandle >= 0);
- * gcState.canHandle++;
- * if (gcState.signalIsPending)
- * setLimit(&gcState);
- *)
- split
- (Vector.new0 (), Kind.Jump, ss, fn l =>
- let
- fun doit (dst, prim, a, b) =
- let
- val tmp = Var.newNoname ()
- in
- Vector.new2
- (Statement.PrimApp
- {args = Vector.new2 (a, b),
- dst = SOME (tmp, Type.word),
- prim = prim},
- Statement.Move
- {dst = Operand.Runtime dst,
- src = (Operand.Var
- {var = tmp,
- ty = Type.word})})
- end
- datatype z = datatype RuntimeOperand.t
- val statements =
- Vector.concat
- [doit (LimitPlusSlop,
- Prim.word32Add,
- Operand.Runtime Base,
- Operand.Runtime FromSize),
- doit (Limit,
- Prim.word32Sub,
- Operand.Runtime LimitPlusSlop,
- Operand.word
- (Word.fromInt
- Runtime.limitSlop))]
- val l' =
- newBlock
- {args = Vector.new0 (),
- kind = Kind.Jump,
- profileInfo = profileInfo,
- statements = statements,
- transfer = (Transfer.Goto
- {args = Vector.new0 (),
- dst = l})}
- in
- (bumpCanHandle 1,
- Transfer.iff
- (Operand.Runtime SignalIsPending,
- {falsee = l,
- truee = l'}))
- end)
- | Thread_atomicEnd =>
- (* gcState.canHandle--;
- * assert(gcState.canHandle >= 0);
- * if (gcState.signalIsPending
- * and 0 == gcState.canHandle)
- * gcState.limit = 0;
- *)
- split
- (Vector.new0 (), Kind.Jump, ss, fn l =>
- let
- datatype z = datatype RuntimeOperand.t
- val statements =
- Vector.new1
- (Statement.Move
- {dst = Operand.Runtime Limit,
- src = Operand.word 0w0})
- val l'' =
- newBlock
- {args = Vector.new0 (),
- kind = Kind.Jump,
- profileInfo = profileInfo,
- statements = statements,
- transfer =
- Transfer.Goto
- {args = Vector.new0 (),
- dst = l}}
- val l' =
- newBlock
- {args = Vector.new0 (),
- kind = Kind.Jump,
- profileInfo = profileInfo,
- statements = Vector.new0 (),
- transfer =
- Transfer.iff
- (Operand.Runtime CanHandle,
- {truee = l,
- falsee = l''})}
- in
- (bumpCanHandle ~1,
+ | Array_array0 => array0 (Operand.int 0)
+ | Array_sub =>
+ (case targ () of
+ NONE => none ()
+ | SOME t => sub t)
+ | Array_update =>
+ (case targ () of
+ NONE => none ()
+ | SOME t =>
+ add (Move {dst = arrayOffset t,
+ src = varOp (a 2)}))
+ | FFI name =>
+ if Option.isNone (Prim.numArgs prim)
+ then normal ()
+ else
+ simpleCCall
+ (CFunction.vanilla
+ {name = name,
+ returnTy =
+ Option.map
+ (var, valOf o toType o varType)})
+ | GC_collect =>
+ ccall
+ {args = Vector.new5 (Operand.GCState,
+ Operand.int 0,
+ Operand.bool true,
+ Operand.File,
+ Operand.Line),
+ func = (CFunction.gc
+ {maySwitchThreads = false})}
+ | IntInf_add => simpleCCall CFunction.intInfAdd
+ | IntInf_compare =>
+ simpleCCall CFunction.intInfCompare
+ | IntInf_equal =>
+ simpleCCall CFunction.intInfEqual
+ | IntInf_gcd => simpleCCall CFunction.intInfGcd
+ | IntInf_mul => simpleCCall CFunction.intInfMul
+ | IntInf_neg => simpleCCall CFunction.intInfNeg
+ | IntInf_quot => simpleCCall CFunction.intInfQuot
+ | IntInf_rem => simpleCCall CFunction.intInfRem
+ | IntInf_sub => simpleCCall CFunction.intInfSub
+ | IntInf_toString =>
+ simpleCCall CFunction.intInfToString
+ | MLton_bogus =>
+ (case toType ty of
+ NONE => none ()
+ | SOME t =>
+ let
+ val c = Operand.Const
+ in
+ move
+ (case Type.dest t of
+ Type.Char =>
+ c (Const.fromChar #"\000")
+ | Type.Double =>
+ c (Const.fromReal "0.0")
+ | Type.Int =>
+ c (Const.fromInt 0)
+ | Type.Pointer =>
+ Operand.Pointer 1
+ | Type.Uint =>
+ c (Const.fromWord 0w0))
+ end)
+ | MLton_bug => simpleCCall CFunction.bug
+ | MLton_eq =>
+ (case targ () of
+ NONE => move (Operand.int 1)
+ | SOME _ => normal ())
+ | MLton_size => simpleCCall CFunction.size
+ | Real_Math_cosh => simpleCCall CFunction.cosh
+ | Real_Math_sinh => simpleCCall CFunction.sinh
+ | Real_Math_tanh => simpleCCall CFunction.tanh
+ | Real_Math_pow => simpleCCall CFunction.pow
+ | Real_copysign => simpleCCall CFunction.copysign
+ | Real_frexp => simpleCCall CFunction.frexp
+ | Real_modf => simpleCCall CFunction.modf
+ | Ref_assign =>
+ (case targ () of
+ NONE => none ()
+ | SOME ty =>
+ add
+ (Move {dst = Offset {base = a 0,
+ bytes = 0,
+ ty = ty},
+ src = varOp (a 1)}))
+ | Ref_deref =>
+ (case targ () of
+ NONE => none ()
+ | SOME ty =>
+ move (Offset {base = a 0,
+ bytes = 0,
+ ty = ty}))
+ | Ref_ref =>
+ let
+ val (ys, ts) =
+ case targ () of
+ NONE => (Vector.new0 (),
+ Vector.new0 ())
+ | SOME t => (Vector.new1 (a 0),
+ Vector.new1 (SOME t))
+ in allocate (ys, sortTypes (0, ts))
+ end
+ | String_equal =>
+ simpleCCall CFunction.stringEqual
+ | String_sub => sub Type.char
+ | Thread_atomicBegin =>
+ (* assert(gcState.canHandle >= 0);
+ * gcState.canHandle++;
+ * if (gcState.signalIsPending)
+ * setLimit(&gcState);
+ *)
+ split
+ (Vector.new0 (), Kind.Jump, ss, fn l =>
+ let
+ fun doit (dst, prim, a, b) =
+ let
+ val tmp = Var.newNoname ()
+ in
+ Vector.new2
+ (Statement.PrimApp
+ {args = Vector.new2 (a, b),
+ dst = SOME (tmp, Type.word),
+ prim = prim},
+ Statement.Move
+ {dst = (Operand.CastWord
+ (Operand.Runtime dst)),
+ src = (Operand.Var
+ {var = tmp,
+ ty = Type.word})})
+ end
+ datatype z = datatype GCField.t
+ val statements =
+ Vector.concat
+ [doit (LimitPlusSlop,
+ Prim.word32Add,
+ Operand.Runtime Base,
+ Operand.Runtime FromSize),
+ doit (Limit,
+ Prim.word32Sub,
+ Operand.Runtime LimitPlusSlop,
+ Operand.word
+ (Word.fromInt
+ Runtime.limitSlop))]
+ val l' =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.Jump,
+ profileInfo = profileInfo,
+ statements = statements,
+ transfer = (Transfer.Goto
+ {args = Vector.new0 (),
+ dst = l})}
+ in
+ (bumpCanHandle 1,
+ Transfer.iff
+ (Operand.Runtime SignalIsPending,
+ {falsee = l,
+ truee = l'}))
+ end)
+ | Thread_atomicEnd =>
+ (* gcState.canHandle--;
+ * assert(gcState.canHandle >= 0);
+ * if (gcState.signalIsPending
+ * and 0 == gcState.canHandle)
+ * gcState.limit = 0;
+ *)
+ split
+ (Vector.new0 (), Kind.Jump, ss, fn l =>
+ let
+ datatype z = datatype GCField.t
+ val statements =
+ Vector.new1
+ (Statement.Move
+ {dst = (Operand.CastWord
+ (Operand.Runtime Limit)),
+ src = Operand.word 0w0})
+ val l'' =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.Jump,
+ profileInfo = profileInfo,
+ statements = statements,
+ transfer =
+ Transfer.Goto
+ {args = Vector.new0 (),
+ dst = l}}
+ val l' =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.Jump,
+ profileInfo = profileInfo,
+ statements = Vector.new0 (),
+ transfer =
Transfer.iff
- (Operand.Runtime SignalIsPending,
- {falsee = l,
- truee = l'}))
- end)
- | Thread_canHandle =>
- move (Operand.Runtime
- RuntimeOperand.CanHandle)
- | Vector_fromArray => move (varOp (a 0))
- | Vector_sub =>
- (case targ () of
- NONE => none ()
- | SOME t => sub t)
- | _ => normal ()
+ (Operand.Runtime CanHandle,
+ {truee = l,
+ falsee = l''})}
+ in
+ (bumpCanHandle ~1,
+ Transfer.iff
+ (Operand.Runtime SignalIsPending,
+ {falsee = l,
+ truee = l'}))
+ end)
+ | Thread_canHandle =>
+ move (Operand.Runtime GCField.CanHandle)
+ | Thread_copy =>
+ ccall {args = (Vector.concat
+ [Vector.new1 Operand.GCState,
+ vos args]),
+ func = CFunction.copyThread}
+ | Thread_switchTo =>
+ simpleCCall CFunction.threadSwitchTo
+ | Vector_fromArray => move (varOp (a 0))
+ | Vector_sub =>
+ (case targ () of
+ NONE => none ()
+ | SOME t => sub t)
+ | World_save =>
+ ccall {args = (Vector.new2
+ (Operand.GCState,
+ Vector.sub (vos args, 0))),
+ func = CFunction.worldSave}
+ | _ => normal ()
end
| S.Exp.Select {tuple, offset} =>
(case Vector.sub (#offsets (tupleInfo (varType tuple)),
1.1 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor CFunction (S: C_FUNCTION_STRUCTS): C_FUNCTION =
struct
open S
datatype t = T of {bytesNeeded: int option,
ensuresBytesFree: bool,
mayGC: bool,
maySwitchThreads: bool,
modifiesFrontier: bool,
modifiesStackTop: bool,
name: string,
needsArrayInit: bool,
returnTy: Type.t option}
fun layout (T {bytesNeeded, ensuresBytesFree, mayGC, maySwitchThreads,
modifiesFrontier, modifiesStackTop, name, needsArrayInit,
returnTy}) =
Layout.record
[("bytesNeeded", Option.layout Int.layout bytesNeeded),
("ensuresBytesFree", Bool.layout ensuresBytesFree),
("mayGC", Bool.layout mayGC),
("maySwitchThreads", Bool.layout maySwitchThreads),
("modifiesFrontier", Bool.layout modifiesFrontier),
("modifiesStackTop", Bool.layout modifiesStackTop),
("name", String.layout name),
("needsArrayInit", Bool.layout needsArrayInit),
("returnTy", Option.layout Type.layout returnTy)]
local
fun make f (T r) = f r
in
val bytesNeeded = make #bytesNeeded
val ensuresBytesFree = make #ensuresBytesFree
val mayGC = make #mayGC
val maySwitchThreads = make #maySwitchThreads
val modifiesFrontier = make #modifiesFrontier
val modifiesStackTop = make #modifiesStackTop
val name = make #name
val needsArrayInit = make #needsArrayInit
val returnTy = make #returnTy
end
fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
modifiesStackTop, needsArrayInit, returnTy, ...}): bool =
(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)
val isOk = Trace.trace ("CFunction.isOk", layout, Bool.layout) isOk
fun equals (T {bytesNeeded = b,
ensuresBytesFree = e,
mayGC = g,
maySwitchThreads = s,
modifiesFrontier = f,
modifiesStackTop = t,
name = n,
needsArrayInit = nai,
returnTy = r},
T {bytesNeeded = b',
ensuresBytesFree = e',
mayGC = g',
maySwitchThreads = s',
modifiesFrontier = f',
modifiesStackTop = t',
name = n',
needsArrayInit = nai',
returnTy = r'}) =
b = b' andalso e = e' andalso g = g' andalso s = s' andalso f = f'
andalso t = t' andalso n = n' andalso nai = nai'
andalso Option.equals (r, r', Type.equals)
val equals =
Trace.trace2 ("CFunction.equals", layout, layout, Bool.layout) equals
local
fun make b =
T {bytesNeeded = NONE,
ensuresBytesFree = true,
mayGC = true,
maySwitchThreads = b,
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_gc",
needsArrayInit = false,
returnTy = NONE}
val t = make true
val f = make false
in
fun gc {maySwitchThreads = b} = if b then t else f
end
fun vanilla {name, returnTy} =
T {bytesNeeded = NONE,
ensuresBytesFree = false,
mayGC = false,
maySwitchThreads = false,
modifiesFrontier = false,
modifiesStackTop = false,
name = name,
needsArrayInit = false,
returnTy = returnTy}
val bug = vanilla {name = "MLton_bug",
returnTy = NONE}
val size = vanilla {name = "MLton_size",
returnTy = SOME Type.int}
val stringEqual = vanilla {name = "String_equal",
returnTy = SOME Type.bool}
end
1.1 mlton/mlton/backend/c-function.sig
Index: c-function.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
type int = Int.t
type word = Word.t
signature C_FUNCTION_STRUCTS =
sig
structure Type: MTYPE
end
signature C_FUNCTION =
sig
include C_FUNCTION_STRUCTS
datatype t = T of {(* bytesNeeded = SOME i means that the i'th
* argument to the function is a word that
* specifies the number of bytes that must be
* free in order for the C function to succeed.
* Limit check insertion is responsible for
* making sure that the bytesNeeded is available.
*)
bytesNeeded: int option,
ensuresBytesFree: bool,
modifiesFrontier: bool,
modifiesStackTop: bool,
mayGC: bool,
maySwitchThreads: bool,
name: string,
needsArrayInit: bool,
returnTy: Type.t option}
val bug: t
val bytesNeeded: t -> int option
val ensuresBytesFree: t -> bool
val equals: t * t -> bool
val gc: {maySwitchThreads: bool} -> t
val isOk: t -> bool
val layout: t -> Layout.t
val mayGC: t -> bool
val maySwitchThreads: t -> bool
val modifiesFrontier: t -> bool
val modifiesStackTop: t -> bool
val name: t -> string
val needsArrayInit: t -> bool
val returnTy: t -> Type.t option
val size: t
val stringEqual: t
val vanilla: {name: string, returnTy: Type.t option} -> t
end
1.1 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor Runtime (S: RUNTIME_STRUCTS): RUNTIME =
struct
open S
structure Type = Mtype ()
structure CFunction = CFunction (structure Type = Type)
structure GCField =
struct
datatype t =
Base
| CanHandle
| CurrentThread
| FromSize
| Frontier
| Limit
| LimitPlusSlop
| MaxFrameSize
| SignalIsPending
| StackBottom
| StackLimit
| StackTop
val ty =
fn Base => Type.pointer
| CanHandle => Type.int
| CurrentThread => Type.pointer
| FromSize => Type.word
| Frontier => Type.pointer
| Limit => Type.pointer
| LimitPlusSlop => Type.pointer
| MaxFrameSize => Type.word
| SignalIsPending => Type.int
| StackBottom => Type.pointer
| StackLimit => Type.pointer
| StackTop => Type.pointer
val baseOffset: int ref = ref 0
val canHandleOffset: int ref = ref 0
val currentThreadOffset: int ref = ref 0
val fromSizeOffset: int ref = ref 0
val frontierOffset: int ref = ref 0
val limitOffset: int ref = ref 0
val limitPlusSlopOffset: int ref = ref 0
val maxFrameSizeOffset: int ref = ref 0
val signalIsPendingOffset: int ref = ref 0
val stackBottomOffset: int ref = ref 0
val stackLimitOffset: int ref = ref 0
val stackTopOffset: int ref = ref 0
fun setOffsets {base, canHandle, currentThread, fromSize, frontier, limit,
limitPlusSlop, maxFrameSize, signalIsPending, stackBottom,
stackLimit, stackTop} =
(baseOffset := base
; canHandleOffset := canHandle
; currentThreadOffset := currentThread
; fromSizeOffset := fromSize
; frontierOffset := frontier
; limitOffset := limit
; limitPlusSlopOffset := limitPlusSlop
; maxFrameSizeOffset := maxFrameSize
; signalIsPendingOffset := signalIsPending
; stackBottomOffset := stackBottom
; stackLimitOffset := stackLimit
; stackTopOffset := stackTop)
val offset =
fn Base => !baseOffset
| CanHandle => !canHandleOffset
| CurrentThread => !currentThreadOffset
| FromSize => !fromSizeOffset
| Frontier => !frontierOffset
| Limit => !limitOffset
| LimitPlusSlop => !limitPlusSlopOffset
| MaxFrameSize => !maxFrameSizeOffset
| SignalIsPending => !signalIsPendingOffset
| StackBottom => !stackBottomOffset
| StackLimit => !stackLimitOffset
| StackTop => !stackTopOffset
val toString =
fn Base => "Base"
| CanHandle => "CanHandle"
| CurrentThread => "CurrentThread"
| FromSize => "FromSize"
| Frontier => "Frontier"
| Limit => "Limit"
| LimitPlusSlop => "LimitPlusSlop"
| MaxFrameSize => "MaxFrameSize"
| SignalIsPending => "SignalIsPending"
| StackBottom => "StackBottom"
| StackLimit => "StackLimit"
| StackTop => "StackTop"
val layout = Layout.str o toString
end
structure ObjectType =
struct
datatype t =
Array of {numBytesNonPointers: int,
numPointers: int}
| Normal of {numPointers: int,
numWordsNonPointers: int}
| Stack
val equals: t * t -> bool = op =
fun layout (t: t): Layout.t =
let
open Layout
in
case t of
Array {numBytesNonPointers = nbnp, numPointers = np} =>
seq [str "Array ",
record [("numBytesNonPointers", Int.layout nbnp),
("numPointers", Int.layout np)]]
| Normal {numPointers = np, numWordsNonPointers = nwnp} =>
seq [str "Normal ",
record [("numPointers", Int.layout np),
("numWordsNonPointers", Int.layout nwnp)]]
| Stack => str "Stack"
end
end
val maxTypeIndex = Int.^ (2, 19)
fun typeIndexToHeader typeIndex =
(Assert.assert ("Runtime.header", fn () =>
0 <= typeIndex
andalso typeIndex < maxTypeIndex)
; Word.orb (0w1, Word.<< (Word.fromInt typeIndex, 0w1)))
fun headerToTypeIndex w = Word.toInt (Word.>> (w, 0w1))
val wordSize: int = 4
val arrayHeaderSize = 3 * wordSize
val labelSize = wordSize
val limitSlop: int = 512
val normalHeaderSize = wordSize
val pointerSize = wordSize
val array0Size = arrayHeaderSize + wordSize (* for the forwarding pointer *)
val arrayLengthOffset = ~ (2 * wordSize)
val allocTooLarge: word = 0wxFFFFFFFC
fun normalSize {numPointers, numWordsNonPointers} =
wordSize * (numPointers + numWordsNonPointers)
fun wordAlign (w: word): word =
let
open Word
in
andb (MLton.Word.addCheck (w, 0w3), notb 0w3)
end
fun isWordAligned (n: int): bool =
0 = Int.rem (n, wordSize)
fun isValidObjectSize (n: int): bool =
n > 0 andalso isWordAligned n
val maxFrameSize = Int.^ (2, 16)
end
1.3 +2 -2 mlton/mlton/codegen/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/sources.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.2
+++ sources.cm 6 Jul 2002 17:22:06 -0000 1.3
@@ -7,8 +7,8 @@
*)
Group
-functor CCodeGen
-functor x86CodeGen
+functor CCodegen
+functor x86Codegen
is
1.22 +388 -268 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.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- c-codegen.fun 23 Jun 2002 01:37:54 -0000 1.21
+++ c-codegen.fun 6 Jul 2002 17:22:06 -0000 1.22
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor CCodeGen (S: C_CODEGEN_STRUCTS): C_CODEGEN =
+functor CCodegen (S: C_CODEGEN_STRUCTS): C_CODEGEN =
struct
open S
@@ -24,12 +24,20 @@
structure Operand = Operand
structure Prim = Prim
structure Register = Register
- structure RuntimeOperand = RuntimeOperand
+ structure Runtime = Runtime
structure Statement = Statement
structure Transfer = Transfer
structure Type = Type
end
+local
+ open Runtime
+in
+ structure CFunction = CFunction
+ structure GCField = GCField
+ structure ObjectType = ObjectType
+end
+
structure Kind =
struct
open Kind
@@ -37,9 +45,9 @@
fun isEntry (k: t): bool =
case k of
Cont _ => true
+ | CReturn {func = CFunction.T {mayGC, ...}, ...} => mayGC
| Func _ => true
| Handler _ => true
- | Runtime _ => true
| _ => false
end
@@ -120,7 +128,11 @@
end
fun push (i, print) = call ("\tPush", [int i], print)
+
+ fun move ({dst, src}, print) =
+ print (concat [dst, " = ", src, ";\n"])
end
+
structure Label =
struct
open Label
@@ -137,10 +149,13 @@
concat ["X", Type.name ty,
C.args [toString base, toString index]]
| CastInt oper => concat ["PointerToInt", C.args [toString oper]]
+ | CastWord oper => concat ["(word)", C.args [toString oper]]
| Char c => C.char c
| Contents {oper, ty} =>
concat ["C", Type.name ty, "(", toString oper, ")"]
+ | File => "__FILE__"
| Float s => C.float s
+ | GCState => "&gcState"
| Global g => Global.toString g
| GlobalPointerNonRoot n =>
concat ["globalpointerNonRoot [", C.int n, "]"]
@@ -148,32 +163,28 @@
| IntInf w =>
concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
| Label l => Label.toStringIndex l
+ | Line => "__LINE__"
| Offset {base, offset, ty} =>
concat ["O", Type.name ty, C.args [toString base, C.int offset]]
| Pointer n => concat ["IntAsPointer", C.args [C.int n]]
| Register r => Register.toString r
| Runtime r =>
let
- datatype z = datatype RuntimeOperand.t
- val ty = (case RuntimeOperand.ty r of
- RuntimeOperand.Int => "Int"
- | RuntimeOperand.Word => "Word")
- val z =
- case r of
- Base => "gcState.base"
- | CanHandle => "gcState.canHandle"
- | CurrentThread => "gcState.currentThread"
- | FromSize => "gcState.fromSize"
- | Frontier => "frontier"
- | Limit => "gcState.limit"
- | LimitPlusSlop => "gcState.limitPlusSlop"
- | MaxFrameSize => "gcState.maxFrameSize"
- | SignalIsPending => "gcState.signalIsPending"
- | StackBottom => "gcState.stackBottom"
- | StackLimit => "gcState.stackLimit"
- | StackTop => "stackTop"
+ datatype z = datatype GCField.t
in
- concat ["((", ty, ")", z, ")"]
+ case r of
+ Base => "gcState.base"
+ | CanHandle => "gcState.canHandle"
+ | CurrentThread => "gcState.currentThread"
+ | FromSize => "gcState.fromSize"
+ | Frontier => "frontier"
+ | Limit => "gcState.limit"
+ | LimitPlusSlop => "gcState.limitPlusSlop"
+ | MaxFrameSize => "gcState.maxFrameSize"
+ | SignalIsPending => "gcState.signalIsPending"
+ | StackBottom => "gcState.stackBottom"
+ | StackLimit => "gcState.stackLimit"
+ | StackTop => "stackTop"
end
| StackOffset {offset, ty} =>
concat ["S", Type.name ty, "(", C.int offset, ")"]
@@ -182,92 +193,155 @@
val layout = Layout.str o toString
end
-structure Statement =
- struct
- open Statement
-
- fun output (s, print) =
- case s of
- Noop => ()
- | _ =>
- (print "\t"
- ; (case s of
- Move {dst, src} =>
- print (concat [Operand.toString dst, " = ",
- Operand.toString src, ";\n"])
- | Noop => ()
- | Object {dst, numPointers, numWordsNonPointers, stores} =>
- (C.call ("Object", [Operand.toString dst,
- C.int numWordsNonPointers,
- C.int numPointers],
- print)
- ; print "\t"
- ; (Vector.foreach
- (stores, fn {offset, value} =>
- (C.call
- (concat ["A", Type.name (Operand.ty value)],
- [C.int offset, Operand.toString value],
- print)
- ; print "\t")))
- ; C.call ("EndObject",
- [C.int
- (Runtime.objectHeaderSize
- +
- Runtime.objectSize
- {numPointers = numPointers,
- numWordsNonPointers = numWordsNonPointers})],
- print))
- | PrimApp {args, dst, prim} =>
- let
- val _ =
- case dst of
- NONE => ()
- | SOME dst =>
- print (concat [Operand.toString dst, " = "])
- fun doit () =
- C.call (Prim.toString prim,
- Vector.toListMap (args, Operand.toString),
- print)
- val _ =
- case Prim.name prim of
- Prim.Name.FFI s =>
- (case Prim.numArgs prim of
- NONE => print (concat [s, ";\n"])
- | SOME _ => doit ())
- | _ => doit ()
- in
- ()
- end
- | SetExnStackLocal {offset} =>
- C.call ("SetExnStackLocal", [C.int offset], print)
- | SetExnStackSlot {offset} =>
- C.call ("SetExnStackSlot", [C.int offset], print)
- | SetSlotExnStack {offset} =>
- C.call ("SetSlotExnStack", [C.int offset], print)
- ))
+fun creturn (t: Type.t): string = concat ["CReturn", Type.name t]
- fun toString s =
+fun outputDeclarations
+ {additionalMainArgs: string list,
+ includes: string list,
+ maxFrameIndex: int,
+ name: string,
+ print: string -> unit,
+ program = (Machine.Program.T
+ {chunks, frameOffsets, floats, globals,
+ globalsNonRoot, intInfs, maxFrameSize, objectTypes, strings,
+ ...}),
+ rest: unit -> unit
+ }: unit =
+ let
+ fun outputIncludes () =
+ (List.foreach (includes, fn i => (print "#include <";
+ print i;
+ print ">\n"))
+ ; print "\n")
+ fun declareGlobals () =
+ C.call ("Globals",
+ List.map (List.map (let open Type
+ in [char, double, int, pointer, uint]
+ end,
+ globals) @ [globalsNonRoot],
+ C.int),
+ print)
+ fun locals ty =
+ List.fold (chunks, 0, fn (Machine.Chunk.T {regMax, ...}, max) =>
+ if regMax ty > max
+ then regMax ty
+ else max)
+ fun declareLocals () =
+ C.call ("Locals",
+ List.map (List.map (let
+ open Type
+ in
+ [char, double, int, pointer, uint]
+ end,
+ locals),
+ C.int),
+ print)
+ fun declareIntInfs () =
+ (print "BeginIntInfs\n"
+ ; List.foreach (intInfs, fn (g, s) =>
+ (C.callNoSemi ("IntInf",
+ [C.int (Global.index g),
+ C.string s],
+ print)
+ ; print "\n"))
+ ; print "EndIntInfs\n")
+ fun declareStrings () =
+ (print "BeginStrings\n"
+ ; List.foreach (strings, fn (g, s) =>
+ (C.callNoSemi ("String",
+ [C.int (Global.index g),
+ C.string s,
+ C.int (String.size s)],
+ print)
+ ; print "\n"))
+ ; print "EndStrings\n")
+ fun declareFloats () =
+ (print "BeginFloats\n"
+ ; List.foreach (floats, fn (g, f) =>
+ (C.callNoSemi ("Float",
+ [C.int (Global.index g),
+ C.float f],
+ print)
+ ; print "\n"))
+ ; print "EndFloats\n")
+ fun declareFrameOffsets () =
+ Vector.foreachi
+ (frameOffsets, fn (i, v) =>
+ (print (concat ["static ushort frameOffsets", C.int i, "[] = {"])
+ ; print (C.int (Vector.length v))
+ ; Vector.foreach (v, fn i => (print ","; print (C.int i)))
+ ; print "};\n"))
+ fun declareObjectTypes () =
+ (print (concat ["static GC_ObjectType objectTypes[] = {\n"])
+ ; (Vector.foreach
+ (objectTypes, fn t =>
+ let
+ val (tag, nonPointers, pointers) =
+ case t of
+ ObjectType.Array {numBytesNonPointers, numPointers} =>
+ (0, numBytesNonPointers, numPointers)
+ | ObjectType.Normal {numPointers, numWordsNonPointers} =>
+ (1, numWordsNonPointers, numPointers)
+ | ObjectType.Stack =>
+ (2, 0, 0)
+ in
+ print (concat ["\t{ ", Int.toString tag, ", ",
+ Int.toString nonPointers, ", ",
+ Int.toString pointers, " },\n"])
+ end))
+ ; print "};\n")
+ fun declareMain () =
let
- val ss = ref []
- fun print s = List.push (ss, s)
- val _ = output (s, print)
- in concat (rev (!ss))
+ val stringSizes =
+ List.fold (strings, 0, fn ((_, s), n) =>
+ n + arrayHeaderSize
+ + Type.align (Type.pointer, String.size s))
+ val intInfSizes =
+ List.fold (intInfs, 0, fn ((_, s), n) =>
+ n + intInfOverhead
+ + Type.align (Type.pointer, String.size s))
+ val bytesLive = intInfSizes + stringSizes
+ val (usedFixedHeap, fromSize) =
+ case !Control.fixedHeap of
+ NONE => (false, 0)
+ | SOME n =>
+ (* div 2 for semispace *)
+ (if n > 0 andalso bytesLive >= n div 2
+ then Out.output (Out.error,
+ "Warning: heap size used with -h is too small to hold static data.\n")
+ else ();
+ (true, n))
+ val magic = C.word (Random.useed ())
+ in
+ C.callNoSemi ("Main",
+ [if usedFixedHeap then C.truee else C.falsee,
+ C.int fromSize,
+ C.int bytesLive,
+ C.int maxFrameSize,
+ C.int maxFrameIndex,
+ C.int (Vector.length objectTypes),
+ magic] @ additionalMainArgs,
+ print)
+ ; print "\n"
end
-
- val layout = Layout.str o toString
+ in
+ print (concat ["#define ", name, "CODEGEN\n\n"])
+ ; outputIncludes ()
+ ; declareGlobals ()
+ ; declareLocals ()
+ ; declareIntInfs ()
+ ; declareStrings ()
+ ; declareFloats ()
+ ; declareFrameOffsets ()
+ ; declareObjectTypes ()
+ ; rest ()
+ ; declareMain ()
end
-fun creturn (t: Type.t): string = concat ["CReturn", Type.name t]
-
-fun output {program = Machine.Program.T {chunks,
- floats,
- frameOffsets,
- globals,
- globalsNonRoot,
- intInfs,
- main = {chunkLabel, label},
- maxFrameSize,
- strings, ...},
+fun output {program as Machine.Program.T {chunks,
+ frameOffsets,
+ main = {chunkLabel, label},
+ objectTypes, ...},
includes,
outputC: unit -> {file: File.t,
print: string -> unit,
@@ -312,48 +386,6 @@
Kind.frameInfoOpt kind
end
val {print, done, ...} = outputC ()
- fun outputIncludes () =
- List.foreach (includes, fn i => (print "#include <";
- print i;
- print ">\n\n"))
- fun declareGlobals () =
- C.call ("Globals",
- List.map (List.map (let open Type
- in [char, double, int, pointer, uint]
- end,
- globals) @ [globalsNonRoot],
- C.int),
- print);
- fun declareIntInfs () =
- (print "BeginIntInfs\n";
- List.foreach (intInfs,
- fn (g, s)
- => (C.callNoSemi ("IntInf",
- [C.int (Global.index g),
- C.string s],
- print)
- ; print "\n"));
- print "EndIntInfs\n")
- fun declareStrings () =
- (print "BeginStrings\n";
- List.foreach (strings,
- fn (g, s)
- => (C.callNoSemi ("String",
- [C.int (Global.index g),
- C.string s,
- C.int (String.size s)],
- print);
- print "\n"));
- print "EndStrings\n");
- fun declareFloats () =
- (print "BeginFloats\n";
- List.foreach (floats, fn (g, f) =>
- (C.callNoSemi ("Float",
- [C.int (Global.index g),
- C.float f],
- print);
- print "\n"));
- print "EndFloats\n");
fun declareChunks () =
List.foreach (chunks, fn Chunk.T {chunkLabel, ...} =>
C.call ("DeclareChunk",
@@ -365,6 +397,17 @@
(if i > 0 then print ",\n\t" else ()
; pr x))
; print "};\n")
+ fun declareFrameLayouts () =
+ make ("GC_frameLayout frameLayouts []", fn l =>
+ let
+ val (size, offsetIndex) =
+ case labelFrameInfo l of
+ NONE => ("0", "NULL")
+ | SOME (FrameInfo.T {size, frameOffsetsIndex}) =>
+ (C.int size, "frameOffsets" ^ C.int frameOffsetsIndex)
+ in
+ print (concat ["{", size, ",", offsetIndex, "}"])
+ end)
fun declareNextChunks () =
make ("void ( *nextChunks []) ()", fn l =>
let
@@ -377,24 +420,6 @@
[ChunkLabel.toString chunkLabel],
print)
end)
- fun declareFrameOffsets () =
- Vector.foreachi
- (frameOffsets, fn (i, v) =>
- (print (concat ["static ushort frameOffsets", C.int i, "[] = {"])
- ; print (C.int (Vector.length v))
- ; Vector.foreach (v, fn i => (print ","; print (C.int i)))
- ; print "};\n"))
- fun declareFrameLayouts () =
- make ("GC_frameLayout frameLayouts []", fn l =>
- let
- val (size, offsetIndex) =
- case labelFrameInfo l of
- NONE => ("0", "NULL")
- | SOME (FrameInfo.T {size, frameOffsetsIndex}) =>
- (C.int size, "frameOffsets" ^ C.int frameOffsetsIndex)
- in
- print (concat ["{", size, ",", offsetIndex, "}"])
- end)
fun declareIndices () =
Vector.foreach
(entryLabels, fn l =>
@@ -405,6 +430,64 @@
; print " "
; print (C.int i)
; print "\n")))
+ fun outputStatement s =
+ let
+ datatype z = datatype Statement.t
+ in
+ case s of
+ Noop => ()
+ | _ =>
+ (print "\t"
+ ; (case s of
+ Move {dst, src} =>
+ C.move ({dst = Operand.toString dst,
+ src = Operand.toString src},
+ print)
+ | Noop => ()
+ | Object {dst, header, size, stores} =>
+ (C.call ("Object", [Operand.toString dst,
+ C.word header],
+ print)
+ ; print "\t"
+ ; (Vector.foreach
+ (stores, fn {offset, value} =>
+ (C.call
+ (concat ["A", Type.name (Operand.ty value)],
+ [C.int offset, Operand.toString value],
+ print)
+ ; print "\t")))
+ ; C.call ("EndObject", [C.int size], print))
+ | PrimApp {args, dst, prim} =>
+ let
+ val _ =
+ case dst of
+ NONE => ()
+ | SOME dst =>
+ print
+ (concat [Operand.toString dst, " = "])
+ fun doit () =
+ C.call
+ (Prim.toString prim,
+ Vector.toListMap (args, Operand.toString),
+ print)
+ val _ =
+ case Prim.name prim of
+ Prim.Name.FFI s =>
+ (case Prim.numArgs prim of
+ NONE => print (concat [s, ";\n"])
+ | SOME _ => doit ())
+ | _ => doit ()
+ in
+ ()
+ end
+ | SetExnStackLocal {offset} =>
+ C.call ("SetExnStackLocal", [C.int offset], print)
+ | SetExnStackSlot {offset} =>
+ C.call ("SetExnStackSlot", [C.int offset], print)
+ | SetSlotExnStack {offset} =>
+ C.call ("SetSlotExnStack", [C.int offset], print)
+ ))
+ end
fun outputChunk (Chunk.T {chunkLabel, blocks, regMax, ...}) =
let
fun labelFrameSize (l: Label.t): int =
@@ -430,19 +513,60 @@
case transfer of
Arith {overflow, success, ...} =>
(jump overflow; jump success)
- | Bug => ()
- | CCall _ => ()
+ | CCall {func = CFunction.T {maySwitchThreads, ...},
+ return, ...} =>
+ if maySwitchThreads
+ then ()
+ else Option.app (return, jump)
| Call {label, ...} => jump label
| Goto dst => jump dst
| Raise => ()
| Return _ => ()
- | Runtime _ => ()
| Switch {cases, default, ...} =>
(Cases.foreach (cases, jump)
; Option.app (default, jump))
| SwitchIP {int, pointer, ...} =>
(jump int; jump pointer)
end)
+ fun push (return: Label.t, size: int) =
+ (C.push (size, print)
+ ; print "\t"
+ ; C.move ({dst = Operand.toString
+ (Operand.StackOffset {offset = ~Runtime.labelSize,
+ ty = Type.label}),
+ src = Operand.toString (Operand.Label return)},
+ print))
+ fun copyArgs (args: Operand.t vector): string list * (unit -> unit) =
+ if Vector.exists (args,
+ fn Operand.StackOffset _ => true
+ | _ => false)
+ then
+ let
+ val _ = print "\t{\n"
+ val c = Counter.new 0
+ val args =
+ Vector.toListMap
+ (args, fn z =>
+ case z of
+ Operand.StackOffset {ty, ...} =>
+ let
+ val tmp =
+ concat ["tmp",
+ Int.toString (Counter.next c)]
+ val _ =
+ print (concat ["\t", Type.toString ty,
+ " ", tmp,
+ " = ", Operand.toString z,
+ ";\n"])
+ in
+ tmp
+ end
+ | _ => Operand.toString z)
+ in
+ (args, fn () => print "\t}\n")
+ end
+ else (Vector.toListMap (args, Operand.toString),
+ fn () => ())
val tracePrintLabelCode =
Trace.trace
("printLabelCode",
@@ -485,33 +609,44 @@
; print ":\n"
end
| _ => ()
- val _ =
- if 0 = !Control.Native.commented
- then ()
- else
- print (let open Layout
- in toString
- (seq [str "\t/* live: ",
- Vector.layout Operand.layout live,
- str " */\n"])
- end)
+ fun pop (FrameInfo.T {size, ...}) = C.push (~ size, print)
val _ =
case kind of
- Kind.Cont {frameInfo, ...} =>
- C.push (~ (FrameInfo.size frameInfo), print)
- | Kind.CReturn {dst, ...} =>
- Option.app
- (dst, fn x =>
- print (concat ["\t", Operand.toString x, " = ",
- creturn (Operand.ty x), ";\n"]))
- | Kind.Func {args} => ()
- | Kind.Handler {offset} => C.push (~ offset, print)
+ Kind.Cont {frameInfo, ...} => pop frameInfo
+ | Kind.CReturn {dst, frameInfo, func, ...} =>
+ (if CFunction.mayGC func
+ then pop (valOf frameInfo)
+ else ()
+ ; (Option.app
+ (dst, fn x =>
+ print (concat ["\t", Operand.toString x, " = ",
+ creturn (Operand.ty x), ";\n"]))))
+ | Kind.Func _ => ()
+ | Kind.Handler {offset} => C.push (~offset, print)
| Kind.Jump => ()
- | Kind.Runtime {frameInfo, ...} =>
- C.push (~ (FrameInfo.size frameInfo), print)
val _ =
- Vector.foreach (statements, fn s =>
- Statement.output (s, print))
+ if 0 = !Control.Native.commented
+ then ()
+ else
+ if true
+ then
+ Vector.foreach
+ (live, fn z =>
+ if Type.isPointer (Operand.ty z)
+ then
+ print
+ (concat ["\tCheckPointer(",
+ Operand.toString z,
+ ");\n"])
+ else ())
+ else
+ print (let open Layout
+ in toString
+ (seq [str "\t/* live: ",
+ Vector.layout Operand.layout live,
+ str " */\n"])
+ end)
+ val _ = Vector.foreach (statements, outputStatement)
val _ = outputTransfer (transfer, l)
in ()
end) arg
@@ -550,44 +685,69 @@
; gotoLabel success
; maybePrintLabel overflow
end
- | Bug => (print "\t"; C.bug ("machine", print))
- | CCall {args, prim, return, returnTy} =>
+ | CCall {args,
+ frameInfo,
+ func = CFunction.T {mayGC,
+ maySwitchThreads,
+ modifiesFrontier,
+ modifiesStackTop,
+ name,
+ returnTy,
+ ...},
+ return} =>
let
+ val (args, afterCall) =
+ if mayGC
+ then
+ let
+ val FrameInfo.T {size, ...} =
+ valOf frameInfo
+ val res = copyArgs args
+ val _ = push (valOf return, size)
+ in
+ res
+ end
+ else
+ (Vector.toListMap (args, Operand.toString),
+ fn () => ())
+ val _ =
+ if modifiesFrontier
+ then print "\tFlushFrontier();\n"
+ else ()
+ val _ =
+ if modifiesStackTop
+ then print "\tFlushStackTop();\n"
+ else ()
val _ = print "\t"
val _ =
case returnTy of
NONE => ()
| SOME t => print (concat [creturn t, " = "])
- fun doit () =
- C.call (Prim.toString prim,
- Vector.toListMap (args, Operand.toString),
- print)
+ val _ = C.call (name, args, print)
+ val _ = afterCall ()
+ val _ =
+ if modifiesFrontier
+ then print "\tCacheFrontier();\n"
+ else ()
val _ =
- case Prim.name prim of
- Prim.Name.FFI s =>
- (case Prim.numArgs prim of
- NONE => print (concat [s, ";\n"])
- | SOME _ => doit ())
- | _ => doit ()
- val _ = gotoLabel return
+ if modifiesStackTop
+ then print "\tCacheStackTop();\n"
+ else ()
+ val _ =
+ if maySwitchThreads
+ then print "\tReturn();\n"
+ else Option.app (return, gotoLabel)
in
()
end
| Call {label, return, ...} =>
let
+ val dstChunk = labelChunk label
val _ =
case return of
NONE => ()
- | SOME {return, handler, size} =>
- (C.push (size, print)
- ; (Statement.output
- (Statement.Move
- {dst = (Operand.StackOffset
- {offset = ~Runtime.labelSize,
- ty = Type.label}),
- src = Operand.Label return},
- print)))
- val dstChunk = labelChunk label
+ | SOME {return, size, ...} =>
+ push (return, size)
in
if ChunkLabel.equals (labelChunk source, dstChunk)
then gotoLabel label
@@ -600,13 +760,6 @@
| Goto dst => gotoLabel dst
| Raise => C.call ("\tRaise", [], print)
| Return _ => C.call ("\tReturn", [], print)
- | Runtime {args, prim, return, ...} =>
- (print "\t"
- ; C.call (Prim.toString prim,
- [C.int (labelFrameSize return),
- Label.toStringIndex return]
- @ Vector.toListMap (args, Operand.toString),
- print))
| Switch {test, cases, default} =>
let
val test = Operand.toString test
@@ -673,56 +826,23 @@
; C.profile ("EndChunk (magic)", overhead, print)
; print "EndChunk\n"
end
- fun declareMain () =
- let
- val stringSizes =
- List.fold (strings, 0, fn ((_, s), n) =>
- n + arrayHeaderSize
- + Type.align (Type.pointer, String.size s))
- val intInfSizes =
- List.fold (intInfs,
- 0,
- fn ((_, s), n) =>
- n + intInfOverhead
- + Type.align (Type.pointer, String.size s))
- val liveSize = intInfSizes + stringSizes
- val (useFixedHeap, fromSize) =
- case !Control.fixedHeap of
- NONE => (C.falsee, 0)
- | SOME n => (* div 2 for semispace *)
- (if n > 0 andalso liveSize >= n div 2
- then Out.output (Out.error,
- "Warning: heap size used with -h is too small to hold static data.\n")
- else ();
- (C.truee, n))
- val magic = C.word (Random.useed ())
- in C.profile ("Main (magic)", overhead, print)
- ; C.callNoSemi ("Main",
- [useFixedHeap,
- C.int fromSize,
- C.int liveSize,
- C.int maxFrameSize,
- C.int maxFrameIndex,
- magic,
- ChunkLabel.toString chunkLabel,
- Label.toStringIndex label],
- print)
- ; print "\n"
- end
+ val additionalMainArgs =
+ [ChunkLabel.toString chunkLabel,
+ Label.toStringIndex label]
+ fun rest () =
+ (declareChunks ()
+ ; declareNextChunks ()
+ ; declareFrameLayouts ()
+ ; declareIndices ()
+ ; List.foreach (chunks, outputChunk))
in
- print "#define CCODEGEN\n\n"
- ; outputIncludes ()
- ; declareGlobals ()
- ; declareIntInfs ()
- ; declareStrings ()
- ; declareFloats ()
- ; declareChunks ()
- ; declareNextChunks ()
- ; declareFrameOffsets ()
- ; declareFrameLayouts ()
- ; declareIndices ()
- ; List.foreach (chunks, outputChunk)
- ; declareMain ()
+ outputDeclarations {additionalMainArgs = additionalMainArgs,
+ includes = includes,
+ maxFrameIndex = maxFrameIndex,
+ name = "C",
+ program = program,
+ print = print,
+ rest = rest}
; done ()
end
1.4 +8 -0 mlton/mlton/codegen/c-codegen/c-codegen.sig
Index: c-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- c-codegen.sig 10 Apr 2002 07:02:19 -0000 1.3
+++ c-codegen.sig 6 Jul 2002 17:22:06 -0000 1.4
@@ -23,4 +23,12 @@
print: string -> unit,
done: unit -> unit}
} -> unit
+ val outputDeclarations: {additionalMainArgs: string list,
+ includes: string list,
+ maxFrameIndex: int,
+ name: string,
+ print: string -> unit,
+ program: Machine.Program.t,
+ rest: unit -> unit
+ } -> unit
end
1.3 +2 -1 mlton/mlton/codegen/c-codegen/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/sources.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.2
+++ sources.cm 6 Jul 2002 17:22:06 -0000 1.3
@@ -7,7 +7,8 @@
*)
Group
-functor CCodeGen
+signature C_CODEGEN
+functor CCodegen
is
1.7 +3 -1 mlton/mlton/codegen/x86-codegen/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/sources.cm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.6
+++ sources.cm 6 Jul 2002 17:22:06 -0000 1.7
@@ -7,7 +7,7 @@
*)
Group
-functor x86CodeGen
+functor x86Codegen
is
@@ -15,11 +15,13 @@
../../atoms/sources.cm
../../control/sources.cm
../../backend/sources.cm
+../c-codegen/sources.cm
x86-codegen.sig
x86.sig
x86.fun
x86-pseudo.sig
+x86-mlton-basic.fun
x86-mlton-basic.sig
x86-liveness.sig
x86-liveness.fun
1.26 +25 -141 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.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- x86-codegen.fun 16 Apr 2002 12:09:58 -0000 1.25
+++ x86-codegen.fun 6 Jul 2002 17:22:06 -0000 1.26
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor x86CodeGen(S: X86_CODEGEN_STRUCTS): X86_CODEGEN =
+functor x86Codegen(S: X86_CODEGEN_STRUCTS): X86_CODEGEN =
struct
open S
@@ -17,7 +17,7 @@
structure x86
= x86(structure Label = Machine.Label
- structure Prim = Machine.Prim)
+ structure Runtime = Machine.Runtime)
structure x86MLtonBasic
= x86MLtonBasic(structure x86 = x86
@@ -220,32 +220,6 @@
fun outputC ()
= let
val {file, print, done} = makeC ()
-
- fun make(name, l, pr)
- = (print (concat["static ", name, " = {"]);
- List.foreachi(l,
- fn (i,x) => (if i > 0 then print "," else ();
- pr x));
- print "};\n");
-
- fun outputIncludes()
- = (List.foreach(includes,
- fn i => (print "#include <";
- print i;
- print ">\n"));
- print "\n");
-
- fun declareGlobals()
- = C.call("Globals",
- List.map(List.map(let
- open Type
- in
- [char, double, int, pointer, uint]
- end,
- globals) @ [globalsNonRoot],
- C.int),
- print);
-
fun locals ty
= List.fold(chunks,
0,
@@ -253,66 +227,12 @@
=> if regMax ty > max
then regMax ty
else max)
-
- fun declareLocals()
- = C.call("Locals",
- List.map(List.map(let
- open Type
- in
- [char, double, int, pointer, uint]
- end,
- locals),
- C.int),
- print);
-
- fun declareIntInfs()
- = (print "BeginIntInfs\n";
- List.foreach
- (intInfs,
- fn (g, s)
- => (C.callNoSemi("IntInf",
- [C.int(Machine.Global.index g),
- C.string s],
- print);
- print "\n"));
- print "EndIntInfs\n");
-
- fun declareStrings()
- = (print "BeginStrings\n";
- List.foreach
- (strings,
- fn (g, s)
- => (C.callNoSemi("String",
- [C.int(Machine.Global.index g),
- C.string s,
- C.int(String.size s)],
- print);
- print "\n"));
- print "EndStrings\n");
-
- fun declareFloats()
- = (print "BeginFloats\n";
- List.foreach
- (floats,
- fn (g, f)
- => (C.callNoSemi("Float",
- [C.int(Machine.Global.index g),
- C.float f],
- print);
- print "\n"));
- print "EndFloats\n");
-
- fun declareFrameOffsets()
- = Vector.foreachi
- (frameOffsets,
- fn (i,l)
- => (print (concat["static ushort frameOffsets",
- C.int i,
- "[] = {\n\t"]);
- print (C.int (Vector.length l));
- Vector.foreach (l, fn i => (print ","; print (C.int i)));
- print "};\n"));
-
+ fun make(name, l, pr)
+ = (print (concat["static ", name, " = {"]);
+ List.foreachi(l,
+ fn (i,x) => (if i > 0 then print "," else ();
+ pr x));
+ print "};\n");
fun declareFrameLayouts()
= make("GC_frameLayout frameLayouts[]",
frameLayoutsData,
@@ -321,35 +241,8 @@
C.int size, ",",
"frameOffsets" ^ (C.int offsetIndex),
"}"]))
-
- fun declareMain()
- = let
- val stringSizes
- = List.fold(strings,
- 0,
- fn ((_, s), n)
- => n + arrayHeaderSize
- + Type.align(Type.pointer,
- String.size s))
- val intInfSizes
- = List.fold(intInfs,
- 0,
- fn ((_, s), n)
- => n + intInfOverhead
- + Type.align(Type.pointer,
- String.size s))
- val bytesLive = intInfSizes + stringSizes
- val (usedFixedHeap, fromSize)
- = case !Control.fixedHeap
- of NONE => (false, 0)
- | SOME n
- => (* div 2 for semispace *)
- (if n > 0 andalso bytesLive >= n div 2
- then Out.output(Out.error,
- "Warning: heap size used with -h is too small to hold static data.\n")
- else ();
- (true, n))
- val magic = C.word(Random.useed ())
+ val additionalMainArgs =
+ let
val mainLabel = Label.toString (#label main)
(* Drop the leading _ with Cygwin, because gcc will add it.
*)
@@ -357,31 +250,22 @@
case !Control.hostType of
Control.Cygwin => String.dropPrefix (mainLabel, 1)
| Control.Linux => mainLabel
- in
- C.callNoSemi("Main",
- [if usedFixedHeap then C.truee else C.falsee,
- C.int fromSize,
- C.int bytesLive,
- C.int maxFrameSize,
- C.int maxFrameLayoutIndex,
- magic,
- mainLabel,
- if reserveEsp then "TRUE" else "FALSE"],
- print);
- print "\n"
- end;
+ in
+ [mainLabel,
+ if reserveEsp then "TRUE" else "FALSE"]
+ end
+ fun rest () =
+ declareFrameLayouts()
in
- print "#define X86CODEGEN\n\n";
- outputIncludes();
- declareGlobals();
- declareLocals();
- declareIntInfs();
- declareStrings();
- declareFloats();
- declareFrameOffsets();
- declareFrameLayouts();
- declareMain();
- done ()
+ CCodegen.outputDeclarations
+ {additionalMainArgs = additionalMainArgs,
+ includes = includes,
+ maxFrameIndex = maxFrameLayoutIndex,
+ name = "X86",
+ print = print,
+ program = program,
+ rest = rest}
+ ; done ()
end
val outputC = Control.trace (Control.Pass, "outputC") outputC
1.4 +5 -3 mlton/mlton/codegen/x86-codegen/x86-codegen.sig
Index: x86-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- x86-codegen.sig 10 Apr 2002 07:02:19 -0000 1.3
+++ x86-codegen.sig 6 Jul 2002 17:22:06 -0000 1.4
@@ -9,9 +9,11 @@
type word = Word.t
signature X86_CODEGEN_STRUCTS =
- sig
- structure Machine: MACHINE
- end
+ sig
+ structure CCodegen: C_CODEGEN
+ structure Machine: MACHINE
+ sharing Machine = CCodegen.Machine
+ end
signature X86_CODEGEN =
sig
1.6 +5 -8 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.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- x86-entry-transfer.fun 16 Apr 2002 12:10:52 -0000 1.5
+++ x86-entry-transfer.fun 6 Jul 2002 17:22:06 -0000 1.6
@@ -39,9 +39,6 @@
fun isHandler l = case get l
of SOME (Block.T {entry = Entry.Handler _, ...}) => true
| _ => false
- fun isRuntime l = case get l
- of SOME (Block.T {entry = Entry.Runtime _, ...}) => true
- | _ => false
fun isCReturn l = case get l
of SOME (Block.T {entry = Entry.CReturn _, ...}) => true
| _ => false
@@ -67,10 +64,10 @@
| NONE => true)
| Transfer.Return {...} => true
| Transfer.Raise {...} => true
- | Transfer.Runtime {return, ...}
- => isRuntime return
- | Transfer.CCall {return, ...}
- => isCReturn return))
+ | Transfer.CCall {return, ...} =>
+ (case return of
+ NONE => true
+ | SOME l => isCReturn l)))
before destroy ()
end
@@ -79,4 +76,4 @@
"verifyEntryTransfer"
verifyEntryTransfer
-end
\ No newline at end of file
+end
1.29 +276 -493 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.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86-generate-transfers.fun 16 Apr 2002 12:10:52 -0000 1.28
+++ x86-generate-transfers.fun 6 Jul 2002 17:22:06 -0000 1.29
@@ -17,6 +17,12 @@
open LiveInfo
open Liveness
+ local
+ open Runtime
+ in
+ structure CFunction = CFunction
+ end
+
val rec ones : int -> word
= fn 0 => 0wx0
| n => Word.orb(Word.<<(ones (n-1), 0wx1),0wx1)
@@ -365,71 +371,32 @@
val isLoopHeader = fn _ => false
*)
- fun near label
- = if falling
- then if unique
- then AppendList.appends
- [AppendList.fromList
- (if isLoopHeader label
- handle _ => false
- then [Assembly.pseudoop_p2align
- (Immediate.const_int 4,
- NONE,
- SOME (Immediate.const_int 7)),
- Assembly.label label]
- else [Assembly.label label]),
- profile_assembly]
- else AppendList.appends
- [AppendList.fromList
- (if isLoopHeader label
- handle _ => false
- then [Assembly.pseudoop_p2align
- (Immediate.const_int 4,
- NONE,
- SOME (Immediate.const_int 7)),
- Assembly.label label]
- else [Assembly.label label]),
- AppendList.fromList
- [(* near entry &
- * live transfer assumptions *)
- (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}))})],
- profile_assembly]
- else AppendList.appends
- [AppendList.fromList
- (if isLoopHeader label
- handle _ => false
- then [Assembly.pseudoop_p2align
- (Immediate.const_int 4,
- NONE,
- SOME (Immediate.const_int 7)),
- Assembly.label label]
- else [Assembly.pseudoop_p2align
- (Immediate.const_int 4,
- NONE,
- NONE),
- Assembly.label label]),
+
+ fun near label =
+ let
+ val align =
+ if isLoopHeader label handle _ => false
+ then
+ AppendList.single
+ (Assembly.pseudoop_p2align
+ (Immediate.const_int 4,
+ NONE,
+ SOME (Immediate.const_int 7)))
+ else if falling
+ then AppendList.empty
+ else
+ AppendList.single
+ (Assembly.pseudoop_p2align
+ (Immediate.const_int 4,
+ NONE,
+ NONE))
+ val assumes =
+ if falling andalso unique
+ then AppendList.empty
+ else
+ (* near entry & live transfer assumptions *)
AppendList.fromList
- [(* near entry &
- * live transfer assumptions *)
- (blockAssumes
+ [(blockAssumes
(List.map
(getLiveRegsTransfers
(liveTransfers, label),
@@ -445,35 +412,80 @@
(getLiveFltRegsTransfers
(liveTransfers, label),
fn (memloc,sync)
- => {memloc = memloc,
- sync = sync,
- weight = 1024}))})],
- profile_assembly]
-
+ => {memloc = memloc,
+ sync = sync,
+ weight = 1024}))})]
+ in
+ AppendList.appends
+ [align,
+ AppendList.single (Assembly.label label),
+ assumes,
+ profile_assembly]
+ end
val pre
= case entry
of Jump {label}
=> near label
- | CReturn {label, dst}
- => AppendList.append
- (near label,
- 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, 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")
+ 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
+ end
| Func {label,...}
=> AppendList.append
(AppendList.fromList
@@ -484,9 +496,8 @@
(* entry from far assumptions *)
(farEntry profile_assembly))
| Cont {label,
- frameInfo as Entry.FrameInfo.T
- {size,
- frameLayoutsIndex},
+ frameInfo as FrameInfo.T {size,
+ frameLayoutsIndex},
...}
=> AppendList.append
(AppendList.fromList
@@ -537,35 +548,6 @@
src = bytes,
size = pointerSize}
end))))
- | Runtime {label,
- frameInfo as Entry.FrameInfo.T
- {size,
- frameLayoutsIndex}}
- => 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.snoc
- (profile_assembly,
- let
- val stackTop
- = x86MLton.gcState_stackTopContentsOperand ()
- val bytes
- = x86.Operand.immediate_const_int (~ size)
- in
- (* stackTop += bytes *)
- x86.Assembly.instruction_binal
- {oper = x86.Instruction.ADD,
- dst = stackTop,
- src = bytes,
- size = pointerSize}
- end))))
-
val pre
= AppendList.appends
[if !Control.Native.commented > 1
@@ -936,382 +918,183 @@
{target = stackTopDeref,
absolute = true})))
end
- | Runtime {prim, args, return, size}
- => let
- val _ = enque return
-
- val {dead, ...}
- = livenessTransfer {transfer = transfer,
- liveInfo = liveInfo}
-
- val stackTop'
- = x86MLton.gcState_stackTopContents ()
- val stackTop
- = x86MLton.gcState_stackTopContentsOperand ()
- val bytes
- = x86.Operand.immediate_const_int size
- val stackTopMinusWordDeref
- = x86MLton.gcState_stackTopMinusWordDerefOperand ()
-
- val live = x86Liveness.LiveInfo.getLive(liveInfo, return)
-
- fun default f
- = let
- val target = Label.fromString f
-
- val c_stackPDerefDouble
- = x86MLton.c_stackPDerefDoubleOperand
- val applyFFTemp
- = x86MLton.applyFFTempContentsOperand
-
- val (assembly_args,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))
- in
- AppendList.appends
- [cacheEsp (),
- assembly_args,
- 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},
- (* flushing at Runtime *)
- 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},
- Assembly.directive_ccall (),
- Assembly.instruction_call
- {target = Operand.label target,
- absolute = false},
- 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}],
- (if size_args > 0
- then AppendList.single
+ | CCall {args, dstsize,
+ frameInfo,
+ func = CFunction.T {mayGC,
+ maySwitchThreads,
+ modifiesFrontier,
+ 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,
+ 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})
+ | _ => 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})
- else AppendList.empty),
- unreserveEsp (),
- (* flushing at far transfer *)
- (farTransfer MemLocSet.empty
- AppendList.empty
- (AppendList.single
- (* jmp *(stackTop - WORD_SIZE) *)
- (x86.Assembly.instruction_jmp
- {target = stackTopMinusWordDeref,
- absolute = true})))]
- end
-
- fun thread ()
- = let
- val (thread,threadsize)
- = case args
- of [_, (thread,threadsize)] => (thread,threadsize)
- | _ => Error.bug
- "x86GenerateTransfers::Runtime: args"
-
- val threadTemp
- = x86MLton.threadTempContentsOperand
-
- 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 ()
-
- val resetJoin = Label.newString "resetJoin"
- 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 + 8 *)
- Assembly.instruction_mov
- {dst = stackBottom,
- src = stack,
- size = pointerSize},
- Assembly.instruction_binal
- {oper = Instruction.ADD,
- dst = stackBottom,
- src = Operand.immediate_const_int 8,
- 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
-
- datatype z = datatype Prim.Name.t
- in
- case Prim.name prim
- of GC_collect => default "GC_gc"
- | MLton_halt => default "MLton_exit"
- | Thread_copy => default "GC_copyThread"
- | Thread_copyCurrent => default "GC_copyCurrentThread"
- | Thread_switchTo => thread ()
- | World_save => default "GC_saveWorld"
- | _ => Error.bug "x86GenerateTransfers::Runtime: prim"
- end
- | CCall {target, args, return, dstsize}
- => let
- val {dead, ...}
- = livenessTransfer {transfer = transfer,
- liveInfo = liveInfo}
-
- val c_stackP
- = x86MLton.c_stackPContentsOperand
- val c_stackPDerefDouble
- = x86MLton.c_stackPDerefDoubleOperand
- val applyFFTemp
- = x86MLton.applyFFTempContentsOperand
-
- val (assembly_args,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))
- in
- AppendList.appends
- [cacheEsp (),
- assembly_args,
- AppendList.fromList
- [(* flushing at Ccall *)
- 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},
- Assembly.directive_ccall (),
- Assembly.instruction_call
- {target = Operand.label target,
- absolute = false},
- 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 = ccallflushClasses}],
- (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})
- | _ => Error.bug "CCall")),
- (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),
- unreserveEsp (),
- fall gef
- {label = return,
- live = getLive(liveInfo, return)}]
- end)
-
+ 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,
+ 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})
{label, transfer} : Assembly.t AppendList.t
= case transfer
1.9 +0 -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.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- x86-jump-info.fun 16 Apr 2002 12:10:52 -0000 1.8
+++ x86-jump-info.fun 6 Jul 2002 17:22:06 -0000 1.9
@@ -65,7 +65,6 @@
| Entry.Func {label, ...} => forceNear (jumpInfo, label)
| Entry.Cont {label, ...} => forceNear (jumpInfo, label)
| Entry.Handler {label, ...} => forceNear (jumpInfo, label)
- | Entry.Runtime {label, ...} => ()
| Entry.CReturn {label, ...} => ();
List.foreach
(Transfer.nearTargets transfer,
1.10 +19 -16 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.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- x86-live-transfers.fun 16 Apr 2002 12:10:52 -0000 1.9
+++ x86-live-transfers.fun 6 Jul 2002 17:22:06 -0000 1.10
@@ -17,6 +17,13 @@
struct
open S
open x86
+
+ local
+ open Runtime
+ in
+ structure CFunction = CFunction
+ end
+
structure LiveSet = x86Liveness.LiveSet
structure LiveInfo = x86Liveness.LiveInfo
open x86JumpInfo
@@ -302,10 +309,8 @@
=> ()
| Raise {...}
=> ()
- | Runtime {return, ...}
- => (doit'' return)
| CCall {return, ...}
- => (doit' return)
+ => Option.app (return, doit')
end)
val _
@@ -459,11 +464,11 @@
= case transfer
of Tail _ => (I.PosInfinity, NONE)
| NonTail _ => (I.PosInfinity, NONE)
- | Runtime _ => (I.PosInfinity, NONE)
| Return _ => (I.PosInfinity, NONE)
| Raise _ => (I.PosInfinity, NONE)
- | CCall _
- => if Size.class (MemLoc.size temp) <> Size.INT
+ | CCall {func, ...}
+ => if CFunction.mayGC func
+ orelse Size.class (MemLoc.size temp) <> Size.INT
then (I.PosInfinity, NONE)
else default ()
| _ => default ()
@@ -536,9 +541,9 @@
of Func {...} => (I.PosInfinity, NONE)
| Cont {...} => (I.PosInfinity, NONE)
| Handler {...} => (I.PosInfinity, NONE)
- | Runtime {...} => (I.PosInfinity, NONE)
- | CReturn {...}
- => if Size.class (MemLoc.size temp) <> Size.INT
+ | CReturn {func, ...}
+ => if (CFunction.mayGC func
+ orelse Size.class (MemLoc.size temp) <> Size.INT)
then (I.PosInfinity, NONE)
else default ()
| _ => default ()
@@ -806,10 +811,8 @@
=> ()
| Raise {...}
=> ()
- | Runtime {return, ...}
- => (doit'' return)
| CCall {return, ...}
- => (doit'' return)
+ => Option.app (return, doit'')
end
end
@@ -923,10 +926,10 @@
=> ()
| Raise {...}
=> ()
- | Runtime {return, ...}
- => (doit'' return)
- | CCall {return, ...}
- => (doit' return)
+ | CCall {func, return, ...}
+ => if CFunction.mayGC func
+ then Option.app (return, doit'')
+ else Option.app (return, doit')
end
in
case !defed
1.11 +1 -3 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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-loop-info.fun 16 Apr 2002 12:10:52 -0000 1.10
+++ x86-loop-info.fun 6 Jul 2002 17:22:06 -0000 1.11
@@ -112,10 +112,8 @@
=> ()
| Raise {...}
=> ()
- | Runtime {return, ...}
- => (doit'' return)
| CCall {return, ...}
- => (doit' return)
+ => Option.app (return, doit')
end)
val lf = Graph.loopForestSteensgaard (G, {root = root})
1.11 +2 -10 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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-mlton-basic.sig 10 Apr 2002 07:02:19 -0000 1.10
+++ x86-mlton-basic.sig 6 Jul 2002 17:22:06 -0000 1.11
@@ -13,7 +13,7 @@
structure x86 : X86_PSEUDO
structure Machine: MACHINE
sharing x86.Label = Machine.Label
- sharing x86.Prim = Machine.Prim
+ sharing x86.Runtime = Machine.Runtime
end
signature X86_MLTON_BASIC =
@@ -128,6 +128,7 @@
val gcState_frontierContents: unit -> x86.MemLoc.t
val gcState_frontierContentsOperand: unit -> x86.Operand.t
val gcState_frontierDerefOperand: unit -> x86.Operand.t
+ val gcState_label: x86.Label.t
val gcState_limitContentsOperand: unit -> x86.Operand.t
val gcState_limitPlusSlopContentsOperand: unit -> x86.Operand.t
val gcState_maxFrameSizeContentsOperand: unit -> x86.Operand.t
@@ -141,13 +142,4 @@
val gcState_stackTopDerefOperand: unit -> x86.Operand.t
val gcState_stackTopMinusWordDeref: unit -> x86.MemLoc.t
val gcState_stackTopMinusWordDerefOperand: unit -> x86.Operand.t
-
- (*
- * GC related constants and functions
- *)
- val gcState : x86.Label.t
-
- val GC_OBJECT_HEADER_SIZE : int
- val gcObjectHeader : {nonPointers: int, pointers: int} -> x86.Immediate.t
- val gcArrayHeader : {nonPointers: int, pointers: int} -> x86.Immediate.t
end
1.34 +53 -1300 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.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- x86-mlton.fun 23 Jun 2002 01:37:54 -0000 1.33
+++ x86-mlton.fun 6 Jul 2002 17:22:06 -0000 1.34
@@ -5,518 +5,20 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor x86MLtonBasic(S: X86_MLTON_BASIC_STRUCTS): X86_MLTON_BASIC =
+functor x86MLton(S: X86_MLTON_STRUCTS): X86_MLTON =
struct
open S
+ open x86MLtonBasic
open x86
-
- (*
- * 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 floatSize = Size.DBLE
- val floatBytes = Size.toBytes floatSize
- val objectHeaderBytes = wordBytes
- val arrayHeaderBytes = wordBytes + wordBytes
- val intInfOverheadBytes = arrayHeaderBytes + wordBytes
-
local
- open Machine.Type
+ open Machine
in
- fun toX86Size' t
- = case t
- of Char => x86.Size.BYTE
- | Double => x86.Size.DBLE
- | Int => x86.Size.LONG
- | Pointer => x86.Size.LONG
- | Uint => x86.Size.LONG
- val toX86Size = fn t => toX86Size' (dest t)
- fun toX86Scale' t
- = case t
- of Char => x86.Scale.One
- | Double => x86.Scale.Eight
- | Int => x86.Scale.Four
- | Pointer => x86.Scale.Four
- | Uint => x86.Scale.Four
- val toX86Scale = fn t => toX86Scale' (dest t)
+ structure CFunction = CFunction
+ structure Prim = Prim
+ structure Runtime = Runtime
end
- (*
- * Memory classes
- *)
- structure Classes =
- struct
- local
- fun new s = MemLoc.Class.new {name = s}
- in
- val Heap = new "Heap"
- val Stack = new "Stack"
- val Locals = new "Locals"
- val Globals = new "Globals"
-
- val Temp = MemLoc.Class.Temp
- 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"
- val GCStateHold = new "GCStateHold"
-
- val IntInfRes = new "IntInfRes"
- val ThreadStack = new "ThreadStack"
- end
-
- val allClasses = ref x86.ClassSet.empty
- val livenessClasses = ref x86.ClassSet.empty
- val holdClasses = ref x86.ClassSet.empty
- val runtimeClasses = ref x86.ClassSet.empty
- val heapClasses = ref x86.ClassSet.empty
- val cstaticClasses = ref x86.ClassSet.empty
-
- fun initClasses ()
- = let
- val _ = allClasses :=
- x86.ClassSet.fromList
- (
- Heap::
- Stack::
- Locals::
- Globals::
- Temp::
- CStack::
- Code::
- CStatic::
- StaticTemp::
- StaticNonTemp::
- GCState::
- GCStateHold::
- IntInfRes::
- ThreadStack::
- nil)
-
- val _ = livenessClasses :=
- (if !Control.Native.liveStack
- then x86.ClassSet.fromList
- (
- Temp::
- Locals::
- StaticTemp::
- Stack::
- nil)
- else x86.ClassSet.fromList
- (
- Temp::
- Locals::
- StaticTemp::
- nil))
-
- val _ = holdClasses :=
- x86.ClassSet.fromList
- (
- GCStateHold::
- nil)
-
- val _ = runtimeClasses :=
- x86.ClassSet.fromList
- (
- Heap::
- Stack::
- Globals::
- GCState::
- GCStateHold::
- ThreadStack::
- nil)
-
- val _ = heapClasses :=
- x86.ClassSet.fromList
- (
- Heap::
- nil)
-
- val _ = cstaticClasses :=
- x86.ClassSet.fromList
- (
- CStatic::
- nil)
- in
- ()
- 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 c_stackP = Label.fromString "c_stackP"
- val c_stackPContents
- = makeContents {base = Immediate.label c_stackP,
- size = pointerSize,
- class = Classes.StaticNonTemp}
- val c_stackPContentsOperand
- = Operand.memloc c_stackPContents
- val c_stackPDeref
- = MemLoc.simple {base = c_stackPContents,
- index = Immediate.const_int 0,
- scale = wordScale,
- size = pointerSize,
- class = Classes.CStack}
- val c_stackPDerefOperand
- = Operand.memloc c_stackPDeref
- val c_stackPDerefDouble
- = MemLoc.simple {base = c_stackPContents,
- index = Immediate.const_int 0,
- scale = wordScale,
- size = Size.DBLE,
- 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
- = makeContents {base = Immediate.label intInfTemp,
- size = wordSize,
- class = Classes.StaticTemp}
- val intInfTempContentsOperand
- = Operand.memloc intInfTempContents
- val intInfTempFrontierContents
- = MemLoc.simple {base = intInfTempContents,
- index = Immediate.const_int 0,
- scale = wordScale,
- size = pointerSize,
- class = Classes.IntInfRes}
- val intInfTempFrontierContentsOperand
- = Operand.memloc intInfTempFrontierContents
- val intInfTempValueContents
- = MemLoc.simple {base = intInfTempContents,
- index = Immediate.const_int 1,
- scale = wordScale,
- size = pointerSize,
- class = Classes.IntInfRes}
- val intInfTempValueContentsOperand
- = Operand.memloc intInfTempValueContents
-
- val threadTemp = Label.fromString "threadTemp"
- val threadTempContents
- = makeContents {base = Immediate.label threadTemp,
- size = wordSize,
- class = Classes.StaticTemp}
- val threadTempContentsOperand
- = Operand.memloc threadTempContents
-
- val statusTemp = Label.fromString "statusTemp"
- val statusTempContents
- = makeContents {base = Immediate.label statusTemp,
- size = wordSize,
- class = Classes.StaticTemp}
- val statusTempContentsOperand
- = Operand.memloc statusTempContents
-
- val fileTemp = Label.fromString "fileTemp"
- val fileTempContents
- = makeContents {base = Immediate.label fileTemp,
- size = pointerSize,
- class = Classes.StaticTemp}
- val fileTempContentsOperand
- = Operand.memloc fileTempContents
-
- val applyFFTemp = Label.fromString "applyFFTemp"
- val applyFFTempContents
- = makeContents {base = Immediate.label applyFFTemp,
- size = wordSize,
- class = Classes.StaticTemp}
- val applyFFTempContentsOperand
- = Operand.memloc applyFFTempContents
-
- val realTemp1 = Label.fromString "realTemp1"
- val realTemp1Contents
- = makeContents {base = Immediate.label realTemp1,
- size = floatSize,
- class = Classes.StaticTemp}
- val realTemp1ContentsOperand
- = Operand.memloc realTemp1Contents
-
- val realTemp2 = Label.fromString "realTemp2"
- val realTemp2Contents
- = makeContents {base = Immediate.label realTemp2,
- size = floatSize,
- class = Classes.StaticTemp}
- val realTemp2ContentsOperand
- = Operand.memloc realTemp2Contents
-
- val realTemp3 = Label.fromString "realTemp3"
- val realTemp3Contents
- = makeContents {base = Immediate.label realTemp3,
- size = floatSize,
- class = Classes.StaticTemp}
- val realTemp3ContentsOperand
- = Operand.memloc realTemp3Contents
-
- val fpswTemp = Label.fromString "fpswTemp"
- val fpswTempContents
- = makeContents {base = Immediate.label fpswTemp,
- size = Size.WORD,
- class = Classes.StaticTemp}
- val fpswTempContentsOperand
- = Operand.memloc fpswTempContents
-
- local
- open Machine.Type
- val localC_base = Label.fromString "localuchar"
- val localD_base = Label.fromString "localdouble"
- val localI_base = Label.fromString "localint"
- val localP_base = Label.fromString "localpointer"
- val localU_base = Label.fromString "localuint"
- in
- fun local_base ty
- = case dest ty
- of Char => localC_base
- | Double => localD_base
- | Int => localI_base
- | Pointer => localP_base
- | Uint => localU_base
- end
-
- local
- open Machine.Type
- val globalC_base = Label.fromString "globaluchar"
- val globalC_num = Label.fromString "num_globaluchar"
- val globalD_base = Label.fromString "globaldouble"
- val globalD_num = Label.fromString "num_globaldouble"
- val globalI_base = Label.fromString "globalint"
- val globalI_num = Label.fromString "num_globalint"
- val globalP_base = Label.fromString "globalpointer"
- val globalP_num = Label.fromString "num_globalpointer"
- val globalU_base = Label.fromString "globaluint"
- val globalU_num = Label.fromString "num_globaluint"
- in
- fun global_base ty
- = case dest ty
- of Char => globalC_base
- | Double => globalD_base
- | Int => globalI_base
- | Pointer => globalP_base
- | Uint => globalU_base
- end
-
- val globalPointerNonRoot_base = Label.fromString "globalpointerNonRoot"
-
- val saveGlobals = Label.fromString "saveGlobals"
- val loadGlobals = Label.fromString "loadGlobals"
-
- val fileNameLabel = Label.fromString "fileName"
- val fileName = Operand.immediate_label fileNameLabel
- (* This is a hack: The line number needs to be pushed, but the actual
- * call to GC_gc is about 9 lines further (push 4 more arguments,
- * adjust stackTop, save return label,
- * save gcState.frontier and gcState.stackTop, make call).
- * However, there are probably cases where this is different.
- *
- * We also have another hack because with Cygwin, Label.toString appends
- * an _ to the beginning of each label.
- *)
- val fileLineLabel =
- Promise.lazy
- (fn () =>
- Label.fromString (case !Control.hostType of
- Control.Cygwin => "_LINE__"
- | Control.Linux => "__LINE__"))
- val fileLine
- = fn () => if !Control.debug
- then Operand.immediate (Immediate.const_int 0)
- else (Operand.immediate
- (Immediate.binexp
- {oper = Immediate.Addition,
- exp1 = Immediate.label (fileLineLabel ()),
- exp2 = Immediate.const_int 9}))
-
- val gcState = Label.fromString "gcState"
-
- structure Field = Runtime.GCField
- fun make (f: Field.t, size, class) =
- let
- fun imm () =
- Immediate.binexp
- {oper = Immediate.Addition,
- exp1 = Immediate.label gcState,
- exp2 = Immediate.const_int (Field.offset f)}
- fun contents () =
- makeContents {base = imm (),
- size = size,
- class = class}
- fun operand () = Operand.memloc (contents ())
- in
- (imm, contents, operand)
- end
-
- val (_, gcState_baseContents, gcState_baseContentsOperand) =
- make (Field.Base, pointerSize, Classes.GCState)
-
- val (_, _, gcState_canHandleContentsOperand) =
- make (Field.CanHandle, wordSize, Classes.GCState)
-
- val (gcState_currentThread, gcState_currentThreadContents,
- gcState_currentThreadContentsOperand) =
- make (Field.CurrentThread, pointerSize, Classes.GCState)
-
- val (_, _, gcState_fromSizeContentsOperand) =
- make (Field.FromSize, pointerSize, Classes.GCState)
-
- val (_, gcState_frontierContents, gcState_frontierContentsOperand) =
- make (Field.Frontier, pointerSize, Classes.GCStateHold)
-
- val (_, _, gcState_limitContentsOperand) =
- make (Field.Limit, pointerSize, Classes.GCState)
-
- val (_, _, gcState_limitPlusSlopContentsOperand) =
- make (Field.LimitPlusSlop, pointerSize, Classes.GCState)
-
- val (_, _, gcState_maxFrameSizeContentsOperand) =
- make (Field.MaxFrameSize, pointerSize, Classes.GCState)
-
- val (_, _, gcState_signalIsPendingContentsOperand) =
- make (Field.SignalIsPending, wordSize, Classes.GCState)
-
- val (_, gcState_stackBottomContents, gcState_stackBottomContentsOperand) =
- make (Field.StackBottom, pointerSize, Classes.GCState)
-
- val (_, _, gcState_stackLimitContentsOperand) =
- make (Field.StackLimit, pointerSize, Classes.GCState)
-
- val (gcState_stackTop, gcState_stackTopContents,
- gcState_stackTopContentsOperand) =
- make (Field.StackTop, pointerSize, Classes.GCStateHold)
-
- local
- fun make (contents, class) () =
- Operand.memloc (MemLoc.simple {base = contents (),
- index = Immediate.const_int 0,
- scale = wordScale,
- size = pointerSize,
- class = class})
- in
- val gcState_frontierDerefOperand =
- make (gcState_frontierContents, Classes.Heap)
- val gcState_stackTopDerefOperand =
- make (gcState_stackTopContents, Classes.Stack)
- end
-
-
- fun gcState_stackTopMinusWordDeref () =
- MemLoc.simple {base = gcState_stackTopContents (),
- index = Immediate.const_int ~1,
- scale = wordScale,
- size = pointerSize,
- class = Classes.Stack}
- fun gcState_stackTopMinusWordDerefOperand () =
- Operand.memloc (gcState_stackTopMinusWordDeref ())
-
- fun gcState_currentThread_exnStackContents () =
- MemLoc.simple {base = gcState_currentThreadContents (),
- index = Immediate.const_int 0,
- size = pointerSize,
- scale = wordScale,
- class = Classes.Heap}
- fun gcState_currentThread_exnStackContentsOperand () =
- Operand.memloc (gcState_currentThread_exnStackContents ())
- fun gcState_currentThread_stackContents () =
- MemLoc.simple {base = gcState_currentThreadContents (),
- index = Immediate.const_int 2,
- size = pointerSize,
- scale = wordScale,
- class = Classes.Heap}
- fun gcState_currentThread_stackContentsOperand () =
- Operand.memloc (gcState_currentThread_stackContents ())
- fun gcState_currentThread_stack_reservedContents () =
- MemLoc.simple {base = gcState_currentThread_stackContents (),
- index = Immediate.const_int 0,
- size = pointerSize,
- scale = wordScale,
- class = Classes.ThreadStack}
- fun gcState_currentThread_stack_reservedContentsOperand () =
- Operand.memloc (gcState_currentThread_stack_reservedContents ())
- fun gcState_currentThread_stack_usedContents () =
- MemLoc.simple {base = gcState_currentThread_stackContents (),
- index = Immediate.const_int 1,
- size = pointerSize,
- scale = wordScale,
- class = Classes.ThreadStack}
- fun gcState_currentThread_stack_usedContentsOperand () =
- Operand.memloc (gcState_currentThread_stack_usedContents ())
-
- (*
- * GC related constants and functions
- *)
- val WORD_SIZE = Runtime.wordSize
- val POINTER_SIZE = Runtime.pointerSize
- val GC_OBJECT_HEADER_SIZE = Runtime.objectHeaderSize
- val GC_ARRAY_HEADER_SIZE = Runtime.arrayHeaderSize
-
- fun gcObjectHeader {nonPointers, pointers} =
- Immediate.const_word (Runtime.objectHeader
- {numPointers = pointers,
- numWordsNonPointers = nonPointers})
-
- fun gcArrayHeader {nonPointers, pointers} =
- Immediate.const_word (Runtime.arrayHeader
- {numBytesNonPointers = nonPointers,
- numPointers = pointers})
- (* init *)
- fun init () = let
- val _ = Classes.initClasses ()
- in
- ()
- end
-end
-
-functor x86MLton(S: X86_MLTON_STRUCTS): X86_MLTON =
-struct
-
- open S
- open x86MLtonBasic
- open x86
-
type transInfo = {addData : x86.Assembly.t list -> unit,
frameLayouts: x86.Label.t ->
{size: int,
@@ -524,39 +26,6 @@
live: x86.Label.t -> x86.Operand.t list,
liveInfo: x86Liveness.LiveInfo.t}
- fun applyFF {target : Label.t,
- args : (Operand.t * Size.t) list,
- dst : (Operand.t * Size.t) option,
- live : Operand.t list,
- transInfo as {liveInfo, ...} : transInfo}
- = let
- val return = Label.newString "creturn"
- val _ = x86Liveness.LiveInfo.setLiveOperands
- (liveInfo, return, live)
-
- val (comment_begin,
- comment_end)
- = if !Control.Native.commented > 0
- then ([x86.Assembly.comment "begin applyFF"],
- [x86.Assembly.comment "end applyFF"])
- else ([],[])
- in
- AppendList.fromList
- [Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = comment_begin,
- transfer = SOME (Transfer.ccall {target = target,
- args = args,
- return = return,
- dstsize = Option.map (dst, #2)})},
- Block.T'
- {entry = SOME (Entry.creturn {label = return, dst = dst}),
- profileInfo = ProfileInfo.none,
- statements = comment_end,
- transfer = NONE}]
- end
-
fun prim {prim : Prim.t,
args : (Operand.t * Size.t) vector,
dst : (Operand.t * Size.t) option,
@@ -1239,83 +708,8 @@
in
AppendList.appends
[comment_begin,
- (case Prim.name prim
- of Array_allocate
- => let
- val (dst,dstsize) = getDst ()
- val _
- = Assert.assert
- ("applyPrim: AllocateArray, dstsize",
- fn () => dstsize = pointerSize)
-
- val ((numElts, numEltsSize),
- (numBytes, numBytesSize),
- (header, headerSize)) = getSrc3 ()
-
- val _
- = Assert.assert
- ("applyPrim: AllocateArray, numEltsSize",
- fn () => numEltsSize = wordSize)
- val _
- = Assert.assert
- ("applyPrim: AllocateArray, numBytesSize",
- fn () => numBytesSize = wordSize)
- val _
- = Assert.assert
- ("applyPrim: AllocateArray, headerSize",
- fn () => headerSize = wordSize)
-
- val frontier = gcState_frontierContentsOperand ()
- val frontierDeref = gcState_frontierDerefOperand ()
- val frontierOffset
- = let
- val memloc
- = MemLoc.simple
- {base = gcState_frontierContents (),
- index = Immediate.const_int 1,
- scale = wordScale,
- size = pointerSize,
- class = Classes.Heap}
- in
- Operand.memloc memloc
- end
- val frontierPlusAHW
- = (Operand.memloc o MemLoc.simple)
- {base = gcState_frontierContents (),
- index = Immediate.const_int arrayHeaderBytes,
- scale = Scale.One,
- size = pointerSize,
- class = Classes.Heap}
- val statements =
- [(* *(frontier) = numElts *)
- Assembly.instruction_mov
- {dst = frontierDeref,
- src = numElts,
- size = wordSize},
- (* *(frontier + wordSize) = header *)
- Assembly.instruction_mov
- {dst = frontierOffset,
- src = header,
- size = wordSize},
- (* dst = frontier + arrayHeaderSize *)
- Assembly.instruction_lea
- {dst = dst,
- src = frontierPlusAHW,
- size = pointerSize},
- (* frontier = frontier + numBytes *)
- Assembly.instruction_binal
- {oper = Instruction.ADD,
- dst = frontier,
- src = numBytes,
- size = pointerSize}]
- in
- AppendList.single
- (Block.T' {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = statements,
- transfer = NONE})
- end
- | Array_length => lengthArrayVectorString ()
+ (case Prim.name prim of
+ Array_length => lengthArrayVectorString ()
| Byte_byteToChar => mov ()
| Byte_charToByte => mov ()
| C_CS_charArrayToWord8Array => mov ()
@@ -1389,79 +783,6 @@
| Int_ge => cmp Instruction.GE
| Int_gtu => cmp Instruction.A
| Int_geu => cmp Instruction.AE
- | IntInf_isSmall
- => let
- val (dst,dstsize) = getDst ()
- val (src,srcsize) = getSrc1 ()
- val _
- = Assert.assert
- ("applyPrim: IntInf_isSmall, srcsize",
- fn () => srcsize = wordSize)
- in
- AppendList.fromList
- [Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements
- = [Assembly.instruction_mov
- {dst = intInfTempContentsOperand,
- src = src,
- size = srcsize},
- Assembly.instruction_binal
- {oper = Instruction.AND,
- dst = intInfTempContentsOperand,
- src = Operand.immediate_const_word 0wx1,
- size = srcsize},
- Assembly.instruction_cmp
- {src1 = intInfTempContentsOperand,
- src2 = Operand.immediate_const_word 0wx0,
- size = srcsize},
- Assembly.instruction_setcc
- {condition = Instruction.NE,
- dst = dst,
- size = dstsize}],
- transfer = NONE}]
- end
- | IntInf_areSmall
- => let
- val (dst,dstsize) = getDst ()
- val ((src1,src1size),
- (src2,src2size)) = getSrc2 ()
- val _
- = Assert.assert
- ("applyPrim: IntInf_areSmall, src1size/src2size",
- fn () => src1size = wordSize andalso
- src2size = wordSize)
- in
- AppendList.fromList
- [Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements
- = [Assembly.instruction_mov
- {dst = intInfTempContentsOperand,
- src = src1,
- size = src1size},
- Assembly.instruction_binal
- {oper = Instruction.AND,
- dst = intInfTempContentsOperand,
- src = src2,
- size = src2size},
- Assembly.instruction_binal
- {oper = Instruction.AND,
- dst = intInfTempContentsOperand,
- src = Operand.immediate_const_word 0wx1,
- size = src1size},
- Assembly.instruction_cmp
- {src1 = intInfTempContentsOperand,
- src2 = Operand.immediate_const_word 0wx0,
- size = src1size},
- Assembly.instruction_setcc
- {condition = Instruction.NE,
- dst = dst,
- size = dstsize}],
- transfer = NONE}]
- end
| IntInf_fromVector => mov ()
| IntInf_toVector => mov ()
| IntInf_fromWord => mov ()
@@ -2063,297 +1384,51 @@
comment_end]
end
- fun ccall {prim : Prim.t,
- args : (Operand.t * Size.t) vector,
- return : Label.t,
- dstsize : Size.t option,
- transInfo as {...} : transInfo}
+ fun ccall {args: (x86.Operand.t * x86.Size.t) vector,
+ frameInfo,
+ func as CFunction.T {name, returnTy, ...},
+ return: x86.Label.t option,
+ transInfo: transInfo}
= let
- val primName = Prim.toString prim
- datatype z = datatype Prim.Name.t
-
- fun getDstsize ()
- = case dstsize
- of SOME dstsize => dstsize
- | NONE => Error.bug "ccall: getDstsize"
- fun getSrc1 ()
- = Vector.sub (args, 0)
- handle _ => Error.bug "ccall: getSrc1"
- fun getSrc2 ()
- = (Vector.sub (args, 0), Vector.sub (args, 1))
- handle _ => Error.bug "ccall: getSrc2"
- fun getSrc3 ()
- = (Vector.sub (args, 0), Vector.sub (args, 1), Vector.sub (args, 2))
- handle _ => Error.bug "ccall: getSrc3"
-
- fun intInf_comp f
- = let
- val _
- = Assert.assert
- ("ccall: intInf_comp, dstsize",
- fn () => getDstsize () = wordSize)
- val ((src1,src1size),
- (src2,src2size)) = getSrc2 ()
- val _
- = Assert.assert
- ("ccall: intInf_comp, src1size",
- fn () => src1size = pointerSize)
- val _
- = Assert.assert
- ("ccall: intInf_comp, src2size",
- fn () => src2size = pointerSize)
-
- val args = [(src1,src1size), (src2,src2size)]
- in
- AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall {target = Label.fromString f,
- args = args,
- return = return,
- dstsize = dstsize})})
- end
-
- fun intInf_binop f
- = let
- val _
- = Assert.assert
- ("ccall: intInf_binop, dstsize",
- fn () => getDstsize () = pointerSize)
- val ((src1,src1size),
- (src2,src2size),
- (src3,src3size)) = getSrc3 ()
- val _
- = Assert.assert
- ("ccall: intInf_binop, src1size",
- fn () => src1size = pointerSize)
- val _
- = Assert.assert
- ("ccall: intInf_binop, src2size",
- fn () => src2size = pointerSize)
- val _
- = Assert.assert
- ("ccall: intInf_binop, src3size",
- fn () => src3size = pointerSize)
-
- val args = [(src1,src2size),
- (src2,src2size),
- (src3,src3size),
- (gcState_frontierContentsOperand (), pointerSize)]
- in
- AppendList.single
- ((* intInfTemp = f(src1,src2,src3,frontier) *)
- Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall {target = Label.fromString f,
- args = args,
- return = return,
- dstsize = dstsize})})
- end
-
- fun intInf_unop f
- = let
- val _
- = Assert.assert
- ("ccall: intInf_unnop, dstsize",
- fn () => getDstsize () = pointerSize)
- val ((src1,src1size),
- (src2,src2size)) = getSrc2 ()
- val _
- = Assert.assert
- ("ccall: intInf_unnop, src1size",
- fn () => src1size = pointerSize)
- val _
- = Assert.assert
- ("ccall: intInf_unnop, src2size",
- fn () => src2size = pointerSize)
-
- val args = [(src1,src2size),
- (src2,src2size),
- (gcState_frontierContentsOperand (), pointerSize)]
- in
- AppendList.single
- ((* intInfTemp = f(src1,src2,frontier) *)
- Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall {target = Label.fromString f,
- args = args,
- return = return,
- dstsize = dstsize})})
- end
-
- fun real_ff1 f
- = let
- val (src,srcsize) = getSrc1 ()
- val args = [(src,srcsize)]
- in
- AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall {target = Label.fromString f,
- args = args,
- return = return,
- dstsize = dstsize})})
- end
-
- fun real_ff2 f
- = let
- val ((src1,src1size),
- (src2,src2size)) = getSrc2 ()
- val args = [(src1,src1size), (src2,src2size)]
- in
- AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall {target = Label.fromString f,
- args = args,
- return = return,
- dstsize = dstsize})})
- end
-
+ val dstsize = Option.map (returnTy, toX86Size)
val comment_begin
= if !Control.Native.commented > 0
- then let
- val comment = primName
- in
- AppendList.single
- (x86.Block.T'
- {entry = NONE,
- profileInfo = x86.ProfileInfo.none,
- statements
- = [x86.Assembly.comment
- ("begin ccall: " ^ comment)],
- transfer = NONE})
- end
- else AppendList.empty
+ then AppendList.single (x86.Block.T'
+ {entry = NONE,
+ profileInfo = x86.ProfileInfo.none,
+ statements
+ = [x86.Assembly.comment
+ ("begin ccall: " ^ name)],
+ transfer = NONE})
+ else AppendList.empty
in
AppendList.appends
[comment_begin,
- (case Prim.name prim
- of FFI s
- => (case Prim.numArgs prim
- of NONE => Error.bug "ccall: FFI"
- | SOME _
- => AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall
- {target = Label.fromString s,
- args = Vector.toList args,
- return = return,
- dstsize = dstsize})}))
- | IntInf_compare => intInf_comp "IntInf_compare"
- | IntInf_equal => intInf_comp "IntInf_equal"
- | IntInf_add => intInf_binop "IntInf_do_add"
- | IntInf_gcd => intInf_binop "IntInf_do_gcd"
- | IntInf_mul => intInf_binop "IntInf_do_mul"
- | IntInf_quot => intInf_binop "IntInf_do_quot"
- | IntInf_rem => intInf_binop "IntInf_do_rem"
- | IntInf_sub => intInf_binop "IntInf_do_sub"
- | IntInf_neg => intInf_unop "IntInf_do_neg"
- | IntInf_toString
- => let
- val _
- = Assert.assert
- ("ccall: IntInf_toString, dstsize",
- fn () => getDstsize () = pointerSize)
- val ((src1,src1size),
- (src2,src2size),
- (src3,src3size)) = getSrc3 ()
- val _
- = Assert.assert
- ("ccall: IntInf_toString, src1size/src2size/src3size",
- fn () => src1size = pointerSize andalso
- src2size = wordSize andalso
- src3size = wordSize)
-
- val args = [(src1,src2size),
- (src2,src2size),
- (src3,src3size),
- (gcState_frontierContentsOperand (), pointerSize)]
- in
- AppendList.single
- ((* intInfTemp
- * = IntInf_do_toString(src1,src2,src3,frontier)
- *)
- Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall
- {target = Label.fromString "IntInf_do_toString",
- args = args,
- return = return,
- dstsize = dstsize})})
- end
- | MLton_bug
- => AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall
- {target = Label.fromString "MLton_bug",
- args = Vector.toList args,
- return = return,
- dstsize = dstsize})})
- | MLton_size
- => AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall
- {target = Label.fromString "MLton_size",
- args = Vector.toList args,
- return = return,
- dstsize = dstsize})})
- | Real_Math_cosh => real_ff1 "cosh"
- | Real_Math_pow => real_ff2 "pow"
- | Real_Math_sinh => real_ff1 "sinh"
- | Real_Math_tanh => real_ff1 "tanh"
- | Real_copysign => real_ff2 "copysign"
- | Real_frexp => real_ff2 "frexp"
- | Real_modf => real_ff2 "modf"
- | String_equal
- => AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.ccall
- {target = Label.fromString "String_equal",
- args = Vector.toList args,
- return = return,
- dstsize = dstsize})})
- | _ => Error.bug ("ccall: strange Prim.Name.t: " ^ primName))]
+ AppendList.single
+ (Block.T'
+ {entry = NONE,
+ profileInfo = ProfileInfo.none,
+ statements = [],
+ transfer = SOME (Transfer.ccall
+ {args = Vector.toList args,
+ dstsize = dstsize,
+ frameInfo = frameInfo,
+ func = func,
+ return = return,
+ target = Label.fromString name})})]
end
- fun creturn {prim : Prim.t,
- label : Label.t,
- dst : (Operand.t * Size.t) option,
- transInfo as {liveInfo, live, ...} : transInfo}
+ fun creturn {dst: (x86.Operand.t * x86.Size.t) option,
+ frameInfo: x86.FrameInfo.t option,
+ func: CFunction.t,
+ label: x86.Label.t,
+ transInfo as {live, liveInfo, ...}: transInfo}
= let
- val primName = Prim.toString prim
- datatype z = datatype Prim.Name.t
-
+ 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
@@ -2361,318 +1436,28 @@
in
AppendList.single
(x86.Block.T'
- {entry = SOME (Entry.creturn {label = label,
- dst = dst}),
+ {entry = SOME (Entry.creturn {dst = dst,
+ frameInfo = frameInfo,
+ func = func,
+ label = label}),
profileInfo = ProfileInfo.none,
statements = [],
transfer = NONE})
end
-
- fun intInf ()
- = let
- val (dst,dstsize) = getDst ()
-
- val _ = x86Liveness.LiveInfo.setLiveOperands
- (liveInfo, label, live label)
- in
- AppendList.single
- (Block.T'
- {entry = SOME (Entry.creturn
- {label = label,
- dst = SOME (intInfTempContentsOperand,
- pointerSize)}),
- profileInfo = ProfileInfo.none,
- statements
- = [(* gcState.frontier = intInfTemp->frontier *)
- Assembly.instruction_mov
- {dst = gcState_frontierContentsOperand (),
- src = intInfTempFrontierContentsOperand,
- size = pointerSize},
- (* dst = intInfTemp->value *)
- Assembly.instruction_mov
- {dst = dst,
- src = intInfTempValueContentsOperand,
- size = dstsize}],
- transfer = NONE})
- end
-
val comment_end
= if !Control.Native.commented > 0
- then let
- val comment = primName
- in
- AppendList.single
- (x86.Block.T'
- {entry = NONE,
- profileInfo = x86.ProfileInfo.none,
- statements
- = [x86.Assembly.comment
- ("end creturn: " ^ comment)],
- transfer = NONE})
- end
- else AppendList.empty
- in
- AppendList.appends
- [(case Prim.name prim
- of FFI s
- => (case Prim.numArgs prim
- of NONE => Error.bug "ccall: FFI"
- | SOME _ => default ())
- | IntInf_compare => default ()
- | IntInf_equal => default ()
- | IntInf_add => intInf ()
- | IntInf_gcd => intInf ()
- | IntInf_sub => intInf ()
- | IntInf_mul => intInf ()
- | IntInf_quot => intInf ()
- | IntInf_rem => intInf ()
- | IntInf_neg => intInf ()
- | IntInf_toString => intInf ()
- | MLton_bug => default ()
- | MLton_size => default ()
- | Real_Math_cosh => default ()
- | Real_Math_pow => default ()
- | Real_Math_sinh => default ()
- | Real_Math_tanh => default ()
- | Real_copysign => default ()
- | Real_frexp => default ()
- | Real_modf => default ()
- | String_equal => default ()
- | _ => Error.bug ("creturn: strange Prim.Name.t: " ^ primName)),
- comment_end]
- end
-
- fun runtimecall {prim : Prim.t,
- args : (Operand.t * Size.t) vector,
- return : Label.t,
- transInfo as {frameLayouts, ...} : transInfo}
- = let
- val primName = Prim.toString prim
- datatype z = datatype Prim.Name.t
-
- fun getSrc1 ()
- = Vector.sub (args, 0)
- handle _ => Error.bug "runtimecall: getSrc1"
- fun getSrc2 ()
- = (Vector.sub (args, 0), Vector.sub (args, 1))
- handle _ => Error.bug "runtimecall: getSrc2"
- fun getSrc3 ()
- = (Vector.sub (args, 0), Vector.sub (args, 1), Vector.sub (args, 2))
- handle _ => Error.bug "runtimecall: getSrc3"
-
- val frameSize = case frameLayouts return
- of NONE => Error.bug "runtimecall: framesize"
- | SOME {size, ...} => size
-
- fun thread ()
- = let
- val (thread,threadsize) = getSrc1 ()
- val _
- = Assert.assert
- ("runtimecall: thread",
- fn () => threadsize = pointerSize)
- in
- AppendList.single
- ((* thread might be of the form SX(?),
- * and invoke runtime will change the stackTop,
- * so copy the thread to a local location.
- *)
- Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements
- = [Assembly.instruction_mov
- {dst = threadTempContentsOperand,
- src = thread,
- size = threadsize}],
- transfer
- = SOME (Transfer.runtime
- {prim = prim,
- args = [(Operand.immediate_label gcState, pointerSize),
- (threadTempContentsOperand, threadsize)],
- return = return,
- size = frameSize})})
- end
-
- fun thread_copyCurrent ()
- = let
- in
- AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer
- = SOME (Transfer.runtime
- {prim = prim,
- args = [(Operand.immediate_label gcState, pointerSize)],
- return = return,
- size = frameSize})})
- end
-
- val comment_begin
- = if !Control.Native.commented > 0
- then let
- val comment = primName
- in
- AppendList.single
- (x86.Block.T'
- {entry = NONE,
- profileInfo = x86.ProfileInfo.none,
- statements
- = [x86.Assembly.comment
- ("begin runtimecall: " ^ comment)],
- transfer = NONE})
- end
- else AppendList.empty
+ then (AppendList.single
+ (x86.Block.T' {entry = NONE,
+ profileInfo = x86.ProfileInfo.none,
+ statements
+ = [x86.Assembly.comment
+ ("end creturn: " ^ name)],
+ transfer = NONE}))
+ else AppendList.empty
in
- AppendList.appends
- [comment_begin,
- (case Prim.name prim
- of GC_collect
- => let
- val ((amount,amountsize),
- (force,forcesize)) = getSrc2 ()
- val _
- = Assert.assert
- ("runtimecall: GC_collect, amountsize",
- fn () => amountsize = wordSize)
- val _
- = Assert.assert
- ("runtimecall: GC_collect, forcesize",
- fn () => forcesize = wordSize)
- in
- AppendList.single
- (Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer
- = SOME (Transfer.runtime
- {prim = prim,
- args = [(Operand.immediate_label gcState, pointerSize),
- (amount,amountsize),
- (force,forcesize),
- (fileName, pointerSize),
- (fileLine (), wordSize)],
- return = return,
- size = frameSize})})
- end
- | MLton_halt
- => let
- val (status,statussize) = getSrc1 ()
- val _
- = Assert.assert
- ("runtimecall: MLton_halt, statussize",
- fn () => statussize = wordSize)
- in
- AppendList.single
- ((* status might be of the form SX(?),
- * and invoke runtime will change the stackTop,
- * so copy the status to a local location.
- *)
- Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements
- = [Assembly.instruction_mov
- {dst = statusTempContentsOperand,
- src = status,
- size = statussize}],
- transfer
- = SOME (Transfer.runtime
- {prim = prim,
- args = [(statusTempContentsOperand, statussize)],
- return = return,
- size = frameSize})})
- end
- | Thread_copy => thread ()
- | Thread_copyCurrent => thread_copyCurrent ()
- | Thread_switchTo => thread ()
- | World_save
- => let
- val (file,filesize) = getSrc1 ()
- val _
- = Assert.assert
- ("runtimecall: World_save, filesize",
- fn () => filesize = pointerSize)
- in
- AppendList.single
- ((* file might be of the form SX(?),
- * and invoke runtime will change the stackTop,
- * so copy the file to a local location.
- *)
- Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements
- = [Assembly.instruction_mov
- {dst = fileTempContentsOperand,
- src = file,
- size = filesize}],
- transfer
- = SOME (Transfer.runtime
- {prim = prim,
- args = [(Operand.immediate_label gcState, pointerSize),
- (fileTempContentsOperand, filesize),
- (Operand.immediate_label saveGlobals,
- pointerSize)],
- return = return,
- size = frameSize})})
- end
- | _ => Error.bug ("runtimecall: strange Prim.Name.t: " ^ primName))]
+ AppendList.appends [default (), comment_end]
end
- fun runtimereturn {prim : Machine.Prim.t,
- label : Label.t,
- frameInfo : Entry.FrameInfo.t,
- transInfo as {frameLayouts, live, liveInfo, ...} : transInfo}
- = let
- val primName = Prim.toString prim
- datatype z = datatype Prim.Name.t
-
- fun default ()
- = let
- val _ = x86Liveness.LiveInfo.setLiveOperands
- (liveInfo, label, live label)
- in
- AppendList.single
- (x86.Block.T'
- {entry = SOME (Entry.runtime {label = label,
- frameInfo = frameInfo}),
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = NONE})
- end
-
- val comment_end
- = if !Control.Native.commented > 0
- then let
- val comment = primName
- in
- AppendList.single
- (x86.Block.T'
- {entry = NONE,
- profileInfo = x86.ProfileInfo.none,
- statements
- = [x86.Assembly.comment
- ("end runtimereturn: " ^ comment)],
- transfer = NONE})
- end
- else AppendList.empty
- in
- AppendList.appends
- [(case Prim.name prim
- of GC_collect => default ()
- | MLton_halt => default ()
- | Thread_copy => default ()
- | Thread_copyCurrent => default ()
- | Thread_switchTo => default ()
- | World_save => default ()
- | _ => Error.bug ("runtimereturn: strange Prim.Name.t: " ^ primName)),
- comment_end]
- end
-
fun arith {prim : Prim.t,
args : (Operand.t * Size.t) vector,
dst : (Operand.t * Size.t),
@@ -2839,36 +1624,4 @@
| _ => Error.bug ("arith: strange Prim.Name.t: " ^ primName))]
end
- val bug_msg_label = Label.fromString "MLton_bug_msg"
- fun bug {transInfo as {addData, frameLayouts, live, liveInfo, ...} : transInfo}
- = let
- val bugLabel = Label.newString "bug"
- val _ = x86Liveness.LiveInfo.setLiveOperands
- (liveInfo, bugLabel, [])
- in
- AppendList.appends
- [AppendList.fromList
- [Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.goto {target = bugLabel})},
- Block.T'
- {entry = SOME (Entry.jump {label = bugLabel}),
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = NONE}],
- (applyFF {target = Label.fromString "MLton_bug",
- args = [(Operand.label bug_msg_label,
- pointerSize)],
- dst = NONE,
- live = [],
- transInfo = transInfo}),
- AppendList.fromList
- [Block.T'
- {entry = NONE,
- profileInfo = ProfileInfo.none,
- statements = [],
- transfer = SOME (Transfer.goto {target = bugLabel})}]]
- end
end
1.13 +20 -34 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.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- x86-mlton.sig 10 Apr 2002 07:02:19 -0000 1.12
+++ x86-mlton.sig 6 Jul 2002 17:22:06 -0000 1.13
@@ -30,39 +30,25 @@
live: x86.Label.t -> x86.Operand.t list,
liveInfo: x86Liveness.LiveInfo.t}
- (* bug, runtime and primitive Assembly sequences. *)
- val creturn : {prim : Machine.Prim.t,
- label : x86.Label.t,
- dst : (x86.Operand.t * x86.Size.t) option,
- transInfo : transInfo}
- -> x86.Block.t' AppendList.t
- val runtimereturn : {prim : Machine.Prim.t,
- label : x86.Label.t,
- frameInfo : x86.Entry.FrameInfo.t,
- transInfo : transInfo}
- -> x86.Block.t' AppendList.t
- val prim : {prim : Machine.Prim.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) option,
- transInfo : transInfo}
- -> x86.Block.t' AppendList.t
- 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,
- transInfo : transInfo}
- -> x86.Block.t' AppendList.t
- val bug : {transInfo: transInfo} -> x86.Block.t' AppendList.t
- val ccall : {prim : Machine.Prim.t,
- args : (x86.Operand.t * x86.Size.t) vector,
- return : x86.Label.t,
- dstsize : x86.Size.t option,
- transInfo : transInfo}
- -> x86.Block.t' AppendList.t
- val runtimecall : {prim : Machine.Prim.t,
- args : (x86.Operand.t * x86.Size.t) vector,
- return : x86.Label.t,
- transInfo : transInfo}
- -> x86.Block.t' AppendList.t
+ dst : (x86.Operand.t * x86.Size.t),
+ 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,
+ 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
end
1.11 +29 -31 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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-pseudo.sig 10 Apr 2002 07:02:19 -0000 1.10
+++ x86-pseudo.sig 6 Jul 2002 17:22:06 -0000 1.11
@@ -11,7 +11,7 @@
signature X86_PSEUDO =
sig
structure Label : HASH_ID
- structure Prim : PRIM
+ structure Runtime: RUNTIME
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
@@ -378,31 +378,31 @@
check: bool} -> t
end
- structure Entry :
- sig
- structure FrameInfo :
- sig
- type t
- val frameInfo : {size: int,
- frameLayoutsIndex: int} -> t
- end
+ structure FrameInfo:
+ sig
+ type t
+ val frameInfo : {size: int,
+ frameLayoutsIndex: int} -> t
+ end
+ structure Entry:
+ sig
type t
- val label : t -> Label.t
- val jump : {label: Label.t} -> t
- val func : {label: Label.t,
- live: MemLocSet.t} -> t
- val cont : {label: Label.t,
- live: MemLocSet.t,
- frameInfo: FrameInfo.t} -> t
- val handler : {label: Label.t,
- live: MemLocSet.t,
- offset: int} -> t
- val runtime : {label: Label.t,
- frameInfo: FrameInfo.t} -> t
- val creturn : {label: Label.t,
- dst: (Operand.t * Size.t) option} -> t
+ val cont: {label: Label.t,
+ live: MemLocSet.t,
+ frameInfo: FrameInfo.t} -> t
+ val creturn: {dst: (Operand.t * Size.t) option,
+ frameInfo: FrameInfo.t option,
+ func: Runtime.CFunction.t,
+ label: Label.t} -> t
+ val func: {label: Label.t,
+ live: MemLocSet.t} -> t
+ val handler: {label: Label.t,
+ live: MemLocSet.t,
+ offset: int} -> t
+ val jump: {label: Label.t} -> t
+ val label: t -> Label.t
end
structure ProfileInfo :
@@ -441,14 +441,12 @@
size: int} -> t
val return : {live: MemLocSet.t} -> t
val raisee : {live: MemLocSet.t} -> t
- val runtime : {prim: Prim.t,
- args: (Operand.t * Size.t) list,
- return: Label.t,
- size: int} -> t
- val ccall : {target: Label.t,
- args: (Operand.t * Size.t) list,
- return: Label.t,
- dstsize: Size.t option} -> t
+ val ccall : {args: (Operand.t * Size.t) list,
+ dstsize: Size.t option,
+ frameInfo: FrameInfo.t option,
+ func: Runtime.CFunction.t,
+ return: Label.t option,
+ target: Label.t} -> t
end
structure Block :
1.21 +8 -5 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.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- x86-simplify.fun 10 Apr 2002 07:02:19 -0000 1.20
+++ x86-simplify.fun 6 Jul 2002 17:22:06 -0000 1.21
@@ -2511,11 +2511,14 @@
(cases,
fn target => update target),
default = update default}
- | Transfer.CCall {target, args, return, dstsize}
- => Transfer.CCall {target = target,
- args = args,
- return = update return,
- dstsize = dstsize}
+ | 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.25 +39 -85 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.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- x86-translate.fun 23 Jun 2002 01:37:54 -0000 1.24
+++ x86-translate.fun 6 Jul 2002 17:22:06 -0000 1.25
@@ -26,6 +26,7 @@
structure Label = Machine.Label
structure Prim = Machine.Prim
+ structure Runtime = Machine.Runtime
structure Type =
struct
@@ -95,14 +96,19 @@
=> x86.Operand.immediate_const_word w
| IntInf ii
=> x86.Operand.immediate_const_word ii
+ | File => x86MLton.fileLine ()
| Float f
- => Error.bug "toX86Operand: Float, unimplemented"
+ => Error.bug "toX86Operand: Float, unimplemented"
+ | GCState => x86.Operand.label x86MLton.gcState_label
| Pointer i
=> x86.Operand.immediate_const_int i
| Label l
=> x86.Operand.immediate_label l
+ | Line => x86MLton.fileLine ()
| CastInt p
=> toX86Operand p
+ | CastWord p
+ => toX86Operand p
| Register l
=> x86.Operand.memloc (Local.toX86MemLoc l)
| Global g
@@ -123,7 +129,7 @@
end
| Runtime oper
=> let
- datatype z = datatype Machine.RuntimeOperand.t
+ datatype z = datatype Machine.Runtime.GCField.t
open x86MLton
in
case oper of
@@ -236,28 +242,13 @@
type transInfo = x86MLton.transInfo
+ fun toX86FrameInfo {label,
+ transInfo as {frameLayouts, ...} : transInfo} =
+ Option.map (frameLayouts label, x86.FrameInfo.frameInfo)
+
structure Entry =
struct
structure Kind = Machine.Kind
-
- structure FrameInfo =
- struct
- fun toX86FrameInfo {label,
- frameInfo = Machine.FrameInfo.T {size = size', ...},
- transInfo as {frameLayouts, ...} : transInfo}
- = case frameLayouts label
- of NONE => Error.bug "toX86FrameInfo: label"
- | SOME {size, frameLayoutsIndex}
- => let
- val _ = Assert.assert
- ("toX86FrameInfo: size",
- fn () => size = size')
- in
- x86.Entry.FrameInfo.frameInfo
- {size = size,
- frameLayoutsIndex = frameLayoutsIndex}
- end
- end
fun toX86Blocks {label, kind,
transInfo as {frameLayouts, live, liveInfo, ...} : transInfo}
@@ -295,11 +286,11 @@
statements = [],
transfer = NONE})
end
- | Kind.Cont {args, frameInfo}
+ | Kind.Cont {args, ...}
=> let
- val frameInfo = FrameInfo.toX86FrameInfo {label = label,
- frameInfo = frameInfo,
- transInfo = transInfo}
+ val frameInfo =
+ valOf (toX86FrameInfo {label = label,
+ transInfo = transInfo})
val args
= Vector.fold
(args,
@@ -331,7 +322,7 @@
statements = [],
transfer = NONE})
end
- | Kind.CReturn {prim, dst}
+ | Kind.CReturn {dst, frameInfo, func}
=> let
fun convert x
= (Operand.toX86Operand x,
@@ -339,21 +330,11 @@
val dst = Option.map (dst, convert)
in
x86MLton.creturn
- {prim = prim,
- label = label,
- dst = dst,
- transInfo = transInfo}
- end
- | Kind.Runtime {frameInfo, prim}
- => let
- val frameInfo = FrameInfo.toX86FrameInfo {label = label,
- frameInfo = frameInfo,
- transInfo = transInfo}
- in
- x86MLton.runtimereturn
- {prim = prim,
+ {dst = dst,
+ frameInfo = toX86FrameInfo {label = label,
+ transInfo = transInfo},
+ func = func,
label = label,
- frameInfo = frameInfo,
transInfo = transInfo}
end)
end
@@ -558,7 +539,7 @@
transfer = NONE}),
comment_end]
end
- | Object {dst, stores, numPointers, numWordsNonPointers}
+ | Object {dst, header, size, stores}
=> let
val (comment_begin,
comment_end) = comments statement
@@ -583,11 +564,6 @@
size = x86MLton.pointerSize,
class = x86MLton.Classes.Heap}
- val gcObjectHeaderWord
- = (x86.Operand.immediate o x86MLton.gcObjectHeader)
- {nonPointers = numWordsNonPointers,
- pointers = numPointers}
-
fun stores_toX86Assembly ({offset, value}, l)
= let
val size = x86MLton.toX86Size (Operand.ty value)
@@ -627,13 +603,11 @@
{entry = NONE,
profileInfo = x86.ProfileInfo.none,
statements
- = ((* *(frontier)
- * = gcObjectHeader(numWordsNonPointers,
- * numPointers)
- *)
+ = ((* *(frontier) = header *)
x86.Assembly.instruction_mov
{dst = frontierDeref,
- src = gcObjectHeaderWord,
+ src = (x86.Operand.immediate
+ (x86.Immediate.const_word header)),
size = x86MLton.pointerSize})::
((* dst = frontier + objectHeaderSize *)
x86.Assembly.instruction_lea
@@ -645,12 +619,8 @@
x86.Assembly.instruction_binal
{oper = x86.Instruction.ADD,
dst = frontier,
- src = x86.Operand.immediate_const_int
- (objectHeaderBytes
- + (Runtime.objectSize
- {numPointers = numPointers,
- numWordsNonPointers =
- numWordsNonPointers})),
+ src = (x86.Operand.immediate_const_int
+ size),
size = x86MLton.pointerSize}],
stores_toX86Assembly)),
(*
@@ -865,41 +835,25 @@
success = success,
transInfo = transInfo})
end
- | Bug
- => AppendList.append
- (comments transfer,
- x86MLton.bug {transInfo = transInfo})
- | CCall {args, prim, return, returnTy}
+ | CCall {args, frameInfo, func, return}
=> let
fun convert x
= (Operand.toX86Operand x,
x86MLton.toX86Size (Operand.ty x))
- val args = Vector.map(args, convert)
- val dstsize = Option.map (returnTy, x86MLton.toX86Size)
+ val args = Vector.map (args, convert)
in
AppendList.append
(comments transfer,
- x86MLton.ccall
- {prim = prim,
- args = args,
- return = return,
- dstsize = dstsize,
- transInfo = transInfo})
- end
- | Runtime {args, prim, return}
- => let
- fun convert x
- = (Operand.toX86Operand x,
- x86MLton.toX86Size (Operand.ty x))
- val args = Vector.map(args, convert)
- in
- AppendList.append
- (comments transfer,
- x86MLton.runtimecall
- {prim = prim,
- args = args,
- return = return,
- transInfo = transInfo})
+ x86MLton.ccall {args = args,
+ frameInfo = (case return of
+ NONE => NONE
+ | SOME l =>
+ toX86FrameInfo
+ {label = l,
+ transInfo = transInfo}),
+ func = func,
+ return = return,
+ transInfo = transInfo})
end
| Return {live}
=> AppendList.append
1.28 +50 -71 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.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- x86.fun 10 Apr 2002 07:02:20 -0000 1.27
+++ x86.fun 6 Jul 2002 17:22:06 -0000 1.28
@@ -43,6 +43,12 @@
open S
+ local
+ open Runtime
+ in
+ structure CFunction = CFunction
+ end
+
structure Label =
struct
open Label
@@ -3537,24 +3543,23 @@
val instruction_fbinasp = Instruction o Instruction.fbinasp
end
- structure Entry =
- struct
- structure FrameInfo =
- struct
- datatype t = T of {size: int,
- frameLayoutsIndex: int}
-
- fun toString (T {size, frameLayoutsIndex})
- = concat ["{",
- "size = ", Int.toString size, ", ",
- "frameLayoutsIndex = ",
- Int.toString frameLayoutsIndex, "}"]
- val layout = Layout.str o toString
+ structure FrameInfo =
+ struct
+ datatype t = T of {size: int,
+ frameLayoutsIndex: int}
- val frameInfo = T
- end
+ fun toString (T {size, frameLayoutsIndex})
+ = concat ["{",
+ "size = ", Int.toString size, ", ",
+ "frameLayoutsIndex = ",
+ Int.toString frameLayoutsIndex, "}"]
+ val layout = Layout.str o toString
+ val frameInfo = T
+ end
+ structure Entry =
+ struct
datatype t
= Jump of {label: Label.t}
| Func of {label: Label.t,
@@ -3565,10 +3570,10 @@
| Handler of {label: Label.t,
live: MemLocSet.t,
offset: int}
- | Runtime of {label: Label.t,
- frameInfo: FrameInfo.t}
- | CReturn of {label: Label.t,
- dst: (Operand.t * Size.t) option}
+ | CReturn of {dst: (Operand.t * Size.t) option,
+ frameInfo: FrameInfo.t option,
+ func: CFunction.t,
+ label: Label.t}
val toString
= fn Jump {label} => concat ["Jump::",
@@ -3609,18 +3614,19 @@
"] (",
Int.toString offset,
")"]
- | Runtime {label, frameInfo}
- => concat ["Runtime::",
- Label.toString label,
- " ",
- FrameInfo.toString frameInfo]
- | CReturn {label, dst}
+ | CReturn {dst, frameInfo, func, label}
=> concat ["CReturn::",
Label.toString label,
" ",
case dst
- of SOME (dst,dstsize) => Operand.toString dst
- | NONE => ""]
+ of SOME (dst, _) => Operand.toString dst
+ | NONE => "",
+ " ",
+ CFunction.name func,
+ " ",
+ case frameInfo of
+ NONE => ""
+ | SOME f => FrameInfo.toString f]
val layout = Layout.str o toString
val uses_defs_kills
@@ -3633,7 +3639,6 @@
| Func {label, ...} => label
| Cont {label, ...} => label
| Handler {label, ...} => label
- | Runtime {label, ...} => label
| CReturn {label, ...} => label
val live
@@ -3647,7 +3652,6 @@
val isFunc = fn Func _ => true | _ => false
val cont = Cont
val handler = Handler
- val runtime = Runtime
val creturn = CReturn
val isNear = fn Jump _ => true
@@ -3900,14 +3904,12 @@
size: int}
| Return of {live: MemLocSet.t}
| Raise of {live: MemLocSet.t}
- | Runtime of {prim: Prim.t,
- args: (Operand.t * Size.t) list,
- return: Label.t,
- size: int}
- | CCall of {target: Label.t,
- args: (Operand.t * Size.t) list,
- return: Label.t,
- dstsize: Size.t option}
+ | CCall of {args: (Operand.t * Size.t) list,
+ dstsize: Size.t option,
+ frameInfo: FrameInfo.t option,
+ func: CFunction.t,
+ return: Label.t option,
+ target: Label.t}
val toString
= fn Goto {target}
@@ -3985,19 +3987,7 @@
fn (memloc, l) => (MemLoc.toString memloc)::l),
", "),
"]"]
- | Runtime {prim, args, return, size}
- => concat ["RUNTIME ",
- Prim.toString prim,
- "(",
- (concat o List.separate)
- (List.map(args, fn (oper,_) => Operand.toString oper),
- ", "),
- ") <",
- Label.toString return,
- " ",
- Int.toString size,
- ">"]
- | CCall {target, args, return, dstsize}
+ | CCall {args, dstsize, frameInfo, func, return, target}
=> concat ["CCALL ",
Label.toString target,
"(",
@@ -4005,17 +3995,13 @@
(List.map(args, fn (oper,_) => Operand.toString oper),
", "),
") <",
- Label.toString return,
+ Option.toString Label.toString return,
">"]
val layout = Layout.str o toString
val uses_defs_kills
= fn Switch {test, cases, default}
=> {uses = [test], defs = [], kills = []}
- | Runtime {args, ...}
- => {uses = List.map(args, fn (oper,_) => oper),
- defs = [],
- kills = []}
| CCall {args, ...}
=> {uses = List.map(args, fn (oper,_) => oper),
defs = [],
@@ -4035,8 +4021,9 @@
| NonTail {return,handler,...} => return::(case handler
of NONE => nil
| SOME handler => [handler])
- | Runtime {return,...} => [return]
- | CCall {return,...} => [return]
+ | CCall {return,...} => (case return of
+ NONE => []
+ | SOME l => [l])
| _ => []
val live
@@ -4051,24 +4038,17 @@
=> Switch {test = replacer {use = true, def = false} test,
cases = cases,
default = default}
- | Runtime {prim, args, return, size}
- => Runtime {prim = prim,
- args = List.map(args,
- fn (oper,size) => (replacer {use = true,
- def = false}
- oper,
- size)),
- return = return,
- size = size}
- | CCall {target, args, return, dstsize}
- => CCall {target = target,
- args = List.map(args,
+ | CCall {args, dstsize, 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,
- dstsize = dstsize}
+ target = target}
| transfer => transfer
val goto = Goto
@@ -4078,7 +4058,6 @@
val nontail = NonTail
val return = Return
val raisee = Raise
- val runtime = Runtime
val ccall = CCall
end
1.18 +41 -47 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.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- x86.sig 10 Apr 2002 07:02:20 -0000 1.17
+++ x86.sig 6 Jul 2002 17:22:06 -0000 1.18
@@ -11,7 +11,7 @@
signature X86_STRUCTS =
sig
structure Label : HASH_ID
- structure Prim : PRIM
+ structure Runtime: RUNTIME
end
signature X86 =
@@ -999,17 +999,17 @@
val instruction_fbinasp : {oper: Instruction.fbinasp} -> t
end
- structure Entry :
- sig
- structure FrameInfo :
- sig
- datatype t = T of {size: int,
- frameLayoutsIndex: int}
-
- val frameInfo : {size: int,
- frameLayoutsIndex: int} -> t
- end
+ structure FrameInfo:
+ sig
+ datatype t = T of {size: int,
+ frameLayoutsIndex: int}
+
+ val frameInfo: {size: int,
+ frameLayoutsIndex: int} -> t
+ end
+ structure Entry:
+ sig
datatype t
= Jump of {label: Label.t}
| Func of {label: Label.t,
@@ -1020,34 +1020,32 @@
| Handler of {label: Label.t,
live: MemLocSet.t,
offset: int}
- | Runtime of {label: Label.t,
- frameInfo: FrameInfo.t}
- | CReturn of {label: Label.t,
- dst: (Operand.t * Size.t) option}
-
- val toString : t -> string
- val uses_defs_kills : t -> {uses: Operand.t list,
- defs: Operand.t list,
- kills: Operand.t list}
- val label : t -> Label.t
- val live : t -> MemLocSet.t
+ | CReturn of {dst: (Operand.t * Size.t) option,
+ frameInfo: FrameInfo.t option,
+ func: Runtime.CFunction.t,
+ label: Label.t}
- val jump : {label: Label.t} -> t
- val func : {label: Label.t,
- live: MemLocSet.t} -> t
- val isFunc : t -> bool
val cont : {label: Label.t,
live: MemLocSet.t,
frameInfo: FrameInfo.t} -> t
+ val creturn: {dst: (Operand.t * Size.t) option,
+ frameInfo: FrameInfo.t option,
+ func: Runtime.CFunction.t,
+ label: Label.t} -> t
+ val func : {label: Label.t,
+ live: MemLocSet.t} -> t
val handler : {label: Label.t,
live: MemLocSet.t,
offset: int} -> t
- val runtime : {label: Label.t,
- frameInfo: FrameInfo.t} -> t
- val creturn : {label: Label.t,
- dst: (Operand.t * Size.t) option} -> t
-
+ val isFunc : t -> bool
val isNear : t -> bool
+ val jump : {label: Label.t} -> t
+ val label : t -> Label.t
+ val live : t -> MemLocSet.t
+ val toString : t -> string
+ val uses_defs_kills : t -> {uses: Operand.t list,
+ defs: Operand.t list,
+ kills: Operand.t list}
end
structure ProfileInfo :
@@ -1119,14 +1117,12 @@
size: int}
| Return of {live: MemLocSet.t}
| Raise of {live: MemLocSet.t}
- | Runtime of {prim: Prim.t,
- args: (Operand.t * Size.t) list,
- return: Label.t,
- size: int}
- | CCall of {target: Label.t,
- args: (Operand.t * Size.t) list,
- return: Label.t,
- dstsize: Size.t option}
+ | CCall of {args: (Operand.t * Size.t) list,
+ dstsize: Size.t option,
+ frameInfo: FrameInfo.t option,
+ func: Runtime.CFunction.t,
+ return: Label.t option,
+ target: Label.t}
val toString : t -> string
@@ -1154,14 +1150,12 @@
size: int} -> t
val return : {live: MemLocSet.t} -> t
val raisee : {live: MemLocSet.t} -> t
- val runtime : {prim: Prim.t,
- args: (Operand.t * Size.t) list,
- return: Label.t,
- size: int} -> t
- val ccall : {target: Label.t,
- args: (Operand.t * Size.t) list,
- return: Label.t,
- dstsize: Size.t option} -> t
+ val ccall: {args: (Operand.t * Size.t) list,
+ dstsize: Size.t option,
+ frameInfo: FrameInfo.t option,
+ func: Runtime.CFunction.t,
+ return: Label.t option,
+ target: Label.t} -> t
end
structure Block :
1.1 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor x86MLtonBasic(S: X86_MLTON_BASIC_STRUCTS): X86_MLTON_BASIC =
struct
open S
open x86
structure Runtime = Machine.Runtime
(*
* 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 floatSize = Size.DBLE
val floatBytes = Size.toBytes floatSize
val objectHeaderBytes = wordBytes
val arrayHeaderBytes = Runtime.arrayHeaderSize
val intInfOverheadBytes = arrayHeaderBytes + wordBytes
local
open Machine.Type
in
fun toX86Size' t
= case t
of Char => x86.Size.BYTE
| Double => x86.Size.DBLE
| Int => x86.Size.LONG
| Pointer => x86.Size.LONG
| Uint => x86.Size.LONG
val toX86Size = fn t => toX86Size' (dest t)
fun toX86Scale' t
= case t
of Char => x86.Scale.One
| Double => x86.Scale.Eight
| Int => x86.Scale.Four
| Pointer => x86.Scale.Four
| Uint => x86.Scale.Four
val toX86Scale = fn t => toX86Scale' (dest t)
end
(*
* Memory classes
*)
structure Classes =
struct
local
fun new s = MemLoc.Class.new {name = s}
in
val Heap = new "Heap"
val Stack = new "Stack"
val Locals = new "Locals"
val Globals = new "Globals"
val Temp = MemLoc.Class.Temp
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"
val GCStateHold = new "GCStateHold"
val IntInfRes = new "IntInfRes"
val ThreadStack = new "ThreadStack"
end
val allClasses = ref x86.ClassSet.empty
val livenessClasses = ref x86.ClassSet.empty
val holdClasses = ref x86.ClassSet.empty
val runtimeClasses = ref x86.ClassSet.empty
val heapClasses = ref x86.ClassSet.empty
val cstaticClasses = ref x86.ClassSet.empty
fun initClasses ()
= let
val _ = allClasses :=
x86.ClassSet.fromList
(
Heap::
Stack::
Locals::
Globals::
Temp::
CStack::
Code::
CStatic::
StaticTemp::
StaticNonTemp::
GCState::
GCStateHold::
IntInfRes::
ThreadStack::
nil)
val _ = livenessClasses :=
(if !Control.Native.liveStack
then x86.ClassSet.fromList
(
Temp::
Locals::
StaticTemp::
Stack::
nil)
else x86.ClassSet.fromList
(
Temp::
Locals::
StaticTemp::
nil))
val _ = holdClasses :=
x86.ClassSet.fromList
(
GCStateHold::
nil)
val _ = runtimeClasses :=
x86.ClassSet.fromList
(
Heap::
Stack::
Globals::
GCState::
GCStateHold::
ThreadStack::
nil)
val _ = heapClasses :=
x86.ClassSet.fromList
(
Heap::
nil)
val _ = cstaticClasses :=
x86.ClassSet.fromList
(
CStatic::
nil)
in
()
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 c_stackP = Label.fromString "c_stackP"
val c_stackPContents
= makeContents {base = Immediate.label c_stackP,
size = pointerSize,
class = Classes.StaticNonTemp}
val c_stackPContentsOperand
= Operand.memloc c_stackPContents
val c_stackPDeref
= MemLoc.simple {base = c_stackPContents,
index = Immediate.const_int 0,
scale = wordScale,
size = pointerSize,
class = Classes.CStack}
val c_stackPDerefOperand
= Operand.memloc c_stackPDeref
val c_stackPDerefDouble
= MemLoc.simple {base = c_stackPContents,
index = Immediate.const_int 0,
scale = wordScale,
size = Size.DBLE,
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
= makeContents {base = Immediate.label intInfTemp,
size = wordSize,
class = Classes.StaticTemp}
val intInfTempContentsOperand
= Operand.memloc intInfTempContents
val intInfTempFrontierContents
= MemLoc.simple {base = intInfTempContents,
index = Immediate.const_int 0,
scale = wordScale,
size = pointerSize,
class = Classes.IntInfRes}
val intInfTempFrontierContentsOperand
= Operand.memloc intInfTempFrontierContents
val intInfTempValueContents
= MemLoc.simple {base = intInfTempContents,
index = Immediate.const_int 1,
scale = wordScale,
size = pointerSize,
class = Classes.IntInfRes}
val intInfTempValueContentsOperand
= Operand.memloc intInfTempValueContents
val threadTemp = Label.fromString "threadTemp"
val threadTempContents
= makeContents {base = Immediate.label threadTemp,
size = wordSize,
class = Classes.StaticTemp}
val threadTempContentsOperand
= Operand.memloc threadTempContents
val statusTemp = Label.fromString "statusTemp"
val statusTempContents
= makeContents {base = Immediate.label statusTemp,
size = wordSize,
class = Classes.StaticTemp}
val statusTempContentsOperand
= Operand.memloc statusTempContents
val fileTemp = Label.fromString "fileTemp"
val fileTempContents
= makeContents {base = Immediate.label fileTemp,
size = pointerSize,
class = Classes.StaticTemp}
val fileTempContentsOperand
= Operand.memloc fileTempContents
val applyFFTemp = Label.fromString "applyFFTemp"
val applyFFTempContents
= makeContents {base = Immediate.label applyFFTemp,
size = wordSize,
class = Classes.StaticTemp}
val applyFFTempContentsOperand
= Operand.memloc applyFFTempContents
val realTemp1 = Label.fromString "realTemp1"
val realTemp1Contents
= makeContents {base = Immediate.label realTemp1,
size = floatSize,
class = Classes.StaticTemp}
val realTemp1ContentsOperand
= Operand.memloc realTemp1Contents
val realTemp2 = Label.fromString "realTemp2"
val realTemp2Contents
= makeContents {base = Immediate.label realTemp2,
size = floatSize,
class = Classes.StaticTemp}
val realTemp2ContentsOperand
= Operand.memloc realTemp2Contents
val realTemp3 = Label.fromString "realTemp3"
val realTemp3Contents
= makeContents {base = Immediate.label realTemp3,
size = floatSize,
class = Classes.StaticTemp}
val realTemp3ContentsOperand
= Operand.memloc realTemp3Contents
val fpswTemp = Label.fromString "fpswTemp"
val fpswTempContents
= makeContents {base = Immediate.label fpswTemp,
size = Size.WORD,
class = Classes.StaticTemp}
val fpswTempContentsOperand
= Operand.memloc fpswTempContents
local
open Machine.Type
val localC_base = Label.fromString "localuchar"
val localD_base = Label.fromString "localdouble"
val localI_base = Label.fromString "localint"
val localP_base = Label.fromString "localpointer"
val localU_base = Label.fromString "localuint"
in
fun local_base ty
= case dest ty
of Char => localC_base
| Double => localD_base
| Int => localI_base
| Pointer => localP_base
| Uint => localU_base
end
local
open Machine.Type
val globalC_base = Label.fromString "globaluchar"
val globalC_num = Label.fromString "num_globaluchar"
val globalD_base = Label.fromString "globaldouble"
val globalD_num = Label.fromString "num_globaldouble"
val globalI_base = Label.fromString "globalint"
val globalI_num = Label.fromString "num_globalint"
val globalP_base = Label.fromString "globalpointer"
val globalP_num = Label.fromString "num_globalpointer"
val globalU_base = Label.fromString "globaluint"
val globalU_num = Label.fromString "num_globaluint"
in
fun global_base ty
= case dest ty
of Char => globalC_base
| Double => globalD_base
| Int => globalI_base
| Pointer => globalP_base
| Uint => globalU_base
end
val globalPointerNonRoot_base = Label.fromString "globalpointerNonRoot"
val saveGlobals = Label.fromString "saveGlobals"
val loadGlobals = Label.fromString "loadGlobals"
val fileNameLabel = Label.fromString "fileName"
val fileName = Operand.immediate_label fileNameLabel
(* This is a hack: The line number needs to be pushed, but the actual
* call to GC_gc is about 9 lines further (push 4 more arguments,
* adjust stackTop, save return label,
* save gcState.frontier and gcState.stackTop, make call).
* However, there are probably cases where this is different.
*
* We also have another hack because with Cygwin, Label.toString appends
* an _ to the beginning of each label.
*)
val fileLineLabel =
Promise.lazy
(fn () =>
Label.fromString (case !Control.hostType of
Control.Cygwin => "_LINE__"
| Control.Linux => "__LINE__"))
val fileLine
= fn () => if !Control.debug
then Operand.immediate (Immediate.const_int 0)
else (Operand.immediate
(Immediate.binexp
{oper = Immediate.Addition,
exp1 = Immediate.label (fileLineLabel ()),
exp2 = Immediate.const_int 9}))
val gcState_label = Label.fromString "gcState"
structure Field = Runtime.GCField
fun make (f: Field.t, size, class) =
let
fun imm () =
Immediate.binexp
{oper = Immediate.Addition,
exp1 = Immediate.label gcState_label,
exp2 = Immediate.const_int (Field.offset f)}
fun contents () =
makeContents {base = imm (),
size = size,
class = class}
fun operand () = Operand.memloc (contents ())
in
(imm, contents, operand)
end
val gcState_operand =
Operand.memloc (makeContents {base = Immediate.label gcState_label,
size = pointerSize,
class = Classes.StaticNonTemp})
val (_, gcState_baseContents, gcState_baseContentsOperand) =
make (Field.Base, pointerSize, Classes.GCState)
val (_, _, gcState_canHandleContentsOperand) =
make (Field.CanHandle, wordSize, Classes.GCState)
val (gcState_currentThread, gcState_currentThreadContents,
gcState_currentThreadContentsOperand) =
make (Field.CurrentThread, pointerSize, Classes.GCState)
val (_, _, gcState_fromSizeContentsOperand) =
make (Field.FromSize, pointerSize, Classes.GCState)
val (_, gcState_frontierContents, gcState_frontierContentsOperand) =
make (Field.Frontier, pointerSize, Classes.GCStateHold)
val (_, _, gcState_limitContentsOperand) =
make (Field.Limit, pointerSize, Classes.GCState)
val (_, _, gcState_limitPlusSlopContentsOperand) =
make (Field.LimitPlusSlop, pointerSize, Classes.GCState)
val (_, _, gcState_maxFrameSizeContentsOperand) =
make (Field.MaxFrameSize, pointerSize, Classes.GCState)
val (_, _, gcState_signalIsPendingContentsOperand) =
make (Field.SignalIsPending, wordSize, Classes.GCState)
val (_, gcState_stackBottomContents, gcState_stackBottomContentsOperand) =
make (Field.StackBottom, pointerSize, Classes.GCState)
val (_, _, gcState_stackLimitContentsOperand) =
make (Field.StackLimit, pointerSize, Classes.GCState)
val (gcState_stackTop, gcState_stackTopContents,
gcState_stackTopContentsOperand) =
make (Field.StackTop, pointerSize, Classes.GCStateHold)
local
fun make (contents, class) () =
Operand.memloc (MemLoc.simple {base = contents (),
index = Immediate.const_int 0,
scale = wordScale,
size = pointerSize,
class = class})
in
val gcState_frontierDerefOperand =
make (gcState_frontierContents, Classes.Heap)
val gcState_stackTopDerefOperand =
make (gcState_stackTopContents, Classes.Stack)
end
fun gcState_stackTopMinusWordDeref () =
MemLoc.simple {base = gcState_stackTopContents (),
index = Immediate.const_int ~1,
scale = wordScale,
size = pointerSize,
class = Classes.Stack}
fun gcState_stackTopMinusWordDerefOperand () =
Operand.memloc (gcState_stackTopMinusWordDeref ())
fun gcState_currentThread_exnStackContents () =
MemLoc.simple {base = gcState_currentThreadContents (),
index = Immediate.const_int 0,
size = pointerSize,
scale = wordScale,
class = Classes.Heap}
fun gcState_currentThread_exnStackContentsOperand () =
Operand.memloc (gcState_currentThread_exnStackContents ())
fun gcState_currentThread_stackContents () =
MemLoc.simple {base = gcState_currentThreadContents (),
index = Immediate.const_int 2,
size = pointerSize,
scale = wordScale,
class = Classes.Heap}
fun gcState_currentThread_stackContentsOperand () =
Operand.memloc (gcState_currentThread_stackContents ())
fun gcState_currentThread_stack_reservedContents () =
MemLoc.simple {base = gcState_currentThread_stackContents (),
index = Immediate.const_int 0,
size = pointerSize,
scale = wordScale,
class = Classes.ThreadStack}
fun gcState_currentThread_stack_reservedContentsOperand () =
Operand.memloc (gcState_currentThread_stack_reservedContents ())
fun gcState_currentThread_stack_usedContents () =
MemLoc.simple {base = gcState_currentThread_stackContents (),
index = Immediate.const_int 1,
size = pointerSize,
scale = wordScale,
class = Classes.ThreadStack}
fun gcState_currentThread_stack_usedContentsOperand () =
Operand.memloc (gcState_currentThread_stack_usedContents ())
(* init *)
fun init () = let
val _ = Classes.initClasses ()
in
()
end
end
1.47 +3 -1 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- control.sig 4 Jun 2002 22:47:56 -0000 1.46
+++ control.sig 6 Jul 2002 17:22:07 -0000 1.47
@@ -72,6 +72,8 @@
val layoutInline: inline -> Layout.t
val setInlineSize: int -> unit
+ val inlineArrayAllocation: bool ref
+
(* The input file on the command line, minus path and extension *)
val inputFile: File.t ref
@@ -101,7 +103,7 @@
| ExtBasicBlocks
(* decycle using loop headers
* - use full CFG
- * - use loop exits of non-allocatin loops
+ * - use loop exits of non-allocating loops
*)
| LoopHeaders of {fullCFG: bool,
loopExits: bool}
1.58 +5 -0 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- control.sml 10 Apr 2002 07:02:20 -0000 1.57
+++ control.sml 6 Jul 2002 17:22:07 -0000 1.58
@@ -157,6 +157,11 @@
NonRecursive {product = size, small = small}
| Leaf _ => Leaf {size = SOME size}
| LeafNoLoop _ => LeafNoLoop {size = SOME size})
+
+val inlineArrayAllocation =
+ control {name = "inline array allocation",
+ default = true,
+ toString = Bool.toString}
val inputFile = control {name = "input file",
default = "<bogus>",
1.32 +8 -5 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- compile.sml 10 Apr 2002 07:02:20 -0000 1.31
+++ compile.sml 6 Jul 2002 17:22:07 -0000 1.32
@@ -19,8 +19,10 @@
structure Xml = Xml (open Atoms)
structure Sxml = Xml
structure Ssa = Ssa (open Atoms)
+structure Runtime = Runtime ()
structure Machine = Machine (structure Label = Ssa.Label
- structure Prim = Atoms.Prim)
+ structure Prim = Atoms.Prim
+ structure Runtime = Runtime)
(*---------------------------------------------------*)
(* Compiler Passes *)
@@ -43,8 +45,9 @@
structure Backend = Backend (structure Ssa = Ssa
structure Machine = Machine
fun funcToLabel f = f)
-structure CCodeGen = CCodeGen (structure Machine = Machine)
-structure x86CodeGen = x86CodeGen (structure Machine = Machine)
+structure CCodegen = CCodegen (structure Machine = Machine)
+structure x86Codegen = x86Codegen (structure CCodegen = CCodegen
+ structure Machine = Machine)
local open Elaborate
in
@@ -427,13 +430,13 @@
if !Control.Native.native
then
Control.trace (Control.Top, "x86 code gen")
- x86CodeGen.output {program = machine,
+ x86Codegen.output {program = machine,
includes = !Control.includes,
outputC = outputC,
outputS = outputS}
else
Control.trace (Control.Top, "C code gen")
- CCodeGen.output {program = machine,
+ CCodegen.output {program = machine,
includes = !Control.includes,
outputC = outputC}
val _ = Control.message (Control.Detail, PropertyList.stats)
1.70 +3 -0 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- main.sml 4 Jun 2002 22:47:56 -0000 1.69
+++ main.sml 6 Jul 2002 17:22:07 -0000 1.70
@@ -138,6 +138,9 @@
*)
(Normal, "inline", " n", "inlining threshold",
Int setInlineSize),
+ (Expert, "inline-array", " {true|false}",
+ "inline array allocation",
+ boolRef inlineArrayAllocation),
(* (Normal, "I", "dir", "search dir for include files",
* push includeDirs),
*)
1.17 +2 -1 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- shrink.fun 10 Apr 2002 07:02:20 -0000 1.16
+++ shrink.fun 6 Jul 2002 17:22:07 -0000 1.17
@@ -645,7 +645,8 @@
| _ => Prim.ApplyArg.Var vi)
| _ => Prim.ApplyArg.Var vi)
in
- Prim.apply (prim, Vector.toList args', VarInfo.equals)
+ traceApply Prim.apply
+ (prim, Vector.toList args', VarInfo.equals)
handle e =>
Error.bug (concat ["Prim.apply raised ",
Layout.toString (Exn.layout e)])
1.7 +2 -2 mlton/runtime/GC_world.c
Index: GC_world.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/GC_world.c,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- GC_world.c 25 Apr 2002 17:31:03 -0000 1.6
+++ GC_world.c 6 Jul 2002 17:22:08 -0000 1.7
@@ -10,7 +10,7 @@
/* GC_saveWorld */
/* ------------------------------------------------- */
-void GC_saveWorld(GC_state s, int fd, void (*saveGlobals)(int fd)) {
+void GC_saveWorld (GC_state s, int fd) {
char buf[80];
GC_enter(s);
@@ -27,7 +27,7 @@
swriteUint(fd, (uint)s->currentThread);
swriteUint(fd, (uint)s->signalHandler);
swrite(fd, s->base, s->frontier - s->base);
- (*saveGlobals)(fd);
+ (*s->saveGlobals)(fd);
GC_leave(s);
}
1.5 +21 -37 mlton/runtime/IntInf.h
Index: IntInf.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/IntInf.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- IntInf.h 23 Jun 2002 01:37:54 -0000 1.4
+++ IntInf.h 6 Jul 2002 17:22:08 -0000 1.5
@@ -16,19 +16,6 @@
#include "mlton-basis.h"
/*
- * A pointer to a struct intInfRes_t is used to communicate the state of the
- * world back from some of the C support routines and the running MLton world.
- * The frontier slot holds the new heap frontier and the value slot holds the
- * result. In cases where some storage might be needed, the ML code allocates
- * the maximum amount which might be needed and calls the C routine. It then
- * uses what it must, possibly rolling the heap frontier back.
- */
-struct intInfRes_t {
- pointer frontier,
- value;
-};
-
-/*
* IntInf_init() is passed an array of struct intInfInit's (along
* with a pointer to the current GC_state) at the start of the program.
* The array is terminated by an intInfInit with mlstr field NULL.
@@ -44,37 +31,34 @@
};
extern void IntInf_init(GC_state state, struct intInfInit inits[]);
-extern struct intInfRes_t *IntInf_do_add(pointer lhs,
+
+/* All of these routines modify the frontier in gcState. They assume that
+ * there are bytes bytes free, and allocate an array to store the result
+ * at the current frontier position.
+ */
+extern pointer IntInf_do_add(pointer lhs,
pointer rhs,
- uint bytes,
- pointer frontier),
- *IntInf_do_sub(pointer lhs,
+ uint bytes),
+ IntInf_do_sub(pointer lhs,
pointer rhs,
- uint bytes,
- pointer frontier),
- *IntInf_do_mul(pointer lhs,
+ uint bytes),
+ IntInf_do_mul(pointer lhs,
pointer rhs,
- uint bytes,
- pointer frontier),
- *IntInf_do_toString(pointer arg,
+ uint bytes),
+ IntInf_do_toString(pointer arg,
int base,
- uint bytes,
- pointer frontier),
- *IntInf_do_neg(pointer arg,
- uint bytes,
- pointer frontier),
- *IntInf_do_quot(pointer num,
+ uint bytes),
+ IntInf_do_neg(pointer arg,
+ uint bytes),
+ IntInf_do_quot(pointer num,
pointer den,
- uint bytes,
- pointer frontier),
- *IntInf_do_rem(pointer num,
+ uint bytes),
+ IntInf_do_rem(pointer num,
pointer den,
- uint bytes,
- pointer frontier),
- *IntInf_do_gcd(pointer lhs,
+ uint bytes),
+ IntInf_do_gcd(pointer lhs,
pointer rhs,
- uint bytes,
- pointer frontier);
+ uint bytes);
extern Word IntInf_smallMul(Word lhs, Word rhs, pointer carry);
extern int IntInf_compare(pointer lhs, pointer rhs),
1.29 +0 -2 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- Makefile 1 May 2002 19:12:41 -0000 1.28
+++ Makefile 6 Jul 2002 17:22:08 -0000 1.29
@@ -155,7 +155,6 @@
Posix/TTY/getpgrp.o \
Posix/TTY/sendbreak.o \
Posix/TTY/setpgrp.o \
- GC_size.o \
GC_world.o \
bcopy.o \
gc.o \
@@ -305,7 +304,6 @@
Posix/TTY/getpgrp-gdb.o \
Posix/TTY/sendbreak-gdb.o \
Posix/TTY/setpgrp-gdb.o \
- GC_size-gdb.o \
GC_world-gdb.o \
bcopy.o \
gc-gdb.o \
1.51 +845 -242 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- gc.c 27 Jun 2002 17:29:27 -0000 1.50
+++ gc.c 6 Jul 2002 17:22:08 -0000 1.51
@@ -28,9 +28,6 @@
#include <limits.h>
#endif
-typedef unsigned long long W64;
-typedef unsigned long W32;
-
#define METER FALSE /* Displays distribution of object sizes at program exit. */
/* The mutator should maintain the invariants
@@ -49,26 +46,61 @@
BOGUS_POINTER = 0x1,
DEBUG = FALSE,
DEBUG_DETAILED = FALSE,
+ DEBUG_MARK = FALSE,
+ DEBUG_MARK_SIZE = FALSE,
DEBUG_MEM = FALSE,
DEBUG_SIGNALS = FALSE,
FORWARDED = 0xFFFFFFFF,
HEADER_SIZE = WORD_SIZE,
STACK_HEADER_SIZE = WORD_SIZE,
+ VERIFY_MARK = TRUE,
};
-#define STACK_HEADER STACK_TAG
+typedef enum {
+ MARK_MODE,
+ UNMARK_MODE,
+} MarkMode;
+
+W32 mark (GC_state s, pointer root, MarkMode mode);
+
#define BOGUS_THREAD (GC_thread)BOGUS_POINTER
-#define STRING_HEADER GC_arrayHeader(1, 0)
-#define WORD8_VECTOR_HEADER GC_arrayHeader(1, 0)
-#define THREAD_HEADER GC_objectHeader(2, 1)
+
+#define STACK_HEADER GC_objectHeader (STACK_TYPE_INDEX)
+#define STRING_HEADER GC_objectHeader (STRING_TYPE_INDEX)
+#define THREAD_HEADER GC_objectHeader (THREAD_TYPE_INDEX)
+#define WORD8_VECTOR_HEADER GC_objectHeader (WORD8_TYPE_INDEX)
#define SPLIT_HEADER() \
do { \
- tag = header & TAG_MASK; \
- numNonPointers = (header & NON_POINTER_MASK) >> POINTER_BITS; \
- numPointers = header & POINTER_MASK; \
+ int objectTypeIndex; \
+ GC_ObjectType *t; \
+ \
+ assert (1 == (header & 1)); \
+ objectTypeIndex = (header & TYPE_INDEX_MASK) >> 1; \
+ assert (0 <= objectTypeIndex \
+ and objectTypeIndex < s->maxObjectTypeIndex); \
+ t = &s->objectTypes [objectTypeIndex]; \
+ tag = t->tag; \
+ numNonPointers = t->numNonPointers; \
+ numPointers = t->numPointers; \
+ if (DEBUG_DETAILED) \
+ fprintf (stderr, "SPLIT_HEADER (0x%08x) numNonPointers = %u numPointers = %u\n", \
+ (uint)header, numNonPointers, numPointers); \
} while (0)
+static char* tagToString (GC_ObjectTypeTag t) {
+ switch (t) {
+ case ARRAY_TAG:
+ return "ARRAY";
+ case NORMAL_TAG:
+ return "NORMAL";
+ case STACK_TAG:
+ return "STACK";
+ default:
+ die ("bad tag %u", t);
+ }
+}
+
static inline ulong meg (uint n) {
return n / (1024ul * 1024ul);
}
@@ -268,41 +300,30 @@
/* display */
/* ------------------------------------------------- */
-void GC_display(GC_state s, FILE *stream) {
- fprintf(stream, "GC state\n\tbase = %x frontier - base = %u limit - frontier = %u\n",
+void GC_display (GC_state s, FILE *stream) {
+ fprintf (stream, "GC state\n\tbase = 0x%x\n\tfrontier - base = %u\n\tlimit - base = %u\n\tlimit - frontier = %d\n",
(uint) s->base,
s->frontier - s->base,
+ s->limit - s->base,
s->limit - s->frontier);
- fprintf(stream, "\tcanHandle = %d\n", s->canHandle);
- fprintf(stream, "\texnStack = %u bytesNeeded = %u reserved = %u used = %u\n",
+ fprintf (stream, "\tcanHandle = %d\n", s->canHandle);
+ fprintf (stream, "\texnStack = %u bytesNeeded = %u reserved = %u used = %u\n",
s->currentThread->exnStack,
s->currentThread->bytesNeeded,
s->currentThread->stack->reserved,
s->currentThread->stack->used);
- fprintf(stream, "\tstackBottom = %x\nstackTop - stackBottom = %u\nstackLimit - stackTop = %u\n",
+ fprintf (stream, "\tstackBottom = %x\nstackTop - stackBottom = %u\nstackLimit - stackTop = %u\n",
(uint)s->stackBottom,
s->stackTop - s->stackBottom,
(s->stackLimit - s->stackTop));
}
/* ------------------------------------------------- */
-/* ensureFree */
-/* ------------------------------------------------- */
-
-static inline void
-ensureFree(GC_state s, uint bytesRequested)
-{
- if (s->frontier + bytesRequested > s->limit) {
- GC_doGC(s, bytesRequested, 0);
- }
-}
-
-/* ------------------------------------------------- */
/* object */
/* ------------------------------------------------- */
static inline pointer
-object(GC_state s, uint header, uint bytesRequested)
+object (GC_state s, uint header, uint bytesRequested)
{
pointer result;
@@ -314,12 +335,75 @@
return result;
}
+static inline W64 w64align (W64 w) {
+ return ((w + 3) & ~ 3);
+}
+
+pointer GC_arrayAllocate (GC_state s, W32 ensureBytesFree, W32 numElts,
+ W32 header) {
+ uint numPointers;
+ uint numNonPointers;
+ uint tag;
+ uint eltSize;
+ W64 arraySize64;
+ W32 arraySize;
+ W32 *frontier;
+ W32 *last;
+ pointer res;
+ W32 require;
+ W64 require64;
+
+ SPLIT_HEADER();
+ assert ((numPointers == 1 and numNonPointers == 0)
+ or (numPointers == 0 and numNonPointers > 0));
+ eltSize = numPointers * POINTER_SIZE + numNonPointers;
+ arraySize64 =
+ w64align((W64)eltSize * (W64)numElts + GC_ARRAY_HEADER_SIZE);
+ require64 = arraySize64 + (W64)ensureBytesFree;
+ if (require64 >= 0x100000000llu)
+ die ("Out of memory: cannot allocate %llu bytes.\n",
+ require64);
+ require = (W32)require64;
+ arraySize = (W32)arraySize64;
+ if (DEBUG)
+ fprintf (stderr, "array with %u elts of size %u and total size %u. ensureBytesFree = %u\n",
+ (uint)numElts, (uint)eltSize, (uint)arraySize,
+ (uint)ensureBytesFree);
+ if (require > s->limitPlusSlop - s->frontier) {
+ GC_enter (s);
+ GC_doGC (s, require, 0);
+ GC_leave (s);
+ }
+ frontier = (W32*)s->frontier;
+ last = (W32*)((pointer)frontier + arraySize);
+ *frontier++ = 0; /* counter word */
+ *frontier++ = numElts;
+ *frontier++ = header;
+ res = (pointer)frontier;
+ if (1 == numPointers)
+ for ( ; frontier < last; frontier++)
+ *frontier = 0x1;
+ s->frontier = (pointer)last;
+ /* Unfortunately, the invariant isn't quite true here, because unless we
+ * did the GC, we never set s->currentThread->stack->used to reflect
+ * what the mutator did with stackTop.
+ */
+ /* assert(GC_mutatorInvariant(s)); */
+ if (DEBUG) {
+ fprintf (stderr, "GC_arrayAllocate done. res = 0x%x frontier = 0x%x\n",
+ (uint)res, (uint)s->frontier);
+ GC_display (s, stderr);
+ }
+ assert (ensureBytesFree <= s->limitPlusSlop - s->frontier);
+ return res;
+}
+
/* ------------------------------------------------- */
/* getFrameLayout */
/* ------------------------------------------------- */
static inline GC_frameLayout *
-getFrameLayout(GC_state s, word returnAddress)
+getFrameLayout (GC_state s, word returnAddress)
{
GC_frameLayout *layout;
uint index;
@@ -328,9 +412,9 @@
index = *((uint*)(returnAddress - 4));
else
index = (uint)returnAddress;
- assert(0 <= index and index <= s->maxFrameIndex);
+ assert (0 <= index and index <= s->maxFrameIndex);
layout = &(s->frameLayouts[index]);
- assert(layout->numBytes > 0);
+ assert (layout->numBytes > 0);
return layout;
}
@@ -343,27 +427,27 @@
* If you change this, make sure and change Thread_switchTo in ccodegen.h
* and thread_switchTo in x86-generate-transfers.sml.
*/
-static inline uint stackSlop(GC_state s) {
+static inline uint stackSlop (GC_state s) {
return 2 * s->maxFrameSize;
}
-static inline uint initialStackSize(GC_state s) {
- return stackSlop(s);
+static inline uint initialStackSize (GC_state s) {
+ return stackSlop (s);
}
static inline uint
-stackBytes(uint size)
+stackBytes (uint size)
{
- return wordAlign(HEADER_SIZE + sizeof(struct GC_stack) + size);
+ return wordAlign (HEADER_SIZE + sizeof (struct GC_stack) + size);
}
/* If you change this, make sure and change Thread_switchTo in ccodegen.h
* and thread_switchTo in x86-generate-transfers.sml.
*/
static inline pointer
-stackBottom(GC_stack stack)
+stackBottom (GC_stack stack)
{
- return ((pointer)stack) + sizeof(struct GC_stack);
+ return ((pointer)stack) + sizeof (struct GC_stack);
}
/* Pointer to the topmost word in use on the stack. */
@@ -391,24 +475,24 @@
* and thread_switchTo in x86-generate-transfers.sml.
*/
static inline uint
-currentStackUsed(GC_state s)
+currentStackUsed (GC_state s)
{
return s->stackTop - s->stackBottom;
}
static inline bool
-stackIsEmpty(GC_stack stack)
+stackIsEmpty (GC_stack stack)
{
return 0 == stack->used;
}
static inline uint
-topFrameSize(GC_state s, GC_stack stack)
+topFrameSize (GC_state s, GC_stack stack)
{
GC_frameLayout *layout;
- assert(not(stackIsEmpty(stack)));
- layout = getFrameLayout(s, *(word*)(stackTop(stack) - WORD_SIZE));
+ assert (not (stackIsEmpty (stack)));
+ layout = getFrameLayout(s, *(word*)(stackTop (stack) - WORD_SIZE));
return layout->numBytes;
}
@@ -416,41 +500,43 @@
* the stackTop is less than the stackLimit.
*/
static inline bool
-stackTopIsOk(GC_state s, GC_stack stack)
+stackTopIsOk (GC_state s, GC_stack stack)
{
- return stackTop(stack)
- <= stackLimit(s, stack)
- + (stackIsEmpty(stack) ? 0 : topFrameSize(s, stack));
+ return stackTop (stack)
+ <= stackLimit (s, stack)
+ + (stackIsEmpty (stack) ? 0 : topFrameSize (s, stack));
}
static inline GC_stack
-newStack(GC_state s, uint size)
+newStack (GC_state s, uint size)
{
GC_stack stack;
- stack = (GC_stack)object(s, STACK_HEADER, stackBytes(size));
+ stack = (GC_stack) object (s, STACK_HEADER, stackBytes (size));
stack->reserved = size;
stack->used = 0;
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "0x%x = newStack (%u)\n", (uint)stack, size);
return stack;
}
inline void
-GC_setStack(GC_state s)
+GC_setStack (GC_state s)
{
GC_stack stack;
stack = s->currentThread->stack;
- s->stackBottom = stackBottom(stack);
- s->stackTop = stackTop(stack);
- s->stackLimit = stackLimit(s, stack);
+ s->stackBottom = stackBottom (stack);
+ s->stackTop = stackTop (stack);
+ s->stackLimit = stackLimit (s, stack);
}
static inline void
-stackCopy(GC_stack from, GC_stack to)
+stackCopy (GC_stack from, GC_stack to)
{
- assert(from->used <= to->reserved);
+ assert (from->used <= to->reserved);
to->used = from->used;
- memcpy(stackBottom(to), stackBottom(from), from->used);
+ memcpy (stackBottom (to), stackBottom (from), from->used);
}
/* ------------------------------------------------- */
@@ -514,24 +600,27 @@
/* The number of bytes in an array, not including the header. */
static inline uint
-arrayNumBytes(pointer p,
+arrayNumBytes (pointer p,
uint numPointers,
uint numNonPointers)
{
uint numElements, bytesPerElement, result;
- numElements = GC_arrayNumElements(p);
- bytesPerElement = numNonPointers + toBytes(numPointers);
- result = wordAlign(numElements * bytesPerElement);
+ numElements = GC_arrayNumElements (p);
+ bytesPerElement = numNonPointers + toBytes (numPointers);
+ result = wordAlign (numElements * bytesPerElement);
+ /* Empty arrays have POINTER_SIZE bytes for the forwarding pointer */
+ if (0 == result)
+ result = POINTER_SIZE;
return result;
}
static inline void
-maybeCall(GC_pointerFun f, GC_state s, pointer *pp)
+maybeCall (GC_pointerFun f, GC_state s, pointer *pp)
{
- if (GC_isPointer(*pp))
- f(s, pp);
+ if (GC_isPointer (*pp))
+ f (s, pp);
}
/* ------------------------------------------------- */
@@ -540,15 +629,15 @@
/* Apply f to each global pointer into the heap. */
inline void
-GC_foreachGlobal(GC_state s, GC_pointerFun f)
+GC_foreachGlobal (GC_state s, GC_pointerFun f)
{
int i;
for (i = 0; i < s->numGlobals; ++i)
- maybeCall(f, s, &s->globals[i]);
- maybeCall(f, s, (pointer*)&s->currentThread);
- maybeCall(f, s, (pointer*)&s->savedThread);
- maybeCall(f, s, (pointer*)&s->signalHandler);
+ maybeCall (f, s, &s->globals [i]);
+ maybeCall (f, s, (pointer*)&s->currentThread);
+ maybeCall (f, s, (pointer*)&s->savedThread);
+ maybeCall (f, s, (pointer*)&s->signalHandler);
}
/* ------------------------------------------------- */
@@ -560,27 +649,72 @@
* Returns pointer to the end of object, i.e. just past object.
*/
inline pointer
-GC_foreachPointerInObject(GC_state s, GC_pointerFun f, pointer p)
+GC_foreachPointerInObject (GC_state s, GC_pointerFun f, pointer p)
{
word header;
uint numPointers;
uint numNonPointers;
uint tag;
- header = GC_getHeader(p);
+ header = GC_getHeader (p);
SPLIT_HEADER();
if (DEBUG_DETAILED)
- fprintf(stderr, "foreachPointerInObject p = 0x%x header = 0x%x tag = 0x%x numNonPointers = %d numPointers = %d\n",
- (uint)p, header, tag, numNonPointers, numPointers);
- if (NORMAL_TAG == tag) { /* It's a normal object. */
+ fprintf(stderr, "foreachPointerInObject p = 0x%x header = 0x%x tag = %s numNonPointers = %d numPointers = %d\n",
+ (uint)p, header, tagToString (tag),
+ numNonPointers, numPointers);
+ switch (tag) {
+ case ARRAY_TAG: {
+ uint numBytes;
pointer max;
- p += toBytes(numNonPointers);
- max = p + toBytes(numPointers);
+ assert (ARRAY_TAG == tag);
+ assert (0 == GC_arrayNumElements (p)
+ ? 0 == numPointers
+ : TRUE);
+ numBytes = arrayNumBytes (p, numPointers, numNonPointers);
+ max = p + numBytes;
+ if (numPointers == 0) {
+ /* There are no pointers, just update p. */
+ p = max;
+ } else if (numNonPointers == 0) {
+ assert (0 < GC_arrayNumElements (p));
+ /* It's an array with only pointers. */
+ for (; p < max; p += POINTER_SIZE)
+ maybeCall (f, s, (pointer*)p);
+ } else {
+ uint numBytesPointers;
+
+ numBytesPointers = toBytes(numPointers);
+ /* For each array element. */
+ while (p < max) {
+ pointer max2;
+ p += numNonPointers;
+ max2 = p + numBytesPointers;
+ /* For each internal pointer. */
+ for ( ; p < max2; p += POINTER_SIZE)
+ maybeCall(f, s, (pointer*)p);
+ }
+ }
+ assert(p == max);
+ }
+ break;
+ case NORMAL_TAG: {
+ pointer max;
+
+ p += toBytes (numNonPointers);
+ max = p + toBytes (numPointers);
/* Apply f to all internal pointers. */
- for ( ; p < max; p += POINTER_SIZE)
+ for ( ; p < max; p += POINTER_SIZE) {
+ if (DEBUG_DETAILED)
+ fprintf(stderr, "p = 0x%08x *p = 0x%08x\n",
+ (uint)p, (uint)*p);
maybeCall(f, s, (pointer*)p);
- } else if (STACK_TAG == tag) {
+ }
+ }
+ break;
+ default:
+ assert (STACK_TAG == tag);
+ {
GC_stack stack;
pointer top, bottom;
int i;
@@ -616,44 +750,7 @@
}
assert(top == bottom);
p += sizeof(struct GC_stack) + stack->reserved;
- } else { /* It's an array. */
- uint numBytes;
-
- assert(ARRAY_TAG == tag);
- numBytes = arrayNumBytes(p, numPointers, numNonPointers);
- if (numBytes == 0)
- /* An empty array -- skip the POINTER_SIZE bytes
- * for the forwarding pointer.
- */
- p += POINTER_SIZE;
- else {
- pointer max;
-
- max = p + numBytes;
- if (numPointers == 0) {
- /* There are no pointers, just update p. */
- p = max;
- } else if (numNonPointers == 0) {
- /* It's an array with only pointers. */
- for (; p < max; p += POINTER_SIZE)
- maybeCall(f, s, (pointer*)p);
- } else {
- uint numBytesPointers;
-
- numBytesPointers = toBytes(numPointers);
- /* For each array element. */
- while (p < max) {
- pointer max2;
-
- p += numNonPointers;
- max2 = p + numBytesPointers;
- /* For each internal pointer. */
- for ( ; p < max2; p += POINTER_SIZE)
- maybeCall(f, s, (pointer*)p);
- }
- }
- assert(p == max);
- }
+ }
}
return p;
}
@@ -662,18 +759,21 @@
/* toData */
/* ------------------------------------------------- */
-/* p should point at the beginning of an object (i.e. the header).
- * Returns a pointer to the start of the object data.
+/* If p points at the beginning of an object, then toData p returns a pointer
+ * to the start of the object data.
*/
static inline pointer
-toData(pointer p)
+toData (pointer p)
{
word header;
header = *(word*)p;
- return ((0x0 == (header & 0x80000000))
- ? p + 2 * WORD_SIZE
- : p + WORD_SIZE);
+ if (0 == header)
+ /* Looking at the counter word in an array. */
+ return p + GC_ARRAY_HEADER_SIZE;
+ else
+ /* Looking at a header word. */
+ return p + GC_NORMAL_HEADER_SIZE;
}
/* ------------------------------------------------- */
@@ -687,17 +787,23 @@
*/
static inline void
-GC_foreachPointerInRange(GC_state s, pointer front, pointer *back,
- GC_pointerFun f)
+GC_foreachPointerInRange (GC_state s, pointer front, pointer *back,
+ GC_pointerFun f)
{
pointer b;
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "GC_foreachPointerInRange front = 0x%08x *back = 0x%08x\n",
+ (uint)front, (uint)*back);
b = *back;
- assert(front <= b);
+ assert (front <= b);
while (front < b) {
while (front < b) {
- assert(isWordAligned((uint)front));
- front = GC_foreachPointerInObject(s, f, toData(front));
+ assert (isWordAligned ((uint)front));
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "front = 0x%08x *back = 0x%08x\n",
+ (uint)front, (uint)*back);
+ front = GC_foreachPointerInObject(s, f, toData (front));
}
b = *back;
}
@@ -710,27 +816,28 @@
#ifndef NODEBUG
-static inline bool
-isInFromSpace(GC_state s, pointer p)
-{
+static inline bool GC_isInFromSpace (GC_state s, pointer p) {
return (s->base <= p and p < s->frontier);
}
-static inline void
-assertIsInFromSpace(GC_state s, pointer *p)
+static inline void
+assertIsInFromSpace (GC_state s, pointer *p)
{
- assert(isInFromSpace(s, *p));
+#ifndef NODEBUG
+ unless (GC_isInFromSpace (s, *p))
+ die ("gc.c: assertIsInFromSpace (0x%x);\n", (uint)*p);
+#endif
}
static inline bool
-isInToSpace(GC_state s, pointer p)
+isInToSpace (GC_state s, pointer p)
{
return (not(GC_isPointer(p))
or (s->toBase <= p and p < s->toBase + s->toSize));
}
static bool
-invariant(GC_state s)
+invariant (GC_state s)
{
/* would be nice to add divisiblity by pagesize of various things */
@@ -818,17 +925,28 @@
return threadBytes() + stackBytes(initialStackSize(s));
}
+static inline void
+ensureFree(GC_state s, uint bytesRequested)
+{
+ if (bytesRequested > s->limit - s->frontier) {
+ GC_doGC(s, bytesRequested, 0);
+ }
+}
+
static inline GC_thread
-newThreadOfSize(GC_state s, uint stackSize)
+newThreadOfSize (GC_state s, uint stackSize)
{
GC_stack stack;
GC_thread t;
- ensureFree(s, stackBytes(stackSize) + threadBytes());
- stack = newStack(s, stackSize);
- t = (GC_thread)object(s, THREAD_HEADER, threadBytes());
+ ensureFree (s, stackBytes (stackSize) + threadBytes ());
+ stack = newStack (s, stackSize);
+ t = (GC_thread) object (s, THREAD_HEADER, threadBytes ());
t->exnStack = BOGUS_EXN_STACK;
t->stack = stack;
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "0x%x = newThreadOfSize (%u)\n",
+ (uint)t, stackSize);;
return t;
}
@@ -840,7 +958,7 @@
}
static inline void
-copyThread(GC_state s, GC_thread from, uint size)
+copyThread (GC_state s, GC_thread from, uint size)
{
GC_thread to;
@@ -848,9 +966,9 @@
* Hence we need to stash from where the GC can find it.
*/
s->savedThread = from;
- to = newThreadOfSize(s, size);
+ to = newThreadOfSize (s, size);
from = s->savedThread;
- stackCopy(from->stack, to->stack);
+ stackCopy (from->stack, to->stack);
to->exnStack = from->exnStack;
s->savedThread = to;
}
@@ -886,7 +1004,7 @@
* They are a bit tricky because of the case when the runtime system is invoked
* from within an ML signal handler.
*/
-inline void
+void
GC_enter(GC_state s)
{
/* used needs to be set because the mutator has changed s->stackTop. */
@@ -901,41 +1019,39 @@
assert(invariant(s));
}
-void GC_leave(GC_state s)
+void GC_leave (GC_state s)
{
- assert(GC_mutatorInvariant(s));
+ assert (GC_mutatorInvariant (s));
if (s->signalIsPending and 0 == s->canHandle)
s->limit = 0;
unless (s->inSignalHandler)
- unblockSignals(s);
+ unblockSignals (s);
}
inline void
-GC_copyCurrentThread(GC_state s)
+GC_copyCurrentThread (GC_state s)
{
GC_thread t;
- GC_enter(s);
+ GC_enter (s);
t = s->currentThread;
- copyThread(s, t, t->stack->used);
- assert(s->frontier <= s->limit);
- GC_leave(s);
+ copyThread (s, t, t->stack->used);
+ GC_leave (s);
}
static inline uint
-stackNeedsReserved(GC_state s, GC_stack stack)
+stackNeedsReserved (GC_state s, GC_stack stack)
{
return stack->used + stackSlop(s) - topFrameSize(s, stack);
}
inline void
-GC_copyThread(GC_state s, GC_thread t)
+GC_copyThread (GC_state s, GC_thread t)
{
GC_enter (s);
assert (t->stack->reserved == t->stack->used);
- copyThread (s, t, stackNeedsReserved(s, t->stack));
- assert(s->frontier <= s->limit);
- GC_leave(s);
+ copyThread (s, t, stackNeedsReserved (s, t->stack));
+ GC_leave (s);
}
extern struct GC_state gcState;
@@ -1323,19 +1439,20 @@
{
int i;
- assert(isWordAligned(sizeof(struct GC_thread)));
+ assert (isWordAligned (sizeof (struct GC_thread)));
for (i = 0; i < s->numGlobals; ++i)
s->globals[i] = (pointer)BOGUS_POINTER;
- GC_setHeapParams(s, s->bytesLive + initialThreadBytes(s));
- assert(s->bytesLive + initialThreadBytes(s) + LIMIT_SLOP <= s->fromSize);
- GC_fromSpace(s);
+ GC_setHeapParams (s, s->bytesLive + initialThreadBytes (s));
+ assert (s->bytesLive + initialThreadBytes (s) + LIMIT_SLOP
+ <= s->fromSize);
+ GC_fromSpace (s);
s->frontier = s->base;
s->toSize = s->fromSize;
- GC_toSpace(s); /* FIXME: Why does toSpace need to be allocated? */
- switchToThread(s, newThreadOfSize(s, initialStackSize(s)));
- assert(initialThreadBytes(s) == s->frontier - s->base);
- assert(s->frontier + s->bytesLive <= s->limit);
- assert(GC_mutatorInvariant(s));
+ GC_toSpace (s); /* FIXME: Why does toSpace need to be allocated? */
+ switchToThread (s, newThreadOfSize (s, initialStackSize (s)));
+ assert (initialThreadBytes (s) == s->frontier - s->base);
+ assert (s->frontier + s->bytesLive <= s->limit);
+ assert (GC_mutatorInvariant (s));
}
static void usage(string s) {
@@ -1415,7 +1532,7 @@
readProcessor();
worldFile = NULL;
i = 1;
- if (argc > 1 and (0 == strcmp(argv[1], "@MLton"))) {
+ if (argc > 1 and (0 == strcmp (argv [1], "@MLton"))) {
bool done;
/* process @MLton args */
@@ -1522,6 +1639,27 @@
GC_foreachPointerInRange (s, to, &limit, translatePointer);
}
+static inline void copy (pointer src, pointer dst, uint size) {
+ uint *to,
+ *from,
+ *limit;
+
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "copy (0x%08x, 0x%08x, %u)\n",
+ (uint)src, (uint)dst, size);
+ assert (isWordAligned((uint)src));
+ assert (isWordAligned((uint)dst));
+ assert (isWordAligned(size));
+ assert (dst <= src or src + size <= dst);
+ if (src == dst)
+ return;
+ from = (uint*)src;
+ to = (uint*)dst;
+ limit = (uint*)(src + size);
+ until (from == limit)
+ *to++ = *from++;
+}
+
/* ------------------------------------------------- */
/* forward */
/* ------------------------------------------------- */
@@ -1538,7 +1676,7 @@
if (DEBUG_DETAILED)
fprintf(stderr, "forward pp = 0x%x *pp = 0x%x\n", (uint)pp, (uint)*pp);
- assert(isInFromSpace(s, *pp));
+ assert (GC_isInFromSpace (s, *pp));
p = *pp;
header = GC_getHeader(p);
if (header != FORWARDED) { /* forward the object */
@@ -1548,8 +1686,14 @@
/* Compute the space taken by the header and object body. */
SPLIT_HEADER();
if (NORMAL_TAG == tag) { /* Fixed size object. */
- headerBytes = GC_OBJECT_HEADER_SIZE;
+ headerBytes = GC_NORMAL_HEADER_SIZE;
objectBytes = toBytes(numPointers + numNonPointers);
+ if (VERIFY_MARK)
+ s->forwardSize += headerBytes + objectBytes;
+ if (DEBUG_MARK_SIZE)
+ fprintf (stderr, "0x%08x normal of size %u\n",
+ (uint)p,
+ headerBytes + objectBytes);
skip = 0;
} else if (STACK_TAG == tag) { /* Stack. */
GC_stack stack;
@@ -1557,6 +1701,12 @@
headerBytes = STACK_HEADER_SIZE;
/* Resize stacks not being used as continuations. */
stack = (GC_stack)p;
+ if (VERIFY_MARK)
+ s->forwardSize += stackBytes (stack->reserved);
+ if (DEBUG_MARK_SIZE)
+ fprintf (stderr, "0x%08x stack of size %u\n",
+ (uint)p,
+ stackBytes (stack->reserved));
if (stack->used != stack->reserved) {
if (4 * stack->used <= stack->reserved)
stack->reserved = stack->reserved / 2;
@@ -1572,15 +1722,17 @@
objectBytes = sizeof (struct GC_stack) + stack->used;
skip = stack->reserved - stack->used;
} else { /* Array. */
- assert(ARRAY_TAG == tag);
+ assert (ARRAY_TAG == tag);
headerBytes = GC_ARRAY_HEADER_SIZE;
- objectBytes = arrayNumBytes(p, numPointers,
+ objectBytes = arrayNumBytes (p, numPointers,
numNonPointers);
+ if (VERIFY_MARK)
+ s->forwardSize += headerBytes + objectBytes;
+ if (DEBUG_MARK_SIZE)
+ fprintf (stderr, "0x%08x array of size %u\n",
+ (uint)p,
+ headerBytes + objectBytes);
skip = 0;
- /* Empty arrays have POINTER_SIZE bytes for the
- * forwarding pointer.
- */
- if (0 == objectBytes) objectBytes = POINTER_SIZE;
}
size = headerBytes + objectBytes;
/* This check is necessary, because toSpace may be smaller
@@ -1595,23 +1747,10 @@
die ("Out of memory (forward).\nDiagnostic: probably a RAM problem.");
}
/* Copy the object. */
- if (FALSE and processor_has_sse2 and size >= 8192) {
- extern void bcopy_simd(void *, void const *, int);
- bcopy_simd(p - headerBytes, s->back, size);
- } else {
- uint *to,
- *from,
- *limit;
-
- to = (uint *)s->back;
- from = (uint *)(p - headerBytes);
- assert (isWordAligned((uint)to));
- assert (isWordAligned((uint)from));
- assert (isWordAligned(size));
- limit = (uint *)((char *)from + size);
- until (from == limit)
- *to++ = *from++;
- }
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "copying from 0x%08x to 0x%08x\n",
+ (uint)p, (uint)s->back);
+ copy (p - headerBytes, s->back, size);
#if METER
if (size < sizeof(sizes)/sizeof(sizes[0])) sizes[size]++;
#endif
@@ -1642,6 +1781,28 @@
assert(front == *back);
}
+static inline uint objectSize (GC_state s, pointer p)
+{
+ uint headerBytes, objectBytes;
+ word header;
+ uint tag, numPointers, numNonPointers;
+
+ header = GC_getHeader(p);
+ SPLIT_HEADER();
+ if (NORMAL_TAG == tag) { /* Fixed size object. */
+ headerBytes = GC_NORMAL_HEADER_SIZE;
+ objectBytes = toBytes (numPointers + numNonPointers);
+ } else if (STACK_TAG == tag) { /* Stack. */
+ headerBytes = STACK_HEADER_SIZE;
+ objectBytes = sizeof(struct GC_stack) + ((GC_stack)p)->reserved;
+ } else { /* Array. */
+ assert(ARRAY_TAG == tag);
+ headerBytes = GC_ARRAY_HEADER_SIZE;
+ objectBytes = arrayNumBytes(p, numPointers, numNonPointers);
+ }
+ return headerBytes + objectBytes;
+}
+
/* ------------------------------------------------- */
/* doGC */
/* ------------------------------------------------- */
@@ -1850,6 +2011,8 @@
assert (bytesRequested <= s->limit - s->frontier);
}
+static inline void markCompact (GC_state s);
+
void GC_doGC(GC_state s, uint bytesRequested, uint stackBytesRequested) {
uint gcTime;
uint size;
@@ -1860,25 +2023,34 @@
if (DEBUG or s->messages)
fprintf(stderr, "Starting gc. bytesRequested = %u\n",
bytesRequested);
- fixedGetrusage(RUSAGE_SELF, &ru_start);
+ fixedGetrusage (RUSAGE_SELF, &ru_start);
prepareToSpace (s, bytesRequested, stackBytesRequested);
assert (s->toBase != (void*)NULL);
if (DEBUG or s->messages) {
- fprintf(stderr, "fromSpace = %x toSpace = %x\n",
- (uint)s->base, (uint)s->toBase);
- fprintf(stderr, "fromSpace size = %s",
+ fprintf (stderr, "fromSpace = %x toSpace = %x\n",
+ (uint)s->base, (uint)s->toBase);
+ fprintf (stderr, "fromSpace size = %s",
uintToCommaString(s->fromSize));
- fprintf(stderr, " toSpace size = %s\n",
+ fprintf (stderr, " toSpace size = %s\n",
uintToCommaString(s->toSize));
}
s->numGCs++;
s->bytesAllocated += s->frontier - s->base - s->bytesLive;
/* The actual GC. */
+ if (FALSE)
+ markCompact (s);
s->back = s->toBase;
s->toLimit = s->toBase + s->toSize;
front = s->back;
- GC_foreachGlobal(s, forward);
- forwardEachPointerInRange(s, front, &s->back);
+ if (VERIFY_MARK)
+ s->forwardSize = 0;
+ GC_foreachGlobal (s, forward);
+ forwardEachPointerInRange (s, front, &s->back);
+ if (VERIFY_MARK and s->markSize != s->forwardSize) {
+ fprintf (stderr, "markSize = %u forwardSize = %u\n",
+ s->markSize, s->forwardSize);
+ die ("bug");
+ }
size = s->fromSize;
swapSemis (s);
GC_setStack(s);
@@ -1896,14 +2068,14 @@
}
fixedGetrusage(RUSAGE_SELF, &ru_finish);
rusageMinusMax(&ru_finish, &ru_start, &ru_total);
- rusagePlusMax(&s->ru_gc, &ru_total, &s->ru_gc);
- gcTime = rusageTime(&ru_total);
- s->maxPause = max(s->maxPause, gcTime);
+ rusagePlusMax (&s->ru_gc, &ru_total, &s->ru_gc);
+ gcTime = rusageTime (&ru_total);
+ s->maxPause = max (s->maxPause, gcTime);
if (DEBUG or s->messages) {
- fprintf(stderr, "Finished gc.\n");
- fprintf(stderr, "time(ms): %s\n", intToCommaString(gcTime));
- fprintf(stderr, "live(bytes): %s (%.1f%%)\n",
- intToCommaString(s->bytesLive),
+ fprintf (stderr, "Finished gc.\n");
+ fprintf (stderr, "time(ms): %s\n", intToCommaString (gcTime));
+ fprintf (stderr, "live(bytes): %s (%.1f%%)\n",
+ intToCommaString (s->bytesLive),
100.0 * ((double) s->bytesLive) / size);
}
if (DEBUG)
@@ -1915,22 +2087,22 @@
/* GC_gc */
/* ------------------------------------------------- */
-void GC_gc(GC_state s, uint bytesRequested, bool force,
+void GC_gc (GC_state s, uint bytesRequested, bool force,
string file, int line) {
uint stackBytesRequested;
- GC_enter(s);
+ GC_enter (s);
s->currentThread->bytesNeeded = bytesRequested;
start:
stackBytesRequested =
- (stackTopIsOk(s, s->currentThread->stack))
+ (stackTopIsOk (s, s->currentThread->stack))
? 0
- : stackBytes(2 * s->currentThread->stack->reserved);
+ : stackBytes (2 * s->currentThread->stack->reserved);
if (DEBUG) {
fprintf (stderr, "%s %d: ", file, line);
- fprintf(stderr, "bytesRequested = %u stackBytesRequested = %u\n",
+ fprintf (stderr, "bytesRequested = %u stackBytesRequested = %u\n",
bytesRequested, stackBytesRequested);
- GC_display(s, stderr);
+ GC_display (s, stderr);
}
if (force or
(W64)(W32)s->frontier + (W64)bytesRequested
@@ -1951,10 +2123,10 @@
/* The newStack can't cause a GC, because we checked above to
* make sure there was enough space.
*/
- stack = newStack(s, size);
- stackCopy(s->currentThread->stack, stack);
+ stack = newStack (s, size);
+ stackCopy (s->currentThread->stack, stack);
s->currentThread->stack = stack;
- GC_setStack(s);
+ GC_setStack (s);
} else {
/* Switch to the signal handler thread. */
assert (0 == s->canHandle);
@@ -1972,13 +2144,14 @@
* to continue with, which will decrement s->canHandle to 0.
*/
s->canHandle = 2;
- switchToThread(s, s->signalHandler);
+ switchToThread (s, s->signalHandler);
bytesRequested = s->currentThread->bytesNeeded;
+ assert (0 == bytesRequested);
if (bytesRequested > s->limit - s->frontier)
goto start;
}
assert (s->currentThread->bytesNeeded <= s->limit - s->frontier);
- /* The GC_enter and GC_leave must be outside the while loop. If they
+ /* The GC_enter and GC_leave must be outside the start loop. If they
* were inside and force == TRUE, a signal handler could intervene just
* before the GC_enter or just after the GC_leave, which would set
* limit to 0 and cause the while loop to go forever, performing a GC
@@ -1991,11 +2164,11 @@
/* GC_createStrings */
/* ------------------------------------------------- */
-void GC_createStrings(GC_state s, struct GC_stringInit inits[]) {
+void GC_createStrings (GC_state s, struct GC_stringInit inits[]) {
pointer frontier;
int i;
- assert(invariant(s));
+ assert (invariant (s));
frontier = s->frontier;
for(i = 0; inits[i].str != NULL; ++i) {
uint numElements, numBytes;
@@ -2008,10 +2181,14 @@
if (frontier + numBytes >= s->limit)
die("Unable to allocate string constant \"%s\".",
inits[i].str);
- *(word*)frontier = numElements;
- *(word*)(frontier + WORD_SIZE) = STRING_HEADER;
+ *(word*)frontier = 0; /* counter word */
+ *(word*)(frontier + WORD_SIZE) = numElements;
+ *(word*)(frontier + 2 * WORD_SIZE) = STRING_HEADER;
s->globals[inits[i].globalIndex] =
frontier + GC_ARRAY_HEADER_SIZE;
+ if (DEBUG_DETAILED)
+ fprintf (stderr, "allocated string at 0x%x\n",
+ (uint)s->globals[inits[i].globalIndex]);
{
int j;
@@ -2105,33 +2282,459 @@
}
/* ------------------------------------------------- */
-/* GC_objectSize */
+/* mark */
/* ------------------------------------------------- */
-/* Compute the space taken by the header and object body. */
-inline uint
-GC_objectSize(pointer p)
-{
- uint headerBytes, objectBytes;
- word header;
- uint tag, numPointers, numNonPointers;
+static inline uint *arrayCounterp (pointer a) {
+ return ((uint*)a - 3);
+}
- header = GC_getHeader(p);
+static inline uint arrayCounter (pointer a) {
+ return *(arrayCounterp (a));
+}
+
+static inline bool isMarked (pointer p) {
+ return MARK_MASK & GC_getHeader (p);
+}
+
+static bool modeEqMark (MarkMode m, pointer p) {
+ return (((MARK_MODE == m) and isMarked (p))
+ or ((UNMARK_MODE == m) and not isMarked (p)));
+}
+
+/* GC_mark (s, p) sets all the mark bits in the object graph pointed to by p.
+ * If the mode is MARK, it sets the bits to 1.
+ * If the mode is UNMARK, it sets the bits to 0.
+ * It returns the amount marked.
+ */
+W32 mark (GC_state s, pointer root, MarkMode mode) {
+ pointer cur; /* The current object being marked. */
+ GC_offsets frameOffsets;
+ Header* headerp;
+ Header header;
+ uint index;
+ GC_frameLayout *layout;
+ pointer max; /* The end of the pointers in an object. */
+ pointer next; /* The next object to mark. */
+ Header *nextHeaderp;
+ Header nextHeader;
+ W32 numBytes;
+ uint numNonPointers;
+ uint numPointers;
+ pointer prev; /* The previous object on the mark stack. */
+ W32 size;
+ uint tag;
+ pointer todo; /* A pointer to the pointer in cur to next. */
+ pointer top; /* The top of the next stack frame to mark. */
+
+ if (modeEqMark (mode, root))
+ /* Object has already been marked. */
+ return 0;
+ size = 0;
+ cur = root;
+ prev = NULL;
+ headerp = GC_getHeaderp (cur);
+ header = *(Header*)headerp;
+ goto mark;
+markNext:
+ /* cur is the object that was being marked.
+ * prev is the mark stack.
+ * next is the unmarked object to be marked.
+ * todo is a pointer to the pointer inside cur that points to next.
+ * headerp points to the header of next.
+ * header is the header of next.
+ */
+ if (DEBUG_MARK)
+ fprintf (stderr, "markNext cur = 0x%08x next = 0x%08x prev = 0x%08x todo = 0x%08x\n",
+ (uint)cur, (uint)next, (uint)prev, (uint)todo);
+ assert (not modeEqMark (mode, next));
+ assert (header == GC_getHeader (next));
+ assert (headerp == GC_getHeaderp (next));
+ assert (*(pointer*) todo == next);
+ *(pointer*)todo = prev;
+ prev = cur;
+ cur = next;
+mark:
+ if (DEBUG_MARK)
+ fprintf (stderr, "mark cur = 0x%08x prev = 0x%08x mode = %s\n",
+ (uint)cur, (uint)prev,
+ (mode == MARK_MODE) ? "mark" : "unmark");
+ /* cur is the object to mark.
+ * prev is the mark stack.
+ * headerp points to the header of cur.
+ * header is the header of cur.
+ */
+ assert (not modeEqMark (mode, cur));
+ assert (header == GC_getHeader (cur));
+ assert (headerp == GC_getHeaderp (cur));
+ header = (MARK_MODE == mode)
+ ? header | MARK_MASK
+ : header & ~MARK_MASK;
SPLIT_HEADER();
- if (NORMAL_TAG == tag) { /* Fixed size object. */
- headerBytes = GC_OBJECT_HEADER_SIZE;
- objectBytes = toBytes(numPointers + numNonPointers);
- } else if (STACK_TAG == tag) { /* Stack. */
- headerBytes = STACK_HEADER_SIZE;
- objectBytes = sizeof(struct GC_stack) + ((GC_stack)p)->reserved;
- } else { /* Array. */
- assert(ARRAY_TAG == tag);
- headerBytes = GC_ARRAY_HEADER_SIZE;
- objectBytes = arrayNumBytes(p, numPointers, numNonPointers);
- /* Empty arrays have POINTER_SIZE bytes for the
- * forwarding pointer.
+ switch (tag) {
+ case ARRAY_TAG:
+ assert (0 == GC_arrayNumElements (cur)
+ ? 0 == numPointers
+ : TRUE);
+ numBytes = arrayNumBytes (cur, numPointers, numNonPointers);
+ if (DEBUG_MARK_SIZE)
+ fprintf (stderr, "0x%08x array of size %u\n",
+ (uint)cur,
+ GC_ARRAY_HEADER_SIZE + (uint)numBytes);
+ size += GC_ARRAY_HEADER_SIZE + numBytes;
+ *headerp = header;
+ if (0 == numBytes or 0 == numPointers)
+ goto ret;
+ assert (0 == numNonPointers);
+ max = cur + numBytes;
+ todo = cur;
+ index = 0;
+markInArray:
+ if (DEBUG_MARK)
+ fprintf (stderr, "markInArray index = %d\n", index);
+ if (todo == max) {
+ *arrayCounterp (cur) = 0;
+ goto ret;
+ }
+ next = *(pointer*)todo;
+ if (not GC_isPointer (next)) {
+markNextInArray:
+ todo += POINTER_SIZE;
+ index++;
+ goto markInArray;
+ }
+ nextHeaderp = GC_getHeaderp (next);
+ nextHeader = *nextHeaderp;
+ if ((nextHeader & MARK_MASK)
+ == (MARK_MODE == mode ? MARK_MASK : 0))
+ goto markNextInArray;
+ *arrayCounterp (cur) = index;
+ headerp = nextHeaderp;
+ header = nextHeader;
+ goto markNext;
+ case NORMAL_TAG:
+ todo = cur + toBytes (numNonPointers);
+ max = todo + toBytes (numPointers);
+ if (DEBUG_MARK_SIZE)
+ fprintf (stderr, "0x%08x normal of size %u\n",
+ (uint)cur,
+ GC_NORMAL_HEADER_SIZE + (max - cur));
+ size += GC_NORMAL_HEADER_SIZE + (max - cur);
+ index = 0;
+markInNormal:
+ assert (todo <= max);
+ if (DEBUG_MARK)
+ fprintf (stderr, "markInNormal index = %d\n", index);
+ if (todo == max) {
+ *headerp = header & ~COUNTER_MASK;
+ goto ret;
+ }
+ next = *(pointer*)todo;
+ if (not GC_isPointer (next)) {
+markNextInNormal:
+ todo += POINTER_SIZE;
+ index++;
+ goto markInNormal;
+ }
+ nextHeaderp = GC_getHeaderp (next);
+ nextHeader = *nextHeaderp;
+ if ((nextHeader & MARK_MASK)
+ == (MARK_MODE == mode ? MARK_MASK : 0))
+ goto markNextInNormal;
+ *headerp = (header & ~COUNTER_MASK) |
+ (index << COUNTER_SHIFT);
+ headerp = nextHeaderp;
+ header = nextHeader;
+ goto markNext;
+ default:
+ assert (STACK_TAG == tag);
+ *headerp = header;
+ if (DEBUG_MARK_SIZE)
+ fprintf (stderr, "0x%08x stack of size %u\n",
+ (uint)cur,
+ stackBytes (((GC_stack)cur)->reserved));
+ size += stackBytes (((GC_stack)cur)->reserved);
+ top = stackTop ((GC_stack)cur);
+ assert (((GC_stack)cur)->used <= ((GC_stack)cur)->reserved);
+markInStack:
+ /* Invariant: top points just past the return address of the
+ * frame to be marked.
*/
- if (0 == objectBytes) objectBytes = POINTER_SIZE;
+ assert (stackBottom ((GC_stack)cur) <= top);
+ if (DEBUG_MARK)
+ fprintf (stderr, "markInStack top = %d\n",
+ top - stackBottom ((GC_stack)cur));
+
+ if (top == stackBottom ((GC_stack)(cur)))
+ goto ret;
+ index = 0;
+ layout = getFrameLayout (s, *(word*) (top - WORD_SIZE));
+ frameOffsets = layout->offsets;
+ ((GC_stack)cur)->markTop = top;
+markInFrame:
+ if (index == frameOffsets [0]) {
+ top -= layout->numBytes;
+ goto markInStack;
+ }
+ todo = top - layout->numBytes + frameOffsets [index + 1];
+ next = *(pointer*)todo;
+ if (DEBUG_MARK)
+ fprintf (stderr,
+ " offset %u todo 0x%08x next = 0x%08x\n",
+ frameOffsets [index + 1],
+ (uint)todo, (uint)next);
+ if (not GC_isPointer (next)) {
+ index++;
+ goto markInFrame;
+ }
+ nextHeaderp = GC_getHeaderp (next);
+ nextHeader = *nextHeaderp;
+ if ((nextHeader & MARK_MASK)
+ == (MARK_MODE == mode ? MARK_MASK : 0)) {
+ index++;
+ goto markInFrame;
+ }
+ ((GC_stack)cur)->markIndex = index;
+ headerp = nextHeaderp;
+ header = nextHeader;
+ goto markNext;
+ }
+ assert (FALSE);
+ret:
+ /* Done marking cur, continue with prev.
+ * Need to set the pointer in the prev object that pointed to cur
+ * to point back to prev, and restore prev.
+ */
+ if (DEBUG_MARK)
+ fprintf (stderr, "return cur = 0x%08x prev = 0x%08x\n",
+ (uint)cur, (uint)prev);
+ assert (modeEqMark (mode, cur));
+ if (NULL == prev)
+ return size;
+ headerp = GC_getHeaderp (prev);
+ header = *headerp;
+ SPLIT_HEADER();
+ switch (tag) {
+ case ARRAY_TAG:
+ max = prev + arrayNumBytes (prev, numPointers, numNonPointers);
+ index = arrayCounter (prev);
+ todo = prev + index * POINTER_SIZE;
+ next = cur;
+ cur = prev;
+ prev = *(pointer*)todo;
+ *(pointer*)todo = next;
+ todo += POINTER_SIZE;
+ index++;
+ goto markInArray;
+ case NORMAL_TAG:
+ todo = prev + toBytes (numNonPointers);
+ max = todo + toBytes (numPointers);
+ index = (header & COUNTER_MASK) >> COUNTER_SHIFT;
+ todo += index * POINTER_SIZE;
+ next = cur;
+ cur = prev;
+ prev = *(pointer*)todo;
+ *(pointer*)todo = next;
+ todo += POINTER_SIZE;
+ index++;
+ goto markInNormal;
+ default:
+ assert (STACK_TAG == tag);
+ next = cur;
+ cur = prev;
+ index = ((GC_stack)cur)->markIndex;
+ top = ((GC_stack)cur)->markTop;
+ layout = getFrameLayout (s, *(word*) (top - WORD_SIZE));
+ frameOffsets = layout->offsets;
+ todo = top - layout->numBytes + frameOffsets [index + 1];
+ prev = *(pointer*)todo;
+ *(pointer*)todo = next;
+ index++;
+ goto markInFrame;
}
- return headerBytes + objectBytes;
+ assert (FALSE);
+}
+
+static inline void markGlobal (GC_state s, pointer *pp) {
+ s->markSize += mark (s, *pp, MARK_MODE);
+}
+
+static inline void unmarkGlobal (GC_state s, pointer *pp) {
+ mark (s, *pp, UNMARK_MODE);
+}
+
+static inline void threadInternal (GC_state s, pointer *pp) {
+ Header *headerp;
+
+ headerp = GC_getHeaderp(*pp);
+ *(Header*)pp = *headerp;
+ *headerp = (Header)pp;
+}
+
+static inline void updateForwardPointers (GC_state s) {
+ pointer back;
+ pointer front;
+ uint gap;
+ Header header;
+ Header *headerp;
+ pointer p;
+ uint size;
+ uint totalSize;
+
+ if (DEBUG_MARK)
+ fprintf (stderr, "updateForwardPointers\n");
+ back = s->frontier;
+ front = s->base;
+ gap = 0;
+ totalSize = 0;
+updateObject:
+ if (front == back)
+ goto done;
+ headerp = (Header*)front;
+ header = *headerp;
+ if (0 == header) {
+ /* We're looking at an array. Move to the header. */
+ p = front + 3 * WORD_SIZE;
+ headerp = (Header*)(p - WORD_SIZE);
+ header = *headerp;
+ } else
+ p = front + WORD_SIZE;
+ if (1 == (1 & header)) {
+ /* It's a header */
+ if (MARK_MASK & header) {
+ /* It is marked, but has no forward pointers.
+ * Thread internal pointers.
+ */
+thread:
+ size = objectSize (s, p);
+ if (DEBUG_MARK)
+ fprintf (stderr, "threading 0x%08x of size %u\n",
+ (uint)p, size);
+ totalSize += size;
+ front += size;
+ GC_foreachPointerInObject (s, threadInternal, p);
+ goto updateObject;
+ } else {
+ /* It's not marked. */
+ size = objectSize (s, p);
+ gap += size;
+ front += size;
+ goto updateObject;
+ }
+ } else {
+ pointer new;
+
+ assert (0 == (3 & header));
+ /* It's a pointer. This object must be live. Fix all the
+ * forward pointers to it, store its header, then thread
+ * its internal pointers.
+ */
+ new = p - gap;
+ do {
+ pointer cur;
+
+ cur = (pointer)header;
+ header = *(word*)cur;
+ *(word*)cur = (word)new;
+ } while (0 == (1 & header));
+ *headerp = header;
+ goto thread;
+ }
+done:
+ s->markSize = totalSize;
+ return;
+}
+
+static inline void updateBackwardPointersAndSlide (GC_state s) {
+ pointer back;
+ pointer front;
+ uint gap;
+ Header header;
+ pointer p;
+ uint size;
+ uint totalSize;
+
+ if (DEBUG_MARK)
+ fprintf (stderr, "updateBackwardPointersAndSlide\n");
+ back = s->frontier;
+ front = s->base;
+ gap = 0;
+ totalSize = 0;
+updateObject:
+ if (front == back)
+ goto done;
+ header = *(word*)front;
+ if (0 == header) {
+ /* We're looking at an array. Move to the header. */
+ p = front + 3 * WORD_SIZE;
+ header = *(Header*)(p - WORD_SIZE);
+ } else
+ p = front + WORD_SIZE;
+ if (1 == (1 & header)) {
+ /* It's a header */
+ if (MARK_MASK & header) {
+ /* It is marked, but has no backward pointers to it.
+ * Unmark it.
+ */
+unmark:
+ *GC_getHeaderp (p) = header & ~MARK_MASK;
+ size = objectSize (s, p);
+ if (DEBUG_MARK)
+ fprintf (stderr, "unmarking 0x%08x of size %u\n",
+ (uint)p, size);
+ /* slide */
+ unless (0 == gap)
+ if (DEBUG_MARK)
+ fprintf (stderr, "sliding 0x%08x down %u\n",
+ (uint)front, gap);
+ copy (front, front - gap, size);
+ totalSize += size;
+ front += size;
+ goto updateObject;
+ } else {
+ size = objectSize (s, p);
+ /* It's not marked. */
+ gap += size;
+ front += size;
+ goto updateObject;
+ }
+ } else {
+ pointer new;
+
+ assert (0 == (3 & header));
+ /* It's a pointer. This object must be live. Fix all the
+ * forward pointers to it. Then unmark it.
+ */
+ new = p - gap;
+ do {
+ pointer cur;
+
+ cur = (pointer)header;
+ header = *(word*)cur;
+ *(word*)cur = (word)new;
+ } while (0 == (1 & header));
+ /* The header will be stored by umark. */
+ goto unmark;
+ }
+done:
+ return;
+}
+
+static inline void markCompact (GC_state s) {
+ GC_foreachGlobal (s, markGlobal);
+ GC_foreachGlobal (s, threadInternal);
+ updateForwardPointers (s);
+ updateBackwardPointersAndSlide (s);
+}
+
+uint GC_size (GC_state s, pointer root) {
+ uint res;
+
+ if (DEBUG_MARK)
+ fprintf (stderr, "GC_size marking\n");
+ res = mark (s, root, MARK_MODE);
+ if (DEBUG_MARK)
+ fprintf (stderr, "GC_size unmarking\n");
+ mark (s, root, UNMARK_MODE);
+ return res;
}
1.25 +299 -308 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- gc.h 27 Apr 2002 01:54:43 -0000 1.24
+++ gc.h 6 Jul 2002 17:22:08 -0000 1.25
@@ -12,45 +12,6 @@
* A two-space stop-and-copy GC.
*
* Has three kinds of objects: normal (fixed size), arrays, and stacks.
- *
- * Object Layout
- * -------------
- * Pointers always point at the first data word of the object.
- * All objects are preceded by a header word.
- * Array header words are preceded by a length.
- *
- * Here are the header bits.
- *
- * al mark
- * 31 30 29 28 27 -- 14 13 -- 0
- * normal 1 0 # words nonpointers # pointers
- * stack 1 1 unused unused
- * array 0 0 # bytes of nonpointers # pointers
- *
- * Length word
- * 31
- * 0
- *
- * al stands for alignment and is currently unused. Someday it will be used
- * for better double alignment.
- *
- * The mark bit is only used during GC_size.
- *
- * For now, arrays must be either all pointers or all nonpointers.
- *
- * There are are two things that the GC needs to do
- * 1. Locate the header given a pointer to the (first data word) object.
- * 2. Locate the header given a pointer to the beginning of the object, which
- * is either the header or the array length.
- *
- * (1) happens for every (live) pointer during a GC, while (2) happens for every
- * live object. Since (1) occurs more frequently than (2), the design of header
- * bits is optimized for that case.
- *
- * (1) is easy, because the header is the preceeding word.
- *
- * (2) is easy, because if the high bit is set, we are looking at the header.
- * If not, the next word is the header.
*/
#include <signal.h>
@@ -62,74 +23,80 @@
typedef uint word;
typedef char* pointer;
+typedef unsigned long long W64;
+typedef unsigned long W32;
+typedef W32 Header;
+
+/*
+ * Header word bits look as follows:
+ * 31 mark bit
+ * 30 - 20 counter bits
+ * 19 - 1 type index bits
+ * 0 1
+ *
+ * The mark bit is used by the mark compact GC and GC_size to mark an object
+ * as reachable. The counter bits are used during the mark phase in conjunction
+ * with pointer reversal to implement the mark stack. They record the current
+ * pointer
+ *
+ * The type index is an index into an array of struct GC_ObjectType's, where
+ * each element describes the layout of an object. There are three kinds of
+ * objects: array, normal, and stack.
+ *
+ * Arrays are layed out as follows
+ * counter word
+ * length word
+ * header word
+ * data words ...
+ * The counter word is used during marking to help implement the mark stack.
+ * The length word is the number of elements in the array.
+ * The header word contains a type index that describes the layout of elements.
+ * For now, arrays are either all pointers or all nonpointers.
+ *
+ * Normal objects are a header word followed by the data words, which consist
+ * of all nonpointer data followed by all pointer data.
+ *
+ * 19 bits means that there are only 2^19 different different object layouts,
+ * which appears to be plenty, since there were < 128 different types required
+ * for a self-compile.
+ */
/* Sizes are (almost) always measured in bytes. */
enum {
- WORD_SIZE = 4,
- GC_OBJECT_HEADER_SIZE = WORD_SIZE,
- GC_ARRAY_HEADER_SIZE = WORD_SIZE + GC_OBJECT_HEADER_SIZE,
- LIMIT_SLOP = 512,
- /* Number of bits specifying the number of nonpointers in an object. */
- NON_POINTER_BITS = 14,
- /* Number of bits specifying the number of pointers in an object. */
- POINTER_BITS = 14,
- NON_POINTERS_SHIFT = POINTER_BITS,
- POINTER_SIZE = WORD_SIZE,
-
- /* Here are the masks for the various parts of header words. */
- TAG_MASK = 0xC0000000,
- ALIGNMENT_BIT = 0x20000000,
- MARK_BIT = 0x10000000,
- NON_POINTER_MASK = 0x0FFFC000,
- POINTER_MASK = 0x00003FFF,
-
- /* Here are the tags for the three kinds of objects. */
- ARRAY_TAG = 0x00000000,
- STACK_TAG = 0xC0000000,
- NORMAL_TAG = 0x80000000,
+ WORD_SIZE = 4,
+ COUNTER_MASK = 0x7FF00000,
+ COUNTER_SHIFT = 20,
+ GC_ARRAY_HEADER_SIZE = 3 * WORD_SIZE,
+ GC_NORMAL_HEADER_SIZE = WORD_SIZE,
+ TYPE_INDEX_BITS = 19,
+ TYPE_INDEX_MASK = 0x000FFFFE,
+ LIMIT_SLOP = 512,
+ MARK_MASK = 0x80000000,
+ POINTER_SIZE = WORD_SIZE,
+ STACK_TYPE_INDEX = 0,
+ STRING_TYPE_INDEX = 1,
+ THREAD_TYPE_INDEX = 2,
+ WORD8_VECTOR_TYPE_INDEX = STRING_TYPE_INDEX,
+ WORD_VECTOR_TYPE_INDEX = 3,
};
#define TWOPOWER(n) (1 << (n))
-/*
- * Build the one word header for an object, given the number of words of
- * nonpointers and the number of pointers.
- */
-static inline word GC_objectHeader(uint np, uint p) {
- assert(np < TWOPOWER(NON_POINTER_BITS));
- assert(p < TWOPOWER(POINTER_BITS));
- return NORMAL_TAG | p | (np << NON_POINTERS_SHIFT);
-}
-
-/*
- * Build the one word header for an array, given the number of bytes of
- * nonpointers and the number of pointers.
- */
-static inline word GC_arrayHeader(uint np, uint p) {
- /* Arrays are allowed one fewer non pointer bit, because the top
- * non pointer bit is used for the continuation header word.
- */
- assert(np < TWOPOWER(NON_POINTER_BITS - 1));
- assert(p < TWOPOWER(POINTER_BITS));
- return ARRAY_TAG | p | (np << NON_POINTERS_SHIFT);
-}
-
/* ------------------------------------------------- */
-/* GC_isPointer */
+/* object type */
/* ------------------------------------------------- */
-/* Returns true if p looks like a pointer, i.e. if p = 0 mod 4. */
-static inline bool GC_isPointer(pointer p) {
- return(0 == ((word)p & 0x3));
-}
-
-static inline uint wordAlign(uint p) {
- return ((p + 3) & ~ 3);
-}
-
-static inline bool isWordAligned(uint x) {
- return 0 == (x & 0x3);
-}
+typedef enum {
+ ARRAY_TAG,
+ NORMAL_TAG,
+ STACK_TAG,
+} GC_ObjectTypeTag;
+
+typedef struct {
+ GC_ObjectTypeTag tag;
+ ushort numNonPointers;
+ ushort numPointers;
+} GC_ObjectType;
/* ------------------------------------------------- */
/* GC_frameLayout */
@@ -150,12 +117,24 @@
/* GC_stack */
/* ------------------------------------------------- */
-/*
- * Stacks with used == reserved are continuations.
- */
-typedef struct GC_stack {
- uint reserved; /* Number of bytes reserved for stack. */
- uint used; /* Number of bytes in use. */
+typedef struct GC_stack {
+ /* markTop and markIndex are only used during marking. They record the
+ * current pointer in the stack that is being followed. markTop points
+ * to the top of the stack frame containing the pointer and markI is the
+ * index in that frames frameOffsets of the pointer slot. So, when the
+ * GC pointer reversal gets back to the stack, it can continue with the
+ * next pointer (either in the current frame or the next frame).
+ */
+ pointer markTop;
+ W32 markIndex;
+ /* reserved is the number of bytes reserved for stack, i.e. its maximum
+ * size.
+ */
+ uint reserved;
+ /* used is the number of bytes in use by the stack.
+ * Stacks with used == reserved are continuations.
+ */
+ uint used;
/* The next address is the bottom of the stack, and the following
* reserved bytes hold space for the stack.
*/
@@ -185,169 +164,181 @@
/* General note:
* stackBottom, stackLimit, and stackTop are computed from
- * s->currentThread->stack. It is expected that MLton side effects these
+ * s->currentThread->stack. It is expected that the mutator side effects these
* directly rather than mucking with s->currentThread->stack. Upon entering
* the runtime system, the GC will update s->currentThread->stack based on
* these values so that everything is consistent.
- *
- * If you change the order of the fields in this struct, then you must update
- * x86-mlton.fun with the new offsets.
*/
+
typedef struct GC_state {
/* These fields are at the front because they are the most commonly
- * referenced.
+ * referenced, and having them at smaller offsets may decrease code size.
*/
pointer frontier; /* base <= frontier < limit */
pointer limit; /* end of from space */
pointer stackTop;
pointer stackLimit; /* stackBottom + stackSize - maxFrameSize */
- GC_thread currentThread; /* This points to a thread in the heap. */
- /* heap */
- uint fromSize; /* size (bytes) of from space */
+ pointer back; /* Points at next available word in toSpace. */
pointer base; /* start (lowest address) of from space */
- uint toSize; /* size (bytes) of to space */
- pointer toBase; /* start (lowest address) of to space */
- pointer limitPlusSlop; /* limit + LIMIT_SLOP */
-
- /* globals */
- uint numGlobals;
- pointer *globals; /* an array of size numGlobals */
-
- /* savedThread is only set while either
- * - executing a signal handler. It is set to the thread that was
- * running when the signal arrived.
- * - calling switchToThread, in which case it is set to the thread
- * that called switchToThread
- */
- GC_thread savedThread;
-
- /* Stack in current thread */
- pointer stackBottom;
- uint maxFrameSize;
- uint maxFrameIndex; /* 0 <= frameIndex < maxFrameIndex */
- GC_frameLayout *frameLayouts;
- /* GC_init computes frameLayout index using native codegen style. */
- bool native;
-
- /* Print out a message at the start and end of each gc. */
- bool messages;
-
+ ullong bytesAllocated;
+ ullong bytesCopied;
+ int bytesLive; /* Number of bytes copied by most recent GC. */
+ GC_thread currentThread; /* This points to a thread in the heap. */
/* The dfs stack is only used during the depth-first-search of an
* object. This is used in computing the size of an object.
* Top points at the next free space.
*/
- pointer dfsTop;
pointer dfsBottom;
-
- /* serializeStart holds the frontier at the start of the serialized
- * object during object serialization.
- */
- pointer serializeStart;
-
- /* only used during GC */
- int bytesLive; /* Number of bytes copied by most recent GC. */
- pointer back; /* Points at next available word in toSpace. */
- pointer toLimit; /* End of tospace. */
-
- /* Memory */
- uint totalRam; /* bytes */
- uint totalSwap; /* bytes */
+ pointer dfsTop;
+ uint forwardSize;
+ GC_frameLayout *frameLayouts;
+ uint fromSize; /* Size (bytes) of from space. */
+ pointer *globals; /* An array of size numGlobals. */
uint halfMem; /* bytes */
uint halfRam; /* bytes */
+ bool inSignalHandler; /* TRUE iff a signal handler is running. */
+ /* canHandle == 0 iff GC may switch to the signal handler
+ * thread. This is used to implement critical sections.
+ */
+ volatile int canHandle;
+ bool isOriginal;
+ pointer limitPlusSlop; /* limit + LIMIT_SLOP */
uint liveThresh1;
uint liveThresh2;
uint liveThresh3;
- bool useFixedHeap; /* if true, then don't resize the heap */
- uint maxHeap; /* if zero, then unlimited, else limit total heap */
-
- /* ------------------------------------------------- */
- /* loadWorld */
- /* ------------------------------------------------- */
- bool translateUp; /* used by translateHeap */
- uint translateDiff; /* used by translateHeap */
- uint magic; /* The magic number required for a valid world file. */
-
- /* ------------------------------------------------- */
- /* Signals */
- /* ------------------------------------------------- */
- volatile int canHandle; /* == 0 iff GC can switch to the signal handler
- * thread. This is used to implement critical
- * sections.
- */
- GC_thread signalHandler;/* The signal handler thread. */
- sigset_t signalsHandled;/* The signals handler expects to be handled. */
- volatile bool signalIsPending; /* TRUE iff a signal has been received but not
- * processed.
- */
- sigset_t signalsPending;/* The signals that need to be handled. */
- bool inSignalHandler; /* TRUE iff a signal handler is running. */
-
- /* ------------------------------------------------- */
- /* gc-summary statistics */
- /* ------------------------------------------------- */
- bool summary; /* print a summary of gc info when the program is done */
- ullong bytesAllocated;
- ullong bytesCopied;
- uint numGCs;
- ullong numLCs;
- struct rusage ru_gc; /* total resource usage spent in gc */
- uint maxPause; /* max time spent in any gc in milliseconds. */
- uint startTime; /* the time when GC_init or GC_loadWorld is called */
+ uint magic; /* The magic number required for a valid world file. */
+ uint markSize;
+ uint maxBytesLive;
+ uint maxFrameIndex; /* 0 <= frameIndex < maxFrameIndex */
+ uint maxFrameSize;
+ uint maxHeap; /* if zero, then unlimited, else limit total heap */
uint maxHeapSizeSeen;
+ uint maxObjectTypeIndex; /* 0 <= typeIndex < maxObjectTypeIndex */
+ uint maxPause; /* max time spent in any gc in milliseconds. */
uint maxStackSizeSeen;
- uint maxBytesLive;
- float ramSlop;
- bool isOriginal;
+ bool messages; /* Print out a message at the start and end of each gc. */
+ /* native is true iff the native codegen was used.
+ * The GC needs to know this because it affects how it finds the
+ * layout of stack frames.
+ */
+ bool native;
+ uint numGCs; /* Total number of GCs done. */
+ uint numGlobals; /* Number of pointers in globals array. */
+ ullong numLCs;
+ GC_ObjectType *objectTypes; /* Array of object types. */
uint pageSize; /* bytes */
+ float ramSlop;
+ struct rusage ru_gc; /* total resource usage spent in gc */
+ /* savedThread is only set
+ * when executing a signal handler. It is set to the thread that
+ * was running when the signal arrived.
+ * or by GC_copyThread and GC_copyCurrentThread, which used it to store
+ * their result.
+ */
+ GC_thread savedThread;
+ /* Save globals writes out the values of all of the globals to fd. */
+ void (*saveGlobals)(int fd);
+ /* serializeStart holds the frontier at the start of the serialized
+ * object during object serialization.
+ */
+ pointer serializeStart;
+ GC_thread signalHandler; /* The mutator signal handler thread. */
+ sigset_t signalsHandled; /* The signals handler expects to be handled. */
+ /* signalIsPending is TRUE iff a signal has been received but not
+ * processed by the mutator signal handler.
+ */
+ volatile bool signalIsPending;
+ /* The signals that have been recieved but not processed by the mutator
+ * signal handler.
+ */
+ sigset_t signalsPending;
+ pointer stackBottom; /* The bottom of the stack in the current thread. */
+ uint startTime; /* The time when GC_init or GC_loadWorld was called. */
+ /* If summary is TRUE, then print a summary of gc info when the program
+ * is done .
+ */
+ bool summary;
+ pointer toBase; /* The start (lowest address) of to space. */
+ pointer toLimit; /* The end of tospace. */
+ uint toSize; /* size (bytes) of to space */
+ uint totalRam; /* bytes */
+ uint totalSwap; /* bytes */
+ uint translateDiff; /* used by translateHeap */
+ bool translateUp; /* used by translateHeap */
+ bool useFixedHeap; /* if true, then don't resize the heap */
} *GC_state;
-/* ------------------------------------------------- */
-/* Initialization */
-/* ------------------------------------------------- */
+static inline uint wordAlign(uint p) {
+ return ((p + 3) & ~ 3);
+}
-/* GC_init must be called before doing any allocation.
- * It must also be called before MLTON_init, GC_createStrings, and GC_createIntInfs.
- * Before calling GC_init, you must initialize:
- * numGlobals
- * globals
- * maxFrameSize
- * maxFrameIndex
- * frameLayouts
- * native
- * useFixedHeap
- * if (useFixedHeap)
- * then fromSize should be set to the semispace size
- * else fromSize be set to the initial amount of live data that will be placed
- * into the heap (e.g. with GC_createStrings). The initial heap size will
- * be set to fromSize * s->liveRatio.
- * maxHeapSize should be set to 0 if you want it to be figured out
- * automatically, otherwise set it to what you want.
+static inline bool isWordAligned(uint x) {
+ return 0 == (x & 0x3);
+}
+
+/*
+ * fixedGetrusage() works just like getrusage() except that it actually works.
+ * I.e., it does not suffer from the Linux kernel bugs associated with the user
+ * and system times.
*/
-int GC_init(GC_state s, int argc, char **argv,
- void (*loadGlobals)(FILE *file));
+int fixedGetrusage(int who, struct rusage *rup);
+
+/* ---------------------------------------------------------------- */
+/* GC functions */
+/* ---------------------------------------------------------------- */
+
+/* Allocate an array with the specified header and number of elements.
+ * Also ensure that frontier + bytesNeeded < limit after the array is allocated.
+ */
+pointer GC_arrayAllocate (GC_state s, W32 bytesNeeded, W32 numElts,
+ W32 header);
+
+/* The array size is stored before the header */
+static inline uint* GC_arrayNumElementsp (pointer a) {
+ return ((uint*)a - 2);
+}
+
+static inline int GC_arrayNumElements (pointer a) {
+ return *(GC_arrayNumElementsp (a));
+}
+
+static inline void GC_arrayShrink (pointer array, uint numElements) {
+ *GC_arrayNumElementsp (array) = numElements;
+}
+
+/* GC_copyThread (s, t) copies the thread pointed to by t and places the
+ * result in s->savedThread.
+ */
+void GC_copyThread (GC_state s, GC_thread t);
+/* GC_copyThread (s) copies the current thread, s->currentThread, and places
+ * the result in s->savedThread.
+ */
+void GC_copyCurrentThread (GC_state s);
+
+/* GC_createStrings allocates a collection of strings in the heap.
+ * It assumes that there is enough space.
+ * The inits array should be NULL terminated,
+ * i.e.the final element should be {0, NULL, 0}.
+ */
struct GC_stringInit {
uint globalIndex;
char *str;
uint size;
};
+void GC_createStrings (GC_state s, struct GC_stringInit inits[]);
-/* The inits array should be NULL terminated.
- * I.E. the final element should be {0, NULL, 0}.
- */
-void GC_createStrings(GC_state s, struct GC_stringInit inits[]);
+/* GC_deseralize returns the deserialization of the word8vector. */
+/* pointer GC_deserialize (GC_state s, pointer word8vector); */
-/*
- * The function fixedGetrusage() works just like getrusage() except
- * that it actually works. I.e., it does not suffer from the Linux
- * kernel bugs associated with the user and system times.
- */
-int fixedGetrusage(int who, struct rusage *rup);
+/* GC_display (s, str) prints out the state s to stream str. */
+void GC_display (GC_state s, FILE *stream);
-/* ------------------------------------------------- */
-/* GC_done */
-/* ------------------------------------------------- */
+/* GC_doGC is for use by GC related functions only. External callers should
+ * use GC_gc.
+ */
+void GC_doGC (GC_state s, uint bytesRequested, uint stackBytesRequested);
/* GC_done should be called after the program is done.
* munmaps heap and stack.
@@ -355,121 +346,121 @@
*/
void GC_done (GC_state s);
-/* ------------------------------------------------- */
-/* GC_gc */
-/* ------------------------------------------------- */
-
-void GC_doGC (GC_state s, uint bytesRequested, uint stackBytesRequested);
+/* GC_enter is fo use by GC functions only.
+ * It is called when transitioning from the mutator to the GC.
+ */
void GC_enter (GC_state s);
-void GC_leave(GC_state s);
-/* Do a gc.
+/* GC_finishHandler should be called by the mutator signal handler thread when
+ * it is done handling the signal.
+ */
+void GC_finishHandler (GC_state s);
+
+/* GC_foreachPointerInObject (s, f, p) applies f to each pointer in the object
+ * pointer to by p.
+ */
+typedef void (*GC_pointerFun)(GC_state s, pointer *p);
+pointer GC_foreachPointerInObject(GC_state s, GC_pointerFun f, pointer p);
+
+void GC_fromSpace (GC_state s);
+
+/* GC_gc does a gc.
* This will also resize the stack if necessary.
* It will also switch to the signal handler thread if there is a pending signal.
*/
void GC_gc (GC_state s, uint bytesRequested, bool force,
string file, int line);
-/* ------------------------------------------------- */
-/* GC_size */
-/* ------------------------------------------------- */
-
-/* Return the amount of heap space taken by the object pointed to by root. */
-uint GC_size (GC_state s, pointer root);
-
-/* ------------------------------------------------- */
-/* Serialization */
-/* ------------------------------------------------- */
+/* GC_getHeaderp returns a pointer to the header for the object pointed to by
+ * p.
+ */
+static inline Header* GC_getHeaderp (pointer p) {
+ return (Header*)(p - WORD_SIZE);
+}
-/* Return a serialized version of the object rooted at root. */
-/* pointer GC_serialize(GC_state s, pointer root); */
+/* GC_gerHeader returns the header for the object pointed to by p. */
+static inline Header GC_getHeader (pointer p) {
+ return *(GC_getHeaderp(p));
+}
-/* Return the deserialization of the word8vector pointed to by pointer */
-/* pointer GC_deserialize(GC_state s, pointer word8vector); */
+/* GC_handler is the baked-in C signal handler.
+ * It causes the next limit check to fail by setting s->limit to zero.
+ * This, in turn, will cause the GC to run the SML signal handler.
+ */
+void GC_handler (GC_state s, int signum);
-/* ------------------------------------------------- */
-/* Arrays */
-/* ------------------------------------------------- */
+/* GC_init must be called before doing any allocation.
+ * It must also be called before MLTON_init, GC_createStrings, and GC_createIntInfs.
+ * Before calling GC_init, you must initialize:
+ * numGlobals
+ * globals
+ * maxFrameSize
+ * maxFrameIndex
+ * frameLayouts
+ * native
+ * useFixedHeap
+ * if (useFixedHeap)
+ * then fromSize should be set to the semispace size
+ * else fromSize be set to the initial amount of live data that will be placed
+ * into the heap (e.g. with GC_createStrings). The initial heap size will
+ * be set to fromSize * s->liveRatio.
+ * maxHeapSize should be set to 0 if you want it to be figured out
+ * automatically, otherwise set it to what you want.
+ */
+int GC_init (GC_state s, int argc, char **argv,
+ void (*loadGlobals)(FILE *file));
-/* The array size is stored before the header */
-static inline uint* GC_arrayNumElementsp(pointer a) {
- return ((uint*)a - 2);
+/* GC_isPointer returns true if p looks like a pointer, i.e. if p = 0 mod 4. */
+static inline bool GC_isPointer (pointer p) {
+ return (0 == ((word)p & 0x3));
}
-static inline int GC_arrayNumElements(pointer a) {
- return *(GC_arrayNumElementsp(a));
+static inline bool GC_isValidFrontier (GC_state s, pointer frontier) {
+ return s->base <= frontier and frontier <= s->limit;
}
-static inline void GC_arrayShrink(pointer array, uint numElements) {
- *GC_arrayNumElementsp(array) = numElements;
+static inline bool GC_isValidSlot (GC_state s, pointer slot) {
+ return s->stackBottom <= slot
+ and slot < s->stackBottom + s->currentThread->stack->reserved;
}
-/* ------------------------------------------------- */
-/* Threads */
-/* ------------------------------------------------- */
-
-/* Both copyThread and copyCurrentThread place the copy in s->savedThread. */
-void GC_copyThread(GC_state s, GC_thread t);
-void GC_copyCurrentThread(GC_state s);
-void GC_threadSwitchTo(GC_state s, GC_thread t);
-
-/* ------------------------------------------------- */
-/* Worlds */
-/* ------------------------------------------------- */
+/* GC_leave is for use by GC functions only.
+ * It is called when transition from the GC to the mutator.
+ */
+void GC_leave (GC_state s);
-void GC_loadWorld(GC_state s,
+void GC_loadWorld (GC_state s,
char *fileName,
void (*loadGlobals)(FILE *file));
-void GC_saveWorld(GC_state s, int fd, void (*saveGlobals)(int fd));
-/* ------------------------------------------------- */
-/* GC_handler */
-/* ------------------------------------------------- */
+bool GC_mutatorInvariant (GC_state s);
-/* This is the baked-in signal handler. It causes the next limit check to fail.
+/*
+ * Build the header for an object, given the index to its type info.
*/
-void GC_handler(GC_state s, int signum);
+static inline word GC_objectHeader (W32 t) {
+ assert (t < TWOPOWER (TYPE_INDEX_BITS));
+ return 1 | (t << 1);
+}
-void GC_finishHandler (GC_state s);
+/* Write out the current world to the file descriptor. */
+void GC_saveWorld (GC_state s, int fd);
-/* ------------------------------------------------- */
-/* Misc */
-/* ------------------------------------------------- */
+/* Return a serialized version of the object rooted at root. */
+/* pointer GC_serialize(GC_state s, pointer root); */
-static inline bool GC_isValidFrontier(GC_state s, pointer frontier) {
- return s->base <= frontier and frontier <= s->limit;
-}
+void GC_setHeapParams (GC_state s, uint size);
-static inline bool GC_isValidSlot(GC_state s, pointer slot) {
- return s->stackBottom <= slot
- and slot < s->stackBottom + s->currentThread->stack->reserved;
-}
+void GC_setStack (GC_state s);
-typedef void (*GC_pointerFun)(GC_state s, pointer *p);
+/* Return the amount of heap space taken by the object pointed to by root. */
+uint GC_size (GC_state s, pointer root);
-void GC_display(GC_state s, FILE *stream);
-void GC_fromSpace(GC_state s);
-bool GC_mutatorInvariant(GC_state s);
-uint GC_objectSize(pointer p);
-void GC_setHeapParams(GC_state s, uint size);
-void GC_setStack(GC_state s);
-void GC_toSpace(GC_state s);
+void GC_toSpace (GC_state s);
/* Translate all pointers to the heap from within the stack and the heap for
* a heap that has moved from s->base == old to s->base.
*/
void GC_translateHeap(GC_state s, pointer from, pointer to, uint size);
-
-pointer GC_foreachPointerInObject(GC_state s, GC_pointerFun f, pointer p);
-
-/* Return a pointer to the header for the object pointed to by p. */
-static inline word* GC_getHeaderp(pointer p) {
- return (word*)(p - WORD_SIZE);
-}
-
-/* Return the header for the object pointed to by p. */
-static inline word GC_getHeader(pointer p) {
- return *(GC_getHeaderp(p));
-}
#endif /* #ifndef _MLTON_GC_H */
1.5 +81 -207 mlton/runtime/basis/IntInf.c
Index: IntInf.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/IntInf.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- IntInf.c 23 Jun 2002 01:37:54 -0000 1.4
+++ IntInf.c 6 Jul 2002 17:22:08 -0000 1.5
@@ -8,14 +8,17 @@
#include "gmp.h"
#include "IntInf.h"
+#include <stddef.h> /* for offsetof */
#include <string.h>
+/* Import the global gcState so we can get and set the frontier. */
+extern struct GC_state gcState;
/*
- * Second header word for bignums and strings.
+ * Third header word for bignums and strings.
*/
-#define BIGMAGIC GC_arrayHeader(4, 0)
-#define STRMAGIC GC_arrayHeader(1, 0)
+#define BIGMAGIC GC_objectHeader(WORD_VECTOR_TYPE_INDEX)
+#define STRMAGIC GC_objectHeader(STRING_TYPE_INDEX)
/*
@@ -23,7 +26,8 @@
* the chars member.
*/
typedef struct strng {
- uint card, /* number of chars */
+ uint counter, /* used by GC. */
+ card, /* number of chars */
magic; /* STRMAGIC */
char chars[0]; /* actual chars */
} strng;
@@ -34,7 +38,8 @@
* the isneg member.
*/
typedef struct bignum {
- uint card, /* one more than the number of limbs */
+ uint counter, /* used by GC. */
+ card, /* one more than the number of limbs */
magic, /* BIGMAGIC */
isneg; /* iff bignum is negative */
ulong limbs[0]; /* big digits, least significant first */
@@ -52,35 +57,6 @@
/*
- * Convert a pointer to a strng pointer.
- */
-static inline strng *
-toString(pointer arg)
-{
- strng *sp;
-
- assert(not isSmall(arg));
- sp = (strng *)((uint)arg - 2*sizeof(uint));
- assert(sp->magic == STRMAGIC);
- return (sp);
-}
-
-
-/*
- * Convert frontier space to a strng pointer and intialize card and magic.
- */
-static inline strng *
-initFrontierAsStrng(pointer frontier, uint bytes)
-{
- strng *sp;
-
- sp = (strng*)frontier;
- sp->card = (bytes - 8);
- sp->magic = STRMAGIC;
- return (sp);
-}
-
-/*
* Convert a bignum intInf to a bignum pointer.
*/
static inline bignum *
@@ -89,27 +65,13 @@
bignum *bp;
assert(not isSmall(arg));
- bp = (bignum *)((uint)arg - 2*sizeof(uint));
+ bp = (bignum *)((uint)arg - offsetof(struct bignum, isneg));
assert(bp->magic == BIGMAGIC);
return (bp);
}
/*
- * Convert frontier space to a bignum pointer and intialize card and magic.
- */
-static inline bignum *
-initFrontierAsBignum(pointer frontier, uint bytes)
-{
- bignum *bp;
-
- bp = (bignum*)frontier;
- bp->card = (bytes - 8) / 4;
- bp->magic = BIGMAGIC;
- return (bp);
-}
-
-/*
* Given an intInf, a pointer to an __mpz_struct and something large enough
* to contain 2 limbs, fill in the __mpz_struct.
*/
@@ -142,15 +104,20 @@
* Initialize an __mpz_struct to use the space provided by an ML array.
*/
static inline void
-init(bignum *bp, __mpz_struct *mpzp)
+initRes(__mpz_struct *mpzp, uint bytes)
{
- assert(bp->card > 1);
- mpzp->_mp_alloc = bp->card - 1;
- mpzp->_mp_size = 0;
+ struct bignum *bp;
+
+ assert(bytes <= gcState.limitPlusSlop - gcState.frontier);
+ bp = (bignum*)gcState.frontier;
+ /* We have as much space for the limbs as there is to the end of the
+ * heap. Divide by 4 to get number of words.
+ */
+ mpzp->_mp_alloc = (gcState.limitPlusSlop - (pointer)bp->limbs) / 4;
+ mpzp->_mp_size = 0; /* is this necessary? */
mpzp->_mp_d = bp->limbs;
}
-
/*
* Count number of leading zeros. The argument will not be zero.
* This MUST be replaced with assembler.
@@ -171,25 +138,21 @@
/*
- * Given an __mpz_struct pointer which reflects the answer, and a
- * struct intInfRes_t pointer which is the actual answer, fill in the latter.
+ * Given an __mpz_struct pointer which reflects the answer, set gcState.frontier
+ * and return the answer.
* If the answer fits in a fixnum, we return that, with the frontier
* rolled back.
* If the answer doesn't need all of the space allocated, we adjust
* the array size and roll the frontier slightly back.
- * Note, this all assumes that the last thing allocated was the array
- * which is used for space by the __mpz_struct.
*/
-static void
-answer(__mpz_struct *ans, struct intInfRes_t *res)
+static pointer
+answer(__mpz_struct *ans)
{
bignum *bp;
int size;
- bp = (bignum *)&ans->_mp_d[-3];
+ bp = (bignum *)((pointer)ans->_mp_d - offsetof(struct bignum, limbs));
assert(ans->_mp_d == bp->limbs);
- assert(ans->_mp_alloc == bp->card - 1);
- assert(bp->magic == BIGMAGIC);
size = ans->_mp_size;
if (size < 0) {
bp->isneg = TRUE;
@@ -216,64 +179,54 @@
*/
ans = val;
if (val < (uint)1<<30) {
- ans = ans<<1 | 1;
- res->value = (pointer)ans;
- res->frontier = (pointer)bp;
- return;
+ return (pointer)(ans<<1 | 1);
}
}
- res->value = (pointer)&bp->isneg;
- res->frontier = (pointer)&bp->limbs[size];
- unless (size == ans->_mp_alloc)
- GC_arrayShrink((pointer)res->value, size+1);
+ gcState.frontier = (pointer)&bp->limbs[size];
+ assert(gcState.frontier <= gcState.limitPlusSlop);
+ bp->counter = 0;
+ bp->card = size + 1; /* +1 for isNeg word */
+ bp->magic = BIGMAGIC;
+ return (pointer)&bp->isneg;
}
-struct intInfRes_t *
-IntInf_do_add(pointer lhs, pointer rhs, uint bytes, pointer frontier)
+static pointer
+binary(pointer lhs, pointer rhs, uint bytes,
+ void(*binop)(__mpz_struct *resmpz,
+ __gmp_const __mpz_struct *lhsspace,
+ __gmp_const __mpz_struct *rhsspace))
{
- bignum *bp;
__mpz_struct lhsmpz,
rhsmpz,
resmpz;
mp_limb_t lhsspace[2],
rhsspace[2];
- static struct intInfRes_t res;
- bp = initFrontierAsBignum(frontier, bytes);
- /* assert(frontier == (pointer)&bp->limbs[bp->card - 1]); */
+ initRes(&resmpz, bytes);
fill(lhs, &lhsmpz, lhsspace);
fill(rhs, &rhsmpz, rhsspace);
- init(bp, &resmpz);
- mpz_add(&resmpz, &lhsmpz, &rhsmpz);
- assert((resmpz._mp_alloc < bp->card)
- and (resmpz._mp_d == bp->limbs));
- answer(&resmpz, &res);
- assert((pointer)bp <= res.frontier);
- return (&res);
+ binop(&resmpz, &lhsmpz, &rhsmpz);
+ return answer(&resmpz);
}
-struct intInfRes_t *
-IntInf_do_sub(pointer lhs, pointer rhs, uint bytes, pointer frontier)
+pointer IntInf_do_add(pointer lhs, pointer rhs, uint bytes)
{
- bignum *bp;
- __mpz_struct lhsmpz,
- rhsmpz,
- resmpz;
- mp_limb_t lhsspace[2],
- rhsspace[2];
- static struct intInfRes_t res;
+ return binary(lhs, rhs, bytes, &mpz_add);
+}
- bp = initFrontierAsBignum(frontier, bytes);
- /* assert(frontier == (pointer)&bp->limbs[bp->card - 1]); */
- fill(lhs, &lhsmpz, lhsspace);
- fill(rhs, &rhsmpz, rhsspace);
- init(bp, &resmpz);
- mpz_sub(&resmpz, &lhsmpz, &rhsmpz);
- assert((resmpz._mp_alloc < bp->card)
- and (resmpz._mp_d == bp->limbs));
- answer(&resmpz, &res);
- assert((pointer)bp <= res.frontier);
- return (&res);
+pointer IntInf_do_gcd(pointer lhs, pointer rhs, uint bytes)
+{
+ return binary(lhs, rhs, bytes, &mpz_gcd);
+}
+
+pointer IntInf_do_mul(pointer lhs, pointer rhs, uint bytes)
+{
+ return binary(lhs, rhs, bytes, &mpz_mul);
+}
+
+pointer IntInf_do_sub(pointer lhs, pointer rhs, uint bytes)
+{
+ return binary(lhs, rhs, bytes, &mpz_sub);
}
uint
@@ -286,30 +239,6 @@
return ((uint)(ullong)prod);
}
-struct intInfRes_t *
-IntInf_do_mul(pointer lhs, pointer rhs, uint bytes, pointer frontier)
-{
- bignum *bp;
- __mpz_struct lhsmpz,
- rhsmpz,
- resmpz;
- mp_limb_t lhsspace[2],
- rhsspace[2];
- static struct intInfRes_t res;
-
- bp = initFrontierAsBignum(frontier, bytes);
- /* assert(frontier == (pointer)&bp->limbs[bp->card - 1]); */
- fill(lhs, &lhsmpz, lhsspace);
- fill(rhs, &rhsmpz, rhsspace);
- init(bp, &resmpz);
- mpz_mul(&resmpz, &lhsmpz, &rhsmpz);
- assert((resmpz._mp_alloc < bp->card)
- and (resmpz._mp_d == bp->limbs));
- answer(&resmpz, &res);
- assert((pointer)bp <= res.frontier);
- return (&res);
-}
-
/*
* Return an integer which compares to 0 as the two intInf args compare
* to each other.
@@ -351,57 +280,44 @@
* Arg is an intInf, base is the base to use (2, 8, 10 or 16) and space is a
* string (mutable) which is large enough.
*/
-struct intInfRes_t *
-IntInf_do_toString(pointer arg, int base, uint bytes, pointer frontier)
+pointer
+IntInf_do_toString(pointer arg, int base, uint bytes)
{
strng *sp;
__mpz_struct argmpz;
mp_limb_t argspace[2];
char *str;
uint size;
- static struct intInfRes_t res;
assert(base == 2 || base == 8 || base == 10 || base == 16);
fill(arg, &argmpz, argspace);
- sp = initFrontierAsStrng(frontier, bytes);
+ sp = (strng*)gcState.frontier;
str = mpz_get_str(sp->chars, base, &argmpz);
assert(str == sp->chars);
size = strlen(str);
- assert(0 < size && size < sp->card);
if (*sp->chars == '-')
*sp->chars = '~';
- GC_arrayShrink((pointer)str, size);
- size += sizeof(pointer) - 1;
- size -= size % sizeof(pointer);
- /* assert(frontier >= &sp->chars[size]); */
- res.frontier = &sp->chars[size];
- res.value = (pointer)str;
- return (&res);
+ sp->counter = 0;
+ sp->card = size;
+ sp->magic = STRMAGIC;
+ gcState.frontier = &sp->chars[wordAlign(size)];
+ assert(gcState.frontier <= gcState.limitPlusSlop);
+ return (pointer)str;
}
-
-struct intInfRes_t *
-IntInf_do_neg(pointer arg, uint bytes, pointer frontier)
+pointer
+IntInf_do_neg(pointer arg, uint bytes)
{
- bignum *bp;
__mpz_struct argmpz,
resmpz;
mp_limb_t argspace[2];
- static struct intInfRes_t res;
- bp = initFrontierAsBignum(frontier, bytes);
- /* assert(frontier == (pointer)&bp->limbs[bp->card - 1]); */
+ initRes(&resmpz, bytes);
fill(arg, &argmpz, argspace);
- init(bp, &resmpz);
mpz_neg(&resmpz, &argmpz);
- assert((resmpz._mp_alloc < bp->card)
- and (resmpz._mp_d == bp->limbs));
- answer(&resmpz, &res);
- assert((pointer)bp <= res.frontier);
- return (&res);
+ return answer(&resmpz);
}
-
/*
* Quotient (round towards 0, remainder is returned by IntInf_rem).
* space is a word array with enough space for the quotient
@@ -415,10 +331,9 @@
* num is the numerator bignum, den is the denominator and frontier is
* the current frontier.
*/
-struct intInfRes_t *
-IntInf_do_quot(pointer num, pointer den, uint bytes, pointer frontier)
+pointer
+IntInf_do_quot(pointer num, pointer den, uint bytes)
{
- bignum *spbp;
__mpz_struct resmpz,
nmpz,
dmpz;
@@ -432,11 +347,8 @@
qsize;
bool resIsNeg;
uint shift;
- static struct intInfRes_t res;
- spbp = initFrontierAsBignum(frontier, bytes);
- /* assert(frontier == (pointer)&spbp->limbs[spbp->card - 1]); */
- init(spbp, &resmpz);
+ initRes(&resmpz, bytes);
fill(num, &nmpz, nss);
resIsNeg = FALSE;
nsize = nmpz._mp_size;
@@ -455,11 +367,8 @@
or (nsize >= dsize && nmpz._mp_d[nsize - 1] != 0));
qsize = 1 + nsize - dsize;
if (dsize == 1) {
- if (nsize == 0) {
- res.value = (pointer)1; /* tagged 0 */
- res.frontier = (pointer)spbp;
- return (&res);
- }
+ if (nsize == 0)
+ return (pointer)1; /* tagged 0 */
mpn_divrem_1(resmpz._mp_d,
(mp_size_t)0,
nmpz._mp_d,
@@ -472,7 +381,6 @@
shift = leadingZeros(dmpz._mp_d[dsize - 1]);
if (shift == 0) {
dp = dmpz._mp_d;
- assert(&np[nsize] <= &spbp->limbs[spbp->card - 1]);
memcpy((void *)np,
nmpz._mp_d,
nsize * sizeof(*nmpz._mp_d));
@@ -481,7 +389,6 @@
unless (carry == 0)
np[nsize++] = carry;
dp = &np[nsize];
- assert(&dp[dsize] <= &spbp->limbs[spbp->card - 1]);
mpn_lshift(dp, dmpz._mp_d, dsize, shift);
}
carry = mpn_divrem(resmpz._mp_d,
@@ -495,9 +402,7 @@
resmpz._mp_d[qsize++] = carry;
}
resmpz._mp_size = resIsNeg ? - qsize : qsize;
- answer(&resmpz, &res);
- assert((pointer)spbp <= res.frontier);
- return (&res);
+ return answer(&resmpz);
}
@@ -514,10 +419,9 @@
* num is the numerator bignum, den is the denominator and frontier is
* the current frontier.
*/
-struct intInfRes_t *
-IntInf_do_rem(pointer num, pointer den, uint bytes, pointer frontier)
+pointer
+IntInf_do_rem(pointer num, pointer den, uint bytes)
{
- bignum *spbp;
__mpz_struct resmpz,
nmpz,
dmpz;
@@ -529,11 +433,8 @@
dsize;
bool resIsNeg;
uint shift;
- static struct intInfRes_t res;
- spbp = initFrontierAsBignum(frontier, bytes);
- /* assert(frontier == (pointer)&spbp->limbs[spbp->card - 1]); */
- init(spbp, &resmpz);
+ initRes(&resmpz, bytes);
fill(num, &nmpz, nss);
nsize = nmpz._mp_size;
resIsNeg = nsize < 0;
@@ -562,7 +463,6 @@
shift = leadingZeros(dmpz._mp_d[dsize - 1]);
if (shift == 0) {
dp = dmpz._mp_d;
- assert(&resmpz._mp_d[nsize] <= &spbp->limbs[spbp->card - 1]);
memcpy((void *)resmpz._mp_d,
(void *)nmpz._mp_d,
nsize * sizeof(*nmpz._mp_d));
@@ -574,7 +474,6 @@
unless (carry == 0)
resmpz._mp_d[nsize++] = carry;
dp = &resmpz._mp_d[nsize];
- assert(&dp[dsize] <= &spbp->limbs[spbp->card - 1]);
mpn_lshift(dp, dmpz._mp_d, dsize, shift);
}
mpn_divrem(&resmpz._mp_d[dsize],
@@ -595,36 +494,10 @@
}
}
resmpz._mp_size = resIsNeg ? - nsize : nsize;
- answer(&resmpz, &res);
- assert((pointer)spbp <= res.frontier);
- return (&res);
+ return answer(&resmpz);
}
-struct intInfRes_t *
-IntInf_do_gcd(pointer lhs, pointer rhs, uint bytes, pointer frontier)
-{
- bignum *bp;
- __mpz_struct lhsmpz,
- rhsmpz,
- resmpz;
- mp_limb_t lhsspace[2],
- rhsspace[2];
- static struct intInfRes_t res;
-
- bp = initFrontierAsBignum(frontier, bytes);
- /* assert(frontier == (pointer)&bp->limbs[bp->card - 1]); */
- fill(lhs, &lhsmpz, lhsspace);
- fill(rhs, &rhsmpz, rhsspace);
- init(bp, &resmpz);
- mpz_gcd(&resmpz, &lhsmpz, &rhsmpz);
- assert((resmpz._mp_alloc < bp->card)
- and (resmpz._mp_d == bp->limbs));
- answer(&resmpz, &res);
- assert((pointer)bp <= res.frontier);
- return (&res);
-}
-
/*
* For each entry { globalIndex, mlstr} in the inits array (which is terminated
* by one with an mlstr of NULL), set
@@ -706,6 +579,7 @@
}
}
state->globals[inits->globalIndex] = (pointer)&bp->isneg;
+ bp->counter = 0;
bp->card = alen + 1;
bp->magic = BIGMAGIC;
bp->isneg = neg;
1.2 +4 -2 mlton/runtime/basis/Int/quot.c
Index: quot.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/quot.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- quot.c 18 Jul 2001 05:51:06 -0000 1.1
+++ quot.c 6 Jul 2002 17:22:08 -0000 1.2
@@ -1,14 +1,16 @@
+#include <stdio.h>
+
#include "mlton-basis.h"
Int Int_quot(Int numerator, Int denominator) {
register int eax asm("ax");
-
+
eax = numerator ;
__asm__ __volatile__ ("cdq\n idivl %1"
:
: "r" (eax), "m" (denominator)
: "eax", "edx");
-
+
return eax;
}
1.2 +3 -3 mlton/runtime/basis/MLton/exit.c
Index: exit.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/MLton/exit.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- exit.c 18 Jul 2001 05:51:06 -0000 1.1
+++ exit.c 6 Jul 2002 17:22:08 -0000 1.2
@@ -3,7 +3,7 @@
extern struct GC_state gcState;
-void MLton_exit(int status) {
- GC_done(&gcState);
- exit(status);
+void MLton_exit (int status) {
+ GC_done (&gcState);
+ exit (status);
}
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Got root? We do.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel