[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