/* Copyright (C) 1997-1999 NEC Research Institute.
 * Please see the file LICENSE for license information.
 */
#include "mlton-lib.h"

#if defined(_WIN32)
#include <windows.h>
#endif

/* ------------------------------------------------- */
/*                     counters                      */
/* ------------------------------------------------- */

ullong MLTON_numTrampolines;
ullong MLTON_numLimitChecks;
ullong MLTON_numInterReturns;
ullong MLTON_numReturns;
ullong MLTON_XmlKnown;
ullong MLTON_XmlUnknown;
ullong MLTON_SxmlKnown;
ullong MLTON_SxmlUnknown;
ullong MLTON_CpsKnown;
ullong MLTON_CpsUnknown;
ullong MLTON_CpsCall;
ullong MLTON_CpsLoop;
ullong MLTON_CpsDispatch;
ullong MLTON_CpsCoerce;

/* ------------------------------------------------- */
/*                     MLTON_bug                      */
/* ------------------------------------------------- */

void MLTON_bug(string msg) {
	fprintf(stderr, "MLton bug: %s.\n%s\n",
		msg,
		"Please send a bug report to MLton@research.nj.nec.com.");
 	exit(2);
}

/* ------------------------------------------------- */
/*                     MLTON_init                     */
/* ------------------------------------------------- */

void MLTON_usage(string s) {
	die("Usage: %s [@MLton [load-world file] [fixed-heap n[{k|m}]] [max-heap n[{k|m}]] [gc-messages] [gc-summary] --] args", 
		s);
}

uint stringToBytes(string s) {
	char c;
	uint result;
	int i, m;
	
	result = 0;
	i = 0;

	while ((c = s[i++]) != '\000') {
		switch (c) {
		case 'm':
			if (s[i] == '\000') 
				result = result * 1048576;
			else return 0;
			break;
		case 'k':
			if (s[i] == '\000') 
				result = result * 1024;
			else return 0;
			break;
		default:
			m = (int)(c - '0');
			if (0 <= m and m <= 9)
				result = result * 10 + m;
			else return 0;
		}
	}
	
	return result;
}

void setupArgvArgc(int argc, char **argv, MLTON_state *state, int i)
{
	/* Setup argv and argc that SML sees. */
	/* i is now the index of the first real arg */
#if defined(_WIN32)
	state->environment = (uint) environ;
#else
	state->environ = (uint) environ;
#endif
	
	state->commandName = (uint)(argv[0]);
	state->argc = argc - i;
	state->argv = (uint)(argv + i);
}

void MLTON_init(int argc, 
	       char **argv,
	       MLTON_state *state,
	       uint magic,
	       void (*loadGlobals)(FILE *file)) {
	GC_state *gcState;
	char *worldFile;
	int i;
	bool done, heapSizeCommandLine;

	gcState = state->gcState;
	
	state->isOriginal = TRUE;
	state->magic = magic;
	
	gcState->messages = FALSE;
	gcState->summary = FALSE;
	heapSizeCommandLine = FALSE;
	gcState->maxHeapSize = 0;
	
	MLTON_numTrampolines = 0;
	MLTON_numLimitChecks = 0;
	MLTON_numInterReturns = 0;
	MLTON_numReturns = 0;
	MLTON_XmlKnown = 0;
	MLTON_XmlUnknown = 0;
	MLTON_SxmlKnown = 0;
	MLTON_SxmlUnknown = 0;
	MLTON_CpsKnown = 0;
	MLTON_CpsUnknown = 0;
	MLTON_CpsCall = 0;
	MLTON_CpsLoop = 0;
	MLTON_CpsDispatch = 0;
	MLTON_CpsCoerce = 0;
	
	i = 1;
	if (argc > 1 and (0 == strcmp(argv[1], "@MLton"))) {
		/* process @MLton args */
		i = 2;
		done = FALSE;
		while (!done) {
			if (i == argc)
				MLTON_usage(argv[0]);
			else {
				string arg;

				arg = argv[i];
				if (0 == strcmp(arg, "fixed-heap")) {
					++i;
					if (i == argc)
						MLTON_usage(argv[0]);
					heapSizeCommandLine = TRUE;
					gcState->useFixedHeap = TRUE;
					gcState->fromSize =
						stringToBytes(argv[i++]);
				} else if (0 == strcmp(arg, "max-heap")) {
					++i;
					if (i == argc) 
						MLTON_usage(argv[0]);
					heapSizeCommandLine = TRUE;
					gcState->useFixedHeap = FALSE;
					gcState->maxHeapSize =
						stringToBytes(argv[i++]);
				} else if (0 == strcmp(arg, "gc-messages")) {
					++i;
					gcState->messages = TRUE;
				} else if (0 == strcmp(arg, "gc-summary")) {
					++i;
					gcState->summary = TRUE;
				} else if (0 == strcmp(arg, "load-world")) {
					++i;
					if (i == argc) 
						MLTON_usage(argv[0]);
					if (NULL == loadGlobals) 
						die("%s cannot load a world file.", argv[0]);
					state->isOriginal = FALSE;
					worldFile = argv[i++];
				} else if (0 == strcmp(arg, "--")) {
					++i;
					done = TRUE;
				} else if (i > 1)
					MLTON_usage(argv[0]);
			        else done = TRUE;
			}
		}
	}
	
	if (state->isOriginal) 
		GC_init(gcState);
	else 
		GC_loadWorld(gcState, magic, worldFile, heapSizeCommandLine,
				loadGlobals);
	
	/* Setup argv and argc that SML sees. */
	/* i is now the index of the first real arg */
	setupArgvArgc(argc, argv, state, i);
}

void print(pointer s) {
	fwrite(s, 1, GC_arrayNumElements(s), stderr);
}

int stringEqual(pointer s1, pointer s2) {
	if (s1 == s2) return TRUE;
	else {
		int n1, n2;

		n1 = GC_arrayNumElements(s1);
		n2 = GC_arrayNumElements(s2);
		if (n1 != n2) 
			return FALSE;
		else {
			int i;	
			for(i = 0; i < n1 ; ++i)
				if (*(s1 + i) != *(s2 + i)) 
					return FALSE;
		}
	}
	
	return TRUE;
}

/* ------------------------------------------------- */
/*                        Int                        */
/* ------------------------------------------------- */

void MLTON_overflow() {
	die("MLton does not handle overflow.");
}

#if defined(_WIN32)
#else
int MLTON_Int_addCheck(int n1, int n2) {
	register int eax asm("ax");

	eax = n1;

 	__asm__ __volatile__ ("addl %1, %0\n\tjo MLTON_overflow"
		:
		: "r" (eax), "m" (n2)
		: "eax");

	return eax;
}

int MLTON_Int_subCheck(int n1, int n2) {
	register int eax asm("ax");

	eax = n1;

 	__asm__ __volatile__ ("subl %1, %0\n\tjo MLTON_overflow"
		:
		: "r" (eax), "m" (n2)
		: "eax");

	return eax;
}

int MLTON_Int_mulCheck(int n1, int n2) {
	register int eax asm("ax");

	eax = n1;

 	__asm__ __volatile__ ("imull %1, %0\n\tjo MLTON_overflow"
		:
		: "r" (eax), "m" (n2)
		: "eax");

	return eax;
}
#endif

int intQuot(int numerator, int denominator) {
	register int eax asm("ax");
	
	eax = numerator ;
	
	__asm__ __volatile__ ("cdq\n        idivl %1"
		: 
		: "r" (eax), "m" (denominator)
		: "eax", "edx");
	
	return eax;
}

int intRem(int numerator, int denominator) {
	register int eax asm("ax"),
			edx asm("dx");
	
	eax = numerator ;
	
	__asm__ __volatile__ ("cdq\n        idivl %1"
		: 
		: "r" (eax), "m" (denominator)
		: "eax", "edx");
	
	return edx;
}

/* ------------------------------------------------- */
/*                       Real                        */
/* ------------------------------------------------- */

/* All this code assumes IEEE 754/854 and little endian.
 *
 * In memory, the 64 bits a double are layed out as follows.
 *
 * bits 7-0 of mantissa
 * bits 15-8 of mantissa
 * bits 23-16 of mantissa
 * bits 31-24 of mantissa
 * bits 39-32 of mantissa
 * bits 47-40 of mantissa
 * bits 3-0 of exponent
 * bits 51-48 of mantissa
 * sign bit
 * bits 10-4 of exponent
 */

int signBit(double d) {
	return (((unsigned char *)&d)[7] & 0x80) >> 7;
}

/* masks for word 1 */
#define EXPONENT_MASK 0x7FF00000
#define MANTISSA_MASK 0x000FFFFF
#define SIGNBIT_MASK  0x80000000
#define MANTISSA_HIGHBIT_MASK 0x00080000

int class(double d) {
	uint word0, word1;

	word0 = ((uint *)&d)[0];
	word1 = ((uint *)&d)[1];
	
	if ((word1 & EXPONENT_MASK) == EXPONENT_MASK) {
		/* NAN_QUIET, NAN_SIGNALLING, or INF */
		if (word0 or (word1 & MANTISSA_MASK)) {
			/* NAN_QUIET or NAN_SIGNALLING -- look at the highest bit of mantissa */
			if (word1 & MANTISSA_HIGHBIT_MASK)
				return NAN_QUIET;
			else
				return NAN_SIGNALLING;
		} else
			return INF;
	} else {
		/* ZERO, NORMAL, or SUBNORMAL */
		if (word1 & EXPONENT_MASK)
       			return NORMAL;
		else if (word0 or (word1 & MANTISSA_MASK))
			return SUBNORMAL;
		else
			return ZERO;
	}
}

int isFinite(double d) {
	uint word1;

	word1 = ((uint *)&d)[1];

	return !((word1 & EXPONENT_MASK) == EXPONENT_MASK);
}

int isNan(double d) {
	uint word0, word1;

	word0 = ((uint *)&d)[0];
  	word1 = ((uint *)&d)[1];

	return (((word1 & EXPONENT_MASK) == EXPONENT_MASK)
		and (word0 or (word1 & MANTISSA_MASK)));
}

int isNormal(double d) {
	uint word1, exponent;

	word1 = ((uint *)&d)[1];
  
  	exponent = word1 & EXPONENT_MASK;

	return not(exponent == 0 or exponent == EXPONENT_MASK);
}

#define ROUNDING_CONTROL_MASK 0x0C00
#define ROUNDING_CONTROL_SHIFT 10

void setRoundingMode(int mode) {
	unsigned short controlWord;

	__asm__ __volatile__ ("fstcw %0"
			: "=m" (controlWord)
			: );
	controlWord =  
		(mode << ROUNDING_CONTROL_SHIFT) 
		| (controlWord & ~ROUNDING_CONTROL_MASK);

	__asm__ __volatile__ ("fldcw %0"
                        :
			: "m" (controlWord));
}

int getRoundingMode() {
	unsigned short controlWord;

	__asm__ __volatile__ ("fstcw %0"
			: "=m" (controlWord)
			: );

	return (controlWord & ROUNDING_CONTROL_MASK) >> ROUNDING_CONTROL_SHIFT;
}

double round(double d) {
	register double f0;

	f0 = d;

	__asm__ __volatile__ ("frndint"
			:
			: "t" (f0));

	return f0;
}

/* ------------------------------------------------- */
/*                       MLton                        */
/* ------------------------------------------------- */

/* Linux specific.  Uses /dev/random to get a random word. */
uint MLTON_MLton_random() {
	uint result;
#if defined(_WIN32)
	result = rand();
#else
	FILE *file;

	file = sopen("/dev/random", "r");
	result = sreadUint(file);
	fclose(file);
#endif
	return result;
}

/* ------------------------------------------------- */
/*                       Date                        */
/* ------------------------------------------------- */

struct tm MLTON_tm;

/* Begin modified from KitV3 src/Runtime/Time.c */

/* SunOS 4 appears not to have mktime: */
#if defined(sun) && !defined(__svr4__)
#define tm2cal(tptr)   timelocal(tptr)
#else
#define tm2cal(tptr)   mktime(tptr)
#endif

int MLTON_localoffset () {
	struct tm *gmt;
	time_t t1, t2, td;

	t1 = time((time_t*)0);
	gmt = gmtime (&t1);
	t2 = tm2cal(gmt);
  
  /* SunOs appears to lack difftime: */
#if defined(sun) && !defined(__svr4__)
	td = (time_t)((long)t2 - (long)t1);
#else
	td = difftime(t2, t1);
#endif

	return td;
}

/* End modified from KitV3 src/Runtime/Time.c */

/* ------------------------------------------------- */
/*                       Time                        */
/* ------------------------------------------------- */

#if defined (_WIN32)
#else
struct timeval MLTON_timeval;
#endif

/* ------------------------------------------------- */
/*                       Word                        */
/* ------------------------------------------------- */

uint MLTON_Word32_arshiftAsm(uint w, uint s) {
	register uchar cl asm("cl");
	
	if (s > 31) cl = 31;
	else cl = s;

	__asm__ __volatile__ ("sarl %%cl, %0"
			      :
			      : "m" (w), "r" (cl));
	return w;
}

uchar MLTON_Word8_arshift(uchar w, uint s) {
	register uchar cl asm("cl");
	
	if (s > 7) cl = 7;
	else cl = s;

	__asm__ __volatile__ ("sarb %%cl, %0"
			      :
			      : "m" (w), "r" (cl));
	return w;
}