[MLton-devel] cvs commit: C codegen cleanup
Stephen Weeks
sweeks@users.sourceforge.net
Tue, 13 May 2003 19:50:12 -0700
sweeks 03/05/13 19:50:12
Modified: doc/examples/ffi ffi.h
mlton/backend backend.fun machine.fun mtype.fun rssa.fun
runtime.fun runtime.sig ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun c-codegen.sig
mlton/codegen/x86-codegen x86-codegen.fun x86-codegen.sig
x86-mlton-basic.fun x86-mlton.fun
mlton/control control.sig control.sml
mlton/core-ml lookup-constant.fun
mlton/main compile.sml
runtime basis-constants.h gc.c gc.h
Added: include c-chunk.h c-common.h c-main.h main.h x86-main.h
Removed: include ccodegen.h codegen.h mlton.h x86codegen.h
Log:
Fixed bug that Mike Thomas found with _Thread_returnToC begin
undefined on Cygwin. It was a problem with a missing "_" in
x86-main.h.
Moved the implementation of Array_length and Vector_length from the
codegens to the backend.
Starting moving the implementation of Runtime.GCField from the
codegens to the backend. It works with the C codegen, but the native
codegen needs to be fixed to handle the new kinds of operands (offsets
of GCState). For now, the backend switches on which codegen is being
used and generates the appropriate operand. Once the native codegen
is updated, we should eliminate the switches and the
Machine.Operand.Runtime variant.
Added a new Runtime.GCField, ExnStack, and a new field to GC_state,
exnStack, which stores the current exception stack value. This made
it easy to avoid complexities with accessing
s->currentThread->exnStack.
Reorganized the include directory to make it more clear what gets
included for each codegen. Cleaned up the include file (now called
c-chunk.h) that goes in every file containing a C chunk generated by
the C codegen. This file includes a lot less than it used to. This
is in conjunction with turning on the code in the C codegen to output
the prototypes for all FFI functions that are called. What this means
is that now when compiling -native false with FFI calls, there is no
need to include any other files in the C files being compiled, which
cleans up a long-standing problem.
Eventually, I'd like to move toward eliminating all knowledge in the
codegens about ExnStack, Frontier, StackBottom, and StackTop (except
for possibly some optimization hints). Looking at c-chunk.h, there
are only a few uses left, corresponding to stack slots, object
allocation, stack push/pop, and return/raise.
Revision Changes Path
1.2 +1 -1 mlton/doc/examples/ffi/ffi.h
Index: ffi.h
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/ffi.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ffi.h 20 Jul 2001 17:01:38 -0000 1.1
+++ ffi.h 14 May 2003 02:50:10 -0000 1.2
@@ -1,6 +1,6 @@
/* ffi.h */
-#include "mlton.h"
+#include "libmlton.h"
#define BOOL0 0
#define BOOL1 1
1.1 mlton/include/c-chunk.h
Index: c-chunk.h
===================================================================
#ifndef _C_CHUNK_H_
#define _C_CHUNK_H_
#include "my-lib.h"
#include "c-common.h"
#define WORD_SIZE 4
#ifndef DEBUG_CCODEGEN
#define DEBUG_CCODEGEN FALSE
#endif
typedef unsigned char Char;
typedef double Double;
typedef int Int;
typedef char *Pointer;
typedef unsigned long Word32;
typedef Word32 Word;
typedef unsigned long long Word64;
#define Bool Int
extern Char CReturnC;
extern Double CReturnD;
extern Int CReturnI;
extern Char *CReturnP;
extern Word CReturnU;
extern struct cont (*nextChunks []) ();
extern Int nextFun;
extern Int returnToC;
extern struct GC_state gcState;
extern Char globaluchar[];
extern Double globaldouble[];
extern Int globalint[];
extern Pointer globalpointer[];
extern Word globaluint[];
extern Pointer globalpointerNonRoot[];
#define GCState ((Pointer)&gcState)
#define ExnStack *(Word*)(GCState + ExnStackOffset)
#define Frontier *(Word*)(GCState + FrontierOffset)
#define StackBottom *(Word*)(GCState + StackBottomOffset)
#define StackTop *(Word*)(GCState + StackTopOffset)
#define IsInt(p) (0x3 & (int)(p))
#define BZ(x, l) \
do { \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: BZ(%d, %s)\n", \
__FILE__, __LINE__, (x), #l); \
if (0 == (x)) goto l; \
} while (0)
#define BNZ(x, l) \
do { \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: BNZ(%d, %s)\n", \
__FILE__, __LINE__, (x), #l); \
if (x) goto l; \
} while (0)
/* ------------------------------------------------- */
/* Chunk */
/* ------------------------------------------------- */
#define Chunk(n) \
DeclareChunk(n) { \
struct cont cont; \
int l_nextFun = nextFun;
#define ChunkSwitch(n) \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: entering chunk %d l_nextFun = %d\n", \
__FILE__, __LINE__, n, l_nextFun); \
while (1) { \
top: \
switch (l_nextFun) {
#define EndChunk \
default: \
/* interchunk return */ \
nextFun = l_nextFun; \
cont.nextChunk = (void*)nextChunks[nextFun]; \
leaveChunk: \
return cont; \
} /* end switch (l_nextFun) */ \
} /* end while (1) */ \
} /* end chunk */
/* ------------------------------------------------- */
/* Calling SML from C */
/* ------------------------------------------------- */
#define Thread_returnToC() \
do { \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: Thread_returnToC()\n", \
__FILE__, __LINE__); \
returnToC = TRUE; \
return cont; \
} while (0)
/* ------------------------------------------------- */
/* farJump */
/* ------------------------------------------------- */
#define FarJump(n, l) \
do { \
PrepFarJump(n, l); \
goto leaveChunk; \
} while (0)
/* ------------------------------------------------- */
/* Globals */
/* ------------------------------------------------- */
#define Global(ty, i) (global ## ty [ i ])
#define GC(i) Global(uchar, i)
#define GD(i) Global(double, i)
#define GI(i) Global(int, i)
#define GP(i) Global(pointer, i)
#define GPNR(i) Global(pointerNonRoot, i)
#define GU(i) Global(uint, i)
/* ------------------------------------------------- */
/* Registers */
/* ------------------------------------------------- */
#define Declare(ty, name, i) ty Reg(name, i)
#define DC(n) Declare(Char, c, n)
#define DD(n) Declare(Double, d, n)
#define DI(n) Declare(Int, i, n)
#define DP(n) Declare(Pointer, p, n)
#define DU(n) Declare(Word, u, n)
#define Reg(name, i) local ## name ## i
#define RC(n) Reg(c, n)
#define RD(n) Reg(d, n)
#define RI(n) Reg(i, n)
#define RP(n) Reg(p, n)
#define RU(n) Reg(u, n)
/* ------------------------------------------------- */
/* Memory */
/* ------------------------------------------------- */
#define Offset(ty, b, o) (*(ty*)((b) + (o)))
#define OC(b, i) Offset(Char, b, i)
#define OD(b, i) Offset(Double, b, i)
#define OI(b, i) Offset(Int, b, i)
#define OP(b, i) Offset(Pointer, b, i)
#define OU(b, i) Offset(Word, b, i)
#define Contents(t, x) (*(t*)(x))
#define CC(x) Contents(Char, x)
#define CD(x) Contents(Double, x)
#define CI(x) Contents(Int, x)
#define CP(x) Contents(Pointer, x)
#define CU(x) Contents(Word, x)
/* ------------------------------------------------- */
/* Stack */
/* ------------------------------------------------- */
#define Slot(ty, i) *(ty*)(StackTop + (i))
#define SC(i) Slot(Char, i)
#define SD(i) Slot(Double, i)
#define SI(i) Slot(Int, i)
#define SP(i) Slot(Pointer, i)
#define SU(i) Slot(Word, i)
#define Push(bytes) \
do { \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: Push (%d)\n", \
__FILE__, __LINE__, bytes); \
StackTop += (bytes); \
assert (StackBottom <= StackTop); \
} while (0)
#define Return() \
do { \
l_nextFun = *(Word*)(StackTop - WORD_SIZE); \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: Return() l_nextFun = %d\n", \
__FILE__, __LINE__, l_nextFun); \
goto top; \
} while (0)
#define Raise() \
do { \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: Raise\n", \
__FILE__, __LINE__); \
StackTop = StackBottom + ExnStack; \
Return(); \
} while (0) \
#define ProfileLabel(l) \
__asm__ __volatile__ (#l ## ":" : : )
#define SmallIntInf(n) ((Pointer)(n))
#define Object(x, h) \
do { \
*(Word*)Frontier = (h); \
x = Frontier + WORD_SIZE; \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: 0x%x = Object(%d)\n", \
__FILE__, __LINE__, x, h); \
} while (0)
#define EndObject(bytes) \
do { \
Frontier += (bytes); \
} while (0)
/* ------------------------------------------------- */
/* Arrays */
/* ------------------------------------------------- */
#define ArrayOffset(ty, b, i) (*(ty*)((b) + ((i) * sizeof(ty))))
#define XC(b, i) ArrayOffset (Char, b, i)
#define XD(b, i) ArrayOffset (Double, b, i)
#define XI(b, i) ArrayOffset (Int, b, i)
#define XP(b, i) ArrayOffset (Pointer, b, i)
#define XU(b, i) ArrayOffset (Word, b, i)
/* ------------------------------------------------- */
/* Char */
/* ------------------------------------------------- */
#define Char_lt(c1, c2) ((c1) < (c2))
#define Char_le(c1, c2) ((c1) <= (c2))
#define Char_gt(c1, c2) ((c1) > (c2))
#define Char_ge(c1, c2) ((c1) >= (c2))
#define Char_chr(c) ((Char)(c))
#define Char_ord(c) ((Int)(c))
/* ------------------------------------------------- */
/* Cpointer */
/* ------------------------------------------------- */
#define Cpointer_isNull(x) (NULL == (void*)(x))
/* ------------------------------------------------- */
/* Int */
/* ------------------------------------------------- */
/* The old -DFAST_INT has been renamed to -DINT_JO. */
#if (defined (FAST_INT))
#define INT_JO
#endif
/* The default is to use INT_TEST. */
#if (! defined (INT_NO_CHECK) && ! defined (INT_JO) && ! defined (INT_TEST) && ! defined (INT_LONG))
#define INT_TEST
#endif
enum {
MAXINT = 0x7FFFFFFF,
MININT = (int)0x80000000,
MAXWORD = 0xFFFFFFFF,
};
#if (defined (INT_NO_CHECK))
#define Int_addCheck(dst, n1, n2, l) dst = n1 + n2
#define Int_mulCheck(dst, n1, n2, l) dst = n1 * n2
#define Int_negCheck(dst, n, l) dst = -n
#define Int_subCheck(dst, n1, n2, l) dst = n1 - n2
#define Word32_addCheck(dst, n1, n2, l) dst = n1 + n2
#define Word32_mulCheck(dst, n1, n2, l) dst = n1 * n2
#endif
#if (defined (INT_TEST))
#define Int_addCheckXC(dst, x, c, l) \
do { \
if (c >= 0) { \
if (x > MAXINT - c) \
goto l; \
} else if (x < MININT - c) \
goto l; \
dst = x + c; \
} while (0)
#define Int_addCheckCX(dst, c, x, l) Int_addCheckXC(dst, x, c, l)
#define Int_subCheckCX(dst, c, x, l) \
do { \
if (c >= 0) { \
if (x < c - MAXINT) \
goto l; \
} else if (x > c - MININT) \
goto l; \
dst = c - x; \
} while (0)
#define Int_subCheckXC(dst, x, c, l) \
do { \
if (c <= 0) { \
if (x > MAXINT + c) \
goto l; \
} else if (x < MININT + c) \
goto l; \
dst = x - c; \
} while (0)
#define Word32_addCheckXC(dst, x, c, l) \
do { \
if (x > MAXWORD - c) \
goto l; \
dst = x + c; \
} while (0)
#define Word32_addCheckCX(dst, c, x, l) Word32_addCheckXC(dst, x, c, l)
#define Int_addCheck Int_addCheckXC
#define Int_subCheck Int_subCheckXC
#define Word32_addCheck Word32_addCheckXC
#endif
static inline Int Int_addOverflow (Int lhs, Int rhs, Bool *overflow) {
long long tmp;
tmp = (long long)lhs + rhs;
*overflow = (tmp != (int)tmp);
return tmp;
}
static inline Int Int_mulOverflow (Int lhs, Int rhs, Bool *overflow) {
long long tmp;
tmp = (long long)lhs * rhs;
*overflow = (tmp != (int)tmp);
return tmp;
}
static inline Int Int_subOverflow (Int lhs, Int rhs, Bool *overflow) {
long long tmp;
tmp = (long long)lhs - rhs;
*overflow = (tmp != (int)tmp);
return tmp;
}
static inline Word32 Word32_addOverflow (Word32 lhs, Word32 rhs, Bool *overflow) {
Word64 tmp;
tmp = (Word64)lhs + rhs;
*overflow = (tmp != (Word32)tmp);
return tmp;
}
static inline Word32 Word32_mulOverflow (Word32 lhs, Word32 rhs, Bool *overflow) {
Word64 tmp;
tmp = (Word64)lhs * rhs;
*overflow = (tmp != (Word32)tmp);
return tmp;
}
#if (defined (INT_TEST) || defined (INT_LONG))
#define check(dst, n1, n2, l, f); \
do { \
int overflow; \
dst = f(n1, n2, &overflow); \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: " #f "(%d, %d) = %d\n", \
__FILE__, __LINE__, n1, n2, dst); \
if (overflow) { \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%s:%d: overflow\n", \
__FILE__, __LINE__); \
goto l; \
} \
} while (0)
#define Int_mulCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Int_mulOverflow)
#define Int_negCheck(dst, n, l) \
do { \
if (n == MININT) \
goto l; \
dst = -n; \
} while (0)
#define Word32_mulCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Word32_mulOverflow)
#endif
#if (defined (INT_LONG))
#define Int_addCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Int_addOverflow)
#define Int_subCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Int_subOverflow)
#define Word32_addCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Word32_addOverflow)
#endif
#if (defined (INT_JO))
static void MLton_overflow () {
die("Internal overflow detected. Halt.");
}
static inline Int Int_addCheckFast (Int n1, Int n2) {
__asm__ __volatile__ ("addl %1, %0\n\tjo MLton_overflow"
: "+r" (n1) : "g" (n2) : "cc");
return n1;
}
static inline Int Int_mulCheckFast (Int n1, Int n2) {
__asm__ __volatile__ ("imull %1, %0\n\tjo MLton_overflow"
: "+r" (n1) : "g" (n2) : "cc");
return n1;
}
static inline Int Int_negCheckFast (Int n) {
__asm__ __volatile__ ("negl %1\n\tjo MLton_overflow"
: "+r" (n) : : "cc" );
return n;
}
static inline Int Int_subCheckFast (Int n1, Int n2) {
__asm__ __volatile__ ("subl %1, %0\n\tjo MLton_overflow"
: "+r" (n1) : "g" (n2) : "cc" );
return n1;
}
static inline Word Word32_addCheckFast (Word n1, Word n2) {
__asm__ __volatile__ ("addl %1, %0\n\tjc MLton_overflow"
: "+r" (n1) : "g" (n2) : "cc");
return n1;
}
static inline Word Word32_mulCheckFast (Word n1, Word n2) {
__asm__ __volatile__ ("imull %1, %0\n\tjc MLton_overflow"
: "+r" (n1) : "g" (n2) : "cc");
return n1;
}
#define check(dst,n1,n2,l,f) dst = f(n1, n2)
#define Int_addCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Int_addCheckFast)
#define Int_mulCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Int_mulCheckFast)
#define Int_negCheck(dst, n, l) \
dst = Int_negCheckFast(n)
#define Int_subCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Int_subCheckFast)
#define Word32_addCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Word32_addCheckFast)
#define Word32_mulCheck(dst, n1, n2, l) \
check(dst, n1, n2, l, Word32_mulCheckFast)
#endif
#if (defined (INT_NO_CHECK) || defined (INT_JO) || defined (INT_LONG))
#define Int_addCheckCX Int_addCheck
#define Int_addCheckXC Int_addCheck
#define Int_subCheckCX Int_subCheck
#define Int_subCheckXC Int_subCheck
#define Word32_addCheckCX Word32_addCheck
#define Word32_addCheckXC Word32_addCheck
#endif
#define Int_add(n1, n2) ((n1) + (n2))
#define Int_mul(n1, n2) ((n1) * (n2))
#define Int_sub(n1, n2) ((n1) - (n2))
#define Int_lt(n1, n2) ((n1) < (n2))
#define Int_le(n1, n2) ((n1) <= (n2))
#define Int_gt(n1, n2) ((n1) > (n2))
#define Int_ge(n1, n2) ((n1) >= (n2))
#define Int_geu(x, y) ((Word)(x) >= (Word)(y))
#define Int_gtu(x, y) ((Word)(x) > (Word)(y))
#define Int_neg(n) (-(n))
/* ------------------------------------------------- */
/* MLton */
/* ------------------------------------------------- */
/* Used by polymorphic equality to implement equal on ground types
* like char, int, word, and on ref cells.
* It is emitted by backend/machine.fun.
*/
#define MLton_eq(x, y) ((x) == (y))
/* ------------------------------------------------- */
/* Real */
/* ------------------------------------------------- */
Double acos (Double x);
#define Real_Math_acos acos
Double asin (Double x);
#define Real_Math_asin asin
Double atan (Double x);
#define Real_Math_atan atan
Double atan2 (Double x, Double y);
#define Real_Math_atan2 atan2
Double cos (Double x);
#define Real_Math_cos cos
Double cosh (Double x);
#define Real_Math_cosh cosh
Double exp (Double x);
#define Real_Math_exp exp
Double log (Double x);
#define Real_Math_ln log
Double log10 (Double x);
#define Real_Math_log10 log10
Double pow (Double x, Double y);
#define Real_Math_pow pow
Double sin (Double x);
#define Real_Math_sin sin
Double sinh (Double x);
#define Real_Math_sinh sinh
Double sqrt (Double x);
#define Real_Math_sqrt sqrt
Double tan (Double x);
#define Real_Math_tan tan
Double tanh (Double x);
#define Real_Math_tanh tanh
#define Real_abs fabs
#define Real_add(x, y) ((x) + (y))
#define Real_copysign copysign
#define Real_div(x, y) ((x) / (y))
#define Real_equal(x1, x2) ((x1) == (x2))
#define Real_fromInt(n) ((Double)(n))
#define Real_ge(x1, x2) ((x1) >= (x2))
#define Real_gt(x1, x2) ((x1) > (x2))
Double ldexp (Double x, Int i);
#define Real_ldexp ldexp
#define Real_le(x1, x2) ((x1) <= (x2))
#define Real_lt(x1, x2) ((x1) < (x2))
#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))
Int Real_qequal (Double x1, Double x2);
Double Real_round (Double x);
#define Real_sub(x, y) ((x) - (y))
#define Real_toInt(x) ((int)(x))
typedef volatile union {
Word tab[2];
Double d;
} DoubleOr2Words;
static inline double Real_fetch (double *dp) {
DoubleOr2Words u;
Word32 *p;
p = (Word32*)dp;
u.tab[0] = p[0];
u.tab[1] = p[1];
return u.d;
}
static inline void Real_move (double *dst, double *src) {
Word32 *pd;
Word32 *ps;
Word32 t;
pd = (Word32*)dst;
ps = (Word32*)src;
t = ps[1];
pd[0] = ps[0];
pd[1] = t;
}
static inline void Real_store (double *dp, double d) {
DoubleOr2Words u;
Word32 *p;
p = (Word32*)dp;
u.d = d;
p[0] = u.tab[0];
p[1] = u.tab[1];
}
/* ------------------------------------------------- */
/* Word8 */
/* ------------------------------------------------- */
#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_div(w1, w2) ((w1) / (w2))
#define Word8_fromInt(x) ((Char)(x))
#define Word8_fromLargeWord(w) ((Char)(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_neg(w) (-(w))
#define Word8_notb(w) (~(w))
#define Word8_orb(w1, w2) ((w1) | (w2))
#define Word8_rol(x, y) ((x)>>(8-(y)) | ((x)<<(y)))
#define Word8_ror(x, y) ((x)>>(y) | ((x)<<(8-(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))
/* ------------------------------------------------- */
/* Word8Array */
/* ------------------------------------------------- */
#define Word8Array_subWord(a, i) (((Word*)(a))[i])
#define Word8Array_updateWord(a, i, w) ((Word*)(a))[i] = (w)
/* ------------------------------------------------- */
/* Word8Vector */
/* ------------------------------------------------- */
#define Word8Vector_subWord(a, i) (((Word*)(a))[i])
/* ------------------------------------------------- */
/* Word32 */
/* ------------------------------------------------- */
#define Word32_add(w1,w2) ((w1) + (w2))
#define Word32_andb(w1,w2) ((w1) & (w2))
/* The macro for Word32_arshift isn't ANSI C, because ANSI doesn't guarantee
* sign extension. We use it anyway cause it always seems to work.
* We do it because using a procedure call slows down IntInf by a factor of 2.
*/
#define Word32_arshift(w, s) ((int)(w) >> (s))
#define Word32_div(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_xorb(w1, w2) ((w1) ^ (w2))
#endif /* #ifndef _CCODEGEN_H_ */
1.1 mlton/include/c-common.h
Index: c-common.h
===================================================================
#ifndef _C_COMMON_H_
#define _C_COMMON_H_
#ifndef DEBUG_CCODEGEN
#define DEBUG_CCODEGEN FALSE
#endif
struct cont {
void *nextChunk;
};
#define ChunkName(n) Chunk ## n
#define DeclareChunk(n) \
struct cont ChunkName(n)(void)
#define Chunkp(n) &(ChunkName(n))
#define PrepFarJump(n, l) \
do { \
cont.nextChunk = (void*)ChunkName(n); \
nextFun = l; \
} while (0)
#endif
1.1 mlton/include/c-main.h
Index: c-main.h
===================================================================
#ifndef _C_MAIN_H_
#define _C_MAIN_H_
#include "main.h"
#include "c-common.h"
#define Main(al, cs, mg, mfs, mlw, mmc, ps, mc, ml) \
/* Globals */ \
char CReturnC; /* The CReturn's must be globals and cannot be per chunk */ \
double CReturnD; /* because they may be assigned in one chunk and read in */ \
int CReturnI; /* another. See, e.g. Array_allocate. */ \
char *CReturnP; \
uint CReturnU; \
int nextFun; \
bool returnToC; \
void MLton_callFromC () { \
struct cont cont; \
GC_state s; \
\
if (DEBUG_CCODEGEN) \
fprintf (stderr, "MLton_callFromC() starting\n"); \
s = &gcState; \
s->savedThread = s->currentThread; \
/* Return to the C Handler thread. */ \
GC_switchToThread (s, s->callFromCHandler); \
nextFun = *(int*)(s->stackTop - WORD_SIZE); \
cont.nextChunk = nextChunks[nextFun]; \
returnToC = FALSE; \
do { \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
} while (not returnToC); \
GC_switchToThread (s, s->savedThread); \
s->savedThread = BOGUS_THREAD; \
if (DEBUG_CCODEGEN) \
fprintf (stderr, "MLton_callFromC done\n"); \
} \
int main (int argc, char **argv) { \
struct cont cont; \
gcState.native = FALSE; \
Initialize (al, cs, mg, mfs, mlw, mmc, ps); \
if (gcState.isOriginal) { \
real_Init(); \
PrepFarJump(mc, ml); \
} else { \
/* Return to the saved world */ \
nextFun = *(int*)(gcState.stackTop - WORD_SIZE); \
cont.nextChunk = nextChunks[nextFun]; \
} \
/* Trampoline */ \
while (1) { \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
cont=(*(struct cont(*)(void))cont.nextChunk)(); \
} \
}
#endif
1.1 mlton/include/main.h
Index: main.h
===================================================================
#ifndef _MAIN_H_
#define _MAIN_H_
#include "libmlton.h"
/* The label must be declared as weak because gcc's optimizer may prove that
* the code that declares the label is dead and hence eliminate declaration.
*/
#define DeclareProfileLabel(l) \
void l() __attribute__ ((weak))
#define BeginIntInfs static struct GC_intInfInit intInfInits[] = {
#define IntInf(g, n) { g, n },
#define EndIntInfs };
#define BeginStrings static struct GC_stringInit stringInits[] = {
#define String(g, s, l) { g, s, l },
#define EndStrings };
#define BeginReals static void real_Init() {
#define Real(c, f) globaldouble[c] = f;
#define EndReals }
#define LoadArray(a, f) sfread (a, sizeof(*a), cardof(a), f)
#define SaveArray(a, fd) swrite (fd, a, sizeof(*a) * cardof(a))
/* gcState can't be static because stuff in mlton-lib.c refers to it */
#define Globals(c, d, i, p, u, nr) \
struct GC_state gcState; \
char globaluchar[c]; \
double globaldouble[d]; \
int globalint[i]; \
pointer globalpointer[p]; \
uint globaluint[u]; \
pointer globalpointerNonRoot[nr]; \
static void saveGlobals (int fd) { \
SaveArray (globaluchar, fd); \
SaveArray (globaldouble, fd); \
SaveArray (globalint, fd); \
SaveArray (globalpointer, fd); \
SaveArray (globaluint, fd); \
} \
static void loadGlobals (FILE *file) { \
LoadArray (globaluchar, file); \
LoadArray (globaldouble, file); \
LoadArray (globalint, file); \
LoadArray (globalpointer, file); \
LoadArray (globaluint, file); \
}
#define Initialize(al, cs, mg, mfs, mlw, mmc, ps) \
gcState.alignment = al; \
gcState.cardSizeLog2 = cs; \
gcState.frameLayouts = frameLayouts; \
gcState.frameLayoutsSize = cardof(frameLayouts); \
gcState.frameSources = frameSources; \
gcState.frameSourcesSize = cardof(frameSources); \
gcState.globals = globalpointer; \
gcState.globalsSize = cardof(globalpointer); \
gcState.intInfInits = intInfInits; \
gcState.intInfInitsSize = cardof(intInfInits); \
gcState.loadGlobals = loadGlobals; \
gcState.magic = mg; \
gcState.maxFrameSize = mfs; \
gcState.mayLoadWorld = mlw; \
gcState.mutatorMarksCards = mmc; \
gcState.objectTypes = objectTypes; \
gcState.objectTypesSize = cardof(objectTypes); \
gcState.profileStack = ps; \
gcState.sourceLabels = sourceLabels; \
gcState.sourceLabelsSize = cardof(sourceLabels); \
gcState.saveGlobals = saveGlobals; \
gcState.sources = sources; \
gcState.sourcesSize = cardof(sources); \
gcState.sourceSeqs = sourceSeqs; \
gcState.sourceSeqsSize = cardof(sourceSeqs); \
gcState.sourceSuccessors = sourceSuccessors; \
gcState.stringInits = stringInits; \
gcState.stringInitsSize = cardof(stringInits); \
MLton_init (argc, argv, &gcState); \
#endif /* #ifndef _CODEGEN_H_ */
1.1 mlton/include/x86-main.h
Index: x86-main.h
===================================================================
#ifndef _X86_MAIN_H_
#define _X86_MAIN_H_
#include "main.h"
/* Globals */
word applyFFTemp;
word checkTemp;
char cReturnTempB;
double cReturnTempD;
word cReturnTempL;
word c_stackP;
word divTemp;
word fileTemp;
word fpswTemp;
word indexTemp;
word intInfTemp;
char MLton_bug_msg[] = "cps machine";
word raTemp1;
double raTemp2;
double realTemp1;
double realTemp2;
double realTemp3;
word spill[16];
word stackTopTemp;
word statusTemp;
word switchTemp;
word threadTemp;
#ifndef DEBUG_X86CODEGEN
#define DEBUG_X86CODEGEN FALSE
#endif
#define Locals(c, d, i, p, u) \
char localuchar[c]; \
double localdouble[d]; \
int localint[i]; \
pointer localpointer[p]; \
uint localuint[u]
#if (defined (__CYGWIN__))
#define ReturnToC "_Thread_returnToC"
#elif (defined (__FreeBSD__) || defined (__linux__) || defined (__sun__))
#define ReturnToC "Thread_returnToC"
#else
#error ReturnToC not defined
#endif
#define Main(al, cs, mg, mfs, mlw, mmc, ps, ml, reserveEsp) \
void MLton_jumpToSML (pointer jump) { \
word lc_stackP; \
\
if (DEBUG_X86CODEGEN) \
fprintf (stderr, "MLton_jumpToSML(0x%08x) starting\n", (uint)jump); \
lc_stackP = c_stackP; \
if (reserveEsp) \
__asm__ __volatile__ \
("pusha\nmovl %%esp,%0\nmovl %1,%%ebp\nmovl %2,%%edi\njmp *%3\n.global "ReturnToC"\n"ReturnToC":\nmovl %0,%%esp\npopa" \
: "=o" (c_stackP) \
: "o" (gcState.stackTop), "o" (gcState.frontier), "r" (jump) \
); \
else \
__asm__ __volatile__ \
("pusha\nmovl %%esp,%0\nmovl %1,%%ebp\nmovl %2,%%esp\njmp *%3\n.global "ReturnToC"\n"ReturnToC":\nmovl %0,%%esp\npopa" \
: "=o" (c_stackP) \
: "o" (gcState.stackTop), "o" (gcState.frontier), "r" (jump) \
); \
c_stackP = lc_stackP; \
if (DEBUG_X86CODEGEN) \
fprintf (stderr, "MLton_jumpToSML(0x%08x) done\n", (uint)jump); \
return; \
} \
void MLton_callFromC () { \
pointer jump; \
GC_state s; \
\
if (DEBUG_X86CODEGEN) \
fprintf (stderr, "MLton_callFromC() starting\n"); \
s = &gcState; \
s->savedThread = s->currentThread; \
/* Return to the C Handler thread. */ \
GC_switchToThread (s, s->callFromCHandler); \
jump = *(pointer*)(s->stackTop - WORD_SIZE); \
MLton_jumpToSML(jump); \
GC_switchToThread (s, s->savedThread); \
s->savedThread = BOGUS_THREAD; \
if (DEBUG_X86CODEGEN) \
fprintf (stderr, "MLton_callFromC() done\n"); \
return; \
} \
int main (int argc, char **argv) { \
pointer jump; \
extern pointer ml; \
gcState.native = TRUE; \
Initialize (al, cs, mg, mfs, mlw, mmc, ps); \
if (gcState.isOriginal) { \
real_Init(); \
jump = (pointer)&ml; \
} else { \
jump = *(pointer*)(gcState.stackTop - WORD_SIZE); \
} \
MLton_jumpToSML(jump); \
return 1; \
}
#endif /* #ifndef _X86CODEGEN_H_ */
1.51 +19 -10 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- backend.fun 24 Apr 2003 20:50:47 -0000 1.50
+++ backend.fun 14 May 2003 02:50:10 -0000 1.51
@@ -421,6 +421,16 @@
temp = temp
})
end
+ fun runtimeOp (field: GCField.t, ty: Type.t): M.Operand.t =
+ if !Control.Native.native
+ then M.Operand.Runtime field
+ else
+ M.Operand.Offset {base = M.Operand.GCState,
+ offset = GCField.offset field,
+ ty = ty}
+ val exnStackOp = runtimeOp (GCField.ExnStack, Type.ExnStack)
+ val stackBottomOp = runtimeOp (GCField.StackBottom, Type.Word)
+ val stackTopOp = runtimeOp (GCField.StackTop, Type.Word)
fun translateOperand (oper: R.Operand.t): M.Operand.t =
let
datatype z = datatype R.Operand.t
@@ -444,7 +454,10 @@
| PointerTycon pt =>
M.Operand.Word (Runtime.typeIndexToHeader
(PointerTycon.index pt))
- | Runtime r => M.Operand.Runtime r
+ | Runtime f =>
+ if !Control.Native.native
+ then M.Operand.Runtime f
+ else runtimeOp (f, R.Operand.ty oper)
| SmallIntInf w => M.Operand.SmallIntInf w
| Var {var, ...} => varOperand var
end
@@ -505,25 +518,21 @@
Vector.new2
(M.Statement.PrimApp
{args = (Vector.new2
- (M.Operand.Runtime GCField.StackTop,
+ (stackTopOp,
M.Operand.Int
(handlerOffset () + Runtime.wordSize))),
dst = SOME tmp,
prim = Prim.word32Add},
M.Statement.PrimApp
- {args = (Vector.new2
- (tmp,
- M.Operand.Cast
- (M.Operand.Runtime GCField.StackBottom,
- M.Type.word))),
- dst = SOME (M.Operand.Runtime GCField.ExnStack),
+ {args = Vector.new2 (tmp, stackBottomOp),
+ dst = SOME exnStackOp,
prim = Prim.word32Sub})
end
| SetExnStackSlot =>
(* ExnStack = *(uint* )(stackTop + offset); *)
Vector.new1
(M.Statement.move
- {dst = M.Operand.Runtime GCField.ExnStack,
+ {dst = exnStackOp,
src = M.Operand.StackOffset {offset = linkOffset (),
ty = Type.ExnStack}})
| SetHandler h =>
@@ -538,7 +547,7 @@
(M.Statement.move
{dst = M.Operand.StackOffset {offset = linkOffset (),
ty = Type.ExnStack},
- src = M.Operand.Runtime GCField.ExnStack})
+ src = exnStackOp})
| _ => Error.bug (concat
["backend saw strange statement: ",
R.Statement.toString s])
1.46 +5 -1 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- machine.fun 24 Apr 2003 20:50:49 -0000 1.45
+++ machine.fun 14 May 2003 02:50:10 -0000 1.46
@@ -1036,12 +1036,16 @@
in
case Operand.ty base of
- Type.EnumPointers {enum, pointers} =>
+ Type.CPointer => true
+ | Type.EnumPointers {enum, pointers} =>
0 = Vector.length enum
andalso
((* Vector_fromArray header update. *)
(offset = Runtime.headerOffset
andalso Type.equals (ty, Type.word))
+ orelse
+ (offset = Runtime.arrayLengthOffset
+ andalso Type.equals (ty, Type.int))
orelse
Vector.forall
(pointers, fn p =>
1.8 +5 -5 mlton/mlton/backend/mtype.fun
Index: mtype.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/mtype.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mtype.fun 24 Apr 2003 20:50:51 -0000 1.7
+++ mtype.fun 14 May 2003 02:50:10 -0000 1.8
@@ -23,11 +23,11 @@
fun toString t =
case dest t of
- Char => "uchar"
- | Double => "double"
- | Int => "int"
- | Pointer => "pointer"
- | Uint => "uint"
+ Char => "Char"
+ | Double => "Double"
+ | Int => "Int"
+ | Pointer => "Pointer"
+ | Uint => "Word"
val layout = Layout.str o toString
1.32 +3 -0 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- rssa.fun 10 Apr 2003 01:52:20 -0000 1.31
+++ rssa.fun 14 May 2003 02:50:10 -0000 1.32
@@ -1095,6 +1095,9 @@
(offset = Runtime.headerOffset
andalso Type.equals (ty, Type.word))
orelse
+ (offset = Runtime.arrayLengthOffset
+ andalso Type.equals (ty, Type.int))
+ orelse
Vector.forall
(pointers, fn p =>
case tyconTy p of
1.13 +4 -2 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- runtime.fun 18 Apr 2003 22:44:59 -0000 1.12
+++ runtime.fun 14 May 2003 02:50:10 -0000 1.13
@@ -48,6 +48,7 @@
val canHandleOffset: int ref = ref 0
val cardMapOffset: int ref = ref 0
val currentThreadOffset: int ref = ref 0
+ val exnStackOffset: int ref = ref 0
val frontierOffset: int ref = ref 0
val limitOffset: int ref = ref 0
val limitPlusSlopOffset: int ref = ref 0
@@ -57,12 +58,13 @@
val stackLimitOffset: int ref = ref 0
val stackTopOffset: int ref = ref 0
- fun setOffsets {canHandle, cardMap, currentThread, frontier,
+ fun setOffsets {canHandle, cardMap, currentThread, exnStack, frontier,
limit, limitPlusSlop, maxFrameSize, signalIsPending,
stackBottom, stackLimit, stackTop} =
(canHandleOffset := canHandle
; cardMapOffset := cardMap
; currentThreadOffset := currentThread
+ ; exnStackOffset := exnStack
; frontierOffset := frontier
; limitOffset := limit
; limitPlusSlopOffset := limitPlusSlop
@@ -76,7 +78,7 @@
fn CanHandle => !canHandleOffset
| CardMap => !cardMapOffset
| CurrentThread => !currentThreadOffset
- | ExnStack => Error.bug "exn stack offset not defined"
+ | ExnStack => !exnStackOffset
| Frontier => !frontierOffset
| Limit => !limitOffset
| LimitPlusSlop => !limitPlusSlopOffset
1.22 +1 -0 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- runtime.sig 18 Apr 2003 22:44:59 -0000 1.21
+++ runtime.sig 14 May 2003 02:50:10 -0000 1.22
@@ -41,6 +41,7 @@
val setOffsets: {canHandle: int,
cardMap: int,
currentThread: int,
+ exnStack: int,
frontier: int,
limit: int,
limitPlusSlop: int,
1.39 +9 -5 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.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- ssa-to-rssa.fun 18 Apr 2003 22:44:59 -0000 1.38
+++ ssa-to-rssa.fun 14 May 2003 02:50:10 -0000 1.39
@@ -808,6 +808,11 @@
if Type.isPointer t
then yes ()
else no ()
+ fun arrayOrVectorLength () =
+ move (Operand.Offset
+ {base = varOp (a 0),
+ offset = Runtime.arrayLengthOffset,
+ ty = Type.int})
fun arrayOffset (ty: Type.t): Operand.t =
ArrayOffset {base = varOp (a 0),
index = varOp (a 1),
@@ -1002,6 +1007,7 @@
Array_array =>
array (Operand.Var {var = a 0,
ty = Type.int})
+ | Array_length => arrayOrVectorLength ()
| Array_sub =>
(case targ () of
NONE => none ()
@@ -1026,11 +1032,8 @@
mayGC = callsFromC,
maySwitchThreads = false,
name = name,
- returnTy =
- Option.map
- (var, fn x =>
- Type.toRuntime
- (valOf (toRtype (varType x))))})
+ returnTy = Option.map (toRtype ty,
+ Type.toRuntime)})
| GC_collect =>
ccall
{args = Vector.new5 (Operand.GCState,
@@ -1238,6 +1241,7 @@
:: ss,
t)
end
+ | Vector_length => arrayOrVectorLength ()
| Vector_sub =>
(case targ () of
NONE => none ()
1.54 +25 -62 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.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- c-codegen.fun 13 May 2003 16:36:41 -0000 1.53
+++ c-codegen.fun 14 May 2003 02:50:11 -0000 1.54
@@ -145,7 +145,6 @@
fun outputDeclarations
{additionalMainArgs: string list,
includes: string list,
- name: string,
print: string -> unit,
program = (Program.T
{chunks, frameLayouts, frameOffsets, intInfs, maxFrameSize,
@@ -289,8 +288,7 @@
C.int o #2)
end
in
- print (concat ["#define ", name, "CODEGEN\n\n"])
- ; outputIncludes (includes, print)
+ outputIncludes (includes, print)
; declareGlobals ()
; declareIntInfs ()
; declareStrings ()
@@ -366,7 +364,6 @@
fun output {program as Machine.Program.T {chunks,
frameLayouts,
main = {chunkLabel, label}, ...},
- includes,
outputC: unit -> {file: File.t,
print: string -> unit,
done: unit -> unit}} =
@@ -479,7 +476,7 @@
| Contents {oper, ty} =>
concat ["C", Type.name ty, "(", toString oper, ")"]
| File => "__FILE__"
- | GCState => "&gcState"
+ | GCState => "GCState"
| Global g =>
concat ["G", Type.name (Global.ty g),
if Global.isRoot g
@@ -496,24 +493,7 @@
| Register r =>
concat ["R", Type.name (Register.ty r),
"(", Int.toString (Register.index r), ")"]
- | Runtime r =>
- let
- datatype z = datatype GCField.t
- in
- case r of
- CanHandle => "gcState.canHandle"
- | CardMap => "gcState.cardMapForMutator"
- | CurrentThread => "gcState.currentThread"
- | ExnStack => "ExnStack"
- | Frontier => "frontier"
- | Limit => "gcState.limit"
- | LimitPlusSlop => "gcState.limitPlusSlop"
- | MaxFrameSize => "gcState.maxFrameSize"
- | SignalIsPending => "gcState.signalIsPending"
- | StackBottom => "gcState.stackBottom"
- | StackLimit => "gcState.stackLimit"
- | StackTop => "stackTop"
- end
+ | Runtime _ => Error.bug "C codegen saw Runtime operand"
| SmallIntInf w =>
concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
| StackOffset {offset, ty} =>
@@ -556,7 +536,7 @@
val dst =
concat
["C", Type.name (Operand.ty value),
- "(frontier + ",
+ "(Frontier + ",
C.int (offset
+ Runtime.normalHeaderSize),
")"]
@@ -650,6 +630,9 @@
let
val {name, returnTy, ...} = CFunction.dest func
in
+ if name = "Thread_returnToC"
+ then ()
+ else
doit
(name, fn () =>
let
@@ -664,7 +647,7 @@
Int.toString (Counter.next c)]
in
(concat
- ["extern ", res, " ",
+ [res, " ",
CFunction.name func,
" (",
concat (List.separate
@@ -750,10 +733,7 @@
src = operandToString (Operand.Label return),
srcIsMem = false,
ty = Type.Label return})
- ; C.push (size, print)
- ; if profiling
- then print "\tFlushStackTop();\n"
- else ())
+ ; C.push (size, print))
fun copyArgs (args: Operand.t vector): string list * (unit -> unit) =
if Vector.exists (args,
fn Operand.StackOffset _ => true
@@ -828,10 +808,7 @@
end
| _ => ()
fun pop (fi: FrameInfo.t) =
- (C.push (~ (Program.frameSize (program, fi)), print)
- ; if profiling
- then print "\tFlushStackTop();\n"
- else ())
+ C.push (~ (Program.frameSize (program, fi)), print)
val _ =
case kind of
Kind.Cont {frameInfo, ...} => pop frameInfo
@@ -941,12 +918,8 @@
end
| CCall {args, frameInfo, func, return} =>
let
- val {maySwitchThreads,
- modifiesFrontier,
- modifiesStackTop,
- name,
- returnTy,
- ...} = CFunction.dest func
+ val {maySwitchThreads, name, returnTy, ...} =
+ CFunction.dest func
val (args, afterCall) =
case frameInfo of
NONE =>
@@ -961,16 +934,6 @@
in
res
end
- val _ =
- if modifiesFrontier
- then print "\tFlushFrontier();\n"
- else ()
- val _ =
- if modifiesStackTop
- andalso (Option.isNone frameInfo
- orelse not profiling)
- then print "\tFlushStackTop();\n"
- else ()
val _ = print "\t"
val _ =
case returnTy of
@@ -979,14 +942,6 @@
val _ = C.call (name, args, print)
val _ = afterCall ()
val _ =
- if modifiesFrontier
- then print "\tCacheFrontier();\n"
- else ()
- val _ =
- if modifiesStackTop
- then print "\tCacheStackTop();\n"
- else ()
- val _ =
if maySwitchThreads
then print "\tReturn();\n"
else Option.app (return, gotoLabel)
@@ -1097,10 +1052,19 @@
Int.for (0, 1 + regMax t, fn i =>
C.call (d, [C.int i], print))
end)
+ fun outputOffsets () =
+ List.foreach
+ ([("ExnStackOffset", GCField.ExnStack),
+ ("FrontierOffset", GCField.Frontier),
+ ("StackBottomOffset", GCField.StackBottom),
+ ("StackTopOffset", GCField.StackTop)],
+ fn (name, f) =>
+ print (concat ["#define ", name, " ",
+ Int.toString (GCField.offset f), "\n"]))
in
- print (concat ["#define CCODEGEN\n\n"])
- ; outputIncludes (includes, print)
-(* ; declareFFI () *)
+ outputOffsets ()
+ ; outputIncludes (["c-chunk.h"], print)
+ ; declareFFI ()
; declareChunks ()
; declareProfileLabels ()
; C.callNoSemi ("Chunk", [chunkLabelToString chunkLabel], print)
@@ -1139,8 +1103,7 @@
; print "};\n")
val _ =
outputDeclarations {additionalMainArgs = additionalMainArgs,
- includes = includes,
- name = "C",
+ includes = ["c-main.h"],
program = program,
print = print,
rest = rest}
1.6 +0 -2 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.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-codegen.sig 19 Dec 2002 23:43:33 -0000 1.5
+++ c-codegen.sig 14 May 2003 02:50:11 -0000 1.6
@@ -18,14 +18,12 @@
include C_CODEGEN_STRUCTS
val output: {program: Machine.Program.t,
- includes: string list,
outputC: unit -> {file: File.t,
print: string -> unit,
done: unit -> unit}
} -> unit
val outputDeclarations: {additionalMainArgs: string list,
includes: string list,
- name: string,
print: string -> unit,
program: Machine.Program.t,
rest: unit -> unit
1.39 +1 -3 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.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- x86-codegen.fun 11 Apr 2003 04:31:10 -0000 1.38
+++ x86-codegen.fun 14 May 2003 02:50:11 -0000 1.39
@@ -80,7 +80,6 @@
open x86
structure Type = Machine.Type
fun output {program as Machine.Program.T {chunks, frameLayouts, main, ...},
- includes: string list,
outputC,
outputS}: unit
= let
@@ -181,8 +180,7 @@
in
CCodegen.outputDeclarations
{additionalMainArgs = additionalMainArgs,
- includes = includes,
- name = "X86",
+ includes = ["x86-main.h"],
print = print,
program = program,
rest = rest}
1.5 +0 -1 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.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- x86-codegen.sig 6 Jul 2002 17:22:06 -0000 1.4
+++ x86-codegen.sig 14 May 2003 02:50:11 -0000 1.5
@@ -20,7 +20,6 @@
include X86_CODEGEN_STRUCTS
val output: {program: Machine.Program.t,
- includes: string list,
outputC: unit -> {file: File.t,
print: string -> unit,
done: unit -> unit},
1.17 +3 -8 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- x86-mlton-basic.fun 11 Apr 2003 04:31:10 -0000 1.16
+++ x86-mlton-basic.fun 14 May 2003 02:50:11 -0000 1.17
@@ -435,14 +435,9 @@
fun stackTopTempMinusWordDerefOperand () =
Operand.memloc (stackTopTempMinusWordDeref ())
- 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 ())
+ val (_, gcState_currentThread_exnStackContents,
+ gcState_currentThread_exnStackContentsOperand) =
+ make (Field.ExnStack, wordSize, Classes.GCState)
(* init *)
fun init () = let
1.43 +1 -40 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.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- x86-mlton.fun 25 Mar 2003 04:31:25 -0000 1.42
+++ x86-mlton.fun 14 May 2003 02:50:11 -0000 1.43
@@ -53,42 +53,6 @@
{entry = NONE,
statements = [Assembly.comment ("UNIMPLEMENTED PRIM: " ^ s)],
transfer = NONE}]
-
- fun lengthArrayVectorString ()
- = let
- val (dst,dstsize) = getDst ();
- val _
- = Assert.assert
- ("applyPrim: lengthArrayVectorString, dstsize",
- fn () => dstsize = wordSize)
- val (src,srcsize) = getSrc1 ();
- val _
- = Assert.assert
- ("applyPrim: lengthArrayVectorString, srcsize",
- fn () => srcsize = wordSize)
-
- val memloc
- = case (Operand.deMemloc src)
- of SOME base
- => MemLoc.simple
- {base = base,
- index = Immediate.const_int ~2,
- scale = wordScale,
- size = wordSize,
- class = Classes.Heap}
- | NONE => Error.bug
- "applyPrim: lengthArrayVectorString, src"
- in
- AppendList.fromList
- [Block.mkBlock'
- {entry = NONE,
- statements
- = [Assembly.instruction_mov
- {dst = dst,
- src = Operand.memloc memloc,
- size = wordSize}],
- transfer = NONE}]
- end
fun subWord8ArrayVector ()
= let
@@ -686,9 +650,7 @@
AppendList.appends
[comment_begin,
(case Prim.name prim of
- Array_length => lengthArrayVectorString ()
-
- | Char_lt => cmp Instruction.B
+ Char_lt => cmp Instruction.B
| Char_le => cmp Instruction.BE
| Char_gt => cmp Instruction.A
| Char_ge => cmp Instruction.AE
@@ -1257,7 +1219,6 @@
end
| Real_neg => funa Instruction.FCHS
| Real_round => funa Instruction.FRNDINT
- | Vector_length => lengthArrayVectorString ()
| Word8_toInt => movx Instruction.MOVZX
| Word8_toIntX => movx Instruction.MOVSX
| Word8_fromInt => xvom ()
1.74 +0 -3 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -r1.73 -r1.74
--- control.sig 24 Apr 2003 20:50:55 -0000 1.73
+++ control.sig 14 May 2003 02:50:11 -0000 1.74
@@ -76,9 +76,6 @@
(* Indentation used in laying out ILs. *)
val indentation: int ref
- (* The .h files that should be #include'd in the .c file. *)
- val includes: string list ref
-
datatype inline =
NonRecursive of {product: int,
small: int}
1.90 +0 -5 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.89
retrieving revision 1.90
diff -u -r1.89 -r1.90
--- control.sml 24 Apr 2003 20:50:56 -0000 1.89
+++ control.sml 14 May 2003 02:50:11 -0000 1.90
@@ -196,11 +196,6 @@
val toString = Layout.toString o layout
end
-val includes: string list ref =
- control {name = "includes",
- default = ["mlton.h"],
- toString = List.toString String.toString}
-
datatype inline = datatype Inline.t
val layoutInline = Inline.layout
1.20 +2 -1 mlton/mlton/core-ml/lookup-constant.fun
Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- lookup-constant.fun 23 Jan 2003 03:34:37 -0000 1.19
+++ lookup-constant.fun 14 May 2003 02:50:11 -0000 1.20
@@ -123,6 +123,7 @@
[
"canHandle",
"currentThread",
+ "exnStack",
"frontier",
"cardMapForMutator",
"limit",
@@ -150,7 +151,7 @@
(List.concat
[["#include <stddef.h>", (* for offsetof *)
"#include <stdio.h>"],
- List.map (!Control.includes, fn i =>
+ List.map (["libmlton.h"], fn i =>
concat ["#include <", i, ">"]),
["struct GC_state gcState;",
"int main (int argc, char **argv) {"],
1.51 +1 -2 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- compile.sml 21 Apr 2003 15:16:19 -0000 1.50
+++ compile.sml 14 May 2003 02:50:12 -0000 1.51
@@ -373,6 +373,7 @@
canHandle = get "canHandle",
cardMap = get "cardMapForMutator",
currentThread = get "currentThread",
+ exnStack = get "exnStack",
frontier = get "frontier",
limit = get "limit",
limitPlusSlop = get "limitPlusSlop",
@@ -457,13 +458,11 @@
then
Control.trace (Control.Top, "x86 code gen")
x86Codegen.output {program = machine,
- includes = !Control.includes,
outputC = outputC,
outputS = outputS}
else
Control.trace (Control.Top, "C code gen")
CCodegen.output {program = machine,
- includes = !Control.includes,
outputC = outputC}
val _ = Control.message (Control.Detail, PropertyList.stats)
val _ = Control.message (Control.Detail, HashSet.stats)
1.13 +2 -0 mlton/runtime/basis-constants.h
Index: basis-constants.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis-constants.h,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- basis-constants.h 11 Apr 2003 04:31:11 -0000 1.12
+++ basis-constants.h 14 May 2003 02:50:12 -0000 1.13
@@ -1,6 +1,8 @@
#ifndef _BASIS_CONSTANTS_H_
#define _BASIS_CONSTANTS_H_
+#include <syslog.h>
+
#include <sys/time.h>
#if (defined (__linux__))
#include <sys/ptrace.h>
1.135 +2 -0 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.134
retrieving revision 1.135
diff -u -r1.134 -r1.135
--- gc.c 12 May 2003 23:14:16 -0000 1.134
+++ gc.c 14 May 2003 02:50:12 -0000 1.135
@@ -803,6 +803,7 @@
static void setStack (GC_state s) {
GC_stack stack;
+ s->exnStack = s->currentThread->exnStack;
stack = s->currentThread->stack;
s->stackBottom = stackBottom (s, stack);
s->stackTop = stackTop (s, stack);
@@ -1212,6 +1213,7 @@
fprintf (stderr, "enter\n");
/* used needs to be set because the mutator has changed s->stackTop. */
s->currentThread->stack->used = currentStackUsed (s);
+ s->currentThread->exnStack = s->exnStack;
if (DEBUG)
GC_display (s, stderr);
unless (s->inSignalHandler) {
1.63 +1 -0 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -r1.62 -r1.63
--- gc.h 12 May 2003 23:14:16 -0000 1.62
+++ gc.h 14 May 2003 02:50:12 -0000 1.63
@@ -310,6 +310,7 @@
pointer limit; /* end of from space */
pointer stackTop;
pointer stackLimit; /* stackBottom + stackSize - maxFrameSize */
+ uint exnStack;
uint alignment; /* Either WORD_SIZE or 2 * WORD_SIZE. */
bool amInGC;
-------------------------------------------------------
Enterprise Linux Forum Conference & Expo, June 4-6, 2003, Santa Clara
The only event dedicated to issues related to Linux enterprise solutions
www.enterpriselinuxforum.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel