diff --git a/libpolyml/arb.cpp b/libpolyml/arb.cpp index 1e85fd73..0e5ddba3 100644 --- a/libpolyml/arb.cpp +++ b/libpolyml/arb.cpp @@ -1,2034 +1,2031 @@ /* Title: Arbitrary Precision Package. Author: Dave Matthews, Cambridge University Computer Laboratory Further modification Copyright 2010, 2012, 2015, 2017 David C. J. Matthews Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ /* Arbitrary precision package in C. Integers are held in two formats in this system, long-form and short-form. The two are distinquished by the integer tag bit, short-form having the tag bit set and pointers to long-form being untagged. The long-form integers use the standard Poly format for multi-word objects, with the length count and flags in the word just before the object pointed to. The sign of long-form integers is coded in one of the flag bits. Short integers are signed quantities, and can be directly manipulated by the relevant instructions, but if overflow occurs then the full long versions of the operations will need to be called. There are two versions of long-form integers depending on whether the GMP library is available. If it is then the byte cells contain "limbs", typically native 32 or 64-bit words. If it is not, the fall-back Poly code is used in which long-form integers are vectors of bytes (i.e. unsigned char). Integers are always stored in the least possible number of words, and will be shortened to the short-form when possible. Thanks are due to D. Knuth for the long division algorithm. */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_GMP_H #include #define USE_GMP 1 #endif #include "globals.h" #include "sys.h" #include "run_time.h" #include "arb.h" #include "save_vec.h" #include "processes.h" #include "memmgr.h" #include "rtsentry.h" #include "profiling.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyAddArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolySubtractArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyMultiplyArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyDivideArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyRemainderArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3); POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitraryPair(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYSIGNED PolyCompareArbitrary(PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGCDArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyLCMArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLowOrderAsLargeWord(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyOrArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyAndArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); POLYEXTERNALSYMBOL POLYUNSIGNED PolyXorArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); } -static Handle add_longc(TaskData *taskData, Handle,Handle); -static Handle sub_longc(TaskData *taskData, Handle,Handle); -static Handle mult_longc(TaskData* taskData, Handle, Handle); static Handle or_longc(TaskData *taskData, Handle,Handle); static Handle and_longc(TaskData *taskData, Handle,Handle); static Handle xor_longc(TaskData *taskData, Handle,Handle); static Handle neg_longc(TaskData *taskData, Handle); static Handle gcd_arbitrary(TaskData *taskData, Handle,Handle); static Handle lcm_arbitrary(TaskData *taskData, Handle,Handle); // Number of bits in a Poly word. N.B. This is not necessarily the same as SIZEOF_VOIDP. #define BITS_PER_POLYWORD (SIZEOF_POLYWORD*8) #ifdef USE_GMP #if (BITS_PER_POLYWORD > GMP_LIMB_BITS) // We're assuming that every GMP limb occupies at least one word #error "Size of GMP limb is less than a Poly word" #endif #endif #ifdef USE_GMP #define DEREFLIMBHANDLE(_x) ((mp_limb_t *)DEREFHANDLE(_x)) // Returns the length of the argument with trailing zeros removed. static mp_size_t numLimbs(PolyWord x) { POLYUNSIGNED numWords = OBJECT_LENGTH(x); #if BITS_PER_POLYWORD != GMP_LIMB_BITS ASSERT((numWords & (sizeof(mp_limb_t)/sizeof(PolyWord)-1)) == 0); #endif mp_size_t lu = numWords*sizeof(PolyWord)/sizeof(mp_limb_t); mp_limb_t *u = (mp_limb_t *)x.AsObjPtr(); while (lu > 0 && u[lu-1] == 0) lu--; return lu; } #else // Returns the length of the argument with trailing zeros removed. static POLYUNSIGNED get_length(PolyWord x) { byte *u = (byte *)x.AsObjPtr(); POLYUNSIGNED lu = OBJECT_LENGTH(x)*sizeof(PolyWord); for( ; (lu > 0) && (u[lu-1] == 0); lu--) { /* do nothing */ } return lu; } #endif // Return a uintptr_t value i.e. unsigned 32-bits on 32-bit architecture and 64-bits on 64-bit architecture. POLYUNSIGNED getPolyUnsigned(TaskData *taskData, PolyWord number) { if ( IS_INT(number) ) { POLYSIGNED i = UNTAGGED(number); if ( i < 0 ) raise_exception0(taskData, EXC_size ); return i; } else { if (OBJ_IS_NEGATIVE(GetLengthWord(number))) raise_exception0(taskData, EXC_size ); #ifdef USE_GMP unsigned length = numLimbs(number); if (length > 1) raise_exception0(taskData, EXC_size); mp_limb_t first = *(mp_limb_t*)number.AsCodePtr(); #if (BITS_PER_POLYWORD < GMP_NUMB_BITS) if (first > (mp_limb_t)1 << BITS_PER_POLYWORD) raise_exception0(taskData, EXC_size); #endif return first; #else byte *ptr = number.AsCodePtr(); POLYUNSIGNED length = get_length(number); if (length > sizeof(PolyWord) ) raise_exception0(taskData, EXC_size); POLYSIGNED c = 0; while ( length-- ) c = (c << 8) | ((byte *) ptr)[length]; return c; #endif } } #define MAX_INT_PLUS1 ((POLYUNSIGNED)0x80 << ( (sizeof(PolyWord)-1) *8)) // Return an intptr_t value i.e. signed 32-bits on 32-bit architecture and 64-bits on 64-bit architecture. POLYSIGNED getPolySigned(TaskData *taskData, PolyWord number) { if ( IS_INT(number) ) { return UNTAGGED(number); } else { int sign = OBJ_IS_NEGATIVE(GetLengthWord(number)) ? -1 : 0; #ifdef USE_GMP unsigned length = numLimbs(number); if (length > 1) raise_exception0(taskData, EXC_size); mp_limb_t c = *(mp_limb_t*)number.AsCodePtr(); #else POLYUNSIGNED length = get_length(number); POLYUNSIGNED c = 0; byte *ptr = number.AsCodePtr(); if ( length > sizeof(PolyWord) ) raise_exception0(taskData, EXC_size ); while ( length-- ) { c = (c << 8) | ptr[length]; } #endif if ( sign == 0 && c < MAX_INT_PLUS1) return (POLYSIGNED)c; if ( sign != 0 && c <= MAX_INT_PLUS1) return -((POLYSIGNED)c); raise_exception0(taskData, EXC_size ); /*NOTREACHED*/ return 0; } } short get_C_short(TaskData *taskData, PolyWord number) { int i = (int)get_C_long(taskData, number); if ( i <= 32767 && i >= -32768 ) return i; raise_exception0(taskData, EXC_size ); /*NOTREACHED*/ return 0; } unsigned short get_C_ushort(TaskData *taskData, PolyWord number) { POLYUNSIGNED u = get_C_ulong(taskData, number ); if ( u <= 65535 ) return (short)u; raise_exception0(taskData, EXC_size ); /*NOTREACHED*/ return 0; } #if (SIZEOF_LONG == SIZEOF_POLYWORD) unsigned get_C_unsigned(TaskData *taskData, PolyWord number) { return get_C_ulong(taskData, number); } int get_C_int(TaskData *taskData, PolyWord number) { return get_C_long(taskData, number); } #else // Poly words are the same size as a pointer but that may // not be the same as int or long. unsigned get_C_unsigned(TaskData *taskData, PolyWord number) { POLYUNSIGNED res = get_C_ulong(taskData, number); unsigned result = (unsigned)res; if ((POLYUNSIGNED)result != res) raise_exception0(taskData, EXC_size); return result; } int get_C_int(TaskData *taskData, PolyWord number) { POLYSIGNED res = get_C_long(taskData, number); int result = (int)res; if ((POLYSIGNED)result != res) raise_exception0(taskData, EXC_size); return result; } #endif // Convert short values to long. Returns a pointer to the memory. // This is generally called before allocating memory for the result. // It is unsafe to use the result after the allocation if the value is // an address because it may have been moved by a GC. #ifdef USE_GMP static mp_limb_t *convertToLong(Handle x, mp_limb_t *extend, mp_size_t *length, int *sign) { if (IS_INT(x->Word())) { // Short form - put it in the temporary. POLYSIGNED x_v = UNTAGGED(DEREFWORD(x)); if (x_v < 0) x_v = -x_v; *extend = x_v; if (x_v == 0) *length = 0; else *length = 1; if (sign) *sign = UNTAGGED(x->Word()) >= 0 ? 0 : -1; return extend; } else { *length = numLimbs(x->Word()); if (sign) *sign = OBJ_IS_NEGATIVE(GetLengthWord(x->Word())) ? -1 : 0; return DEREFLIMBHANDLE(x); } } #else static byte *convertToLong(Handle x, byte *extend, POLYUNSIGNED *length, int *sign) { if (IS_INT(x->Word())) { // Short form - put it in the temporary. POLYSIGNED x_v = UNTAGGED(DEREFWORD(x)); if (x_v < 0) x_v = -x_v; /* Put into extend buffer, low order byte first. */ *length = 0; for (unsigned i = 0; i < sizeof(PolyWord); i++) { if (x_v != 0) *length = i + 1; extend[i] = x_v & 0xff; x_v = x_v >> 8; } if (sign) *sign = UNTAGGED(x->Word()) >= 0 ? 0 : -1; return extend; } else { *length = get_length(DEREFWORD(x)); if (sign) *sign = OBJ_IS_NEGATIVE(GetLengthWord(x->Word())) ? -1 : 0; return DEREFBYTEHANDLE(x); } } #endif /* make_canonical is used to force a result into its shortest form, in the style of get_length, but also may convert its argument from long to short integer */ static Handle make_canonical(TaskData *taskData, Handle x, int sign) { #ifdef USE_GMP unsigned size = numLimbs(DEREFWORD(x)); if (size <= 1) // May be zero if the result is zero. { mp_limb_t r = *DEREFLIMBHANDLE(x); if (r <= MAXTAGGED || (r == MAXTAGGED+1 && sign < 0)) { if (sign < 0) return taskData->saveVec.push(TAGGED(-(POLYSIGNED)r)); else return taskData->saveVec.push(TAGGED(r)); } } // Throw away any unused words. DEREFWORDHANDLE(x)->SetLengthWord(WORDS(size*sizeof(mp_limb_t)), F_BYTE_OBJ | (sign < 0 ? F_NEGATIVE_BIT: 0)); return x; #else /* get length in BYTES */ POLYUNSIGNED size = get_length(DEREFWORD(x)); // We can use the short representation if it will fit in a word. if (size <= sizeof(PolyWord)) { /* Convert the digits. */ byte *u = DEREFBYTEHANDLE(x); POLYUNSIGNED r = 0; for (unsigned i=0; i < sizeof(PolyWord); i++) { r |= ((POLYUNSIGNED)u[i]) << (8*i); } /* Check for MAXTAGGED+1 before subtraction in case MAXTAGGED is 0x7fffffff */ if (r <= MAXTAGGED || (r == MAXTAGGED+1 && sign < 0)) { if (sign < 0) return taskData->saveVec.push(TAGGED(-(POLYSIGNED)r)); else return taskData->saveVec.push(TAGGED(r)); } } /* The length word of the object is changed to reflect the new length. This is safe because any words thrown away must be zero. */ DEREFWORDHANDLE(x)->SetLengthWord(WORDS(size), F_BYTE_OBJ | (sign < 0 ? F_NEGATIVE_BIT: 0)); return x; #endif } Handle ArbitraryPrecionFromSigned(TaskData *taskData, POLYSIGNED val) /* Called from routines in the run-time system to generate an arbitrary precision integer from a word value. */ { if (val <= MAXTAGGED && val >= -MAXTAGGED-1) /* No overflow */ return taskData->saveVec.push(TAGGED(val)); POLYUNSIGNED uval = val < 0 ? -val : val; #ifdef USE_GMP Handle y = alloc_and_save(taskData, WORDS(sizeof(mp_limb_t)), ((val < 0) ? F_NEGATIVE_BIT : 0)| F_BYTE_OBJ); mp_limb_t *v = DEREFLIMBHANDLE(y); *v = uval; #else Handle y = alloc_and_save(taskData, 1, ((val < 0) ? F_NEGATIVE_BIT : 0)| F_BYTE_OBJ); byte *v = DEREFBYTEHANDLE(y); for (POLYUNSIGNED i = 0; uval != 0; i++) { v[i] = (byte)(uval & 0xff); uval >>= 8; } #endif return y; } Handle ArbitraryPrecionFromUnsigned(TaskData *taskData, POLYUNSIGNED uval) /* Called from routines in the run-time system to generate an arbitrary precision integer from an unsigned value. */ { if (uval <= MAXTAGGED) return taskData->saveVec.push(TAGGED(uval)); #ifdef USE_GMP Handle y = alloc_and_save(taskData, WORDS(sizeof(mp_limb_t)), F_BYTE_OBJ); mp_limb_t *v = DEREFLIMBHANDLE(y); *v = uval; #else Handle y = alloc_and_save(taskData, 1, F_BYTE_OBJ); byte *v = DEREFBYTEHANDLE(y); for (POLYUNSIGNED i = 0; uval != 0; i++) { v[i] = (byte)(uval & 0xff); uval >>= 8; } #endif return y; } Handle Make_arbitrary_precision(TaskData *taskData, int val) { return ArbitraryPrecionFromSigned(taskData, val); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned uval) { return ArbitraryPrecionFromUnsigned(taskData, uval); } #if (SIZEOF_LONG <= SIZEOF_POLYWORD) Handle Make_arbitrary_precision(TaskData *taskData, long val) { return ArbitraryPrecionFromSigned(taskData, val); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned long uval) { return ArbitraryPrecionFromUnsigned(taskData, uval); } #else // This is needed in Unix in 32-in-64. Handle Make_arbitrary_precision(TaskData *taskData, long val) { if (val <= (long)(MAXTAGGED) && val >= -((long)(MAXTAGGED))-1) /* No overflow */ return taskData->saveVec.push(TAGGED((POLYSIGNED)val)); // Recursive call to handle the high-order part Handle hi = Make_arbitrary_precision(taskData, val >> (sizeof(int32_t) * 8)); // The low-order part is treated as UNsigned. Handle lo = Make_arbitrary_precision(taskData, (uint32_t)val); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hi, twoTo32), lo); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned long uval) { if (uval <= (unsigned long)(MAXTAGGED)) return taskData->saveVec.push(TAGGED((POLYUNSIGNED)uval)); // Recursive call to handle the high-order part Handle hi = Make_arbitrary_precision(taskData, uval >> (sizeof(uint32_t) * 8)); Handle lo = Make_arbitrary_precision(taskData, (uint32_t)uval); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hi, twoTo32), lo); } #endif #ifdef HAVE_LONG_LONG #if (SIZEOF_LONG_LONG <= SIZEOF_POLYWORD) Handle Make_arbitrary_precision(TaskData *taskData, long long val) { return ArbitraryPrecionFromSigned(taskData, val); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned long long uval) { return ArbitraryPrecionFromUnsigned(taskData, uval); } #else // 32-bit implementation. Handle Make_arbitrary_precision(TaskData *taskData, long long val) { if (val <= (long long)(MAXTAGGED) && val >= -((long long)(MAXTAGGED))-1) /* No overflow */ return taskData->saveVec.push(TAGGED((POLYSIGNED)val)); // Recursive call to handle the high-order part Handle hi = Make_arbitrary_precision(taskData, val >> (sizeof(int32_t) * 8)); // The low-order part is treated as UNsigned. Handle lo = Make_arbitrary_precision(taskData, (uint32_t)val); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hi, twoTo32), lo); } Handle Make_arbitrary_precision(TaskData *taskData, unsigned long long uval) { if (uval <= (unsigned long long)(MAXTAGGED)) return taskData->saveVec.push(TAGGED((POLYUNSIGNED)uval)); // Recursive call to handle the high-order part Handle hi = Make_arbitrary_precision(taskData, uval >> (sizeof(uint32_t) * 8)); Handle lo = Make_arbitrary_precision(taskData, (uint32_t)uval); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hi, twoTo32), lo); } #endif #endif #if defined(_WIN32) // Creates an arbitrary precision number from two words. // Used only in Windows for FILETIME and file-size. Handle Make_arb_from_32bit_pair(TaskData *taskData, uint32_t hi, uint32_t lo) { Handle hHi = Make_arbitrary_precision(taskData, hi); Handle hLo = Make_arbitrary_precision(taskData, lo); Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); return add_longc(taskData, mult_longc(taskData, hHi, twoTo32), hLo); } // Convert a Windows FILETIME into an arbitrary precision integer Handle Make_arb_from_Filetime(TaskData *taskData, const FILETIME &ft) { return Make_arb_from_32bit_pair(taskData, ft.dwHighDateTime, ft.dwLowDateTime); } #endif /* Returns hi*scale+lo as an arbitrary precision number. Currently used for Unix time values where the time is returned as two words, a number of seconds and a number of microseconds and we wish to return the result as a number of microseconds. */ Handle Make_arb_from_pair_scaled(TaskData *taskData, unsigned hi, unsigned lo, unsigned scale) { /* We might be able to compute the number as a 64 bit quantity and then convert it but this is probably more portable. It does risk overflowing the save vector. */ Handle hHi = Make_arbitrary_precision(taskData, hi); Handle hLo = Make_arbitrary_precision(taskData, lo); Handle hScale = Make_arbitrary_precision(taskData, scale); return add_longc(taskData, mult_longc(taskData, hHi, hScale), hLo); } Handle neg_longc(TaskData *taskData, Handle x) { if (IS_INT(DEREFWORD(x))) { POLYSIGNED s = UNTAGGED(DEREFWORD(x)); if (s != -MAXTAGGED-1) // If it won't overflow return taskData->saveVec.push(TAGGED(-s)); } // Either overflow or long argument - convert to long form. int sign_x; #if USE_GMP mp_limb_t x_extend; mp_size_t lx; (void)convertToLong(x, &x_extend, &lx, &sign_x); #else byte x_extend[sizeof(PolyWord)]; POLYUNSIGNED lx; (void)convertToLong(x, x_extend, &lx, &sign_x); #endif #ifdef USE_GMP POLYUNSIGNED bytes = lx*sizeof(mp_limb_t); #else POLYUNSIGNED bytes = lx; #endif Handle long_y = alloc_and_save(taskData, WORDS(bytes), F_MUTABLE_BIT|F_BYTE_OBJ); byte *v = DEREFBYTEHANDLE(long_y); if (IS_INT(DEREFWORD(x))) memcpy(v, &x_extend, bytes); else memcpy(v, DEREFBYTEHANDLE(x), bytes); #ifndef USE_GMP // Make sure the last word is zero. We may have unused bytes there. memset(v+bytes, 0, WORDS(bytes)*sizeof(PolyWord)-lx); #endif /* Return the value with the sign changed. */ return make_canonical(taskData, long_y, sign_x ^ -1); } /* neg_longc */ #ifdef USE_GMP static Handle add_unsigned_long(TaskData *taskData, Handle x, Handle y, int sign) { /* find the longer number */ mp_size_t lx, ly; mp_limb_t x_extend, y_extend; mp_limb_t *xb = convertToLong(x, &x_extend, &lx, NULL); mp_limb_t *yb = convertToLong(y, &y_extend, &ly, NULL); mp_limb_t *u; /* limb-pointer for longer number */ mp_limb_t *v; /* limb-pointer for shorter number */ Handle z; mp_size_t lu; /* length of u in limbs */ mp_size_t lv; /* length of v in limbs */ if (lx < ly) { // Get result vector. It must be 1 limb longer than u // to have space for any carry. z = alloc_and_save(taskData, WORDS((ly+1)*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFLIMBHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFLIMBHANDLE(x); lu = ly; lv = lx; } else { // Get result vector. It must be 1 limb longer than u // to have space for any carry. z = alloc_and_save(taskData, WORDS((lx+1)*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFLIMBHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFLIMBHANDLE(y); lu = lx; lv = ly; } mp_limb_t *w = DEREFLIMBHANDLE(z); // Do the addition. mp_limb_t carry = 0; if (lv != 0) carry = mpn_add_n(w, u, v, lv); // Add the carry to the rest of the longer number. if (lu != lv) carry = mpn_add_1(w+lv, u+lv, lu-lv, carry); // Put the remaining carry in the final limb. w[lu] = carry; return make_canonical(taskData, z, sign); } #else static Handle add_unsigned_long(TaskData *taskData, Handle x, Handle y, int sign) { byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; POLYUNSIGNED lx; /* length of u in bytes */ POLYUNSIGNED ly; /* length of v in bytes */ byte *xb = convertToLong(x, x_extend, &lx, NULL); byte *yb = convertToLong(y, y_extend, &ly, NULL); Handle z; byte *u; /* byte-pointer for longer number */ byte *v; /* byte-pointer for shorter number */ POLYUNSIGNED lu, lv; /* Make ``u'' the longer. */ if (lx < ly) { // Get result vector. It must be 1 byte longer than u // to have space for any carry. z = alloc_and_save(taskData, WORDS(ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); lu = ly; lv = lx; } else { // Get result vector. It must be 1 byte longer than u // to have space for any carry, plus one byte for the sign. z = alloc_and_save(taskData, WORDS(lx+2), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); lu = lx; lv = ly; } /* do the actual addition */ byte *w = DEREFBYTEHANDLE(z); unsigned carry = 0; POLYUNSIGNED i = 0; /* Do the additions */ for( ; i < lv; i++) { carry += u[i] + v[i]; w[i] = carry & 0xff; carry >>= 8; } /* Add the carry to the rest of ``u''. */ for( ; i < lu; i++) { carry += u[i]; w[i] = carry & 0xff; carry >>= 8; } /* Finally put the carry into the last byte */ w[i] = (byte)carry; return make_canonical(taskData, z, sign); } /* add_unsigned_long */ #endif #ifdef USE_GMP static Handle sub_unsigned_long(TaskData *taskData, Handle x, Handle y, int sign) { mp_limb_t *u; /* limb-pointer alias for larger number */ mp_limb_t *v; /* limb-pointer alias for smaller number */ mp_size_t lu; /* length of u in limbs */ mp_size_t lv; /* length of v in limbs */ Handle z; /* get the larger argument into ``u'' */ /* This is necessary so that we can discard */ /* the borrow at the end of the subtraction */ mp_size_t lx, ly; mp_limb_t x_extend, y_extend; mp_limb_t *xb = convertToLong(x, &x_extend, &lx, NULL); mp_limb_t *yb = convertToLong(y, &y_extend, &ly, NULL); // Find the larger number. Check the lengths first and if they're equal check the values. int res; if (lx < ly) res = -1; else if (lx > ly) res = 1; else res = mpn_cmp(xb, yb, lx); // If they're equal the result is zero. if (res == 0) return taskData->saveVec.push(TAGGED(0)); /* They are equal */ if (res < 0) { sign ^= -1; /* swap sign of result */ z = alloc_and_save(taskData, WORDS(ly*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFLIMBHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFLIMBHANDLE(x); lu = ly; lv = lx; } else { z = alloc_and_save(taskData, WORDS(lx*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFLIMBHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFLIMBHANDLE(y); lu = lx; lv = ly; } mp_limb_t *w = DEREFLIMBHANDLE(z); // Do the subtraction. mp_limb_t borrow = 0; if (lv != 0) borrow = mpn_sub_n(w, u, v, lv); // Subtract the borrow from the rest of the longer number. if (lu != lv) borrow = mpn_sub_1(w+lv, u+lv, lu-lv, borrow); return make_canonical(taskData, z, sign); } #else static Handle sub_unsigned_long(TaskData *taskData, Handle x, Handle y, int sign) { byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; /* This is necessary so that we can discard */ /* the borrow at the end of the subtraction */ POLYUNSIGNED lx, ly; byte *xb = convertToLong(x, x_extend, &lx, NULL); byte *yb = convertToLong(y, y_extend, &ly, NULL); byte *u; /* byte-pointer alias for larger number */ byte *v; /* byte-pointer alias for smaller number */ POLYUNSIGNED lu; /* length of u in bytes */ POLYUNSIGNED lv; /* length of v in bytes */ Handle z; /* get the larger argument into ``u'' */ if (lx < ly) { sign ^= -1; // swap sign of result z = alloc_and_save(taskData, WORDS(ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); lu = ly; lv = lx; } else if (ly < lx) { z = alloc_and_save(taskData, WORDS(lx+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); lu = lx; lv = ly; } else /* lx == ly */ { /* Must look at the numbers to decide which is bigger. */ POLYUNSIGNED i = lx; while (i > 0 && xb[i-1] == yb[i-1]) i--; if (i == 0) return taskData->saveVec.push(TAGGED(0)); /* They are equal */ if (xb[i-1] < yb[i-1]) { sign ^= -1; /* swap sign of result SPF 21/1/94 */ z = alloc_and_save(taskData, WORDS(ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); v = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); lu = ly; lv = lx; } else { z = alloc_and_save(taskData, WORDS(lx+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? xb : DEREFBYTEHANDLE(x); v = IS_INT(DEREFWORD(y)) ? yb : DEREFBYTEHANDLE(y); lu = lx; lv = ly; } } byte *w = DEREFBYTEHANDLE(z); unsigned borrow = 1; /* Becomes 0 if there is a borrow */ POLYUNSIGNED i = 0; /* Do the subtractions */ for( ; i < lv; i++) { borrow += 255 + u[i] - v[i]; w[i] = borrow & 0xff; borrow >>= 8; } /* Add the borrow into the rest of ``u''. */ for( ; i < lu; i++) { borrow += 255 + u[i]; w[i] = borrow & 0xff; borrow >>= 8; } return make_canonical(taskData, z, sign); } /* sub_unsigned_long */ #endif Handle add_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) { /* Both short */ /* The easiest way to do the addition is simply *x-1+*y, but that makes it more difficult to check for overflow. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) + UNTAGGED(DEREFWORD(y)); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) /* No overflow */ { return taskData->saveVec.push(TAGGED(t)); } } int sign_x, sign_y; if (IS_INT(DEREFWORD(x))) sign_x = UNTAGGED(DEREFWORD(x)) >= 0 ? 0 : -1; else sign_x = OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(x))) ? -1 : 0; if (IS_INT(DEREFWORD(y))) sign_y = UNTAGGED(DEREFWORD(y)) >= 0 ? 0 : -1; else sign_y = OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(y))) ? -1 : 0; /* Work out whether to add or subtract */ if ((sign_y ^ sign_x) >= 0) /* signs the same? */ /* sign(x) * (abs(x) + abs(y)) */ return add_unsigned_long(taskData, x, y, sign_x); else /* sign(x) * (abs(x) - abs(y)) */ return sub_unsigned_long(taskData, x, y, sign_x); } /* add_longc */ Handle sub_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { /* The easiest way to do the subtraction is simply *x-*y+1, but that makes it more difficult to check for overflow. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) - UNTAGGED(DEREFWORD(y)); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) /* No overflow */ return taskData->saveVec.push(TAGGED(t)); } int sign_x, sign_y; if (IS_INT(DEREFWORD(x))) sign_x = UNTAGGED(DEREFWORD(x)) >= 0 ? 0 : -1; else sign_x = OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(x))) ? -1 : 0; if (IS_INT(DEREFWORD(y))) sign_y = UNTAGGED(DEREFWORD(y)) >= 0 ? 0 : -1; else sign_y = OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(y))) ? -1 : 0; /* If the signs are different add the two values. */ if ((sign_y ^ sign_x) < 0) /* signs differ */ { /* sign(x) * (abs(x) + abs(y)) */ return add_unsigned_long(taskData, x, y, sign_x); } else { /* sign(x) * (abs(x) - abs(y)) */ return sub_unsigned_long(taskData, x, y, sign_x); } } /* sub_longc */ Handle mult_longc(TaskData *taskData, Handle y, Handle x) { int sign_x, sign_y; #if USE_GMP mp_limb_t x_extend, y_extend; mp_size_t lx, ly; (void)convertToLong(x, &x_extend, &lx, &sign_x); (void)convertToLong(y, &y_extend, &ly, &sign_y); #else byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; POLYUNSIGNED lx, ly; (void)convertToLong(x, x_extend, &lx, &sign_x); (void)convertToLong(y, y_extend, &ly, &sign_y); #endif // Check for zero args. if (lx == 0 || ly == 0) return taskData->saveVec.push(TAGGED(0)); #if USE_GMP Handle z = alloc_and_save(taskData, WORDS((lx+ly)*sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); mp_limb_t *w = DEREFLIMBHANDLE(z); mp_limb_t *u = IS_INT(DEREFWORD(x)) ? &x_extend : DEREFLIMBHANDLE(x); mp_limb_t *v = IS_INT(DEREFWORD(y)) ? &y_extend : DEREFLIMBHANDLE(y); // The first argument must be the longer. if (lx < ly) mpn_mul(w, v, ly, u, lx); else mpn_mul(w, u, lx, v, ly); return make_canonical(taskData, z, sign_x ^ sign_y); #else /* Get space for result */ Handle long_z = alloc_and_save(taskData, WORDS(lx+ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); /* Can now load the actual addresses because they will not change now. */ byte *u = IS_INT(DEREFWORD(x)) ? x_extend : DEREFBYTEHANDLE(x); byte *v = IS_INT(DEREFWORD(y)) ? y_extend : DEREFBYTEHANDLE(y); byte *w = DEREFBYTEHANDLE(long_z); for(POLYUNSIGNED i = 0; i < lx; i++) { POLYUNSIGNED j; long r = 0; /* Set the carry to zero */ for(j = 0; j < ly; j++) { /* Compute the product. */ r += u[i] * v[j]; /* Now add in to the result. */ r += w[i+j]; w[i+j] = r & 0xff; r >>= 8; } /* Put in any carry. */ w[i+j] = (byte)r; } return make_canonical(taskData, long_z, sign_x ^ sign_y); #endif } /* mult_long */ #ifndef USE_GMP static void div_unsigned_long(byte *u, byte *v, byte *remres, byte *divres, POLYUNSIGNED lu, POLYUNSIGNED lv) // Unsigned division. This is the main divide and remainder routine. // remres must be at least lu+1 bytes long // divres must be at least lu-lv+1 bytes long but can be zero if not required { POLYUNSIGNED i,j; long r; /* Find out how far to shift v to get a 1 in the top bit. */ int bits = 0; for(r = v[lv-1]; r < 128; r <<= 1) bits++; /* 128 ??? */ /* Shift u that amount into res. We have allowed enough room for overflow. */ r = 0; for (i = 0; i < lu; i++) { r |= u[i] << bits; /*``Or in'' the new bits after shifting*/ remres[i] = r & 0xff; /* Put into the destination. */ r >>= 8; /* and shift down the carry. */ } remres[i] = (byte)r; /* Put in the carry */ /* And v that amount. It has already been copied. */ if ( bits ) { r = 0; for (i = 0; i < lv; i++) { r |= v[i] << bits; v[i] = r & 0xff; r >>= 8; } /* No carry */ } for(j = lu; j >= lv; j--) { /* j iterates over the higher digits of the dividend until we are left with a number which is less than the divisor. This is the remainder. */ long quotient, dividend, r; dividend = remres[j]*256 + remres[j-1]; quotient = (remres[j] == v[lv-1]) ? 255 : dividend/(long)v[lv-1]; if (lv != 1) { while ((long)v[lv-2]*quotient > (dividend - quotient*(long)v[lv-1])*256 + (long)remres[j-2]) { quotient--; } } /* The quotient is at most 1 too large */ /* Subtract the product of this with ``v'' from ``res''. */ r = 1; /* Initial borrow */ for(i = 0; i < lv; i++) { r += 255 + remres[j-lv+i] - quotient * v[i]; remres[j-lv+i] = r & 0xff; r >>= 8; } r += remres[j]; /* Borrow from leading digit. */ /* If we are left with a borrow when the subtraction is complete the quotient must have been too big. We add ``v'' to the dividend and subtract 1 from the quotient. */ if (r == 0 /* would be 1 if there were no borrow */) { quotient --; r = 0; for (i = 0; i < lv; i++) { r += v[i] + remres[j-lv+i]; remres[j-lv+i] = r & 0xff; r >>= 8; } } /* Place the next digit of quotient in result */ if (divres) divres[j-lv] = (byte)quotient; } /* Likewise the remainder. */ if (bits) { r = 0; j = lv; while (j > 0) { j--; r |= remres[j]; remres[j] = (r >> bits) & 0xff; r = (r & 0xff) << 8; } } } /* div_unsigned_long */ #endif // Common code for div and mod. Returns handles to the results. static void quotRem(TaskData *taskData, Handle y, Handle x, Handle &remHandle, Handle &divHandle) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { POLYSIGNED xs = UNTAGGED(DEREFWORD(x)); POLYSIGNED ys = UNTAGGED(DEREFWORD(y)); /* Raise exceptions if dividing by zero. */ if (ys == 0) raise_exception0(taskData, EXC_divide); /* Only possible overflow is minint div -1 */ if (xs != -MAXTAGGED-1 || ys != -1) { divHandle = taskData->saveVec.push(TAGGED(xs / ys)); remHandle = taskData->saveVec.push(TAGGED(xs % ys)); return; } } int sign_x, sign_y; #if USE_GMP mp_limb_t x_extend, y_extend; mp_size_t lx, ly; (void)convertToLong(x, &x_extend, &lx, &sign_x); (void)convertToLong(y, &y_extend, &ly, &sign_y); // If length of v is zero raise divideerror. if (ly == 0) raise_exception0(taskData, EXC_divide); if (lx < ly) { divHandle = taskData->saveVec.push(TAGGED(0)); remHandle = x; /* When x < y remainder is x. */ return; } Handle remRes = alloc_and_save(taskData, WORDS(ly * sizeof(mp_limb_t)), F_MUTABLE_BIT | F_BYTE_OBJ); Handle divRes = alloc_and_save(taskData, WORDS((lx - ly + 1) * sizeof(mp_limb_t)), F_MUTABLE_BIT | F_BYTE_OBJ); mp_limb_t *u = IS_INT(DEREFWORD(x)) ? &x_extend : DEREFLIMBHANDLE(x); mp_limb_t *v = IS_INT(DEREFWORD(y)) ? &y_extend : DEREFLIMBHANDLE(y); mp_limb_t *quotient = DEREFLIMBHANDLE(divRes); mp_limb_t *remainder = DEREFLIMBHANDLE(remRes); // Do the division. mpn_tdiv_qr(quotient, remainder, 0, u, lx, v, ly); // Return the results. remHandle = make_canonical(taskData, remRes, sign_x /* Same sign as dividend */); divHandle = make_canonical(taskData, divRes, sign_x ^ sign_y); #else byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; POLYUNSIGNED lx, ly; (void)convertToLong(x, x_extend, &lx, &sign_x); (void)convertToLong(y, y_extend, &ly, &sign_y); /* If length of y is zero raise divideerror */ if (ly == 0) raise_exception0(taskData, EXC_divide); // If the length of divisor is less than the dividend the quotient is zero. if (lx < ly) { divHandle = taskData->saveVec.push(TAGGED(0)); remHandle = x; /* When x < y remainder is x. */ return; } /* copy in case it needs shifting */ Handle longCopyHndl = alloc_and_save(taskData, WORDS(ly), F_BYTE_OBJ | F_MUTABLE_BIT); byte *u = IS_INT(DEREFWORD(y)) ? y_extend : DEREFBYTEHANDLE(y); memcpy(DEREFBYTEHANDLE(longCopyHndl), u, ly); Handle divRes = alloc_and_save(taskData, WORDS(lx-ly+1), F_MUTABLE_BIT|F_BYTE_OBJ); Handle remRes = alloc_and_save(taskData, WORDS(lx+1), F_MUTABLE_BIT|F_BYTE_OBJ); byte *long_x = IS_INT(DEREFWORD(x)) ? x_extend : DEREFBYTEHANDLE(x); div_unsigned_long (long_x, DEREFBYTEHANDLE(longCopyHndl), DEREFBYTEHANDLE(remRes), DEREFBYTEHANDLE(divRes), lx, ly); /* Clear the rest */ for(POLYUNSIGNED i=ly; i < lx+1; i++) { DEREFBYTEHANDLE(remRes)[i] = 0; } remHandle = make_canonical(taskData, remRes, sign_x /* Same sign as dividend */ ); divHandle = make_canonical(taskData, divRes, sign_x ^ sign_y); #endif } // This returns x divided by y. This always rounds towards zero so // corresponds to Int.quot in ML not Int.div. Handle div_longc(TaskData *taskData, Handle y, Handle x) { Handle remHandle, divHandle; quotRem(taskData, y, x, remHandle, divHandle); return divHandle; } Handle rem_longc(TaskData *taskData, Handle y, Handle x) { Handle remHandle, divHandle; quotRem(taskData, y, x, remHandle, divHandle); return remHandle; } #if defined(_WIN32) // Return a FILETIME from an arbitrary precision number. On both 32-bit and 64-bit Windows // this is a pair of 32-bit values. void getFileTimeFromArb(TaskData *taskData, Handle numHandle, PFILETIME ft) { Handle twoTo16 = taskData->saveVec.push(TAGGED(65536)); Handle twoTo32 = mult_longc(taskData, twoTo16, twoTo16); Handle highPart, lowPart; quotRem(taskData, twoTo32, numHandle, lowPart, highPart); ft->dwLowDateTime = get_C_unsigned(taskData, lowPart->Word()); ft->dwHighDateTime = get_C_unsigned(taskData, highPart->Word()); } #endif /* compare_unsigned is passed LONG integers only */ static int compare_unsigned(PolyWord x, PolyWord y) { #ifdef USE_GMP mp_size_t lx = numLimbs(x); mp_size_t ly = numLimbs(y); if (lx != ly) /* u > v if u longer than v */ { return (lx > ly ? 1 : -1); } return mpn_cmp((mp_limb_t *)x.AsCodePtr(), (mp_limb_t *)y.AsCodePtr(), lx); #else /* First look at the lengths */ POLYUNSIGNED lx = get_length(x); POLYUNSIGNED ly = get_length(y); if (lx != ly) /* u > v if u longer than v */ { return (lx > ly ? 1 : -1); } // Same length - look at the values. */ byte *u = x.AsCodePtr(); byte *v = y.AsCodePtr(); POLYUNSIGNED i = lx; while (i > 0) { i--; if (u[i] != v[i]) { return u[i] > v[i] ? 1 : -1; } } /* Must be equal */ return 0; #endif } int compareLong(PolyWord y, PolyWord x) { // Test if the values are bitwise equal. If either is short // this is the only case where the values could be equal. if (x == y) // Equal return 0; if (x.IsTagged()) { // x is short. if (y.IsTagged()) { // Both short. We've already tested for equality. if (x.UnTagged() < y.UnTagged()) return -1; // Less else return 1; // Greater } // y is not short. Just test the sign. If it's negative // it must be less than any short value and if it's positive // it must be greater. if (OBJ_IS_NEGATIVE(GetLengthWord(y))) return 1; // x is greater else return -1; // x is less } // x is not short if (y.IsTagged()) { // y is short. Just test the sign of x if (OBJ_IS_NEGATIVE(GetLengthWord(x))) return -1; // x is less else return 1; // x is greater } // Must both be long. We may be able to determine the result based purely on the sign bits. if (! OBJ_IS_NEGATIVE(GetLengthWord(x))) /* x is positive */ { if (! OBJ_IS_NEGATIVE(GetLengthWord(y))) /* y also positive */ { return compare_unsigned(x, y); } else /* y negative so x > y */ { return 1; } } else { /* x is negative */ if (OBJ_IS_NEGATIVE(GetLengthWord(y))) /* y also negative */ { return compare_unsigned(y, x); } else /* y positive so x < y */ { return -1; } } } /* compareLong */ /* logical_long. General purpose function for binary logical operations. */ static Handle logical_long(TaskData *taskData, Handle x, Handle y, unsigned(*op)(unsigned, unsigned)) { int signX, signY; #if USE_GMP mp_limb_t x_extend, y_extend; mp_size_t lx, ly; (void)convertToLong(x, &x_extend, &lx, &signX); (void)convertToLong(y, &y_extend, &ly, &signY); lx = lx*sizeof(mp_limb_t); // We want these in bytes ly = ly*sizeof(mp_limb_t); #else byte x_extend[sizeof(PolyWord)], y_extend[sizeof(PolyWord)]; POLYUNSIGNED lx, ly; (void)convertToLong(x, x_extend, &lx, &signX); (void)convertToLong(y, y_extend, &ly, &signY); #endif byte *u; /* byte-pointer for longer number */ byte *v; /* byte-pointer for shorter number */ Handle z; int sign, signU, signV; POLYUNSIGNED lu; /* length of u in bytes */ POLYUNSIGNED lv; /* length of v in bytes */ /* find the longer number */ /* Make ``u'' the longer. */ if (lx < ly) { // Get result vector. There can't be any carry at the end so // we just need to make this as large as the larger number. z = alloc_and_save(taskData, WORDS(ly), F_MUTABLE_BIT|F_BYTE_OBJ); /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(y)) ? (byte*)&y_extend : DEREFBYTEHANDLE(y); lu = ly; v = IS_INT(DEREFWORD(x)) ? (byte*)&x_extend : DEREFBYTEHANDLE(x); lv = lx; signU = signY; signV = signX; } else { /* Get result vector. */ #if USE_GMP // Add one limb z = alloc_and_save(taskData, WORDS(lx+sizeof(mp_limb_t)), F_MUTABLE_BIT|F_BYTE_OBJ); #else // Add one word. Actually we just want one more byte. z = alloc_and_save(taskData, WORDS(lx+sizeof(PolyWord)), F_MUTABLE_BIT|F_BYTE_OBJ); #endif /* now safe to dereference pointers */ u = IS_INT(DEREFWORD(x)) ? (byte*)&x_extend : DEREFBYTEHANDLE(x); lu = lx; v = IS_INT(DEREFWORD(y)) ? (byte*)&y_extend : DEREFBYTEHANDLE(y); lv = ly; signU = signX; signV = signY; } sign = (*op)(signU, signV); /* -1 if negative, 0 if positive. */ { /* do the actual operations */ byte *w = DEREFBYTEHANDLE(z); int borrowU = 1, borrowV = 1, borrowW = 1; POLYUNSIGNED i = 0; /* Do the operations. */ for( ; i < lv; i++) { int wI; /* Have to convert negative values to twos complement. */ if (signU) borrowU += 255 - u[i]; else borrowU = u[i]; if (signV) borrowV += 255 - v[i]; else borrowV = v[i]; wI = (*op)(borrowU, borrowV) & 255; if (sign) { /* Have to convert the result back to twos complement. */ borrowW += 255 - wI; w[i] = borrowW & 255; borrowW >>= 8; } else w[i] = wI; borrowU >>= 8; borrowV >>= 8; } /* At this point the borrow of V should be zero. */ ASSERT(signV == 0 || borrowV == 0); /* Continue with ``u''. */ for( ; i < lu; i++) { int wI; if (signU) borrowU += 255 - u[i]; else borrowU = u[i]; if (signV) borrowV = 255; else borrowV = 0; wI = (*op)(borrowU, borrowV) & 255; if (sign) { /* Have to convert the result back to twos complement. */ borrowW += 255 - wI; w[i] = borrowW & 255; borrowW >>= 8; } else w[i] = wI; borrowU >>= 8; borrowV >>= 8; } /* We should now no longer have any borrows. */ ASSERT(signU == 0 || borrowU == 0); ASSERT(sign == 0 || borrowW == 0); } return make_canonical(taskData, z, sign); } /* logical_long */ static unsigned doAnd(unsigned i, unsigned j) { return i & j; } static unsigned doOr(unsigned i, unsigned j) { return i | j; } static unsigned doXor(unsigned i, unsigned j) { return i ^ j; } Handle and_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { /* There's no problem with overflow so we can just AND together the values. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) & UNTAGGED(DEREFWORD(y)); return taskData->saveVec.push(TAGGED(t)); } return logical_long(taskData, x, y, doAnd); } Handle or_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { /* There's no problem with overflow so we can just OR together the values. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) | UNTAGGED(DEREFWORD(y)); return taskData->saveVec.push(TAGGED(t)); } return logical_long(taskData, x, y, doOr); } Handle xor_longc(TaskData *taskData, Handle y, Handle x) { if (IS_INT(DEREFWORD(x)) && IS_INT(DEREFWORD(y))) /* Both short */ { /* There's no problem with overflow so we can just XOR together the values. */ POLYSIGNED t = UNTAGGED(DEREFWORD(x)) ^ UNTAGGED(DEREFWORD(y)); return taskData->saveVec.push(TAGGED(t)); } return logical_long(taskData, x, y, doXor); } // Convert a long precision value to floating point double get_arbitrary_precision_as_real(PolyWord x) { if (IS_INT(x)) { POLYSIGNED t = UNTAGGED(x); return (double)t; } double acc = 0; #if USE_GMP mp_limb_t *u = (mp_limb_t *)(x.AsObjPtr()); mp_size_t lx = numLimbs(x); for ( ; lx > 0; lx--) { int ll = sizeof(mp_limb_t); for ( ; ll > 0 ; ll-- ) { acc = acc * 256; } acc = acc + (double)u[lx-1]; } #else byte *u = (byte *)(x.AsObjPtr()); POLYUNSIGNED lx = OBJECT_LENGTH(x)*sizeof(PolyWord); for( ; lx > 0; lx--) { acc = acc * 256 + (double)u[lx-1]; } #endif if (OBJ_IS_NEGATIVE(GetLengthWord(x))) return -acc; else return acc; } /* Arbitrary precision GCD function. This is really included to make use of GMP's GCD function that selects an algorithm based on the length of the arguments. */ #ifdef USE_GMP Handle gcd_arbitrary(TaskData *taskData, Handle x, Handle y) { /* mpn_gcd requires that each argument is odd and its first argument must be no longer than its second. This requires shifting before the call and after the result has been returned. This code is modelled roughly on the high level mpz_gcd call in GMP. */ mp_limb_t x_extend, y_extend; int sign_x, sign_y; // Signs are ignored - the result is always positive. mp_size_t lx, ly; mp_limb_t *longX = convertToLong(x, &x_extend, &lx, &sign_x); mp_limb_t *longY = convertToLong(y, &y_extend, &ly, &sign_y); // Test for zero length and therefore zero argument if (lx == 0) { // GCD(0,y) = abs(y) if (sign_y) return neg_longc(taskData, y); else return y; } if (ly == 0) { // GCD(x,0 = abs(x) if (sign_x) return neg_longc(taskData, x); else return x; } // If one of the arguments is a single limb we can use the special case. // This doesn't require shifting. It also doesn't say that it could // overwrite the arguments. if (lx == 1 || ly == 1) { mp_limb_t g = (lx == 1) ? mpn_gcd_1(longY, ly, *longX) : mpn_gcd_1(longX, lx, *longY); if (g <= MAXTAGGED) return taskData->saveVec.push(TAGGED(g)); // Need to allocate space. Handle r = alloc_and_save(taskData, WORDS(sizeof(mp_limb_t)), F_BYTE_OBJ); *(DEREFLIMBHANDLE(r)) = g; return r; } // Memory for result. This can be up to the shorter of the two. // We rely on this zero the memory because we may not set every word here. Handle r = alloc_and_save(taskData, WORDS((lx < ly ? lx : ly)*sizeof(mp_limb_t)), F_BYTE_OBJ|F_MUTABLE_BIT); // Can now dereference the handles. mp_limb_t *xl = IS_INT(DEREFWORD(x)) ? &x_extend : DEREFLIMBHANDLE(x); mp_limb_t *yl = IS_INT(DEREFWORD(y)) ? &y_extend : DEREFLIMBHANDLE(y); mp_limb_t *rl = DEREFLIMBHANDLE(r); unsigned xZeroLimbs = 0, xZeroBits = 0; // Remove whole limbs of zeros. There must be a word which is non-zero. while (*xl == 0) { xl++; xZeroLimbs++; lx--; } // Count the low-order bits and shift by that amount. mp_limb_t t = *xl; while ((t & 1) == 0) { t = t >> 1; xZeroBits++; } // Copy the non-zero limbs into a temporary, shifting if necessary. mp_limb_t *xC = (mp_limb_t*)alloca(lx * sizeof(mp_limb_t)); if (xZeroBits != 0) { mpn_rshift(xC, xl, lx, xZeroBits); if (xC[lx-1] == 0) lx--; } else memcpy(xC, xl, lx * sizeof(mp_limb_t)); unsigned yZeroLimbs = 0, yZeroBits = 0; while (*yl == 0) { yl++; yZeroLimbs++; ly--; } t = *yl; while ((t & 1) == 0) { t = t >> 1; yZeroBits++; } mp_limb_t *yC = (mp_limb_t*)alloca(ly * sizeof(mp_limb_t)); if (yZeroBits != 0) { mpn_rshift(yC, yl, ly, yZeroBits); if (yC[ly-1] == 0) ly--; } else memcpy(yC, yl, ly * sizeof(mp_limb_t)); // The result length and shift is the smaller of these unsigned rZeroLimbs, rZeroBits; if (xZeroLimbs < yZeroLimbs || (xZeroLimbs == yZeroLimbs && xZeroBits < yZeroBits)) { rZeroLimbs = xZeroLimbs; rZeroBits = xZeroBits; } else { rZeroLimbs = yZeroLimbs; rZeroBits = yZeroBits; } // Now actually compute the GCD if (lx < ly || (lx == ly && xC[lx-1] < yC[ly-1])) lx = mpn_gcd(xC, yC, ly, xC, lx); else lx = mpn_gcd(xC, xC, lx, yC, ly); // Shift the temporary result into the final area. if (rZeroBits != 0) { t = mpn_lshift(rl+rZeroLimbs, xC, lx, rZeroBits); if (t != 0) rl[rZeroLimbs+lx] = t; } else memcpy(rl+rZeroLimbs, xC, lx * sizeof(mp_limb_t)); return make_canonical(taskData, r, false); } #else // Fallback version for when GMP is not defined. static Handle gxd(TaskData *taskData, Handle x, Handle y) { Handle marker = taskData->saveVec.mark(); while (1) { if (DEREFWORD(y) == TAGGED(0)) return x; Handle res = rem_longc(taskData, y, x); PolyWord newY = res->Word(); PolyWord newX = y->Word(); taskData->saveVec.reset(marker); y = taskData->saveVec.push(newY); x = taskData->saveVec.push(newX); } } static Handle absValue(TaskData *taskData, Handle x) { if (IS_INT(DEREFWORD(x))) { if (UNTAGGED(DEREFWORD(x)) < 0) return neg_longc(taskData, x); } else if (OBJ_IS_NEGATIVE(GetLengthWord(DEREFWORD(x)))) return neg_longc(taskData, x); return x; } Handle gcd_arbitrary(TaskData *taskData, Handle x, Handle y) { x = absValue(taskData, x); y = absValue(taskData, y); if (compareLong(y->Word(), x->Word()) < 0) return gxd(taskData, y, x); else return gxd(taskData, x, y); } #endif // This is provided as an adjunct to GCD. Using this saves the RTS // calls necessary for the division and multiplication. Handle lcm_arbitrary(TaskData *taskData, Handle x, Handle y) { Handle g = gcd_arbitrary(taskData, x, y); return mult_longc(taskData, x, div_longc(taskData, g, y)); } POLYUNSIGNED PolyAddArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // Could raise an exception if out of memory. result = add_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolySubtractArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = sub_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolyMultiplyArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = mult_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolyDivideArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // May raise divide exception result = div_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolyRemainderArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = rem_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This is the older version that took a container as an argument. POLYUNSIGNED PolyQuotRemArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); // arg3 is an address on the stack. It is not a PolyWord. if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // The result handle will almost certainly point into the stack. // This should now be safe within the GC. Handle remHandle, divHandle; quotRem(taskData, pushedArg2, pushedArg1, remHandle, divHandle); arg3.AsObjPtr()->Set(0, divHandle->Word()); arg3.AsObjPtr()->Set(1, remHandle->Word()); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return 0; // Result is unit } // This is the newer version that returns a pair. It's simpler and works with 32-in-64. POLYUNSIGNED PolyQuotRemArbitraryPair(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; // arg3 is an address on the stack. It is not a PolyWord. if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // The result handle will almost certainly point into the stack. // This should now be safe within the GC. Handle remHandle, divHandle; quotRem(taskData, pushedArg2, pushedArg1, remHandle, divHandle); result = alloc_and_save(taskData, 2); result->WordP()->Set(0, divHandle->Word()); result->WordP()->Set(1, remHandle->Word()); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This can be a fast call. It does not need to allocate or use handles. POLYSIGNED PolyCompareArbitrary(PolyWord arg1, PolyWord arg2) { return TAGGED(compareLong(arg2, arg1)).AsSigned(); } POLYUNSIGNED PolyGCDArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { result = gcd_arbitrary(taskData, pushedArg2, pushedArg1); // Generally shouldn't raise an exception but might run out of store. } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolyLCMArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { result = lcm_arbitrary(taskData, pushedArg2, pushedArg1); // Generally shouldn't raise an exception but might run out of store. } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Extract the low order part of an arbitrary precision value as a boxed LargeWord.word // value. If the value is negative it is treated as a twos complement value. // This is used Word.fromLargeInt and LargeWord.fromLargeInt with long-form // arbitrary precision values. POLYUNSIGNED PolyGetLowOrderAsLargeWord(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); uintptr_t p = 0; if (arg.IsTagged()) p = arg.UnTagged(); else { bool negative = OBJ_IS_NEGATIVE(GetLengthWord(arg)) ? true : false; #ifdef USE_GMP mp_limb_t c = *(mp_limb_t*)arg.AsCodePtr(); p = c; #else POLYUNSIGNED length = get_length(arg); if (length > sizeof(uintptr_t)) length = sizeof(uintptr_t); byte *ptr = arg.AsCodePtr(); while (length--) { p = (p << 8) | ptr[length]; } #endif if (negative) p = 0-p; } Handle result = 0; try { result = Make_sysword(taskData, p); } catch (...) {} // We could run out of memory. taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolyOrArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = or_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolyAndArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = and_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } POLYUNSIGNED PolyXorArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = xor_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts arbitraryPrecisionEPT[] = { { "PolyAddArbitrary", (polyRTSFunction)&PolyAddArbitrary}, { "PolySubtractArbitrary", (polyRTSFunction)&PolySubtractArbitrary}, { "PolyMultiplyArbitrary", (polyRTSFunction)&PolyMultiplyArbitrary}, { "PolyDivideArbitrary", (polyRTSFunction)&PolyDivideArbitrary}, { "PolyRemainderArbitrary", (polyRTSFunction)&PolyRemainderArbitrary}, { "PolyQuotRemArbitrary", (polyRTSFunction)&PolyQuotRemArbitrary}, { "PolyQuotRemArbitraryPair", (polyRTSFunction)&PolyQuotRemArbitraryPair }, { "PolyCompareArbitrary", (polyRTSFunction)&PolyCompareArbitrary}, { "PolyGCDArbitrary", (polyRTSFunction)&PolyGCDArbitrary}, { "PolyLCMArbitrary", (polyRTSFunction)&PolyLCMArbitrary}, { "PolyGetLowOrderAsLargeWord", (polyRTSFunction)&PolyGetLowOrderAsLargeWord}, { "PolyOrArbitrary", (polyRTSFunction)&PolyOrArbitrary}, { "PolyAndArbitrary", (polyRTSFunction)&PolyAndArbitrary}, { "PolyXorArbitrary", (polyRTSFunction)&PolyXorArbitrary}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/arb.h b/libpolyml/arb.h index 0af26898..5167909e 100644 --- a/libpolyml/arb.h +++ b/libpolyml/arb.h @@ -1,74 +1,79 @@ /* Title: arb.h - exports signature for arb.c Copyright (c) 2000 Cambridge University Technical Services Limited - Further modification Copyright 2015-16, 2019 David C. J. Matthews + Further modification Copyright 2015-16, 2019, 2020 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifndef ARB_H_INCLUDED #define ARB_H_INCLUDED class SaveVecEntry; typedef SaveVecEntry *Handle; class TaskData; // These functions create values of type int from signed or unsigned values. extern Handle Make_arbitrary_precision(TaskData *taskData, long); extern Handle Make_arbitrary_precision(TaskData *taskData, unsigned long); extern Handle Make_arbitrary_precision(TaskData *taskData, int); extern Handle Make_arbitrary_precision(TaskData *taskData, unsigned); #ifdef HAVE_LONG_LONG extern Handle Make_arbitrary_precision(TaskData *taskData, long long); extern Handle Make_arbitrary_precision(TaskData *taskData, unsigned long long); #endif extern Handle Make_arb_from_32bit_pair(TaskData *taskData, uint32_t hi, uint32_t lo); extern Handle Make_arb_from_pair_scaled(TaskData *taskData, unsigned hi, unsigned lo, unsigned scale); #if defined(_WIN32) extern Handle Make_arb_from_Filetime(TaskData *taskData, const FILETIME &ft); #endif +// Used in the interpreter. +extern Handle add_longc(TaskData* taskData, Handle, Handle); +extern Handle sub_longc(TaskData* taskData, Handle, Handle); +extern Handle mult_longc(TaskData* taskData, Handle, Handle); + // Currently used in basicio.cpp extern Handle div_longc(TaskData *taskData, Handle,Handle); extern Handle rem_longc(TaskData *taskData, Handle,Handle); // Return a uintptr_t/intptr_t value. extern POLYUNSIGNED getPolyUnsigned(TaskData *taskData, PolyWord); extern POLYSIGNED getPolySigned(TaskData *taskData, PolyWord); #define get_C_ulong getPolyUnsigned extern unsigned short get_C_ushort(TaskData *taskData, PolyWord); extern unsigned get_C_unsigned(TaskData *taskData, PolyWord); #define get_C_long getPolySigned extern short get_C_short(TaskData *taskData, PolyWord); extern int get_C_int(TaskData *taskData, PolyWord); extern double get_arbitrary_precision_as_real(PolyWord x); #if defined(_WIN32) void getFileTimeFromArb(TaskData *taskData, Handle numHandle, PFILETIME ft); #endif extern struct _entrypts arbitraryPrecisionEPT[]; #endif diff --git a/libpolyml/bytecode.cpp b/libpolyml/bytecode.cpp index 2579389e..82cd7b85 100644 --- a/libpolyml/bytecode.cpp +++ b/libpolyml/bytecode.cpp @@ -1,2476 +1,2564 @@ /* Title: An interpreter for a compact instruction set. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited Further development Copyright David C.J. Matthews 2015-18, 2020. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif /* #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_MATH_H #include #endif */ #include // Currently just for isnan. #include "globals.h" #include "int_opcodes.h" #include "sys.h" #include "profiling.h" #include "arb.h" #include "reals.h" #include "run_time.h" #include "gc.h" #include "diagnostics.h" #include "polystring.h" #include "scanaddrs.h" #include "rtsentry.h" #include "bytecode.h" #if (SIZEOF_VOIDP == 8 && !defined(POLYML32IN64)) #define IS64BITS 1 #endif #define arg1 (pc[0] + pc[1]*256) #define arg2 (pc[2] + pc[3]*256) const PolyWord True = TAGGED(1); const PolyWord False = TAGGED(0); const PolyWord Zero = TAGGED(0); // This duplicates some code in reals.cpp but is now updated. #define DOUBLESIZE (sizeof(double)/sizeof(POLYUNSIGNED)) union realdb { double dble; POLYUNSIGNED puns[DOUBLESIZE]; }; #define LGWORDSIZE (sizeof(uintptr_t) / sizeof(PolyWord)) // We're using float for Real32 so it needs to be 32-bits. // Assume that's true for the moment. #if (SIZEOF_FLOAT != 4) #error "Float is not 32-bits. Please report this" #endif union flt { float fl; int32_t i; }; ByteCodeInterpreter::ByteCodeInterpreter(stackItem** spAddr, stackItem** slAddr) : mixedCode(false), stackPointerAddress(spAddr), stackLimitAddress(slAddr), overflowPacket(0), dividePacket(0) { #ifdef PROFILEOPCODES memset(frequency, 0, sizeof(frequency)); memset(arg1Value, 0, sizeof(arg1Value)); memset(arg2Value, 0, sizeof(arg2Value)); #endif } ByteCodeInterpreter::~ByteCodeInterpreter() { #ifdef PROFILEOPCODES OutputDebugStringA("Frequency\n"); for (unsigned i = 0; i < 256; i++) { if (frequency[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, frequency[i]); OutputDebugStringA(buffer); } } OutputDebugStringA("Arg1\n"); for (unsigned i = 0; i < 256; i++) { if (arg1Value[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, arg1Value[i]); OutputDebugStringA(buffer); } } OutputDebugStringA("Arg2\n"); for (unsigned i = 0; i < 256; i++) { if (arg2Value[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, arg2Value[i]); OutputDebugStringA(buffer); } } #endif } extern "C" { typedef POLYUNSIGNED(*callFastRts0)(); typedef POLYUNSIGNED(*callFastRts1)(intptr_t); typedef POLYUNSIGNED(*callFastRts2)(intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts3)(intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts4)(intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts5)(intptr_t, intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFullRts0)(PolyObject *); typedef POLYUNSIGNED(*callFullRts1)(PolyObject *, intptr_t); typedef POLYUNSIGNED(*callFullRts2)(PolyObject *, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFullRts3)(PolyObject *, intptr_t, intptr_t, intptr_t); typedef double (*callRTSRtoR) (double); typedef double (*callRTSRRtoR) (double, double); typedef double (*callRTSGtoR) (intptr_t); typedef double (*callRTSRGtoR) (double, intptr_t); typedef float(*callRTSFtoF) (float); typedef float(*callRTSFFtoF) (float, float); typedef float(*callRTSGtoF) (intptr_t); typedef float(*callRTSFGtoF) (float, intptr_t); } // Allocate memory on the heap. Returns with the address of the cell. Does not set the // length word or any of the data. PolyObject* ByteCodeInterpreter::allocateMemory(TaskData * taskData, POLYUNSIGNED words, POLYCODEPTR& pc, stackItem*& sp) { words++; // Add the size of the length word. // N.B. The allocation area may be empty so that both of these are zero. if (taskData->allocPointer >= taskData->allocLimit + words + 1) { #ifdef POLYML32IN64 if (words & 1) words++; #endif taskData->allocPointer -= words; return (PolyObject*)(taskData->allocPointer + 1); } // Insufficient space. SaveInterpreterState(pc, sp); // Find some space to allocate in. Returns a pointer to the newly allocated space. // N.B. This may return zero if the heap is exhausted and it has set this // up for an exception. Generally it allocates by decrementing allocPointer // but if the required memory is large it may allocate in a separate area. PolyWord* space = processes->FindAllocationSpace(taskData, words, true); LoadInterpreterState(pc, sp); if (space == 0) return 0; return (PolyObject*)(space + 1); } // Put a real result in a "box" PolyObject* ByteCodeInterpreter::boxDouble(TaskData* taskData, double d, POLYCODEPTR& pc, stackItem*& sp) { PolyObject* mem = this->allocateMemory(taskData, DOUBLESIZE, pc, sp); if (mem == 0) return 0; mem->SetLengthWord(DOUBLESIZE, F_BYTE_OBJ); union realdb uniondb; uniondb.dble = d; // Copy the words. Depending on the word length this may copy one or more words. for (unsigned i = 0; i < DOUBLESIZE; i++) mem->Set(i, PolyWord::FromUnsigned(uniondb.puns[i])); return mem; } // Extract a double value from a box. double ByteCodeInterpreter::unboxDouble(PolyWord p) { union realdb uniondb; for (unsigned i = 0; i < DOUBLESIZE; i++) uniondb.puns[i] = p.AsObjPtr()->Get(i).AsUnsigned(); return uniondb.dble; } // Largely copied from reals.cpp #if (SIZEOF_FLOAT < SIZEOF_POLYWORD) // Typically for 64-bit mode. Use a tagged representation. // The code-generator on the X86/64 assumes the float is in the // high order word. #define FLT_SHIFT ((SIZEOF_POLYWORD-SIZEOF_FLOAT)*8) float ByteCodeInterpreter::unboxFloat(PolyWord p) { union flt argx; argx.i = p.AsSigned() >> FLT_SHIFT; return argx.fl; } PolyObject* ByteCodeInterpreter::boxFloat(TaskData* taskData, float f, POLYCODEPTR& pc, stackItem*& sp) { union flt argx; argx.fl = f; PolyWord p = PolyWord::FromSigned(((POLYSIGNED)argx.i << FLT_SHIFT) + 1); return p.AsObjPtr(); // Temporarily cast it to this even though it isn't really } #else // Typically for 32-bit mode. Use a boxed representation. PolyObject* ByteCodeInterpreter::boxFloat(TaskData* taskData, float f, POLYCODEPTR& pc, stackItem*& sp) { PolyObject* mem = this->allocateMemory(taskData, 1, pc, sp); if (mem == 0) return 0; mem->SetLengthWord(1, F_BYTE_OBJ); union flt argx; argx.fl = f; mem->Set(0, PolyWord::FromSigned(argx.i)); return mem; } // Extract a double value from a box. float ByteCodeInterpreter::unboxFloat(PolyWord p) { union flt argx; argx.i = (int32_t)p.AsObjPtr()->Get(0).AsSigned(); return argx.fl; } #endif enum ByteCodeInterpreter::_returnValue ByteCodeInterpreter::RunInterpreter(TaskData *taskData) /* (Re)-enter the Poly code from C. */ { // Make packets for exceptions. if (overflowPacket == 0) overflowPacket = makeExceptionPacket(taskData, EXC_overflow); if (dividePacket == 0) dividePacket = makeExceptionPacket(taskData, EXC_divide); // Local values. These are copies of member variables but are used so frequently that // it is important that access should be fast. POLYCODEPTR pc; stackItem*sp; LoadInterpreterState(pc, sp); // We may have taken an interrupt which has set an exception. if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; for(;;){ /* Each instruction */ #if (0) char buff[1000]; sprintf(buff, "addr = %p sp=%p instr=%02x *sp=%p\n", pc, sp, *pc, (*sp).stackAddr); OutputDebugStringA(buff); #endif // These are temporary values used where one instruction jumps to // common code. POLYUNSIGNED tailCount; stackItem* tailPtr; POLYUNSIGNED returnCount; POLYUNSIGNED storeWords; POLYUNSIGNED stackCheck; PolyObject *closure; double dv; #ifdef PROFILEOPCODES frequency[*pc]++; #endif switch(*pc++) { case INSTR_jump8false: { PolyWord u = *sp++; if (u == True) pc += 1; else pc += *pc + 1; break; } case INSTR_jump8: pc += *pc + 1; break; case INSTR_jump8True: { PolyWord u = *sp++; if (u == False) pc += 1; else pc += *pc + 1; break; } case INSTR_jump16True: // Invert the sense of the test and fall through. *sp = ((*sp).w() == True) ? False : True; case INSTR_jump16false: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 2; break; } /* else - false - take the jump */ } case INSTR_jump16: pc += arg1 + 2; break; case INSTR_push_handler: /* Save the old handler value. */ (*(--sp)).stackAddr = GetHandlerRegister(); /* Push old handler */ break; case INSTR_setHandler8: /* Set up a handler */ (*(--sp)).codeAddr = pc + *pc + 1; /* Address of handler */ SetHandlerRegister(sp); pc += 1; break; case INSTR_setHandler16: /* Set up a handler */ (*(--sp)).codeAddr = pc + arg1 + 2; /* Address of handler */ SetHandlerRegister(sp); pc += 2; break; case INSTR_deleteHandler: /* Delete handler retaining the result. */ { stackItem u = *sp++; sp = GetHandlerRegister(); sp++; // Remove handler entry point SetHandlerRegister((*sp).stackAddr); // Restore old handler *sp = u; // Put back the result break; } case INSTR_case16: { // arg1 is the largest value that is in the range POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ if (u >= arg1 || u < 0) pc += 2 + arg1*2; /* Out of range */ else { pc += 2; pc += /* Index */pc[u*2]+pc[u*2 + 1]*256; } break; } case INSTR_tail_b_b: tailCount = *pc; tailPtr = sp + tailCount; sp = tailPtr + pc[1]; TAIL_CALL: /* For general case. */ if (tailCount < 2) Crash("Invalid argument\n"); numTailArguments = (unsigned)(tailCount - 2); for (; tailCount > 0; tailCount--) *(--sp) = *(--tailPtr); pc = (*sp++).codeAddr; /* Pop the original return address. */ closure = (*sp++).w().AsObjPtr(); if (mixedCode) { // Return to the caller in case the function we're calling is machine code. // The number of arguments we're passing is given in the tail-count. There's // no enter-int after this because we're not coming back. (--sp)->codeAddr = pc; *(--sp) = (PolyWord)closure; SaveInterpreterState(pc, sp); return ReturnTailCall; } goto CALL_CLOSURE; /* And drop through. */ case INSTR_call_closure: /* Closure call. */ { closure = (*sp++).w().AsObjPtr(); CALL_CLOSURE: (--sp)->codeAddr = pc; /* Save return address. */ *(--sp) = (PolyWord)closure; if (mixedCode) { SaveInterpreterState(pc, sp); return ReturnCall; // Caller must look at enter-int to determine number of args } pc = *(POLYCODEPTR*)closure; /* Get entry point. */ SaveInterpreterState(pc, sp); // Update in case we're profiling // Check that there at least 128 words on the stack stackCheck = 128; goto STACKCHECK; } case INSTR_callConstAddr8: closure = (*(PolyWord*)(pc + pc[0] + 1)).AsObjPtr(); pc += 1; goto CALL_CLOSURE; case INSTR_callConstAddr16: closure = (*(PolyWord*)(pc + arg1 + 2)).AsObjPtr(); pc += 2; goto CALL_CLOSURE; case INSTR_callLocalB: { closure = (sp[*pc++]).w().AsObjPtr(); goto CALL_CLOSURE; } case INSTR_return_w: returnCount = arg1; /* Get no. of args to remove. */ RETURN: /* Common code for return. */ { stackItem result = *sp++; /* Result */ sp++; /* Remove the link/closure */ pc = (*sp++).codeAddr; /* Return address */ sp += returnCount; /* Add on number of args. */ *(--sp) = result; /* Result */ SaveInterpreterState(pc, sp); // Update in case we're profiling or if returning if (mixedCode) return ReturnReturn; } break; case INSTR_return_b: returnCount = *pc; goto RETURN; case INSTR_return_1: returnCount = 1; goto RETURN; case INSTR_return_2: returnCount = 2; goto RETURN; case INSTR_return_3: returnCount = 3; goto RETURN; case INSTR_stackSize16: { stackCheck = arg1; pc += 2; STACKCHECK: // Check stack space. This is combined with interrupts on the native code version. if (sp - stackCheck < *stackLimitAddress) { SaveInterpreterState(pc, sp); HandleStackOverflow(stackCheck); LoadInterpreterState(pc, sp); } break; } case INSTR_raise_ex: { { PolyException *exn = (PolyException*)((*sp).w().AsObjPtr()); taskData->SetException(exn); } RAISE_EXCEPTION: sp = GetHandlerRegister(); pc = (*sp++).codeAddr; // It is possible we could raise an exception to be // handled by native code but that does not currently happen // during the bootstrap. SetHandlerRegister((*sp++).stackAddr); break; } case INSTR_tuple_2: storeWords = 2; goto TUPLE; case INSTR_tuple_3: storeWords = 3; goto TUPLE; case INSTR_tuple_4: storeWords = 4; goto TUPLE; case INSTR_tuple_b: storeWords = *pc; pc++; goto TUPLE; case INSTR_closureB: storeWords = *pc++; goto CREATE_CLOSURE; break; case INSTR_local_w: { stackItem u = sp[arg1]; *(--sp) = u; pc += 2; break; } case INSTR_constAddr8: *(--sp) = *(PolyWord*)(pc + pc[0] + 1); pc += 1; break; case INSTR_constAddr16: *(--sp) = *(PolyWord*)(pc + arg1 + 2); pc += 2; break; case INSTR_const_int_w: *(--sp) = TAGGED(arg1); pc += 2; break; case INSTR_jump_back8: pc -= *pc + 1; // Check for interrupt in case we're in a loop if (sp < *stackLimitAddress) { SaveInterpreterState(pc, sp); HandleStackOverflow(0); LoadInterpreterState(pc, sp); } break; case INSTR_jump_back16: pc -= arg1 + 1; // Check for interrupt in case we're in a loop if (sp < *stackLimitAddress) { SaveInterpreterState(pc, sp); HandleStackOverflow(0); LoadInterpreterState(pc, sp); } break; case INSTR_lock: { PolyObject *obj = (*sp).w().AsObjPtr(); obj->SetLengthWord(obj->LengthWord() & ~_OBJ_MUTABLE_BIT); break; } case INSTR_ldexc: *(--sp) = GetExceptionPacket(); break; case INSTR_local_b: { stackItem u = sp[*pc]; *(--sp) = u; pc += 1; break; } case INSTR_indirect_b: *sp = (*sp).w().AsObjPtr()->Get(*pc); pc += 1; break; case INSTR_indirectLocalBB: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(*pc++); break; } case INSTR_indirectLocalB0: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(0); break; } case INSTR_indirect0Local0: { PolyWord u = sp[0]; *(--sp) = u.AsObjPtr()->Get(0); break; } case INSTR_indirectLocalB1: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(1); break; } case INSTR_moveToContainerB: { PolyWord u = *sp++; (*sp).stackAddr[*pc] = u; pc += 1; break; } case INSTR_moveToMutClosureB: { PolyWord u = *sp++; (*sp).w().AsObjPtr()->Set(*pc++ + sizeof(uintptr_t) / sizeof(PolyWord), u); break; } case INSTR_indirectContainerB: *sp = (*sp).stackAddr[*pc]; pc += 1; break; case INSTR_indirectClosureBB: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(*pc++ + sizeof(uintptr_t) / sizeof(PolyWord)); break; } case INSTR_indirectClosureB0: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord)); break; } case INSTR_indirectClosureB1: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord) + 1); break; } case INSTR_indirectClosureB2: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord) + 2); break; } case INSTR_set_stack_val_b: { PolyWord u = *sp++; sp[*pc-1] = u; pc += 1; break; } case INSTR_reset_b: sp += *pc; pc += 1; break; case INSTR_reset_r_b: { PolyWord u = *sp; sp += *pc; *sp = u; pc += 1; break; } case INSTR_const_int_b: *(--sp) = TAGGED(*pc); pc += 1; break; case INSTR_local_0: { stackItem u = sp[0]; *(--sp) = u; break; } case INSTR_local_1: { stackItem u = sp[1]; *(--sp) = u; break; } case INSTR_local_2: { stackItem u = sp[2]; *(--sp) = u; break; } case INSTR_local_3: { stackItem u = sp[3]; *(--sp) = u; break; } case INSTR_local_4: { stackItem u = sp[4]; *(--sp) = u; break; } case INSTR_local_5: { stackItem u = sp[5]; *(--sp) = u; break; } case INSTR_local_6: { stackItem u = sp[6]; *(--sp) = u; break; } case INSTR_local_7: { stackItem u = sp[7]; *(--sp) = u; break; } case INSTR_local_8: { stackItem u = sp[8]; *(--sp) = u; break; } case INSTR_local_9: { stackItem u = sp[9]; *(--sp) = u; break; } case INSTR_local_10: { stackItem u = sp[10]; *(--sp) = u; break; } case INSTR_local_11: { stackItem u = sp[11]; *(--sp) = u; break; } case INSTR_local_12: { stackItem u = sp[12]; *(--sp) = u; break; } case INSTR_local_13: { stackItem u = sp[13]; *(--sp) = u; break; } case INSTR_local_14: { stackItem u = sp[14]; *(--sp) = u; break; } case INSTR_local_15: { stackItem u = sp[15]; *(--sp) = u; break; } case INSTR_indirect_0: *sp = (*sp).w().AsObjPtr()->Get(0); break; case INSTR_indirect_1: *sp = (*sp).w().AsObjPtr()->Get(1); break; case INSTR_indirect_2: *sp = (*sp).w().AsObjPtr()->Get(2); break; case INSTR_indirect_3: *sp = (*sp).w().AsObjPtr()->Get(3); break; case INSTR_indirect_4: *sp = (*sp).w().AsObjPtr()->Get(4); break; case INSTR_indirect_5: *sp = (*sp).w().AsObjPtr()->Get(5); break; case INSTR_const_0: *(--sp) = Zero; break; case INSTR_const_1: *(--sp) = TAGGED(1); break; case INSTR_const_2: *(--sp) = TAGGED(2); break; case INSTR_const_3: *(--sp) = TAGGED(3); break; case INSTR_const_4: *(--sp) = TAGGED(4); break; case INSTR_const_10: *(--sp) = TAGGED(10); break; case INSTR_reset_r_1: { PolyWord u = *sp; sp += 1; *sp = u; break; } case INSTR_reset_r_2: { PolyWord u = *sp; sp += 2; *sp = u; break; } case INSTR_reset_r_3: { PolyWord u = *sp; sp += 3; *sp = u; break; } case INSTR_reset_1: sp += 1; break; case INSTR_reset_2: sp += 2; break; case INSTR_stack_containerB: { POLYUNSIGNED words = *pc++; while (words-- > 0) *(--sp) = Zero; sp--; (*sp).stackAddr = sp + 1; break; } case INSTR_callFastRTS0: { callFastRts0 doCall = *(callFastRts0*)(*sp++).w().AsObjPtr(); ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS1: { callFastRts1 doCall = *(callFastRts1*)(*sp++).w().AsObjPtr(); intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS2: { callFastRts2 doCall = *(callFastRts2*)(*sp++).w().AsObjPtr(); intptr_t rtsArg2 = (*sp++).argValue; // Pop off the args, last arg first. intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS3: { callFastRts3 doCall = *(callFastRts3*)(*sp++).w().AsObjPtr(); intptr_t rtsArg3 = (*sp++).argValue; // Pop off the args, last arg first. intptr_t rtsArg2 = (*sp++).argValue; intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS4: { callFastRts4 doCall = *(callFastRts4*)(*sp++).w().AsObjPtr(); intptr_t rtsArg4 = (*sp++).argValue; // Pop off the args, last arg first. intptr_t rtsArg3 = (*sp++).argValue; intptr_t rtsArg2 = (*sp++).argValue; intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS5: { callFastRts5 doCall = *(callFastRts5*)(*sp++).w().AsObjPtr(); intptr_t rtsArg5 = (*sp++).argValue; // Pop off the args, last arg first. intptr_t rtsArg4 = (*sp++).argValue; intptr_t rtsArg3 = (*sp++).argValue; intptr_t rtsArg2 = (*sp++).argValue; intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4, rtsArg5); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_notBoolean: *sp = ((*sp).w() == True) ? False : True; break; case INSTR_isTagged: *sp = (*sp).w().IsTagged() ? True : False; break; case INSTR_cellLength: /* Return the length word. */ *sp = TAGGED((*sp).w().AsObjPtr()->Length()); break; case INSTR_cellFlags: { PolyObject *p = (*sp).w().AsObjPtr(); POLYUNSIGNED f = (p->LengthWord()) >> OBJ_PRIVATE_FLAGS_SHIFT; *sp = TAGGED(f); break; } case INSTR_clearMutable: { PolyObject *obj = (*sp).w().AsObjPtr(); POLYUNSIGNED lengthW = obj->LengthWord(); /* Clear the mutable bit. */ obj->SetLengthWord(lengthW & ~_OBJ_MUTABLE_BIT); *sp = Zero; break; } case INSTR_atomicIncr: { PolyObject* p = (*sp).w().AsObjPtr(); POLYUNSIGNED newValue = taskData->AtomicIncrement(p); *sp = PolyWord::FromUnsigned(newValue); break; } case INSTR_atomicDecr: { PolyObject *p = (*sp).w().AsObjPtr(); POLYUNSIGNED newValue = taskData->AtomicDecrement(p); *sp = PolyWord::FromUnsigned(newValue); break; } case INSTR_equalWord: { PolyWord u = *sp++; *sp = u == (*sp) ? True : False; break; } case INSTR_jumpNEqLocal: { // Compare a local with a constant and jump if not equal. PolyWord u = sp[pc[0]]; if (u.IsTagged() && u.UnTagged() == pc[1]) pc += 3; else pc += pc[2] + 3; break; } case INSTR_jumpNEqLocalInd: { // Test the union tag value in the first word of a tuple. PolyWord u = sp[pc[0]]; u = u.AsObjPtr()->Get(0); if (u.IsTagged() && u.UnTagged() == pc[1]) pc += 3; else pc += pc[2] + 3; break; } case INSTR_isTaggedLocalB: { PolyWord u = sp[*pc++]; *(--sp) = u.IsTagged() ? True : False; break; } case INSTR_jumpTaggedLocal: { PolyWord u = sp[*pc]; // Jump if the value is tagged. if (u.IsTagged()) pc += pc[1] + 2; else pc += 2; break; } case INSTR_lessSigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsSigned() < u.AsSigned()) ? True : False; break; } case INSTR_lessUnsigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsUnsigned() < u.AsUnsigned()) ? True : False; break; } case INSTR_lessEqSigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsSigned() <= u.AsSigned()) ? True : False; break; } case INSTR_lessEqUnsigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsUnsigned() <= u.AsUnsigned()) ? True : False; break; } case INSTR_greaterSigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsSigned() > u.AsSigned()) ? True : False; break; } case INSTR_greaterUnsigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsUnsigned() > u.AsUnsigned()) ? True : False; break; } case INSTR_greaterEqSigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsSigned() >= u.AsSigned()) ? True : False; break; } case INSTR_greaterEqUnsigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsUnsigned() >= u.AsUnsigned()) ? True : False; break; } case INSTR_fixedAdd: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(x) + UNTAGGED(y); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } break; } case INSTR_fixedSub: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(y) - UNTAGGED(x); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } break; } case INSTR_fixedMult: { POLYSIGNED x = UNTAGGED(*sp++); POLYSIGNED y = (*sp).w().AsSigned() - 1; // Just remove the tag POLYSIGNED t = x * y; if (x != 0 && t / x != y) { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } *sp = PolyWord::FromSigned(t+1); // Add back the tag break; } case INSTR_fixedQuot: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) / u); break; } case INSTR_fixedRem: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) % u); break; } case INSTR_wordAdd: { PolyWord u = *sp++; // Because we're not concerned with overflow we can just add the values and subtract the tag. *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() + u.AsUnsigned() - TAGGED(0).AsUnsigned()); break; } case INSTR_wordSub: { PolyWord u = *sp++; *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() - u.AsUnsigned() + TAGGED(0).AsUnsigned()); break; } case INSTR_wordMult: { PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) * UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordDiv: { POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); // Detection of zero is done in ML *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) / u); break; } case INSTR_wordMod: { POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) % u); break; } case INSTR_wordAnd: { PolyWord u = *sp++; // Since both of these should be tagged the tag bit will be preserved. *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() & u.AsUnsigned()); break; } case INSTR_wordOr: { PolyWord u = *sp++; // Since both of these should be tagged the tag bit will be preserved. *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() | u.AsUnsigned()); break; } case INSTR_wordXor: { PolyWord u = *sp++; // This will remove the tag bit so it has to be reinstated. *sp = PolyWord::FromUnsigned(((*sp).w().AsUnsigned() ^ u.AsUnsigned()) | TAGGED(0).AsUnsigned()); break; } case INSTR_wordShiftLeft: { // ML requires shifts greater than a word to return zero. // That's dealt with at the higher level. PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) << UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordShiftRLog: { PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) >> UNTAGGED_UNSIGNED(u)); break; } + case INSTR_arbAdd: + { + PolyWord x = *sp++; + PolyWord y = (*sp); + if (x.IsTagged() && y.IsTagged()) + { + POLYSIGNED t = UNTAGGED(x) + UNTAGGED(y); + if (t <= MAXTAGGED && t >= -MAXTAGGED - 1) + { + *sp = TAGGED(t); + break; + } + } + // One argument was untagged or there was an overflow + try { + Handle mark = taskData->saveVec.mark(); + SaveInterpreterState(pc, sp); + Handle result = add_longc(taskData, taskData->saveVec.push(x), taskData->saveVec.push(y)); + LoadInterpreterState(pc, sp); + *sp = result->Word(); + taskData->saveVec.reset(mark); + } + catch (IOException&) { + // We could run out of store + goto RAISE_EXCEPTION; + } + break; + } + + case INSTR_arbSubtract: + { + PolyWord x = *sp++; + PolyWord y = (*sp); + if (x.IsTagged() && y.IsTagged()) + { + POLYSIGNED t = UNTAGGED(y) - UNTAGGED(x); + if (t <= MAXTAGGED && t >= -MAXTAGGED - 1) + { + *sp = TAGGED(t); + break; + } + } + // One argument was untagged or there was an overflow + try { + Handle mark = taskData->saveVec.mark(); + SaveInterpreterState(pc, sp); + Handle result = sub_longc(taskData, taskData->saveVec.push(x), taskData->saveVec.push(y)); + LoadInterpreterState(pc, sp); + *sp = result->Word(); + taskData->saveVec.reset(mark); + } + catch (IOException&) { + // We could run out of store + goto RAISE_EXCEPTION; + } + break; + } + + case INSTR_arbMultiply: + { + PolyWord x = *sp++; + PolyWord y = (*sp); + if (x.IsTagged() && y.IsTagged()) + { + POLYSIGNED xv = UNTAGGED(x); + POLYSIGNED yv = y.AsSigned() - 1; // Just remove the tag + POLYSIGNED t = xv * yv; + if (xv == 0 || t / xv == yv) + { + *sp = PolyWord::FromSigned(t + 1); // Add back the tag + break; + } + } + try { + Handle mark = taskData->saveVec.mark(); + SaveInterpreterState(pc, sp); + Handle result = mult_longc(taskData, taskData->saveVec.push(x), taskData->saveVec.push(y)); + LoadInterpreterState(pc, sp); + *sp = result->Word(); + taskData->saveVec.reset(mark); + } + catch (IOException&) { + // We could run out of store + goto RAISE_EXCEPTION; + } + break; + } + case INSTR_allocByteMem: { // Allocate byte segment. This does not need to be initialised. POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); PolyObject *t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; // Exception t->SetLengthWord(length, (byte)flags); *sp = (PolyWord)t; break; } case INSTR_getThreadId: *(--sp) = (PolyWord)taskData->threadObject; break; case INSTR_allocWordMemory: { // Allocate word segment. This must be initialised. // We mustn't pop the initialiser until after any potential GC. POLYUNSIGNED length = UNTAGGED_UNSIGNED(sp[2]); PolyObject *t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; PolyWord initialiser = *sp++; POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); t->SetLengthWord(length, (byte)flags); *sp = (PolyWord)t; // Have to initialise the data. for (; length > 0; ) t->Set(--length, initialiser); break; } case INSTR_alloc_ref: { // Allocate a single word mutable cell. This is more common than allocWordMemory on its own. PolyObject *t = this->allocateMemory(taskData, 1, pc, sp); if (t == 0) goto RAISE_EXCEPTION; PolyWord initialiser = (*sp); t->SetLengthWord(1, F_MUTABLE_BIT); t->Set(0, initialiser); *sp = (PolyWord)t; break; } case INSTR_allocMutClosureB: { // Allocate memory for a mutable closure and copy in the code address. POLYUNSIGNED length = *pc++ + sizeof(uintptr_t) / sizeof(PolyWord); PolyObject* t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(length, F_CLOSURE_OBJ | F_MUTABLE_BIT); PolyObject* srcClosure = (*sp).w().AsObjPtr(); *(uintptr_t*)t = *(uintptr_t*)srcClosure; *sp = (PolyWord)t; break; } case INSTR_loadMLWord: { POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); *sp = p->Get(index); break; } case INSTR_loadMLByte: { // The values on the stack are base and index. POLYUNSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = (*sp).w().AsCodePtr(); *sp = TAGGED(p[index]); // Have to tag the result break; } case INSTR_loadUntagged: { POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); *sp = TAGGED(p->Get(index).AsUnsigned()); break; } case INSTR_storeMLWord: { PolyWord toStore = *sp++; POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); p->Set(index, toStore); *sp = Zero; break; } case INSTR_storeMLByte: { POLYUNSIGNED toStore = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = (*sp).w().AsCodePtr(); p[index] = (byte)toStore; *sp = Zero; break; } case INSTR_storeUntagged: { PolyWord toStore = PolyWord::FromUnsigned(UNTAGGED_UNSIGNED(*sp++)); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); p->Set(index, toStore); *sp = Zero; break; } case INSTR_blockMoveWord: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject* dest = (PolyObject*)((*sp++).w().AsCodePtr()); POLYUNSIGNED srcIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject* src = (PolyObject*)((*sp).w().AsCodePtr()); for (POLYUNSIGNED u = 0; u < length; u++) dest->Set(destIndex + u, src->Get(srcIndex + u)); *sp = Zero; break; } case INSTR_blockMoveByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR dest = (*sp++).w().AsCodePtr(); POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR src = (*sp).w().AsCodePtr(); memcpy(dest+destOffset, src+srcOffset, length); *sp = Zero; break; } case INSTR_blockEqualByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg2Ptr = (*sp++).w().AsCodePtr(); POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg1Ptr = (*sp).w().AsCodePtr(); *sp = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length) == 0 ? True : False; break; } case INSTR_blockCompareByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg2Ptr = (*sp++).w().AsCodePtr(); POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg1Ptr = (*sp).w().AsCodePtr(); int result = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length); *sp = result == 0 ? TAGGED(0) : result < 0 ? TAGGED(-1) : TAGGED(1); break; } case INSTR_escape: { switch (*pc++) { case EXTINSTR_callFastRRtoR: { // Floating point call. callRTSRRtoR doCall = *(callRTSRRtoR*)(*sp++).w().AsObjPtr(); PolyWord rtsArg2 = *sp++; PolyWord rtsArg1 = *sp++; double argument1 = unboxDouble(rtsArg1); double argument2 = unboxDouble(rtsArg2); // Allocate memory for the result. double result = doCall(argument1, argument2); PolyObject* t = boxDouble(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastRGtoR: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSRGtoR doCall = *(callRTSRGtoR*)(*sp++).w().AsObjPtr(); intptr_t rtsArg2 = (*sp++).w().AsSigned(); PolyWord rtsArg1 = *sp++; double argument1 = unboxDouble(rtsArg1); // Allocate memory for the result. double result = doCall(argument1, rtsArg2); PolyObject* t = boxDouble(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastGtoR: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSGtoR doCall = *(callRTSGtoR*)(*sp++).w().AsObjPtr(); intptr_t rtsArg1 = (*sp++).w().AsSigned(); // Allocate memory for the result. double result = doCall(rtsArg1); PolyObject* t = boxDouble(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastFtoF: { // Floating point call. The call itself does not allocate but we // need to put the result into a "box". callRTSFtoF doCall = *(callRTSFtoF*)(*sp++).w().AsObjPtr(); PolyWord rtsArg1 = *sp++; float argument = unboxFloat(rtsArg1); // Allocate memory for the result. float result = doCall(argument); PolyObject* t = boxFloat(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastFFtoF: { // Floating point call. callRTSFFtoF doCall = *(callRTSFFtoF*)(*sp++).w().AsObjPtr(); PolyWord rtsArg2 = *sp++; PolyWord rtsArg1 = *sp++; float argument1 = unboxFloat(rtsArg1); float argument2 = unboxFloat(rtsArg2); // Allocate memory for the result. float result = doCall(argument1, argument2); PolyObject* t = boxFloat(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastGtoF: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSGtoF doCall = *(callRTSGtoF*)(*sp++).w().AsObjPtr(); intptr_t rtsArg1 = (*sp++).w().AsSigned(); // Allocate memory for the result. float result = doCall(rtsArg1); PolyObject* t = boxFloat(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastFGtoF: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSFGtoF doCall = *(callRTSFGtoF*)(*sp++).w().AsObjPtr(); intptr_t rtsArg2 = (*sp++).w().AsSigned(); PolyWord rtsArg1 = *sp++; float argument1 = unboxFloat(rtsArg1); // Allocate memory for the result. float result = doCall(argument1, rtsArg2); PolyObject* t = boxFloat(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastRtoR: { // Floating point call. The call itself does not allocate but we // need to put the result into a "box". callRTSRtoR doCall = *(callRTSRtoR*)(*sp++).w().AsObjPtr(); PolyWord rtsArg1 = *sp++; double argument = unboxDouble(rtsArg1); // Allocate memory for the result. double result = doCall(argument); PolyObject* t = boxDouble(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_atomicReset: { // This is needed in the interpreted version otherwise there // is a chance that we could set the value to zero while another // thread is between getting the old value and setting it to the new value. PolyObject* p = (*sp).w().AsObjPtr(); taskData->AtomicReset(p); *sp = TAGGED(0); // Push the unit result break; } case EXTINSTR_longWToTagged: { // Extract the first word and return it as a tagged value. This loses the top-bit POLYUNSIGNED wx = (*sp).w().AsObjPtr()->Get(0).AsUnsigned(); *sp = TAGGED(wx); break; } case EXTINSTR_signedToLongW: { // Shift the tagged value to remove the tag and put it into the first word. // The original sign bit is copied in the shift. intptr_t wx = (*sp).w().UnTagged(); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(intptr_t*)t = wx; *sp = (PolyWord)t; break; } case EXTINSTR_unsignedToLongW: { // As with the above except the value is treated as an unsigned // value and the top bit is zero. uintptr_t wx = (*sp).w().UnTaggedUnsigned(); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wx; *sp = (PolyWord)t; break; } case EXTINSTR_realAbs: { PolyObject* t = this->boxDouble(taskData, fabs(unboxDouble(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realNeg: { PolyObject* t = this->boxDouble(taskData, -(unboxDouble(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatAbs: { PolyObject* t = this->boxFloat(taskData, fabs(unboxFloat(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatNeg: { PolyObject* t = this->boxFloat(taskData, -(unboxFloat(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_fixedIntToReal: { POLYSIGNED u = UNTAGGED(*sp); PolyObject* t = this->boxDouble(taskData, (double)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_fixedIntToFloat: { POLYSIGNED u = UNTAGGED(*sp); PolyObject* t = this->boxFloat(taskData, (float)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatToReal: { float u = unboxFloat(*sp); PolyObject* t = this->boxDouble(taskData, (double)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_wordShiftRArith: { PolyWord u = *sp++; // Strictly speaking, C does not require that this uses // arithmetic shifting so we really ought to set the // high-order bits explicitly. *sp = TAGGED(UNTAGGED(*sp) >> UNTAGGED(u)); break; } case EXTINSTR_lgWordEqual: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = wx == wy ? True : False; break; } case EXTINSTR_lgWordLess: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = (wy < wx) ? True : False; break; } case EXTINSTR_lgWordLessEq: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = (wy <= wx) ? True : False; break; } case EXTINSTR_lgWordGreater: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = (wy > wx) ? True : False; break; } case EXTINSTR_lgWordGreaterEq: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = (wy >= wx) ? True : False; break; } case EXTINSTR_lgWordAdd: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy + wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordSub: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy - wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordMult: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy * wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordDiv: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy / wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordMod: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy % wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordAnd: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy & wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordOr: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy | wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordXor: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy ^ wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordShiftLeft: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy << wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordShiftRLog: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy >> wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordShiftRArith: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); intptr_t wy = *(intptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(intptr_t*)t = wy >> wx; *sp = (PolyWord)t; break; } case EXTINSTR_realEqual: { double u = unboxDouble(*sp++); *sp = u == unboxDouble(*sp) ? True : False; break; } case EXTINSTR_realLess: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) < u ? True : False; break; } case EXTINSTR_realLessEq: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) <= u ? True : False; break; } case EXTINSTR_realGreater: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) > u ? True : False; break; } case EXTINSTR_realGreaterEq: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) >= u ? True : False; break; } case EXTINSTR_realUnordered: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); *sp = (std::isnan(u) || std::isnan(v)) ? True : False; break; } case EXTINSTR_realAdd: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject* t = this->boxDouble(taskData, v + u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realSub: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject* t = this->boxDouble(taskData, v - u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realMult: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject* t = this->boxDouble(taskData, v * u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realDiv: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject* t = this->boxDouble(taskData, v / u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatEqual: { float u = unboxFloat(*sp++); *sp = u == unboxFloat(*sp) ? True : False; break; } case EXTINSTR_floatLess: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) < u ? True : False; break; } case EXTINSTR_floatLessEq: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) <= u ? True : False; break; } case EXTINSTR_floatGreater: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) > u ? True : False; break; } case EXTINSTR_floatGreaterEq: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) >= u ? True : False; break; } case EXTINSTR_floatUnordered: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); *sp = (std::isnan(u) || std::isnan(v)) ? True : False; break; } case EXTINSTR_floatAdd: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject* t = this->boxFloat(taskData, v + u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatSub: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject* t = this->boxFloat(taskData, v - u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatMult: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject* t = this->boxFloat(taskData, v * u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatDiv: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject* t = this->boxFloat(taskData, v / u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realToFloat: { // Convert a double to a float. It's complicated because it depends on the rounding mode. int rMode = *pc++; int current = getrounding(); // If the rounding is 4 it means "use current rounding". // Don't call unboxDouble until we're set the rounding. GCC seems to convert it // before the actual float cast. if (rMode < 4) setrounding(rMode); double d = unboxDouble(*sp); float v = (float)d; // Convert with the appropriate rounding. setrounding(current); PolyObject* t = this->boxFloat(taskData, v, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realToInt: dv = unboxDouble(*sp); goto realtoint; case EXTINSTR_floatToInt: dv = (double)unboxFloat(*sp); realtoint: { // Convert a double or a float to a tagged integer. int rMode = *pc++; // We mustn't try converting a value that will overflow the conversion // but we need to be careful that we don't raise overflow incorrectly due // to rounding. if (dv > (double)(MAXTAGGED + MAXTAGGED / 2) || dv < -(double)(MAXTAGGED + MAXTAGGED / 2)) { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } POLYSIGNED p; switch (rMode) { case POLY_ROUND_TONEAREST: p = (POLYSIGNED)round(dv); break; case POLY_ROUND_DOWNWARD: p = (POLYSIGNED)floor(dv); break; case POLY_ROUND_UPWARD: p = (POLYSIGNED)ceil(dv); break; case POLY_ROUND_TOZERO: default: // Truncation is the default for C. p = (POLYSIGNED)dv; } // Check that the value can be tagged. if (p > MAXTAGGED || p < -MAXTAGGED - 1) { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } *sp = TAGGED(p); break; } case EXTINSTR_loadC8: { // This is similar to loadMLByte except that the base address is a boxed large-word. // Also the index is SIGNED. POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; *sp = TAGGED(p[index]); // Have to tag the result break; } case EXTINSTR_loadC16: { // This and the other loads are similar to loadMLWord with separate // index and offset values. POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; POLYUNSIGNED r = ((uint16_t*)p)[index]; *sp = TAGGED(r); break; } case EXTINSTR_loadC32: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; uintptr_t r = ((uint32_t*)p)[index]; #ifdef IS64BITS // This is tagged in 64-bit mode * sp = TAGGED(r); #else // But boxed in 32-bit mode. PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = r; *sp = (PolyWord)t; #endif break; } #if (defined(IS64BITS) || defined(POLYML32IN64)) case EXTINSTR_loadC64: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; uintptr_t r = ((uint64_t*)p)[index]; // This must be boxed. PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = r; *sp = (PolyWord)t; break; } #endif case EXTINSTR_loadCFloat: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; double r = ((float*)p)[index]; // This must be boxed. PolyObject* t = this->boxDouble(taskData, r, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_loadCDouble: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; double r = ((double*)p)[index]; // This must be boxed. PolyObject* t = this->boxDouble(taskData, r, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_storeC8: { // Similar to storeMLByte except that the base address is a boxed large-word. POLYUNSIGNED toStore = UNTAGGED(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; p[index] = (byte)toStore; *sp = Zero; break; } case EXTINSTR_storeC16: { uint16_t toStore = (uint16_t)UNTAGGED(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((uint16_t*)p)[index] = toStore; *sp = Zero; break; } case EXTINSTR_storeC32: { #ifdef IS64BITS // This is a tagged value in 64-bit mode. uint32_t toStore = (uint32_t)UNTAGGED(*sp++); #else // but a boxed value in 32-bit mode. uint32_t toStore = (uint32_t)(*(uintptr_t*)((*sp++).w().AsObjPtr())); #endif POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((uint32_t*)p)[index] = toStore; *sp = Zero; break; } #if (defined(IS64BITS) || defined(POLYML32IN64)) case EXTINSTR_storeC64: { // This is a boxed value. uint64_t toStore = *(uintptr_t*)((*sp++).w().AsObjPtr()); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((uint64_t*)p)[index] = toStore; *sp = Zero; break; } #endif case EXTINSTR_storeCFloat: { // This is a boxed value. float toStore = (float)unboxDouble(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((float*)p)[index] = toStore; *sp = Zero; break; } case EXTINSTR_storeCDouble: { // This is a boxed value. double toStore = unboxDouble(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((double*)p)[index] = toStore; *sp = Zero; break; } case EXTINSTR_jump32True: // Invert the sense of the test and fall through. *sp = ((*sp).w() == True) ? False : True; case EXTINSTR_jump32False: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 4; break; } /* else - false - take the jump */ } case EXTINSTR_jump32: { // This is a 32-bit signed quantity on both 64-bits and 32-bits. POLYSIGNED offset = pc[3] & 0x80 ? -1 : 0; offset = (offset << 8) | pc[3]; offset = (offset << 8) | pc[2]; offset = (offset << 8) | pc[1]; offset = (offset << 8) | pc[0]; pc += offset + 4; break; } case EXTINSTR_setHandler32: /* Set up a handler */ { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); (--sp)->codeAddr = pc + offset + 4; /* Address of handler */ SetHandlerRegister(sp); pc += 4; break; } case EXTINSTR_case32: { // arg1 is the number of cases i.e. one more than the largest value // This is followed by that number of 32-bit offsets. // If the value is out of range the default case is immediately after the table. POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ if (u >= arg1 || u < 0) pc += 2 + arg1 * 4; /* Out of range */ else { pc += 2; pc += /* Index */pc[u * 4] + (pc[u * 4 + 1] << 8) + (pc[u * 4 + 2] << 16) + (pc[u * 4 + 3] << 24); } break; } case EXTINSTR_tuple_w: { storeWords = arg1; pc += 2; TUPLE: /* Common code for tupling. */ PolyObject* p = this->allocateMemory(taskData, storeWords, pc, sp); if (p == 0) goto RAISE_EXCEPTION; // Exception p->SetLengthWord(storeWords, 0); for (; storeWords > 0; ) p->Set(--storeWords, *sp++); *(--sp) = (PolyWord)p; break; } case EXTINSTR_indirect_w: *sp = (*sp).w().AsObjPtr()->Get(arg1); pc += 2; break; case EXTINSTR_moveToContainerW: { PolyWord u = *sp++; (*sp).stackAddr[arg1] =u; pc += 2; break; } case EXTINSTR_moveToMutClosureW: { PolyWord u = *sp++; (*sp).w().AsObjPtr()->Set(arg1 + sizeof(uintptr_t)/sizeof(PolyWord), u); pc += 2; break; } case EXTINSTR_indirectContainerW: *sp = (*sp).stackAddr[arg1]; pc += 2; break; case EXTINSTR_indirectClosureW: *sp = (*sp).w().AsObjPtr()->Get(arg1+sizeof(uintptr_t)/sizeof(PolyWord)); pc += 2; break; case EXTINSTR_set_stack_val_w: { PolyWord u = *sp++; sp[arg1 - 1] = u; pc += 2; break; } case EXTINSTR_reset_w: sp += arg1; pc += 2; break; case EXTINSTR_reset_r_w: { PolyWord u = *sp; sp += arg1; *sp = u; pc += 2; break; } case EXTINSTR_stack_containerW: { POLYUNSIGNED words = arg1; pc += 2; while (words-- > 0) *(--sp) = Zero; sp--; (*sp).stackAddr = sp + 1; break; } case EXTINSTR_constAddr32: { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); *(--sp) = *(PolyWord*)(pc + offset + 4); pc += 4; break; } case EXTINSTR_allocCSpace: { // Allocate this on the C heap. POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); void* memory = malloc(length); *sp = Make_sysword(taskData, (uintptr_t)memory)->Word(); break; } case EXTINSTR_freeCSpace: { // Both the address and the size are passed as arguments. sp++; // Size PolyWord addr = *sp; free(*(void**)(addr.AsObjPtr())); *sp = TAGGED(0); break; } case EXTINSTR_tail: /* Tail recursive call. */ /* Move items up the stack. */ /* There may be an overlap if the function we are calling has more args than this one. */ tailCount = arg1; tailPtr = sp + tailCount; sp = tailPtr + arg2; goto TAIL_CALL; case EXTINSTR_allocMutClosureW: { // Allocate memory for a mutable closure and copy in the code address. POLYUNSIGNED length = arg1 + sizeof(uintptr_t) / sizeof(PolyWord); pc += 2; PolyObject* t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(length, F_CLOSURE_OBJ | F_MUTABLE_BIT); PolyObject* srcClosure = (*sp).w().AsObjPtr(); *(uintptr_t*)t = *(uintptr_t*)srcClosure; *sp = (PolyWord)t; break; } case EXTINSTR_closureW: { storeWords = arg1; pc += 2; CREATE_CLOSURE: // Allocate a closure. storeWords is the number of non-locals. POLYUNSIGNED length = storeWords + sizeof(uintptr_t) / sizeof(PolyWord); PolyObject* t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(length, F_CLOSURE_OBJ); for (; storeWords > 0; ) t->Set(--storeWords + sizeof(uintptr_t) / sizeof(PolyWord), *sp++); PolyObject* srcClosure = (*sp).w().AsObjPtr(); *(uintptr_t*)t = *(uintptr_t*)srcClosure; *sp = (PolyWord)t; break; } default: Crash("Unknown extended instruction %x\n", pc[-1]); } break; } case INSTR_enterIntX86: // This is a no-op if we are already interpreting. pc += 3; break; default: Crash("Unknown instruction %x\n", pc[-1]); } /* switch */ } /* for */ return ReturnReturn; // Never actually reached } void ByteCodeInterpreter::GarbageCollect(ScanAddress* process) { if (overflowPacket != 0) overflowPacket = process->ScanObjectAddress(overflowPacket); if (dividePacket != 0) dividePacket = process->ScanObjectAddress(dividePacket); } extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedGetAbiList(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec); } // FFI #if (defined(HAVE_LIBFFI) && defined(HAVE_FFI_H)) #ifdef HAVE_ERRNO_H #include #endif #include static struct _abiTable { const char* abiName; ffi_abi abiCode; } abiTable[] = { // Unfortunately the ABI entries are enums rather than #defines so we // can't test individual entries. #ifdef X86_WIN32 {"sysv", FFI_SYSV}, {"stdcall", FFI_STDCALL}, {"thiscall", FFI_THISCALL}, {"fastcall", FFI_FASTCALL}, {"ms_cdecl", FFI_MS_CDECL}, #elif defined(X86_WIN64) {"win64", FFI_WIN64}, #elif defined(X86_64) || (defined (__x86_64__) && defined (X86_DARWIN)) {"unix64", FFI_UNIX64}, #elif defined(X86_ANY) {"sysv", FFI_SYSV}, #endif { "default", FFI_DEFAULT_ABI} }; static Handle mkAbitab(TaskData* taskData, void*, char* p); static Handle toSysWord(TaskData* taskData, void* p) { return Make_sysword(taskData, (uintptr_t)p); } // Convert the Poly type info into ffi_type values. /* datatype cTypeForm = CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } */ static ffi_type* decodeType(PolyWord pType) { PolyWord typeForm = pType.AsObjPtr()->Get(2); PolyWord typeSize = pType.AsObjPtr()->Get(0); if (typeForm.IsDataPtr()) { // Struct size_t size = typeSize.UnTaggedUnsigned(); unsigned short align = (unsigned short)pType.AsObjPtr()->Get(1).UnTaggedUnsigned(); unsigned nElems = 0; PolyWord listStart = typeForm.AsObjPtr()->Get(0); for (PolyWord p = listStart; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nElems++; size_t space = sizeof(ffi_type); // Add space for the elements plus one extra for the zero terminator. space += (nElems + 1) * sizeof(ffi_type*); ffi_type* result = (ffi_type*)calloc(1, space); // Raise an exception rather than returning zero. if (result == 0) return 0; ffi_type** elem = (ffi_type**)(result + 1); result->size = size; result->alignment = align; result->type = FFI_TYPE_STRUCT; result->elements = elem; if (elem != 0) { for (PolyWord p = listStart; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; ffi_type* t = decodeType(e); if (t == 0) return 0; *elem++ = t; } *elem = 0; // Null terminator } return result; } else { switch (typeForm.UnTaggedUnsigned()) { case 0: { // Floating point if (typeSize.UnTaggedUnsigned() == ffi_type_float.size) return &ffi_type_float; else if (typeSize.UnTaggedUnsigned() == ffi_type_double.size) return &ffi_type_double; ASSERT(0); } case 1: // FFI type poiner return &ffi_type_pointer; case 2: // Signed integer. { switch (typeSize.UnTaggedUnsigned()) { case 1: return &ffi_type_sint8; case 2: return &ffi_type_sint16; case 4: return &ffi_type_sint32; case 8: return &ffi_type_sint64; default: ASSERT(0); } } case 3: // Unsigned integer. { switch (typeSize.UnTaggedUnsigned()) { case 1: return &ffi_type_uint8; case 2: return &ffi_type_uint16; case 4: return &ffi_type_uint32; case 8: return &ffi_type_uint64; default: ASSERT(0); } } case 4: // Void return &ffi_type_void; } ASSERT(0); } return 0; } // Create a CIF. This contains all the types and some extra information. // The arguments are the raw ML values. That does make this dependent on the // representations used by the compiler. // This mallocs space for the CIF and the types. The space is never freed. // POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; ffi_abi abi = (ffi_abi)get_C_ushort(taskData, abiValue); try { unsigned nArgs = 0; for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nArgs++; // Allocate space for the cif followed by the argument type vector size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*); ffi_cif* cif = (ffi_cif*)malloc(space); if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type* rtype = decodeType(resultType); if (rtype == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type** atypes = (ffi_type**)(cif + 1); // Copy the arguments types. ffi_type** at = atypes; for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; ffi_type* atype = decodeType(e); if (atype == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); *at++ = atype; } ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes); if (status == FFI_BAD_TYPEDEF) raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif"); else if (status == FFI_BAD_ABI) raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif"); else if (status != FFI_OK) raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif"); result = toSysWord(taskData, cif); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Call a function. POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) { ffi_cif* cif = *(ffi_cif**)cifAddr.AsAddress(); void* f = *(void**)cFunAddr.AsAddress(); void* res = *(void**)resAddr.AsAddress(); void* arg = *(void**)argVec.AsAddress(); // Poly passes the arguments as values, effectively a single struct. // Libffi wants a vector of addresses. void** argVector = (void**)calloc(cif->nargs + 1, sizeof(void*)); unsigned n = 0; uintptr_t p = (uintptr_t)arg; while (n < cif->nargs) { uintptr_t align = cif->arg_types[n]->alignment; p = (p + align - 1) & (0 - align); argVector[n] = (void*)p; p += cif->arg_types[n]->size; n++; } // The result area we have provided is only as big as required. // Libffi may need a larger area. if (cif->rtype->size < FFI_SIZEOF_ARG) { char result[FFI_SIZEOF_ARG]; ffi_call(cif, FFI_FN(f), &result, argVector); if (cif->rtype->type != FFI_TYPE_VOID) memcpy(res, result, cif->rtype->size); } else ffi_call(cif, FFI_FN(f), res, argVector); free(argVector); return TAGGED(0).AsUnsigned(); } #else // Libffi is not present. // A basic table so that the Foreign structure will compile static struct _abiTable { const char* abiName; int abiCode; } abiTable[] = { { "default", 0} }; // Don't raise an exception at this point so we can build calls. POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) { return TAGGED(0).AsUnsigned(); } POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) { TaskData* taskData = TaskData::FindTaskForId(threadId); try { raise_exception_string(taskData, EXC_foreign, "Foreign function calling is not available. Libffi is not installled."); } catch (...) {} // Handle the IOException return TAGGED(0).AsUnsigned(); } #endif // Construct an entry in the ABI table. static Handle mkAbitab(TaskData* taskData, void* arg, char* p) { struct _abiTable* ab = (struct _abiTable*)p; // Construct a pair of the string and the code Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName)); Handle code = Make_arbitrary_precision(taskData, ab->abiCode); Handle result = alloc_and_save(taskData, 2); result->WordP()->Set(0, name->Word()); result->WordP()->Set(1, code->Word()); return result; } // Get ABI list. This is called once only before the basis library is built. POLYUNSIGNED PolyInterpretedGetAbiList(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = makeList(taskData, sizeof(abiTable) / sizeof(abiTable[0]), (char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // No machine-specific calls in the interpreter. struct _entrypts byteCodeEPT[] = { { "PolyInterpretedGetAbiList", (polyRTSFunction)&PolyInterpretedGetAbiList }, { "PolyInterpretedCreateCIF", (polyRTSFunction)&PolyInterpretedCreateCIF }, { "PolyInterpretedCallFunction", (polyRTSFunction)&PolyInterpretedCallFunction }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/int_opcodes.h b/libpolyml/int_opcodes.h index 70714290..826ef29b 100644 --- a/libpolyml/int_opcodes.h +++ b/libpolyml/int_opcodes.h @@ -1,264 +1,267 @@ /* Title: Definitions for the code-tree instructions. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 Cambridge University Technical Services Limited Further development Copyright David C.J. Matthews 2015-18, 2020. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #define INSTR_jump8 0x02 #define INSTR_jump8false 0x03 #define INSTR_loadMLWord 0x04 #define INSTR_storeMLWord 0x05 #define INSTR_alloc_ref 0x06 #define INSTR_blockMoveWord 0x07 #define INSTR_loadUntagged 0x08 #define INSTR_storeUntagged 0x09 #define INSTR_case16 0x0a #define INSTR_call_closure 0x0c #define INSTR_return_w 0x0d #define INSTR_stack_containerB 0x0e #define INSTR_raise_ex 0x10 #define INSTR_callConstAddr16 0x11 #define INSTR_callConstAddr8 0x12 #define INSTR_local_w 0x13 #define INSTR_callLocalB 0x16 #define INSTR_constAddr16 0x1a #define INSTR_const_int_w 0x1b #define INSTR_jump_back8 0x1e #define INSTR_return_b 0x1f #define INSTR_jump_back16 0x20 #define INSTR_indirectLocalBB 0x21 #define INSTR_local_b 0x22 -#define INSTR_indirect_b 0x23 +#define INSTR_indirect_b 0x23 #define INSTR_moveToContainerB 0x24 -#define INSTR_set_stack_val_b 0x25 -#define INSTR_reset_b 0x26 -#define INSTR_reset_r_b 0x27 -#define INSTR_const_int_b 0x28 -#define INSTR_local_0 0x29 -#define INSTR_local_1 0x2a -#define INSTR_local_2 0x2b +#define INSTR_set_stack_val_b 0x25 +#define INSTR_reset_b 0x26 +#define INSTR_reset_r_b 0x27 +#define INSTR_const_int_b 0x28 +#define INSTR_local_0 0x29 +#define INSTR_local_1 0x2a +#define INSTR_local_2 0x2b #define INSTR_local_3 0x2c #define INSTR_local_4 0x2d #define INSTR_local_5 0x2e #define INSTR_local_6 0x2f #define INSTR_local_7 0x30 #define INSTR_local_8 0x31 #define INSTR_local_9 0x32 #define INSTR_local_10 0x33 #define INSTR_local_11 0x34 #define INSTR_indirect_0 0x35 #define INSTR_indirect_1 0x36 #define INSTR_indirect_2 0x37 #define INSTR_indirect_3 0x38 #define INSTR_indirect_4 0x39 #define INSTR_indirect_5 0x3a #define INSTR_const_0 0x3b #define INSTR_const_1 0x3c #define INSTR_const_2 0x3d #define INSTR_const_3 0x3e #define INSTR_const_4 0x3f #define INSTR_const_10 0x40 #define INSTR_return_1 0x42 #define INSTR_return_2 0x43 #define INSTR_return_3 0x44 #define INSTR_local_12 0x45 #define INSTR_jump8True 0x46 #define INSTR_jump16True 0x47 #define INSTR_local_13 0x49 #define INSTR_local_14 0x4a #define INSTR_local_15 0x4b +#define INSTR_arbAdd 0x4c +#define INSTR_arbSubtract 0x4d +#define INSTR_arbMultiply 0x4e #define INSTR_reset_1 0x50 #define INSTR_reset_2 0x51 #define INSTR_indirectClosureBB 0x54 #define INSTR_reset_r_1 0x64 #define INSTR_reset_r_2 0x65 #define INSTR_reset_r_3 0x66 #define INSTR_tuple_b 0x68 #define INSTR_tuple_2 0x69 #define INSTR_tuple_3 0x6a #define INSTR_tuple_4 0x6b #define INSTR_lock 0x6c #define INSTR_ldexc 0x6d #define INSTR_indirectContainerB 0x74 #define INSTR_moveToMutClosureB 0x75 #define INSTR_allocMutClosureB 0x76 #define INSTR_indirectClosureB0 0x77 #define INSTR_push_handler 0x78 #define INSTR_indirectClosureB1 0x7a #define INSTR_tail_b_b 0x7b #define INSTR_indirectClosureB2 0x7c #define INSTR_setHandler8 0x81 #define INSTR_callFastRTS0 0x83 #define INSTR_callFastRTS1 0x84 #define INSTR_callFastRTS2 0x85 #define INSTR_callFastRTS3 0x86 #define INSTR_callFastRTS4 0x87 #define INSTR_callFastRTS5 0x88 #define INSTR_notBoolean 0x91 #define INSTR_isTagged 0x92 #define INSTR_cellLength 0x93 #define INSTR_cellFlags 0x94 #define INSTR_clearMutable 0x95 #define INSTR_atomicIncr 0x97 #define INSTR_atomicDecr 0x98 #define INSTR_equalWord 0xa0 #define INSTR_lessSigned 0xa2 #define INSTR_lessUnsigned 0xa3 #define INSTR_lessEqSigned 0xa4 #define INSTR_lessEqUnsigned 0xa5 #define INSTR_greaterSigned 0xa6 #define INSTR_greaterUnsigned 0xa7 #define INSTR_greaterEqSigned 0xa8 #define INSTR_greaterEqUnsigned 0xa9 #define INSTR_fixedAdd 0xaa #define INSTR_fixedSub 0xab #define INSTR_fixedMult 0xac #define INSTR_fixedQuot 0xad #define INSTR_fixedRem 0xae #define INSTR_wordAdd 0xb1 #define INSTR_wordSub 0xb2 #define INSTR_wordMult 0xb3 #define INSTR_wordDiv 0xb4 #define INSTR_wordMod 0xb5 #define INSTR_wordAnd 0xb7 #define INSTR_wordOr 0xb8 #define INSTR_wordXor 0xb9 #define INSTR_wordShiftLeft 0xba #define INSTR_wordShiftRLog 0xbb #define INSTR_allocByteMem 0xbd #define INSTR_indirectLocalB1 0xc1 #define INSTR_isTaggedLocalB 0xc2 #define INSTR_jumpNEqLocalInd 0xc3 #define INSTR_jumpTaggedLocal 0xc4 #define INSTR_jumpNEqLocal 0xc5 #define INSTR_indirect0Local0 0xc6 #define INSTR_indirectLocalB0 0xc7 #define INSTR_closureB 0xd0 #define INSTR_getThreadId 0xd9 #define INSTR_allocWordMemory 0xda #define INSTR_loadMLByte 0xdc #define INSTR_storeMLByte 0xe4 #define INSTR_blockMoveByte 0xec #define INSTR_blockEqualByte 0xed #define INSTR_blockCompareByte 0xee #define INSTR_deleteHandler 0xf1 #define INSTR_jump16 0xf7 #define INSTR_jump16false 0xf8 #define INSTR_setHandler16 0xf9 #define INSTR_constAddr8 0xfa #define INSTR_stackSize16 0xfc #define INSTR_escape 0xfe #define INSTR_enterIntX86 0xff // Extended opcodes - preceded by escape #define EXTINSTR_stack_containerW 0x0b #define EXTINSTR_allocMutClosureW 0x0f #define EXTINSTR_indirectClosureW 0x10 #define EXTINSTR_indirectContainerW 0x11 #define EXTINSTR_indirect_w 0x14 #define EXTINSTR_moveToContainerW 0x15 #define EXTINSTR_moveToMutClosureW 0x16 #define EXTINSTR_set_stack_val_w 0x17 #define EXTINSTR_reset_w 0x18 #define EXTINSTR_reset_r_w 0x19 #define EXTINSTR_callFastRRtoR 0x1c #define EXTINSTR_callFastRGtoR 0x1d #define EXTINSTR_jump32True 0x48 #define EXTINSTR_floatAbs 0x56 #define EXTINSTR_floatNeg 0x57 #define EXTINSTR_fixedIntToFloat 0x58 #define EXTINSTR_floatToReal 0x59 #define EXTINSTR_realToFloat 0x5a #define EXTINSTR_floatEqual 0x5b #define EXTINSTR_floatLess 0x5c #define EXTINSTR_floatLessEq 0x5d #define EXTINSTR_floatGreater 0x5e #define EXTINSTR_floatGreaterEq 0x5f #define EXTINSTR_floatAdd 0x60 #define EXTINSTR_floatSub 0x61 #define EXTINSTR_floatMult 0x62 #define EXTINSTR_floatDiv 0x63 #define EXTINSTR_realToInt 0x6e #define EXTINSTR_tuple_w 0x67 #define EXTINSTR_floatToInt 0x6f #define EXTINSTR_callFastFtoF 0x70 #define EXTINSTR_callFastGtoF 0x71 #define EXTINSTR_callFastFFtoF 0x72 #define EXTINSTR_callFastFGtoF 0x73 #define EXTINSTR_realUnordered 0x79 #define EXTINSTR_floatUnordered 0x7a #define EXTINSTR_tail 0x7c #define EXTINSTR_callFastRtoR 0x8f #define EXTINSTR_callFastGtoR 0x90 #define EXTINSTR_atomicReset 0x99 #define EXTINSTR_longWToTagged 0x9a #define EXTINSTR_signedToLongW 0x9b #define EXTINSTR_unsignedToLongW 0x9c #define EXTINSTR_realAbs 0x9d #define EXTINSTR_realNeg 0x9e #define EXTINSTR_fixedIntToReal 0x9f #define EXTINSTR_fixedDiv 0xaf #define EXTINSTR_fixedMod 0xb0 #define EXTINSTR_wordShiftRArith 0xbc #define EXTINSTR_lgWordEqual 0xbe #define EXTINSTR_lgWordLess 0xc0 #define EXTINSTR_lgWordLessEq 0xc1 #define EXTINSTR_lgWordGreater 0xc2 #define EXTINSTR_lgWordGreaterEq 0xc3 #define EXTINSTR_lgWordAdd 0xc4 #define EXTINSTR_lgWordSub 0xc5 #define EXTINSTR_lgWordMult 0xc6 #define EXTINSTR_lgWordDiv 0xc7 #define EXTINSTR_lgWordMod 0xc8 #define EXTINSTR_lgWordAnd 0xc9 #define EXTINSTR_lgWordOr 0xca #define EXTINSTR_lgWordXor 0xcb #define EXTINSTR_lgWordShiftLeft 0xcc #define EXTINSTR_lgWordShiftRLog 0xcd #define EXTINSTR_lgWordShiftRArith 0xce #define EXTINSTR_realEqual 0xcf #define EXTINSTR_closureW 0xd0 #define EXTINSTR_realLess 0xd1 #define EXTINSTR_realLessEq 0xd2 #define EXTINSTR_realGreater 0xd3 #define EXTINSTR_realGreaterEq 0xd4 #define EXTINSTR_realAdd 0xd5 #define EXTINSTR_realSub 0xd6 #define EXTINSTR_realMult 0xd7 #define EXTINSTR_realDiv 0xd8 #define EXTINSTR_loadC8 0xdd #define EXTINSTR_loadC16 0xde #define EXTINSTR_loadC32 0xdf #define EXTINSTR_loadC64 0xe0 #define EXTINSTR_loadCFloat 0xe1 #define EXTINSTR_loadCDouble 0xe2 #define EXTINSTR_storeC8 0xe5 #define EXTINSTR_storeC16 0xe6 #define EXTINSTR_storeC32 0xe7 #define EXTINSTR_storeC64 0xe8 #define EXTINSTR_storeCFloat 0xe9 #define EXTINSTR_storeCDouble 0xea #define EXTINSTR_jump32 0xf2 #define EXTINSTR_jump32False 0xf3 #define EXTINSTR_constAddr32 0xf4 #define EXTINSTR_setHandler32 0xf5 #define EXTINSTR_case32 0xf6 #define EXTINSTR_allocCSpace 0xfd #define EXTINSTR_freeCSpace 0xfe diff --git a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML index 4fa4fdd8..9312ddab 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML @@ -1,1743 +1,1746 @@ (* Copyright (c) 2015-18, 2020 David C.J. Matthews Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor INTCODECONS ( structure DEBUG: DEBUG structure PRETTY: PRETTYSIG ) : INTCODECONSSIG = struct open CODE_ARRAY open DEBUG open Address open Misc infix 5 << <<+ <<- >> >>+ >>- ~>> ~>>+ ~>>- (* Shift operators *) infix 3 andb orb xorb andbL orbL xorbL andb8 orb8 xorb8 val op << = Word.<< and op >> = Word.>> and op ~>> = Word.~>> val wordToWord8 = Word8.fromLargeWord o Word.toLargeWord and word8ToWord = Word.fromLargeWord o Word8.toLargeWord (* Typically the compiler is built on a little-endian machine but it could be run on a machine with either endian-ness. We have to find out the endian-ness when we run. There are separate versions of the compiler for 32-bit and 64-bit so that can be a constant. *) local val isBigEndian: unit -> bool = RunCall.rtsCallFast1 "PolyIsBigEndian" in val isBigEndian = isBigEndian() end val opcode_jump = 0wx02 (* 8-bit unsigned jump forward. *) and opcode_jumpFalse = 0wx03 (* Test top of stack. Take 8-bit unsigned jump if false. *) and opcode_loadMLWord = 0wx04 and opcode_storeMLWord = 0wx05 and opcode_alloc_ref = 0wx06 and opcode_blockMoveWord = 0wx07 and opcode_loadUntagged = 0wx08 and opcode_storeUntagged = 0wx09 and opcode_case16 = 0wx0a and opcode_callClosure = 0wx0c and opcode_returnW = 0wx0d and opcode_containerB = 0wx0e and opcode_raiseEx = 0wx10 and opcode_callConstAddr16 = 0wx11 and opcode_callConstAddr8 = 0wx12 and opcode_localW = 0wx13 and opcode_callLocalB = 0wx16 and opcode_constAddr16 = 0wx1a and opcode_constIntW = 0wx1b and opcode_jumpBack8 = 0wx1e (* 8-bit unsigned jump backwards - relative to end of instr. *) and opcode_returnB = 0wx1f and opcode_jumpBack16 = 0wx20 (* 16-bit unsigned jump backwards - relative to end of instr. *) and opcode_indirectLocalBB = 0wx21 and opcode_localB = 0wx22 and opcode_indirectB = 0wx23 and opcode_moveToContainerB = 0wx24 and opcode_setStackValB = 0wx25 and opcode_resetB = 0wx26 and opcode_resetRB = 0wx27 and opcode_constIntB = 0wx28 and opcode_local_0 = 0wx29 and opcode_local_1 = 0wx2a and opcode_local_2 = 0wx2b and opcode_local_3 = 0wx2c and opcode_local_4 = 0wx2d and opcode_local_5 = 0wx2e and opcode_local_6 = 0wx2f and opcode_local_7 = 0wx30 and opcode_local_8 = 0wx31 and opcode_local_9 = 0wx32 and opcode_local_10 = 0wx33 and opcode_local_11 = 0wx34 and opcode_indirect_0 = 0wx35 and opcode_indirect_1 = 0wx36 and opcode_indirect_2 = 0wx37 and opcode_indirect_3 = 0wx38 and opcode_indirect_4 = 0wx39 and opcode_indirect_5 = 0wx3a and opcode_const_0 = 0wx3b and opcode_const_1 = 0wx3c and opcode_const_2 = 0wx3d and opcode_const_3 = 0wx3e and opcode_const_4 = 0wx3f and opcode_const_10 = 0wx40 and opcode_return_1 = 0wx42 and opcode_return_2 = 0wx43 and opcode_return_3 = 0wx44 and opcode_local_12 = 0wx45 and opcode_jumpTrue = 0wx46 and opcode_jump16True = 0wx47 and opcode_local_13 = 0wx49 and opcode_local_14 = 0wx4a and opcode_local_15 = 0wx4b + and opcode_arbAdd = 0wx4c + and opcode_arbSubtract = 0wx4d + and opcode_arbMultiply = 0wx4e and opcode_reset_1 = 0wx50 and opcode_reset_2 = 0wx51 and opcode_indirectClosureBB = 0wx54 and opcode_resetR_1 = 0wx64 and opcode_resetR_2 = 0wx65 and opcode_resetR_3 = 0wx66 and opcode_tupleB = 0wx68 and opcode_tuple_2 = 0wx69 and opcode_tuple_3 = 0wx6a and opcode_tuple_4 = 0wx6b and opcode_lock = 0wx6c and opcode_ldexc = 0wx6d and opcode_indirectContainerB= 0wx74 and opcode_moveToMutClosureB = 0wx75 and opcode_allocMutClosureB = 0wx76 and opcode_indirectClosureB0 = 0wx77 and opcode_pushHandler = 0wx78 and opcode_indirectClosureB1 = 0wx7a and opcode_tailbb = 0wx7b and opcode_indirectClosureB2 = 0wx7c and opcode_setHandler = 0wx81 and opcode_callFastRTS0 = 0wx83 and opcode_callFastRTS1 = 0wx84 and opcode_callFastRTS2 = 0wx85 and opcode_callFastRTS3 = 0wx86 and opcode_callFastRTS4 = 0wx87 and opcode_callFastRTS5 = 0wx88 - (*and opcode_callFullRTS0 = 0wx89 (* Legacy *) - and opcode_callFullRTS1 = 0wx8a - and opcode_callFullRTS2 = 0wx8b - and opcode_callFullRTS3 = 0wx8c - and opcode_callFullRTS4 = 0wx8d - and opcode_callFullRTS5 = 0wx8e*) and opcode_notBoolean = 0wx91 and opcode_isTagged = 0wx92 and opcode_cellLength = 0wx93 and opcode_cellFlags = 0wx94 and opcode_clearMutable = 0wx95 and opcode_atomicIncr = 0wx97 and opcode_atomicDecr = 0wx98 and opcode_equalWord = 0wxa0 and opcode_lessSigned = 0wxa2 and opcode_lessUnsigned = 0wxa3 and opcode_lessEqSigned = 0wxa4 and opcode_lessEqUnsigned = 0wxa5 and opcode_greaterSigned = 0wxa6 and opcode_greaterUnsigned = 0wxa7 and opcode_greaterEqSigned = 0wxa8 and opcode_greaterEqUnsigned = 0wxa9 and opcode_fixedAdd = 0wxaa and opcode_fixedSub = 0wxab and opcode_fixedMult = 0wxac and opcode_fixedQuot = 0wxad and opcode_fixedRem = 0wxae and opcode_wordAdd = 0wxb1 and opcode_wordSub = 0wxb2 and opcode_wordMult = 0wxb3 and opcode_wordDiv = 0wxb4 and opcode_wordMod = 0wxb5 and opcode_wordAnd = 0wxb7 and opcode_wordOr = 0wxb8 and opcode_wordXor = 0wxb9 and opcode_wordShiftLeft = 0wxba and opcode_wordShiftRLog = 0wxbb and opcode_allocByteMem = 0wxbd and opcode_indirectLocalB1 = 0wxc1 and opcode_isTaggedLocalB = 0wxc2 and opcode_jumpNEqLocalInd = 0wxc3 and opcode_jumpTaggedLocal = 0wxc4 and opcode_jumpNEqLocal = 0wxc5 and opcode_indirect0Local0 = 0wxc6 and opcode_indirectLocalB0 = 0wxc7 and opcode_closureB = 0wxd0 and opcode_getThreadId = 0wxd9 and opcode_allocWordMemory = 0wxda and opcode_loadMLByte = 0wxdc and opcode_storeMLByte = 0wxe4 and opcode_blockMoveByte = 0wxec and opcode_blockEqualByte = 0wxed and opcode_blockCompareByte = 0wxee and opcode_deleteHandler = 0wxf1 (* Just deletes the handler - no jump. *) and opcode_jump16 = 0wxf7 and opcode_jump16False = 0wxf8 and opcode_setHandler16 = 0wxf9 and opcode_constAddr8 = 0wxfa (*and opcode_stackSize8 = 0wxfb*) and opcode_stackSize16 = 0wxfc and opcode_escape = 0wxfe (* For two-byte opcodes. *) (*and opcode_enterIntX86 = 0wxff*) (* Reserved - this is the first byte of a call *) (* Extended opcodes - preceded by 0xfe escape *) val ext_opcode_containerW = 0wx0b and ext_opcode_allocMutClosureW = 0wx0f (* Allocate a mutable closure for mutual recursion *) and ext_opcode_indirectClosureW = 0wx10 and ext_opcode_indirectContainerW= 0wx11 and ext_opcode_indirectW = 0wx14 and ext_opcode_moveToContainerW = 0wx15 and ext_opcode_moveToMutClosureW = 0wx16 and ext_opcode_setStackValW = 0wx17 and ext_opcode_resetW = 0wx18 and ext_opcode_resetR_w = 0wx19 and ext_opcode_callFastRTSRRtoR = 0wx1c and ext_opcode_callFastRTSRGtoR = 0wx1d and ext_opcode_jump32True = 0wx48 and ext_opcode_floatAbs = 0wx56 and ext_opcode_floatNeg = 0wx57 and ext_opcode_fixedIntToFloat = 0wx58 and ext_opcode_floatToReal = 0wx59 and ext_opcode_realToFloat = 0wx5a and ext_opcode_floatEqual = 0wx5b and ext_opcode_floatLess = 0wx5c and ext_opcode_floatLessEq = 0wx5d and ext_opcode_floatGreater = 0wx5e and ext_opcode_floatGreaterEq = 0wx5f and ext_opcode_floatAdd = 0wx60 and ext_opcode_floatSub = 0wx61 and ext_opcode_floatMult = 0wx62 and ext_opcode_floatDiv = 0wx63 and ext_opcode_tupleW = 0wx67 and ext_opcode_realToInt = 0wx6e and ext_opcode_floatToInt = 0wx6f and ext_opcode_callFastRTSFtoF = 0wx70 and ext_opcode_callFastRTSGtoF = 0wx71 and ext_opcode_callFastRTSFFtoF = 0wx72 and ext_opcode_callFastRTSFGtoF = 0wx73 and ext_opcode_realUnordered = 0wx79 and ext_opcode_floatUnordered = 0wx7a and ext_opcode_tail = 0wx7c and ext_opcode_callFastRTSRtoR = 0wx8f and ext_opcode_callFastRTSGtoR = 0wx90 and ext_opcode_atomicReset = 0wx99 and ext_opcode_longWToTagged = 0wx9a and ext_opcode_signedToLongW = 0wx9b and ext_opcode_unsignedToLongW = 0wx9c and ext_opcode_realAbs = 0wx9d and ext_opcode_realNeg = 0wx9e and ext_opcode_fixedIntToReal = 0wx9f and ext_opcode_fixedDiv = 0wxaf and ext_opcode_fixedMod = 0wxb0 and ext_opcode_wordShiftRArith = 0wxbc and ext_opcode_lgWordEqual = 0wxbe and ext_opcode_lgWordLess = 0wxc0 and ext_opcode_lgWordLessEq = 0wxc1 and ext_opcode_lgWordGreater = 0wxc2 and ext_opcode_lgWordGreaterEq = 0wxc3 and ext_opcode_lgWordAdd = 0wxc4 and ext_opcode_lgWordSub = 0wxc5 and ext_opcode_lgWordMult = 0wxc6 and ext_opcode_lgWordDiv = 0wxc7 and ext_opcode_lgWordMod = 0wxc8 and ext_opcode_lgWordAnd = 0wxc9 and ext_opcode_lgWordOr = 0wxca and ext_opcode_lgWordXor = 0wxcb and ext_opcode_lgWordShiftLeft = 0wxcc and ext_opcode_lgWordShiftRLog = 0wxcd and ext_opcode_lgWordShiftRArith = 0wxce and ext_opcode_realEqual = 0wxcf and ext_opcode_closureW = 0wxd0 and ext_opcode_realLess = 0wxd1 and ext_opcode_realLessEq = 0wxd2 and ext_opcode_realGreater = 0wxd3 and ext_opcode_realGreaterEq = 0wxd4 and ext_opcode_realAdd = 0wxd5 and ext_opcode_realSub = 0wxd6 and ext_opcode_realMult = 0wxd7 and ext_opcode_realDiv = 0wxd8 and ext_opcode_loadC8 = 0wxdd and ext_opcode_loadC16 = 0wxde and ext_opcode_loadC32 = 0wxdf and ext_opcode_loadC64 = 0wxe0 and ext_opcode_loadCFloat = 0wxe1 and ext_opcode_loadCDouble = 0wxe2 and ext_opcode_storeC8 = 0wxe5 and ext_opcode_storeC16 = 0wxe6 and ext_opcode_storeC32 = 0wxe7 and ext_opcode_storeC64 = 0wxe8 and ext_opcode_storeCFloat = 0wxe9 and ext_opcode_storeCDouble = 0wxea and ext_opcode_jump32 = 0wxf2 (* 32-bit signed jump, forwards or backwards. *) and ext_opcode_jump32False = 0wxf3 (* Test top item. Take 32-bit signed jump if false. *) and ext_opcode_constAddr32 = 0wxf4 (* Followed by a 32-bit offset. Load a constant at that address. *) and ext_opcode_setHandler32 = 0wxf5 (* Setup a handler whose address is given by the 32-bit signed offset. *) and ext_opcode_case32 = 0wxf6 (* Indexed case with 32-bit offsets *) and ext_opcode_allocCSpace = 0wxfd and ext_opcode_freeCSpace = 0wxfe (* A Label is a ref that is later set to the location. Several labels can be linked together so that they are only set at a single point. Only forward jumps are linked so when we come to finally set the label we will have the full list. *) type labels = Word.word ref list ref (* Used for jump, jumpFalse, setHandler and delHandler. *) datatype jumpTypes = Jump | JumpBack | JumpFalse | JumpTrue | SetHandler datatype opcode = SimpleCode of Word8.word list (* Bytes that don't need any special treatment *) | LabelCode of labels (* A label - forwards or backwards. *) | JumpInstruction of { label: labels, jumpType: jumpTypes, size: jumpSize ref } (* Jumps or SetHandler. *) | PushConstant of { constNum: int, size : jumpSize ref, isCall: bool } | PushShort of Word.word | IndexedCase of { labels: labels list, size : jumpSize ref } | LoadLocal of Word8.word (* Locals - simplifies peephole optimisation. *) | IndirectLocal of { localAddr: Word8.word, indirect: Word8.word } (* Ditto *) | UncondTransfer of Word8.word list (* Raisex, return and tail. *) | IsTaggedLocalB of Word8.word | JumpOnIsTaggedLocalB of { label: labels, size: jumpSize ref, localAddr: Word8.word } | JumpNotEqualLocalInd0BB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } | JumpNotEqualLocalConstBB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } and jumpSize = Size8 | Size16 | Size32 and code = Code of { constVec: machineWord list ref, (* Vector of words to be put at end *) procName: string, (* Name of the procedure. *) printAssemblyCode:bool, (* Whether to print the code when we finish. *) printStream: string->unit, (* The stream to use *) stage1Code: opcode list ref, enterIntMode: int (* 0 => None, 1 => X86. *) } val getEnterIntMode: unit -> int = RunCall.rtsCallFast0 "PolyInterpretedEnterIntMode" (* create and initialise a code segment *) fun codeCreate (name : string, parameters) = let val printStream = PRETTY.getSimplePrinter(parameters, []) in Code { constVec = ref [], procName = name, printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters, printStream = printStream, stage1Code = ref [], enterIntMode = getEnterIntMode() } end (* Find the offset in the constant area of a constant. *) (* The first has offset 0. *) fun addConstToVec (valu, Code{constVec, ...}) = let (* Search the list to see if the constant is already there. *) fun findConst valu [] num = (* Add to the list *) ( constVec := ! constVec @ [valu]; num ) | findConst valu (h :: t) num = if wordEq (valu, h) then num else findConst valu t (num + 1) (* Not equal *) in findConst valu (! constVec) 0 end fun printCode (seg: codeVec, procName: string, endcode, printStream) = let val () = printStream "\n"; val () = if procName = "" (* No name *) then printStream "?" else printStream procName; val () = printStream ":\n"; (* prints a string representation of a number *) fun printHex (v) = printStream(Word.fmt StringCvt.HEX v); val ptr = ref 0w0; (* Gets "length" bytes from locations "addr", "addr"+1... Returns an unsigned number. *) fun getB (0, _, _) = 0w0 | getB (length, addr, seg) = (getB (length - 1, addr + 0w1, seg) << 0w8) + word8ToWord (codeVecGet (seg, addr)) (* Prints a relative address. *) fun printDisp (len, spacer: string) = let val ad = getB(len, !ptr, seg) + !ptr + Word.fromInt len val () = printStream spacer; val () = printHex ad; in ptr := !ptr + Word.fromInt len end (* Prints an operand of an instruction *) fun printOp (len, spacer : string) = let val () = printStream spacer; val () = printHex (getB (len, !ptr, seg)) in ptr := !ptr + Word.fromInt len end; in while !ptr < endcode do let val addr = !ptr in printHex addr; (* The address. *) let (* It's an instruction. *) val () = printStream "\t" val opc = codeVecGet (seg, !ptr) (* opcode *) val () = ptr := !ptr + 0w1 in case opc of 0wx02 => (printStream "jump"; printDisp (1, "\t\t")) | 0wx03 => (printStream "jumpFalse"; printDisp (1, "\t")) | 0wx04 => printStream "loadMLWord" | 0wx05 => printStream "storeMLWord" | 0wx06 => printStream "alloc_ref" | 0wx07 => printStream "blockMoveWord" | 0wx08 => printStream "loadUntagged" | 0wx09 => printStream "storeUntagged" | 0wx0a => let (* Have to find out how many items there are. *) val limit = getB (2, !ptr, seg); val () = printOp (2, "case16\t"); val base = !ptr; fun printEntry _ = (printStream "\n\t"; printHex(base + getB(2, !ptr, seg)); ptr := !ptr + 0w2) fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) in forLoop printEntry 0w0 limit end | 0wx0c => printStream "callClosure" | 0wx0d => printOp(2, "returnW\t") | 0wx0e => printStream "containerB" | 0wx0f => printOp(2, "allocMutClosure") | 0wx10 => printStream "raiseEx" | 0wx11 => printDisp (2, "callConstAddr16\t") | 0wx12 => printDisp (1, "callConstAddr8\t") | 0wx13 => printOp(2, "localW\t") | 0wx16 => printOp(1, "callLocalB\t") | 0wx1a => (printStream "constAddr16"; printDisp (2, "\t")) | 0wx1b => printOp(2, "constIntW\t") | 0wx1e => ((* Should be negative *) printStream "jumpBack8\t"; printHex((!ptr - 0w1) - getB(1, !ptr, seg)); ptr := !ptr + 0w1 ) | 0wx1f => printOp(1, "returnB\t") | 0wx20 => ( printStream "jumpBack16\t"; printHex((!ptr - 0w1) - getB(2, !ptr, seg)); ptr := !ptr + 0w2 ) | 0wx21 => (printOp(1, "indirectLocalBB\t"); printOp(1, ",")) | 0wx22 => printOp(1, "localB\t") | 0wx23 => printOp(1, "indirectB\t") | 0wx24 => printOp(1, "moveToContainerB\t") | 0wx25 => printOp(1, "setStackValB\t") | 0wx26 => printOp(1, "resetB\t") | 0wx27 => printOp(1, "resetRB\t") | 0wx28 => printOp(1, "constIntB\t") | 0wx29 => printStream "local_0" | 0wx2a => printStream "local_1" | 0wx2b => printStream "local_2" | 0wx2c => printStream "local_3" | 0wx2d => printStream "local_4" | 0wx2e => printStream "local_5" | 0wx2f => printStream "local_6" | 0wx30 => printStream "local_7" | 0wx31 => printStream "local_8" | 0wx32 => printStream "local_9" | 0wx33 => printStream "local_10" | 0wx34 => printStream "local_11" | 0wx35 => printStream "indirect_0" | 0wx36 => printStream "indirect_1" | 0wx37 => printStream "indirect_2" | 0wx38 => printStream "indirect_3" | 0wx39 => printStream "indirect_4" | 0wx3a => printStream "indirect_5" | 0wx3b => printStream "const_0" | 0wx3c => printStream "const_1" | 0wx3d => printStream "const_2" | 0wx3e => printStream "const_3" | 0wx3f => printStream "const_4" | 0wx40 => printStream "const_10" | 0wx41 => printStream "return_0" | 0wx42 => printStream "return_1" | 0wx43 => printStream "return_2" | 0wx44 => printStream "return_3" | 0wx45 => printStream "local_12" | 0wx46 => (printStream "jumpTrue"; printDisp (1, "\t")) | 0wx47 => (printStream "jumpTrue"; printDisp (2, "\t")) | 0wx49 => printStream "local_13" | 0wx4a => printStream "local_14" | 0wx4b => printStream "local_15" + | 0wx4c => printStream "arbAdd" + | 0wx4d => printStream "arbSubtract" + | 0wx4e => printStream "arbMultiply" | 0wx50 => printStream "reset_1" | 0wx51 => printStream "reset_2" | 0wx54 => (printOp(1, "indirectClosureBB\t"); printOp(1, ", ")) | 0wx64 => printStream "resetR_1" | 0wx65 => printStream "resetR_2" | 0wx66 => printStream "resetR_3" | 0wx68 => printOp(1, "tupleB\t") | 0wx69 => printStream "tuple_2" | 0wx6a => printStream "tuple_3" | 0wx6b => printStream "tuple_4" | 0wx6c => printStream "lock" | 0wx6d => printStream "ldexc" | 0wx74 => printOp(1, "indirectContainerB\t") | 0wx75 => printOp(1, "moveToMutClosureB\t") | 0wx76 => printOp(1, "allocMutClosureB\t") | 0wx77 => printOp(1, "indirectClosureB0\t") | 0wx78 => printStream "pushHandler" | 0wx7a => printOp(1, "indirectClosureB1\t") | 0wx7b => (printOp (1, "tailbb\t"); printOp (1, ",")) | 0wx7c => printOp(1, "indirectClosureB2\t") | 0wx7d => printOp(1, "tail3b\t") | 0wx7e => printOp(1, "tail4b\t") | 0wx7f => printStream "tail3_2" | 0wx80 => printStream "tail3_3" | 0wx81 => (printStream "setHandler"; printDisp (1, "\t")) | 0wx83 => printStream "callFastRTS0" | 0wx84 => printStream "callFastRTS1" | 0wx85 => printStream "callFastRTS2" | 0wx86 => printStream "callFastRTS3" | 0wx87 => printStream "callFastRTS4" | 0wx88 => printStream "callFastRTS5" | 0wx91 => printStream "notBoolean" | 0wx92 => printStream "isTagged" | 0wx93 => printStream "cellLength" | 0wx94 => printStream "cellFlags" | 0wx95 => printStream "clearMutable" | 0wx97 => printStream "atomicIncr" | 0wx98 => printStream "atomicDecr" | 0wxa0 => printStream "equalWord" | 0wxa1 => printOp(1, "equalWordConstB\t") | 0wxa2 => printStream "lessSigned" | 0wxa3 => printStream "lessUnsigned" | 0wxa4 => printStream "lessEqSigned" | 0wxa5 => printStream "lessEqUnsigned" | 0wxa6 => printStream "greaterSigned" | 0wxa7 => printStream "greaterUnsigned" | 0wxa8 => printStream "greaterEqSigned" | 0wxa9 => printStream "greaterEqUnsigned" | 0wxaa => printStream "fixedAdd" | 0wxab => printStream "fixedSub" | 0wxac => printStream "fixedMult" | 0wxad => printStream "fixedQuot" | 0wxae => printStream "fixedRem" | 0wxb1 => printStream "wordAdd" | 0wxb2 => printStream "wordSub" | 0wxb3 => printStream "wordMult" | 0wxb4 => printStream "wordDiv" | 0wxb5 => printStream "wordMod" | 0wxb7 => printStream "wordAnd" | 0wxb8 => printStream "wordOr" | 0wxb9 => printStream "wordXor" | 0wxba => printStream "wordShiftLeft" | 0wxbb => printStream "wordShiftRLog" | 0wxbd => printStream "allocByteMem" | 0wxc1 => printOp(1, "indirectLocalB1\t") | 0wxc2 => printOp(1, "isTaggedLocalB\t") | 0wxc3 => (printOp(1, "jumpNEqLocalInd\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) | 0wxc4 => (printOp(1, "jumpTaggedLocal\t"); printDisp(1, "\t")) | 0wxc5 => (printOp(1, "jumpNEqLocal\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) | 0wxc6 => printStream "indirect0Local0" | 0wxc7 => printOp(1, "indirectLocalB0\t") | 0wxd0 => printOp(1, "closureB\t") | 0wxd9 => printStream "getThreadId" | 0wxda => printStream "allocWordMemory" | 0wxdc => printStream "loadMLByte" | 0wxe4 => printStream "storeMLByte" | 0wxec => printStream "blockMoveByte" | 0wxed => printStream "blockEqualByte" | 0wxee => printStream "blockCompareByte" | 0wxf1 => printStream "deleteHandler" | 0wxf7 => printStream "jump16" | 0wxf8 => printStream "jump16False" | 0wxf9 => printStream "setHandler16" | 0wxfa => printDisp (1, "constAddr8\t") | 0wxfb => printOp(1, "stackSize8\t") | 0wxfc => printOp(2, "stackSize16\t") | 0wxff => printStream "enterIntX86" | 0wxfe => ( case codeVecGet (seg, !ptr) before ptr := !ptr + 0w1 of 0wx0b => printStream "containerW" | 0wx10 => printOp(2, "indirectClosureW\t") | 0wx11 => printOp(2, "indirectContainerW\t") | 0wx14 => printOp(2, "indirectW\t") | 0wx15 => printOp(2, "moveToContainerW\t") | 0wx16 => printOp(2, "moveToMutClosureW\t") | 0wx17 => printOp(2, "setStackValW\t") | 0wx18 => printOp(2, "resetW\t") | 0wx19 => printOp(2, "resetR_w\t") | 0wx1c => printStream "callFastRTSRRtoR" | 0wx1d => printStream "callFastRTSRGtoR" | 0wx48 => (printStream "jumpTrue"; printDisp (4, "\t")) | 0wx56 => printStream "floatAbs" | 0wx57 => printStream "floatNeg" | 0wx58 => printStream "fixedIntToFloat" | 0wx59 => printStream "floatToReal" | 0wx5a => printOp(1, "realToFloat\t") | 0wx5b => printStream "floatEqual" | 0wx5c => printStream "floatLess" | 0wx5d => printStream "floatLessEq" | 0wx5e => printStream "floatGreater" | 0wx5f => printStream "floatGreaterEq" | 0wx60 => printStream "floatAdd" | 0wx61 => printStream "floatSub" | 0wx62 => printStream "floatMult" | 0wx63 => printStream "floatDiv" | 0wx67 => printOp(2, "tupleW\t") | 0wx6e => printOp(1, "realToInt\t") | 0wx6f => printOp(1, "floatToInt\t") | 0wx70 => printStream "callFastRTSFtoF" | 0wx71 => printStream "callFastRTSGtoF" | 0wx72 => printStream "callFastRTSFFtoF" | 0wx73 => printStream "callFastRTSFGtoF" | 0wx79 => printStream "realUnordered" | 0wx7a => printStream "floatUnordered" | 0wx7c => (printOp (2, "tail\t"); printOp (2, ",")) | 0wx8f => printStream "callFastRTSRtoR" | 0wx90 => printStream "callFastRTSGtoR" | 0wx99 => printStream "atomicReset" | 0wx9a => printStream "longWToTagged" | 0wx9b => printStream "signedToLongW" | 0wx9c => printStream "unsignedToLongW" | 0wx9d => printStream "realAbs" | 0wx9e => printStream "realNeg" | 0wx9f => printStream "fixedIntToReal" | 0wxaf => printStream "fixedDiv" | 0wxb0 => printStream "fixedMod" | 0wxbc => printStream "wordShiftRArith" | 0wxbe => printStream "lgWordEqual" | 0wxc0 => printStream "lgWordLess" | 0wxc1 => printStream "lgWordLessEq" | 0wxc2 => printStream "lgWordGreater" | 0wxc3 => printStream "lgWordGreaterEq" | 0wxc4 => printStream "lgWordAdd" | 0wxc5 => printStream "lgWordSub" | 0wxc6 => printStream "lgWordMult" | 0wxc7 => printStream "lgWordDiv" | 0wxc8 => printStream "lgWordMod" | 0wxc9 => printStream "lgWordAnd" | 0wxca => printStream "lgWordOr" | 0wxcb => printStream "lgWordXor" | 0wxcc => printStream "lgWordShiftLeft" | 0wxcd => printStream "lgWordShiftRLog" | 0wxce => printStream "lgWordShiftRArith" | 0wxcf => printStream "realEqual" | 0wxd0 => printOp(2, "closureW\t") | 0wxd1 => printStream "realLess" | 0wxd2 => printStream "realLessEq" | 0wxd3 => printStream "realGreater" | 0wxd4 => printStream "realGreaterEq" | 0wxd5 => printStream "realAdd" | 0wxd6 => printStream "realSub" | 0wxd7 => printStream "realMult" | 0wxd8 => printStream "realDiv" | 0wxdd => printStream "loadC8" | 0wxde => printStream "loadC16" | 0wxdf => printStream "loadC32" | 0wxe0 => printStream "loadC64" | 0wxe1 => printStream "loadCFloat" | 0wxe2 => printStream "loadCDouble" | 0wxe5 => printStream "storeC8" | 0wxe6 => printStream "storeC16" | 0wxe7 => printStream "storeC32" | 0wxe8 => printStream "storeC64" | 0wxe9 => printStream "storeCFloat" | 0wxea => printStream "storeCDouble" | 0wxf2 => printDisp (4, "jump32\t") | 0wxf3 => printDisp (4, "jump32False\t") | 0wxf4 => printDisp (4, "constAddr32\t") | 0wxf5 => printDisp (4, "setHandler32\t") | 0wxf6 => let (* Have to find out how many items there are. *) val limit = getB (2, !ptr, seg); val () = printOp (2, "case32\t"); val base = !ptr; fun printEntry _ = (printStream "\n\t"; printHex(base + getB(4, !ptr, seg)); ptr := !ptr + 0w4) fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) in forLoop printEntry 0w0 limit end | 0wxfd => printStream "allocCSpace" | 0wxfe => printStream "freeCSpace" | _ => printStream ("unknown:0xfe 0x" ^ Word8.toString opc) ) | opc => printStream("unknown:0x" ^ Word8.toString opc) end; (* an instruction. *) printStream "\n" end (* main loop *) end (* printCode *) fun codeSize (SimpleCode l) = List.length l | codeSize (LabelCode _) = 0 | codeSize (JumpInstruction{size=ref Size8, ...}) = 2 | codeSize (JumpInstruction{size=ref Size16, ...}) = 3 | codeSize (JumpInstruction{size=ref Size32, ...}) = 6 | codeSize (PushConstant{size=ref Size8, ...}) = 2 | codeSize (PushConstant{size=ref Size16, ...}) = 3 | codeSize (PushConstant{size=ref Size32, isCall=false, ...}) = 6 | codeSize (PushConstant{size=ref Size32, isCall=true, ...}) = 7 | codeSize (PushShort value) = if value <= 0w4 orelse value = 0w10 then 1 else if value < 0w256 then 2 else 3 | codeSize (IndexedCase{labels, size=ref Size32, ...}) = 4 + List.length labels * 4 | codeSize (IndexedCase{labels, size=ref Size16, ...}) = 3 + List.length labels * 2 | codeSize (IndexedCase{labels=_, size=ref Size8, ...}) = raise InternalError "codeSize" | codeSize (LoadLocal w) = if w <= 0w15 then 1 else 2 | codeSize (IndirectLocal{indirect=0w0, localAddr=0w0}) = 1 | codeSize (IndirectLocal{indirect=0w0, ...}) = 2 | codeSize (IndirectLocal{indirect=0w1, ...}) = 2 | codeSize (IndirectLocal _) = 3 | codeSize (UncondTransfer l) = List.length l | codeSize (IsTaggedLocalB _) = 2 | codeSize (JumpOnIsTaggedLocalB{size=ref Size8, ...}) = 3 | codeSize (JumpOnIsTaggedLocalB{size=ref Size16, ...}) = 5 | codeSize (JumpOnIsTaggedLocalB{size=ref Size32, ...}) = 8 | codeSize (JumpNotEqualLocalInd0BB{size=ref Size8, ...}) = 4 | codeSize (JumpNotEqualLocalInd0BB{label, size, localAddr, const}) = codeSize(IndirectLocal{localAddr=localAddr, indirect=0w0}) + codeSize(PushShort(word8ToWord const)) + 1 + codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) | codeSize (JumpNotEqualLocalConstBB{size=ref Size8, ...}) = 4 | codeSize (JumpNotEqualLocalConstBB {label, size, localAddr, const}) = codeSize(LoadLocal localAddr) + codeSize(PushShort(word8ToWord const)) + 1 + codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) (* General function to process the code. ic is the byte counter within the original code. *) fun foldCode startIc foldFn ops = let fun doFold(oper :: operList, ic) = doFold(operList, (* Get the size BEFORE any possible change. *) ic + Word.fromInt(codeSize oper) before foldFn(oper, ic)) | doFold(_, ic) = ic in doFold(ops, startIc) end (* Process the code, setting the destination of any labels. Return the length of the code. *) fun setLabels(LabelCode(ref labs) :: ops, ic) = (List.app(fn d => d := ic) labs; setLabels(ops, ic)) | setLabels(oper :: ops, ic) = setLabels(ops, ic + Word.fromInt(codeSize oper)) | setLabels([], ic) = ic (* Set the sizes of branches depending on the distance to the destination. *) fun setLabelsAndSizes ops = let val wordLength = wordSize (* Set the labels and adjust the sizes, repeating until it never gets smaller*) fun setLabAndSize(ops, lastSize) = let (* Calculate offsets for constants. *) val endIC = Word.andb(lastSize + wordLength - 0w1, ~ wordLength) val firstConstant = endIC + wordLength * 0w3 (* Because the constant area is word aligned we have to allow for the possibility that the distance between a "load constant" instruction and the target could actually increase. *) val alignment = wordLength - 0w1 fun adjust(JumpInstruction{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = if dest <= ic (* N.B. Include infinite loops as backwards. *) then ic - dest (* Backwards - Counts from start of instruction. *) else dest - (ic + 0w6) (* Forwards - Relative to the current end. *) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(JumpInstruction{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest <= ic then if ic - dest < 0wx100 then size := Size8 else () else if dest - (ic + 0w3) < 0wx100 then size := Size8 else () end | adjust(IndexedCase{size as ref Size32, labels}, ic) = let val startAddr = ic+0w4 (* Use 16-bit case if all the offsets are 16-bits. *) fun is16bit(ref lab) = let val dest = !(hd lab) in dest > startAddr andalso dest < startAddr+0wx10000 end in if List.all is16bit labels then size := Size16 else () end | adjust(PushConstant{size as ref Size32, constNum, ...}, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordLength val offset = constAddr - (ic + 0w6) in if offset < 0wx100-alignment then size := Size8 else if offset < 0wx10000-alignment then size := Size16 else () end | adjust(PushConstant{size as ref Size16, constNum, ...}, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordLength val offset = constAddr - (ic + 0w3) in if offset < 0wx100-alignment then size := Size8 else () end | adjust(JumpOnIsTaggedLocalB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + 0w8) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(JumpOnIsTaggedLocalB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + 0w5) < 0wx100 then size := Size8 else () end | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + Word.fromInt(codeSize j)) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () end | adjust(j as JumpNotEqualLocalConstBB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + Word.fromInt(codeSize j)) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(j as JumpNotEqualLocalConstBB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () end | adjust _ = () val _ = foldCode 0w0 adjust ops val nextSize = setLabels(ops, 0w0) in if nextSize < lastSize then setLabAndSize(ops, nextSize) else if nextSize = lastSize then lastSize else raise InternalError "setLabAndSize - size increased" end in setLabAndSize(ops, setLabels(ops, 0w0)) end fun genCode(ops, Code {constVec, ...}) = let (* First pass - set the labels. *) val codeSize = setLabelsAndSizes ops val wordSize = wordSize (* Align to wordLength. *) val endIC = Word.andb(codeSize + wordSize - 0w1, ~ wordSize) val paddingBytes = List.tabulate(Word.toInt(endIC - codeSize), fn _ => SimpleCode[opcode_const_0]) val endOfCode = endIC div wordSize val firstConstant = endIC + wordSize * 0w3 (* Add 3 for no of consts, fn name and profile count. *) val segSize = endOfCode + Word.fromInt(List.length(! constVec)) + 0w4 val codeVec = byteVecMake segSize val ic = ref 0w0 fun genByte b = byteVecSet(codeVec, !ic, b) before ic := !ic + 0w1 fun genByteCode(SimpleCode bytes, _) = (* Simple code - just generate the bytes. *) List.app genByte bytes | genByteCode(UncondTransfer bytes, _) = List.app genByte bytes | genByteCode(LabelCode _, _) = () | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size32, ...}, ic) = let val dest = !(hd labs) val extOpc = case jumpType of SetHandler => ext_opcode_setHandler32 | JumpFalse => ext_opcode_jump32False | JumpTrue => ext_opcode_jump32True | Jump => ext_opcode_jump32 | JumpBack => ext_opcode_jump32 val diff = dest - (ic + 0w6) in genByte opcode_escape; genByte extOpc; genByte(wordToWord8 diff); (* This may be negative so we must use an arithmetic shift. *) genByte(wordToWord8(diff ~>> 0w8)); genByte(wordToWord8(diff ~>> 0w16)); genByte(wordToWord8(diff ~>> 0w24)) end | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size16, ...}, ic) = let val dest = !(hd labs) in if dest <= ic then (* Jump back. *) let val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" val diff = ic - dest val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" in genByte opcode_jumpBack16; genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end else let val opc = case jumpType of SetHandler => opcode_setHandler16 | JumpFalse => opcode_jump16False | JumpTrue => opcode_jump16True | Jump => opcode_jump16 | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" val diff = dest - (ic + 0w3) val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" in genByte opc; genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end end | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size8, ...}, ic) = let val dest = !(hd labs) in if dest <= ic then (* Jump back. *) let val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" val diff = ic - dest val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" in genByte opcode_jumpBack8; genByte(wordToWord8 diff) end else let val opc = case jumpType of SetHandler => opcode_setHandler | JumpFalse => opcode_jumpFalse | JumpTrue => opcode_jumpTrue | Jump => opcode_jump | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" val diff = dest - (ic + 0w2) val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" in genByte opc; genByte(wordToWord8 diff) end end | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=false, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize (* Offsets are calculated from the END of the instruction *) val offset = constAddr - (ic + 0w6) in genByte opcode_escape; genByte ext_opcode_constAddr32; genByte(wordToWord8 offset); genByte(wordToWord8(offset >> 0w8)); genByte(wordToWord8(offset >> 0w16)); genByte(wordToWord8(offset >> 0w24)) end | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=true, ... }, ic) = ( (* Turn this back into a push of a constant and call-closure. *) genByteCode(PushConstant{ constNum=constNum, size=ref Size32, isCall=false }, ic); genByte opcode_callClosure ) | genByteCode(PushConstant{ constNum, size=ref Size16, isCall, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize val offset = constAddr - (ic + 0w3) val _ = offset < 0wx10000 orelse raise InternalError "genByteCode - constant range" in genByte(if isCall then opcode_callConstAddr16 else opcode_constAddr16); genByte(wordToWord8 offset); genByte(wordToWord8(offset >> 0w8)) end | genByteCode(PushConstant{ constNum, size=ref Size8, isCall, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize val offset = constAddr - (ic + 0w2) val _ = offset < 0wx100 orelse raise InternalError "genByteCode - constant range" in genByte(if isCall then opcode_callConstAddr8 else opcode_constAddr8); genByte(wordToWord8 offset) end | genByteCode(PushShort 0w0, _) = genByte opcode_const_0 | genByteCode(PushShort 0w1, _) = genByte opcode_const_1 | genByteCode(PushShort 0w2, _) = genByte opcode_const_2 | genByteCode(PushShort 0w3, _) = genByte opcode_const_3 | genByteCode(PushShort 0w4, _) = genByte opcode_const_4 | genByteCode(PushShort 0w10, _) = genByte opcode_const_10 | genByteCode(PushShort value, _) = if value < 0w256 then (genByte opcode_constIntB; genByte(wordToWord8 value)) else (genByte opcode_constIntW; genByte(wordToWord8 value); genByte(wordToWord8(value >> 0w8))) | genByteCode(IndexedCase{labels, size=ref Size32, ...}, ic) = let val nCases = List.length labels val () = genByte opcode_escape val () = genByte ext_opcode_case32 val () = genByte(Word8.fromInt nCases) val () = genByte(Word8.fromInt (nCases div 256)) val startOffset = ic+0w4 (* Offsets are relative to here. *) fun putLabel(ref labs) = let val dest = !(hd labs) val diff = dest - startOffset val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" in genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)); genByte(wordToWord8(diff >> 0w16)); genByte(wordToWord8(diff >> 0w24)) end in List.app putLabel labels end | genByteCode(IndexedCase{labels, size=ref Size16, ...}, ic) = let val nCases = List.length labels val () = genByte(opcode_case16) val () = genByte(Word8.fromInt nCases) val () = genByte(Word8.fromInt (nCases div 256)) val startOffset = ic+0w3 (* Offsets are relative to here. *) fun putLabel(ref labs) = let val dest = !(hd labs) val diff = dest - startOffset val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - indexed case" in genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end in List.app putLabel labels end | genByteCode(IndexedCase{size=ref Size8, ...}, _) = raise InternalError "genByteCode - IndexedCase byte" | genByteCode(LoadLocal 0w0, _) = genByte opcode_local_0 | genByteCode(LoadLocal 0w1, _) = genByte opcode_local_1 | genByteCode(LoadLocal 0w2, _) = genByte opcode_local_2 | genByteCode(LoadLocal 0w3, _) = genByte opcode_local_3 | genByteCode(LoadLocal 0w4, _) = genByte opcode_local_4 | genByteCode(LoadLocal 0w5, _) = genByte opcode_local_5 | genByteCode(LoadLocal 0w6, _) = genByte opcode_local_6 | genByteCode(LoadLocal 0w7, _) = genByte opcode_local_7 | genByteCode(LoadLocal 0w8, _) = genByte opcode_local_8 | genByteCode(LoadLocal 0w9, _) = genByte opcode_local_9 | genByteCode(LoadLocal 0w10, _) = genByte opcode_local_10 | genByteCode(LoadLocal 0w11, _) = genByte opcode_local_11 | genByteCode(LoadLocal 0w12, _) = genByte opcode_local_12 | genByteCode(LoadLocal 0w13, _) = genByte opcode_local_13 | genByteCode(LoadLocal 0w14, _) = genByte opcode_local_14 | genByteCode(LoadLocal 0w15, _) = genByte opcode_local_15 | genByteCode(LoadLocal w, _) = (genByte opcode_localB; genByte w) | genByteCode(IndirectLocal{localAddr=0w0, indirect=0w0}, _) = genByte opcode_indirect0Local0 | genByteCode(IndirectLocal{localAddr, indirect=0w0}, _) = (genByte opcode_indirectLocalB0; genByte localAddr) | genByteCode(IndirectLocal{localAddr, indirect=0w1}, _) = (genByte opcode_indirectLocalB1; genByte localAddr) | genByteCode(IndirectLocal{localAddr, indirect}, _) = (genByte opcode_indirectLocalBB; genByte localAddr; genByte indirect) | genByteCode(IsTaggedLocalB addr, _) = (genByte opcode_isTaggedLocalB; genByte addr) | genByteCode(JumpOnIsTaggedLocalB {label=ref labs, size=ref Size8, localAddr}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w3) in genByte opcode_jumpTaggedLocal; genByte localAddr; genByte(wordToWord8 diff) end | genByteCode(JumpOnIsTaggedLocalB {label, size, localAddr}, ic) = ( (* Turn this back into the original sequence. *) genByteCode(IsTaggedLocalB localAddr, ic); genByteCode(JumpInstruction{jumpType=JumpTrue, label=label, size=size}, ic+0w2) ) | genByteCode(JumpNotEqualLocalInd0BB {label=ref labs, size=ref Size8, localAddr, const}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w4) in genByte opcode_jumpNEqLocalInd; genByte localAddr; genByte const; genByte(wordToWord8 diff) end | genByteCode(JumpNotEqualLocalInd0BB {label, size, localAddr, const}, ic) = (* Turn this back into the original sequence. *) (foldCode ic genByteCode [IndirectLocal{localAddr=localAddr, indirect=0w0}, PushShort(word8ToWord const), SimpleCode[opcode_equalWord], JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) | genByteCode(JumpNotEqualLocalConstBB {label=ref labs, size=ref Size8, localAddr, const}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w4) in genByte opcode_jumpNEqLocal; genByte localAddr; genByte const; genByte(wordToWord8 diff) end | genByteCode(JumpNotEqualLocalConstBB {label, size, localAddr, const}, ic) = (* Turn this back into the original sequence. *) (foldCode ic genByteCode [LoadLocal localAddr, PushShort(word8ToWord const), SimpleCode[opcode_equalWord], JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) in foldCode 0w0 genByteCode (ops @ paddingBytes); (codeVec (* Return the completed code. *), endIC (* And the size. *)) end fun setLong (value, addrs, seg) = let val wordLength = wordSize fun putBytes(value, a, seg, i) = if i = wordLength then () else ( byteVecSet(seg, if not isBigEndian then a+i else a+wordLength-i-0w1, Word8.fromInt(value mod 256)); putBytes(value div 256, a, seg, i+0w1) ) in putBytes(value, addrs, seg, 0w0) end (* Peephole optimisation. *) local fun peepHole([], _, output) = List.rev output | peepHole(LabelCode lab1 :: (instrs as LabelCode lab2 :: _), exited, output) = ( (* Consecutive labels. Merge these, discarding the first. *) lab2 := !lab1 @ !lab2; peepHole(instrs, exited, output) ) (* A label followed by an unconditional branch. Forward the original label. Although JumpBack is also unconditional we don't forward those because we don't have a conditional backwards jump. *) | peepHole((LabelCode lab1) :: (jump as JumpInstruction{jumpType=Jump, label=lab2, ...}) :: tl, exited, output) = ( lab2 := !lab1 @ !lab2; (* Leave the jump in the stream and leave "exited" unchanged. This will now be unreachable if we had previously exited but we need to take the jump if we hadn't. *) peepHole(jump :: tl, exited, output) ) (* Discard everything after an unconditional transfer until the next label. *) | peepHole((label as LabelCode _) :: tl, _, output) = peepHole(tl, false, label::output) | peepHole(_ :: tl, true, output) = peepHole(tl, true, output) | peepHole((jump as JumpInstruction{jumpType=Jump, ...}) :: tl, _, output) = peepHole(tl, true, jump :: output) (* Return, raise-exception and tail-call. *) | peepHole((uncond as UncondTransfer _) :: tl, _, output) = peepHole(tl, true, uncond :: output) (* A conditional branch round an unconditional branch. Replace by a conditional branch with the sense reversed. *) | peepHole((cond as JumpInstruction{jumpType=JumpFalse, label=lab1, ...}) :: (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: (tail as LabelCode lab3 :: _), _, output) = if lab1 = lab3 then peepHole(tail, false, JumpInstruction{jumpType=JumpTrue, label=lab2, size=size} :: output) else peepHole(uncond :: tail, false, cond :: output) | peepHole((cond as JumpInstruction{jumpType=JumpTrue, label=lab1, ...}) :: (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: (tail as LabelCode lab3 :: _), _, output) = if lab1 = lab3 then peepHole(tail, false, JumpInstruction{jumpType=JumpFalse, label=lab2, size=size} :: output) else peepHole(uncond :: tail, false, cond :: output) | peepHole(IsTaggedLocalB addr :: JumpInstruction{jumpType=JumpTrue, label, size} :: tail, _, output) = peepHole(tail, false, JumpOnIsTaggedLocalB {label=label, size=size, localAddr=addr} :: output) | peepHole((indLocal as IndirectLocal{localAddr, indirect=0w0}) :: (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = if const < 0w256 then peepHole(tail, false, JumpNotEqualLocalInd0BB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) else peepHole(instrs, false, indLocal :: output) | peepHole((load as LoadLocal localAddr) :: (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = if const < 0w256 then peepHole(tail, false, JumpNotEqualLocalConstBB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) else peepHole(instrs, false, load :: output) | peepHole(hd::tl, exited, output) = peepHole(tl, exited, hd::output) in fun optimise code = peepHole(code, false, []) end (* Generate the code sequence to enter the interpreter when this code is called or returned to or an exception is raised. This is only required when bootstrapping a native code compiler. *) fun genEnterInt(_, Code { enterIntMode = 0 (* None *), ...}) = [] | genEnterInt(b, Code { enterIntMode = 1 (* X86_32 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx24, b]] | genEnterInt(b, Code { enterIntMode = 2 (* X86_64 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx48, b]] | genEnterInt(b, Code { enterIntMode = 3 (* X86_32_64 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx48, b]] | genEnterInt _ = raise InternalError "genEnterInt: unknown architecture value" (* Adds the constants onto the code, and copies the code into a new segment *) fun copyCode {code as Code{ printAssemblyCode, printStream, procName, constVec, stage1Code, ...}, maxStack, numberOfArguments, resultClosure} = let val cvec = code local val revCode = optimise(List.rev(!stage1Code)) (* Add a stack check. This is only needed if the function needs more than 128 words since the call and tail functions check for this much. *) in val codeList = if maxStack < 128 then revCode else SimpleCode[opcode_stackSize16, Word8.fromInt maxStack, Word8.fromInt(maxStack div 256)] :: revCode end (* Add an enterInt if necessary *) (* If we need enter-int code it must go first. *) val enterInt = genEnterInt(Word8.fromInt numberOfArguments + 0wx80, cvec) val (byteVec, endIC) = genCode(enterInt @ codeList, cvec) val wordLength = wordSize (* +3 for profile count, function name and constants count *) val numOfConst = List.length(! constVec) val endOfCode = endIC div wordLength val segSize = endOfCode + Word.fromInt numOfConst + 0w4 val firstConstant = endIC + wordLength * 0w3 (* Add 3 for no of consts, fn name and profile count. *) (* Put in the number of constants. This must go in before we actually put in any constants. *) local val lastWord = (segSize - 0w1) * wordLength in val () = setLong(numOfConst + 2, endIC, byteVec) (* Set the last word of the code to the (negative) byte offset of the start of the code area from the end of this word. *) val () = setLong((numOfConst + 3) * ~ (Word.toInt wordLength), lastWord, byteVec) end (* Now we've filled in all the size info we need to convert the segment into a proper code segment before it's safe to put in any ML values. *) val codeVec = byteVecToCodeVec(byteVec, resultClosure) local val name : string = procName val nameWord : machineWord = toMachineWord name in val () = codeVecPutWord (codeVec, endOfCode+0w1, nameWord) end (* Profile ref. A byte ref used by the profiler in the RTS. *) local val v = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(v, i-0w1, 0w0); clear (i-0w1)) val () = clear(wordSize) in val () = codeVecPutWord (codeVec, endOfCode+0w2, toMachineWord v) end (* and then copy the constants from the constant list. *) local fun setConstant(value, num) = let val constAddr = (firstConstant div wordLength) + num in codeVecPutWord (codeVec, constAddr, value); num+0w1 end in val _ = List.foldl setConstant 0w0 (!constVec) end in if printAssemblyCode then (* print out the code *) (printCode (codeVec, procName, endIC, printStream); printStream"\n") else (); codeVecLock(codeVec, resultClosure) end (* copyCode *) fun addItemToList(item, Code{stage1Code, ...}) = stage1Code := item :: !stage1Code val genOpcode = addItemToList fun putBranchInstruction(brOp, label, cvec) = addItemToList(JumpInstruction{label=label, jumpType=brOp, size = ref Size32}, cvec) fun setLabel(label, cvec) = addItemToList(LabelCode label, cvec) fun createLabel () = ref [ref 0w0] local fun genOpc(opc, cvec) = addItemToList(SimpleCode [opc], cvec) and genExtOpc(opc, cvec) = addItemToList(SimpleCode [opcode_escape, opc], cvec) and genOpcByte(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(SimpleCode [opc, Word8.fromInt arg1], cvec) else raise InternalError "genOpcByte" and genExtOpcByte(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(SimpleCode [opcode_escape, opc, Word8.fromInt arg1], cvec) else raise InternalError "genExtOpcByte" and genExtOpcWord(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 65536 then addItemToList(SimpleCode[opcode_escape, opc, Word8.fromInt arg1, Word8.fromInt (arg1 div 256)], cvec) else raise InternalError "genExtOpcWord" open IEEEReal fun encodeRound TO_NEAREST = 0 | encodeRound TO_NEGINF = 1 | encodeRound TO_POSINF = 2 | encodeRound TO_ZERO = 3 in fun genRaiseEx cvec = addItemToList(UncondTransfer [opcode_raiseEx], cvec) fun genLock cvec = genOpc (opcode_lock, cvec) fun genLdexc cvec = genOpc (opcode_ldexc, cvec) fun genPushHandler cvec = genOpc (opcode_pushHandler, cvec) fun genRTSCallFast(0, cvec) = genOpc (opcode_callFastRTS0, cvec) | genRTSCallFast(1, cvec) = genOpc (opcode_callFastRTS1, cvec) | genRTSCallFast(2, cvec) = genOpc (opcode_callFastRTS2, cvec) | genRTSCallFast(3, cvec) = genOpc (opcode_callFastRTS3, cvec) | genRTSCallFast(4, cvec) = genOpc (opcode_callFastRTS4, cvec) | genRTSCallFast(5, cvec) = genOpc (opcode_callFastRTS5, cvec) | genRTSCallFast(_, _) = raise InternalError "genRTSFastCall" fun genContainer (size, cvec) = if size < 256 then genOpcByte(opcode_containerB, size, cvec) else genExtOpcWord(ext_opcode_containerW, size, cvec) fun genCase (nCases, cvec) = let val labels = List.tabulate(nCases, fn _ => createLabel()) in addItemToList(IndexedCase{labels=labels, size=ref Size32}, cvec); labels end (* For the moment don't try to merge stack resets. *) fun resetStack(0, _, _) = () | resetStack(1, true, cvec) = addItemToList(SimpleCode[opcode_resetR_1], cvec) | resetStack(2, true, cvec) = addItemToList(SimpleCode[opcode_resetR_2], cvec) | resetStack(3, true, cvec) = addItemToList(SimpleCode[opcode_resetR_3], cvec) | resetStack(offset, true, cvec) = if offset < 0 then raise InternalError "resetStack" else if offset > 255 then genExtOpcWord(ext_opcode_resetR_w, offset, cvec) else genOpcByte(opcode_resetRB, offset, cvec) | resetStack(1, false, cvec) = addItemToList(SimpleCode[opcode_reset_1], cvec) | resetStack(2, false, cvec) = addItemToList(SimpleCode[opcode_reset_2], cvec) | resetStack(offset, false, cvec) = if offset < 0 then raise InternalError "resetStack" else if offset > 255 then genExtOpcWord(ext_opcode_resetW, offset, cvec) else genOpcByte(opcode_resetB, offset, cvec) fun genCallClosure(Code{stage1Code as ref(PushConstant{constNum, size, isCall=false} :: tail), ...}) = stage1Code := PushConstant{constNum=constNum, size=size, isCall=true} :: tail | genCallClosure(Code{stage1Code as ref(LoadLocal w :: tail), ...}) = stage1Code := SimpleCode [opcode_callLocalB, w] :: tail | genCallClosure(Code{stage1Code, ...}) = stage1Code := SimpleCode [opcode_callClosure] :: !stage1Code fun genTailCall (toslide, slideby, cvec) = if toslide < 256 andalso slideby < 256 then (* General byte case *) addItemToList(UncondTransfer[opcode_tailbb, Word8.fromInt toslide, Word8.fromInt slideby], cvec) else (* General case. *) addItemToList( UncondTransfer[opcode_escape, ext_opcode_tail, Word8.fromInt toslide, Word8.fromInt(toslide div 256), Word8.fromInt slideby, Word8.fromInt (slideby div 256)], cvec) fun pushConst (value : machineWord, cvec) = if isShort value andalso toShort value < 0w32768 then addItemToList(PushShort(toShort value), cvec) else (* address or large short *) addItemToList(PushConstant{constNum = addConstToVec(value, cvec), size=ref Size32, isCall=false}, cvec) fun genRTSCallFastRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRtoR, cvec) and genRTSCallFastRealRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRRtoR, cvec) and genRTSCallFastGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSGtoR, cvec) and genRTSCallFastRealGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSRGtoR, cvec) and genRTSCallFastFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFtoF, cvec) and genRTSCallFastFloatFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFFtoF, cvec) and genRTSCallFastGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSGtoF, cvec) and genRTSCallFastFloatGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSFGtoF, cvec) fun genDoubleToFloat(SOME rnding, cvec) = genExtOpcByte(ext_opcode_realToFloat, encodeRound rnding, cvec) | genDoubleToFloat(NONE, cvec) = genExtOpcByte(ext_opcode_realToFloat, 5, cvec) and genRealToInt(rnding, cvec) = genExtOpcByte(ext_opcode_realToInt, encodeRound rnding, cvec) and genFloatToInt(rnding, cvec) = genExtOpcByte(ext_opcode_floatToInt, encodeRound rnding, cvec) fun genEqualWordConst(w, cvec) = (pushConst(toMachineWord w, cvec); genOpc(opcode_equalWord, cvec)) fun genIsTagged(Code{stage1Code as ref(LoadLocal addr :: tail), ...}) = stage1Code := IsTaggedLocalB addr :: tail | genIsTagged cvec = genOpc(opcode_isTagged, cvec) fun genIndirectSimple(0, cvec) = genOpc(opcode_indirect_0, cvec) | genIndirectSimple(1, cvec) = genOpc(opcode_indirect_1, cvec) | genIndirectSimple(2, cvec) = genOpc(opcode_indirect_2, cvec) | genIndirectSimple(3, cvec) = genOpc(opcode_indirect_3, cvec) | genIndirectSimple(4, cvec) = genOpc(opcode_indirect_4, cvec) | genIndirectSimple(5, cvec) = genOpc(opcode_indirect_5, cvec) | genIndirectSimple(arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_indirectB, arg1, cvec) else genExtOpcWord(ext_opcode_indirectW, arg1, cvec) fun genIndirectContainer(arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_indirectContainerB, arg1, cvec) else genExtOpcWord(ext_opcode_indirectContainerW, arg1, cvec) fun genMoveToContainer (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_moveToContainerB, arg1, cvec) else genExtOpcWord(ext_opcode_moveToContainerW, arg1, cvec) fun genMoveToMutClosure (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_moveToMutClosureB, arg1, cvec) else genExtOpcWord(ext_opcode_moveToMutClosureW, arg1, cvec) fun genSetStackVal (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_setStackValB, arg1, cvec) else genExtOpcWord(ext_opcode_setStackValW, arg1, cvec) fun genTuple (2, cvec) = genOpc(opcode_tuple_2, cvec) | genTuple (3, cvec) = genOpc(opcode_tuple_3, cvec) | genTuple (4, cvec) = genOpc(opcode_tuple_4, cvec) | genTuple (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_tupleB, arg1, cvec) else genExtOpcWord(ext_opcode_tupleW, arg1, cvec) fun genAllocMutableClosure(closureSize, cvec) = if closureSize < 256 then genOpcByte(opcode_allocMutClosureB, closureSize, cvec) else genExtOpcWord(ext_opcode_allocMutClosureW, closureSize, cvec) fun genClosure (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_closureB, arg1, cvec) else genExtOpcWord(ext_opcode_closureW, arg1, cvec) fun genLocal (arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(LoadLocal(Word8.fromInt arg1), cvec) else addItemToList(SimpleCode[opcode_localW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)], cvec) fun genIndirectClosure{ addr, item, code=cvec } = if addr < 256 andalso item < 256 then ( case item of 0 => genOpcByte(opcode_indirectClosureB0, addr, cvec) | 1 => genOpcByte(opcode_indirectClosureB1, addr, cvec) | 2 => genOpcByte(opcode_indirectClosureB2, addr, cvec) | _ => addItemToList(SimpleCode[opcode_indirectClosureBB, Word8.fromInt addr, Word8.fromInt item], cvec) ) else ( genLocal (addr, cvec); addItemToList(SimpleCode[opcode_escape, ext_opcode_indirectClosureW, Word8.fromInt item, Word8.fromInt (item div 256)], cvec) ) end fun genReturn(1, cvec) = addItemToList(UncondTransfer[opcode_return_1], cvec) | genReturn(2, cvec) = addItemToList(UncondTransfer[opcode_return_2], cvec) | genReturn(3, cvec) = addItemToList(UncondTransfer[opcode_return_3], cvec) | genReturn(arg1, cvec) = addItemToList(UncondTransfer( if 0 <= arg1 andalso arg1 <= 255 then [opcode_returnB, Word8.fromInt arg1] else [opcode_returnW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)]), cvec) fun genIndirect (arg1, cvec as Code{stage1Code as ref(LoadLocal w :: tail), ...}) = if 0 <= arg1 andalso arg1 <= 255 then stage1Code := IndirectLocal{localAddr=w, indirect=Word8.fromInt arg1} :: tail else genIndirectSimple(arg1, cvec) | genIndirect (arg1, cvec) = genIndirectSimple(arg1, cvec) fun genEnterIntCatch(code as Code{stage1Code, ...}) = stage1Code := genEnterInt(0wxff, code) @ !stage1Code and genEnterIntCall(code as Code{stage1Code, ...}, args) = stage1Code := genEnterInt(Word8.fromInt args, code) @ !stage1Code val opcode_notBoolean = SimpleCode [opcode_notBoolean] val opcode_cellLength = SimpleCode [opcode_cellLength] and opcode_cellFlags = SimpleCode [opcode_cellFlags] and opcode_clearMutable = SimpleCode [opcode_clearMutable] and opcode_atomicIncr = SimpleCode [opcode_atomicIncr] and opcode_atomicDecr = SimpleCode [opcode_atomicDecr] and opcode_atomicReset = SimpleCode [opcode_escape, ext_opcode_atomicReset] and opcode_longWToTagged = SimpleCode [opcode_escape, ext_opcode_longWToTagged] and opcode_signedToLongW = SimpleCode [opcode_escape, ext_opcode_signedToLongW] and opcode_unsignedToLongW = SimpleCode [opcode_escape, ext_opcode_unsignedToLongW] and opcode_realAbs = SimpleCode [opcode_escape, ext_opcode_realAbs] and opcode_realNeg = SimpleCode [opcode_escape, ext_opcode_realNeg] and opcode_fixedIntToReal = SimpleCode [opcode_escape, ext_opcode_fixedIntToReal] and opcode_fixedIntToFloat = SimpleCode [opcode_escape, ext_opcode_fixedIntToFloat] and opcode_floatToReal = SimpleCode [opcode_escape, ext_opcode_floatToReal] val opcode_equalWord = SimpleCode [opcode_equalWord] and opcode_lessSigned = SimpleCode [opcode_lessSigned] and opcode_lessUnsigned = SimpleCode [opcode_lessUnsigned] and opcode_lessEqSigned = SimpleCode [opcode_lessEqSigned] and opcode_lessEqUnsigned = SimpleCode [opcode_lessEqUnsigned] and opcode_greaterSigned = SimpleCode [opcode_greaterSigned] and opcode_greaterUnsigned = SimpleCode [opcode_greaterUnsigned] and opcode_greaterEqSigned = SimpleCode [opcode_greaterEqSigned] and opcode_greaterEqUnsigned = SimpleCode [opcode_greaterEqUnsigned] val opcode_fixedAdd = SimpleCode [opcode_fixedAdd] val opcode_fixedSub = SimpleCode [opcode_fixedSub] val opcode_fixedMult = SimpleCode [opcode_fixedMult] val opcode_fixedQuot = SimpleCode [opcode_fixedQuot] val opcode_fixedRem = SimpleCode [opcode_fixedRem] val opcode_fixedDiv = SimpleCode [opcode_escape, ext_opcode_fixedDiv] val opcode_fixedMod = SimpleCode [opcode_escape, ext_opcode_fixedMod] val opcode_wordAdd = SimpleCode [opcode_wordAdd] val opcode_wordSub = SimpleCode [opcode_wordSub] val opcode_wordMult = SimpleCode [opcode_wordMult] val opcode_wordDiv = SimpleCode [opcode_wordDiv] val opcode_wordMod = SimpleCode [opcode_wordMod] val opcode_wordAnd = SimpleCode [opcode_wordAnd] val opcode_wordOr = SimpleCode [opcode_wordOr] val opcode_wordXor = SimpleCode [opcode_wordXor] val opcode_wordShiftLeft = SimpleCode [opcode_wordShiftLeft] val opcode_wordShiftRLog = SimpleCode [opcode_wordShiftRLog] val opcode_wordShiftRArith = SimpleCode [opcode_escape, ext_opcode_wordShiftRArith] val opcode_allocByteMem = SimpleCode [opcode_allocByteMem] val opcode_lgWordEqual = SimpleCode [opcode_escape, ext_opcode_lgWordEqual] val opcode_lgWordLess = SimpleCode [opcode_escape, ext_opcode_lgWordLess] val opcode_lgWordLessEq = SimpleCode [opcode_escape, ext_opcode_lgWordLessEq] val opcode_lgWordGreater = SimpleCode [opcode_escape, ext_opcode_lgWordGreater] val opcode_lgWordGreaterEq = SimpleCode [opcode_escape, ext_opcode_lgWordGreaterEq] val opcode_lgWordAdd = SimpleCode [opcode_escape, ext_opcode_lgWordAdd] val opcode_lgWordSub = SimpleCode [opcode_escape, ext_opcode_lgWordSub] val opcode_lgWordMult = SimpleCode [opcode_escape, ext_opcode_lgWordMult] val opcode_lgWordDiv = SimpleCode [opcode_escape, ext_opcode_lgWordDiv] val opcode_lgWordMod = SimpleCode [opcode_escape, ext_opcode_lgWordMod] val opcode_lgWordAnd = SimpleCode [opcode_escape, ext_opcode_lgWordAnd] val opcode_lgWordOr = SimpleCode [opcode_escape, ext_opcode_lgWordOr] val opcode_lgWordXor = SimpleCode [opcode_escape, ext_opcode_lgWordXor] val opcode_lgWordShiftLeft = SimpleCode [opcode_escape, ext_opcode_lgWordShiftLeft] val opcode_lgWordShiftRLog = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRLog] val opcode_lgWordShiftRArith = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRArith] val opcode_realEqual = SimpleCode [opcode_escape, ext_opcode_realEqual] val opcode_realLess = SimpleCode [opcode_escape, ext_opcode_realLess] val opcode_realLessEq = SimpleCode [opcode_escape, ext_opcode_realLessEq] val opcode_realGreater = SimpleCode [opcode_escape, ext_opcode_realGreater] val opcode_realGreaterEq = SimpleCode [opcode_escape, ext_opcode_realGreaterEq] val opcode_realUnordered = SimpleCode [opcode_escape, ext_opcode_realUnordered] val opcode_realAdd = SimpleCode [opcode_escape, ext_opcode_realAdd] val opcode_realSub = SimpleCode [opcode_escape, ext_opcode_realSub] val opcode_realMult = SimpleCode [opcode_escape, ext_opcode_realMult] val opcode_realDiv = SimpleCode [opcode_escape, ext_opcode_realDiv] and opcode_floatAbs = SimpleCode [opcode_escape, ext_opcode_floatAbs] and opcode_floatNeg = SimpleCode [opcode_escape, ext_opcode_floatNeg] val opcode_floatEqual = SimpleCode [opcode_escape, ext_opcode_floatEqual] val opcode_floatLess = SimpleCode [opcode_escape, ext_opcode_floatLess] val opcode_floatLessEq = SimpleCode [opcode_escape, ext_opcode_floatLessEq] val opcode_floatGreater = SimpleCode [opcode_escape, ext_opcode_floatGreater] val opcode_floatGreaterEq = SimpleCode [opcode_escape, ext_opcode_floatGreaterEq] val opcode_floatUnordered = SimpleCode [opcode_escape, ext_opcode_floatUnordered] val opcode_floatAdd = SimpleCode [opcode_escape, ext_opcode_floatAdd] val opcode_floatSub = SimpleCode [opcode_escape, ext_opcode_floatSub] val opcode_floatMult = SimpleCode [opcode_escape, ext_opcode_floatMult] val opcode_floatDiv = SimpleCode [opcode_escape, ext_opcode_floatDiv] val opcode_getThreadId = SimpleCode [opcode_getThreadId] val opcode_allocWordMemory = SimpleCode [opcode_allocWordMemory] val opcode_alloc_ref = SimpleCode [opcode_alloc_ref] val opcode_loadMLWord = SimpleCode [opcode_loadMLWord] val opcode_loadMLByte = SimpleCode [opcode_loadMLByte] val opcode_loadC8 = SimpleCode [opcode_escape, ext_opcode_loadC8] val opcode_loadC16 = SimpleCode [opcode_escape, ext_opcode_loadC16] val opcode_loadC32 = SimpleCode [opcode_escape, ext_opcode_loadC32] val opcode_loadC64 = SimpleCode [opcode_escape, ext_opcode_loadC64] val opcode_loadCFloat = SimpleCode [opcode_escape, ext_opcode_loadCFloat] val opcode_loadCDouble = SimpleCode [opcode_escape, ext_opcode_loadCDouble] val opcode_loadUntagged = SimpleCode [opcode_loadUntagged] val opcode_storeMLWord = SimpleCode [opcode_storeMLWord] val opcode_storeMLByte = SimpleCode [opcode_storeMLByte] val opcode_storeC8 = SimpleCode [opcode_escape, ext_opcode_storeC8] val opcode_storeC16 = SimpleCode [opcode_escape, ext_opcode_storeC16] val opcode_storeC32 = SimpleCode [opcode_escape, ext_opcode_storeC32] val opcode_storeC64 = SimpleCode [opcode_escape, ext_opcode_storeC64] val opcode_storeCFloat = SimpleCode [opcode_escape, ext_opcode_storeCFloat] val opcode_storeCDouble = SimpleCode [opcode_escape, ext_opcode_storeCDouble] val opcode_storeUntagged = SimpleCode [opcode_storeUntagged] val opcode_blockMoveWord = SimpleCode [opcode_blockMoveWord] val opcode_blockMoveByte = SimpleCode [opcode_blockMoveByte] val opcode_blockEqualByte = SimpleCode [opcode_blockEqualByte] val opcode_blockCompareByte = SimpleCode [opcode_blockCompareByte] val opcode_deleteHandler = SimpleCode [opcode_deleteHandler] val opcode_allocCSpace = SimpleCode [opcode_escape, ext_opcode_allocCSpace] val opcode_freeCSpace = SimpleCode [opcode_escape, ext_opcode_freeCSpace] + val opcode_arbAdd = SimpleCode [opcode_arbAdd] + val opcode_arbSubtract = SimpleCode [opcode_arbSubtract] + val opcode_arbMultiply = SimpleCode [opcode_arbMultiply] structure Sharing = struct type code = code type opcode = opcode type labels = labels type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml index cb882ac0..443fb9fb 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONSSIG.sml @@ -1,222 +1,225 @@ (* Copyright (c) 2016-18, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature INTCODECONSSIG = sig type machineWord = Address.machineWord type address = Address.address type code type opcode type labels type closureRef val opcode_notBoolean: opcode val opcode_cellLength: opcode and opcode_cellFlags: opcode and opcode_clearMutable: opcode and opcode_atomicIncr: opcode and opcode_atomicDecr: opcode and opcode_atomicReset: opcode and opcode_longWToTagged: opcode and opcode_signedToLongW: opcode and opcode_unsignedToLongW: opcode and opcode_realAbs: opcode and opcode_realNeg: opcode and opcode_fixedIntToReal: opcode and opcode_fixedIntToFloat: opcode and opcode_floatToReal: opcode and opcode_floatAbs: opcode and opcode_floatNeg: opcode val opcode_equalWord: opcode and opcode_lessSigned: opcode and opcode_lessUnsigned: opcode and opcode_lessEqSigned: opcode and opcode_lessEqUnsigned: opcode and opcode_greaterSigned: opcode and opcode_greaterUnsigned: opcode and opcode_greaterEqSigned: opcode and opcode_greaterEqUnsigned: opcode val opcode_fixedAdd: opcode val opcode_fixedSub: opcode val opcode_fixedMult: opcode val opcode_fixedQuot: opcode val opcode_fixedRem: opcode val opcode_fixedDiv: opcode val opcode_fixedMod: opcode val opcode_wordAdd: opcode val opcode_wordSub: opcode val opcode_wordMult: opcode val opcode_wordDiv: opcode val opcode_wordMod: opcode val opcode_wordAnd: opcode val opcode_wordOr: opcode val opcode_wordXor: opcode val opcode_wordShiftLeft: opcode val opcode_wordShiftRLog: opcode val opcode_wordShiftRArith: opcode val opcode_allocByteMem: opcode val opcode_lgWordEqual: opcode val opcode_lgWordLess: opcode val opcode_lgWordLessEq: opcode val opcode_lgWordGreater: opcode val opcode_lgWordGreaterEq: opcode val opcode_lgWordAdd: opcode val opcode_lgWordSub: opcode val opcode_lgWordMult: opcode val opcode_lgWordDiv: opcode val opcode_lgWordMod: opcode val opcode_lgWordAnd: opcode val opcode_lgWordOr: opcode val opcode_lgWordXor: opcode val opcode_lgWordShiftLeft: opcode val opcode_lgWordShiftRLog: opcode val opcode_lgWordShiftRArith: opcode val opcode_realEqual: opcode val opcode_realLess: opcode val opcode_realLessEq: opcode val opcode_realGreater: opcode val opcode_realGreaterEq: opcode val opcode_realUnordered: opcode val opcode_realAdd: opcode val opcode_realSub: opcode val opcode_realMult: opcode val opcode_realDiv: opcode val opcode_floatEqual: opcode val opcode_floatLess: opcode val opcode_floatLessEq: opcode val opcode_floatGreater: opcode val opcode_floatGreaterEq: opcode val opcode_floatUnordered: opcode val opcode_floatAdd: opcode val opcode_floatSub: opcode val opcode_floatMult: opcode val opcode_floatDiv: opcode val opcode_getThreadId: opcode val opcode_allocWordMemory: opcode val opcode_alloc_ref: opcode val opcode_loadMLWord: opcode val opcode_loadMLByte: opcode val opcode_loadC8: opcode val opcode_loadC16: opcode val opcode_loadC32: opcode val opcode_loadC64: opcode val opcode_loadCFloat: opcode val opcode_loadCDouble: opcode val opcode_loadUntagged: opcode val opcode_storeMLWord: opcode val opcode_storeMLByte: opcode val opcode_storeC8: opcode val opcode_storeC16: opcode val opcode_storeC32: opcode val opcode_storeC64: opcode val opcode_storeCFloat: opcode val opcode_storeCDouble: opcode val opcode_storeUntagged: opcode val opcode_blockMoveWord: opcode val opcode_blockMoveByte: opcode val opcode_blockEqualByte: opcode val opcode_blockCompareByte: opcode val opcode_deleteHandler: opcode val opcode_allocCSpace: opcode val opcode_freeCSpace: opcode + val opcode_arbAdd: opcode + val opcode_arbSubtract: opcode + val opcode_arbMultiply: opcode val codeCreate: string * Universal.universal list -> code (* makes the initial segment. *) (* GEN- routines all put a value at the instruction counter and add an appropriate amount to it. *) (* gen... - put instructions and their operands. *) val genCallClosure : code -> unit val genRaiseEx : code -> unit val genLock : code -> unit val genLdexc : code -> unit val genPushHandler : code -> unit val genReturn : int * code -> unit val genLocal : int * code -> unit val genIndirect : int * code -> unit val genSetStackVal : int * code -> unit val genCase : int * code -> labels list val genTuple : int * code -> unit val genTailCall : int * int * code -> unit val genIndirectClosure: { addr: int, item: int, code: code } -> unit and genIndirectContainer: int * code -> unit and genMoveToContainer: int * code -> unit and genMoveToMutClosure: int * code -> unit and genClosure: int * code -> unit val genDoubleToFloat: IEEEReal.rounding_mode option * code -> unit and genRealToInt: IEEEReal.rounding_mode * code -> unit and genFloatToInt: IEEEReal.rounding_mode * code -> unit val genAllocMutableClosure: int * code -> unit val genRTSCallFast: int * code -> unit val genRTSCallFastRealtoReal: code -> unit val genRTSCallFastRealRealtoReal: code -> unit val genRTSCallFastGeneraltoReal: code -> unit val genRTSCallFastRealGeneraltoReal: code -> unit val genRTSCallFastFloattoFloat: code -> unit val genRTSCallFastFloatFloattoFloat: code -> unit val genRTSCallFastGeneraltoFloat: code -> unit val genRTSCallFastFloatGeneraltoFloat: code -> unit val genOpcode: opcode * code -> unit (* genEnter instructions are only needed when machine-code routines can call interpreted routines or vice-versa. The enterInt instruction causes the interpreter to be entered and the argument indicates the reason. *) val genEnterIntCatch : code -> unit val genEnterIntCall : code * int -> unit (* pushConst - Generates code to push a constant. *) val pushConst : machineWord * code -> unit (* Create a container on the stack *) val genContainer : int * code -> unit (* copyCode - Finish up after compiling a function. *) val copyCode : {code: code, maxStack: int, numberOfArguments: int, resultClosure: closureRef } -> unit (* putBranchInstruction puts in an instruction which involves a forward reference. *) datatype jumpTypes = Jump | JumpBack | JumpFalse | JumpTrue | SetHandler val putBranchInstruction: jumpTypes * labels * code -> unit val createLabel: unit -> labels (* Define the position of a label. *) val setLabel: labels * code -> unit val resetStack: int * bool * code -> unit (* Set a pending reset *) val genEqualWordConst: word * code -> unit val genIsTagged: code -> unit structure Sharing: sig type code = code type opcode = opcode type labels = labels type closureRef = closureRef end end ; diff --git a/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML b/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML index 79c61b95..aff78ad3 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML @@ -1,1222 +1,1230 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Further development copyright David C.J. Matthews 2016-18,2020 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Generate interpretable code for Poly system from the code tree. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) (* This generates byte-code that is interpreted by the run-time system. It is now used as a fall-back to allow Poly/ML to run on non-X86 architectures. Early versions were used as a porting aid while a native code-generator was being developed and the "enter-int" instructions that were needed for that have been retained although they no longer actually generate code. *) functor INTGCODE ( structure CODECONS : INTCODECONSSIG structure BACKENDTREE: BackendIntermediateCodeSig structure CODE_ARRAY: CODEARRAYSIG sharing CODECONS.Sharing = BACKENDTREE.Sharing = CODE_ARRAY.Sharing ) : GENCODESIG = struct open CODECONS open Address open BACKENDTREE open Misc open CODE_ARRAY val word0 = toMachineWord 0; val DummyValue : machineWord = word0; (* used as result of "raise e" etc. *) type caseForm = { cases : (backendIC * word) list, test : backendIC, caseType: caseType, default : backendIC } (* Where the result, if any, should go *) datatype whereto = NoResult (* discard result *) | ToStack (* Need a result but it can stay on the pseudo-stack *); (* Are we at the end of the function. *) datatype tail = EndOfProc | NotEnd (* Code generate a function or global declaration *) fun codegen (pt, cvec, resultClosure, numOfArgs, localCount, parameters) = let datatype decEntry = StackAddr of int | Empty val decVec = Array.array (localCount, Empty) (* Count of number of items on the stack. *) val realstackptr = ref 1 (* The closure ptr is already there *) (* Maximum size of the stack. *) val maxStack = ref 1 (* Push a value onto the stack. *) fun incsp () = ( realstackptr := !realstackptr + 1; if !realstackptr > !maxStack then maxStack := !realstackptr else () ) (* An entry has been removed from the stack. *) fun decsp () = realstackptr := !realstackptr - 1; fun pushLocalStackValue addr = ( genLocal(!realstackptr + addr, cvec); incsp() ) (* Loads a local, argument or closure value; translating local stack addresses to real stack offsets. *) fun locaddr(BICLoadArgument locn) = pushLocalStackValue (numOfArgs-locn) | locaddr(BICLoadLocal locn) = ( (* positive address - on the stack. *) case Array.sub (decVec, locn) of StackAddr n => pushLocalStackValue (~ n) | _ => (* Should be on the stack, not a function. *) raise InternalError "locaddr: bad stack address" ) | locaddr(BICLoadClosure locn) = (* closure-pointer relative *) ( genIndirectClosure{addr = !realstackptr-1, item=locn, code=cvec}; incsp() ) | locaddr BICLoadRecursive = pushLocalStackValue ~1 (* The closure itself - first value on the stack. *) (* generates code from the tree *) fun gencde (pt : backendIC, whereto : whereto, tailKind : tail, loopAddr) : unit = let (* Save the stack pointer value here. We may want to reset the stack. *) val oldsp = !realstackptr; (* Operations on ML memory always have the base as an ML address. Word operations are always word aligned. The higher level will have extracted any constant offset and scaled it if necessary. That's helpful for the X86 but not for the interpreter. We have to turn them back into indexes. *) fun genMLAddress({base, index, offset}, scale) = ( gencde (base, ToStack, NotEnd, loopAddr); offset mod scale = 0 orelse raise InternalError "genMLAddress"; case (index, offset div scale) of (NONE, soffset) => (pushConst (toMachineWord soffset, cvec); incsp()) | (SOME indexVal, 0) => gencde (indexVal, ToStack, NotEnd, loopAddr) | (SOME indexVal, soffset) => ( gencde (indexVal, ToStack, NotEnd, loopAddr); pushConst (toMachineWord soffset, cvec); genOpcode(opcode_wordAdd, cvec) ) ) (* Load the address, index value and offset for non-byte operations. Because the offset has already been scaled by the size of the operand we have to load the index and offset separately. *) fun genCAddress{base, index, offset} = ( gencde (base, ToStack, NotEnd, loopAddr); case index of NONE => (pushConst (toMachineWord 0, cvec); incsp()) | SOME indexVal => gencde (indexVal, ToStack, NotEnd, loopAddr); pushConst (toMachineWord offset, cvec); incsp() ) val () = case pt of BICEval evl => genEval (evl, tailKind) | BICExtract ext => (* This may just be being used to discard a value which isn't used on this branch. *) if whereto = NoResult then () else locaddr ext | BICField {base, offset} => (gencde (base, ToStack, NotEnd, loopAddr); genIndirect (offset, cvec)) | BICLoadContainer {base, offset} => (gencde (base, ToStack, NotEnd, loopAddr); genIndirectContainer (offset, cvec)) | BICLambda lam => genProc (lam, false, fn () => ()) | BICConstnt(w, _) => let val () = pushConst (w, cvec); in incsp () end | BICCond (testPart, thenPart, elsePart) => genCond (testPart, thenPart, elsePart, whereto, tailKind, loopAddr) | BICNewenv(decls, exp) => let (* Processes a list of entries. *) (* Mutually recursive declarations. May be either lambdas or constants. Recurse down the list pushing the addresses of the closure vectors, then unwind the recursion and fill them in. *) fun genMutualDecs [] = () | genMutualDecs ({lambda, addr, ...} :: otherDecs) = genProc (lambda, true, fn() => ( Array.update (decVec, addr, StackAddr (! realstackptr)); genMutualDecs (otherDecs) )) fun codeDecls(BICRecDecs dl) = genMutualDecs dl | codeDecls(BICDecContainer{size, addr}) = ( (* If this is a container we have to process it here otherwise it will be removed in the stack adjustment code. *) genContainer(size, cvec); (* Push the address of this container. *) realstackptr := !realstackptr + size + 1; (* Pushes N words plus the address. *) Array.update (decVec, addr, StackAddr(!realstackptr)) ) | codeDecls(BICDeclar{value, addr, ...}) = ( gencde (value, ToStack, NotEnd, loopAddr); Array.update (decVec, addr, StackAddr(!realstackptr)) ) | codeDecls(BICNullBinding exp) = gencde (exp, NoResult, NotEnd, loopAddr) in List.app codeDecls decls; gencde (exp, whereto, tailKind, loopAddr) end | BICBeginLoop {loop=body, arguments} => (* Execute the body which will contain at least one Loop instruction. There will also be path(s) which don't contain Loops and these will drop through. *) let val args = List.map #1 arguments (* Evaluate each of the arguments, pushing the result onto the stack. *) fun genLoopArg ({addr, value, ...}) = ( gencde (value, ToStack, NotEnd, loopAddr); Array.update (decVec, addr, StackAddr (!realstackptr)); !realstackptr (* Return the posn on the stack. *) ) val argIndexList = map genLoopArg args; val startSp = ! realstackptr; (* Remember the current top of stack. *) val startLoop = createLabel () val () = setLabel(startLoop, cvec) (* Start of loop *) in (* Process the body, passing the jump-back address down for the Loop instruction(s). *) gencde (body, whereto, tailKind, SOME(startLoop, startSp, argIndexList)) (* Leave the arguments on the stack. They can be cleared later if needed. *) end | BICLoop argList => (* Jump back to the enclosing BeginLoop. *) let val (startLoop, startSp, argIndexList) = case loopAddr of SOME l => l | NONE => raise InternalError "No BeginLoop for Loop instr" (* Evaluate the arguments. First push them to the stack because evaluating an argument may depend on the current value of others. Only when we've evaluated all of them can we overwrite the original argument positions. *) fun loadArgs ([], []) = !realstackptr - startSp (* The offset of all the args. *) | loadArgs (arg:: argList, _ :: argIndexList) = let (* Evaluate all the arguments. *) val () = gencde (arg, ToStack, NotEnd, NONE); val argOffset = loadArgs(argList, argIndexList); in genSetStackVal(argOffset, cvec); (* Copy the arg over. *) decsp(); (* The argument has now been popped. *) argOffset end | loadArgs _ = raise InternalError "loadArgs: Mismatched arguments"; val _: int = loadArgs(List.map #1 argList, argIndexList) in if !realstackptr <> startSp then resetStack (!realstackptr - startSp, false, cvec) (* Remove any local variables. *) else (); (* Jump back to the start of the loop. *) putBranchInstruction(JumpBack, startLoop, cvec) end | BICRaise exp => ( gencde (exp, ToStack, NotEnd, loopAddr); genRaiseEx cvec ) | BICHandle {exp, handler, exPacketAddr} => let (* Save old handler *) val () = genPushHandler cvec val () = incsp () val handlerLabel = createLabel() val () = putBranchInstruction (SetHandler, handlerLabel, cvec) val () = incsp() (* Code generate the body; "NotEnd" because we have to come back to remove the handler; "ToStack" because delHandler needs a result to carry down. *) val () = gencde (exp, ToStack, NotEnd, loopAddr) (* Now get out of the handler and restore the old one. *) val () = genOpcode(opcode_deleteHandler, cvec) val skipHandler = createLabel() val () = putBranchInstruction (Jump, skipHandler, cvec) (* Now process the handler itself. First we have to reset the stack. Note that we have to use "ToStack" again to be consistent with the stack-handling in the body-part. If we actually wanted "NoResult", the stack adjustment code at the end of gencde will take care of this. This means that I don't want to do any clever "end-of-function" optimisation either. SPF 6/1/97 *) val () = realstackptr := oldsp val () = setLabel (handlerLabel, cvec) (* If we were executing machine code we must re-enter the interpreter. *) val () = genEnterIntCatch cvec (* Push the exception packet and set the address. *) val () = genLdexc cvec val () = incsp () val () = Array.update (decVec, exPacketAddr, StackAddr(!realstackptr)) val () = gencde (handler, ToStack, NotEnd, loopAddr) (* Have to remove the exception packet. *) val () = resetStack(1, true, cvec) val () = decsp() (* Finally fix-up the jump around the handler *) val () = setLabel (skipHandler, cvec) in () end | BICCase ({cases, test, default, firstIndex, ...}) => let val () = gencde (test, ToStack, NotEnd, loopAddr) (* Label to jump to at the end of each case. *) val exitJump = createLabel() val () = if firstIndex = 0w0 then () else ( (* Subtract lower limit. Don't check for overflow. Instead allow large value to wrap around and check in "case" instruction. *) pushConst(toMachineWord firstIndex, cvec); genOpcode(opcode_wordSub, cvec) ) (* Generate the case instruction followed by the table of jumps. *) val nCases = List.length cases val caseLabels = genCase (nCases, cvec) val () = decsp () (* The default case, if any, follows the case statement. *) (* If we have a jump to the default set it to jump here. *) local fun fixDefault(NONE, defCase) = setLabel(defCase, cvec) | fixDefault(SOME _, _) = () in val () = ListPair.appEq fixDefault (cases, caseLabels) end val () = gencde (default, whereto, tailKind, loopAddr); fun genCases(SOME body, label) = ( (* First exit from the previous case or the default if this is the first. *) putBranchInstruction(Jump, exitJump, cvec); (* Remove the result - the last case will leave it. *) case whereto of ToStack => decsp () | NoResult => (); (* Fix up the jump to come here. *) setLabel(label, cvec); gencde (body, whereto, tailKind, loopAddr) ) | genCases(NONE, _) = () val () = ListPair.appEq genCases (cases, caseLabels) (* Finally set the exit jump to come here. *) val () = setLabel (exitJump, cvec) in () end | BICTuple recList => let val size = List.length recList in (* Move the fields into the vector. *) List.app(fn v => gencde (v, ToStack, NotEnd, loopAddr)) recList; genTuple (size, cvec); realstackptr := !realstackptr - (size - 1) end | BICSetContainer{container, tuple, filter} => (* Copy the contents of a tuple into a container. If the tuple is a Tuple instruction we can avoid generating the tuple and then unpacking it and simply copy the fields that make up the tuple directly into the container. *) ( case tuple of BICTuple cl => (* Simply set the container from the values. *) let (* Load the address of the container. *) val _ = gencde (container, ToStack, NotEnd, loopAddr); fun setValues([], _, _) = () | setValues(v::tl, sourceOffset, destOffset) = if sourceOffset < BoolVector.length filter andalso BoolVector.sub(filter, sourceOffset) then ( gencde (v, ToStack, NotEnd, loopAddr); (* Move the entry into the container. This instruction pops the value to be moved but not the destination. *) genMoveToContainer(destOffset, cvec); decsp(); setValues(tl, sourceOffset+1, destOffset+1) ) else setValues(tl, sourceOffset+1, destOffset) in setValues(cl, 0, 0) (* The container address is still on the stack. *) end | _ => let (* General case. *) (* First the target tuple, then the container. *) val () = gencde (tuple, ToStack, NotEnd, loopAddr) val () = gencde (container, ToStack, NotEnd, loopAddr) val last = BoolVector.foldli(fn (i, true, _) => i | (_, false, n) => n) ~1 filter fun copy (sourceOffset, destOffset) = if BoolVector.sub(filter, sourceOffset) then ( (* Duplicate the tuple address . *) genLocal(1, cvec); genIndirect(sourceOffset, cvec); genMoveToContainer(destOffset, cvec); if sourceOffset = last then () else copy (sourceOffset+1, destOffset+1) ) else copy(sourceOffset+1, destOffset) in copy (0, 0) (* The container and tuple addresses are still on the stack. *) end ) | BICTagTest { test, tag, ... } => ( gencde (test, ToStack, NotEnd, loopAddr); genEqualWordConst(tag, cvec) ) | BICNullary {oper=BuiltIns.GetCurrentThreadId} => ( genOpcode(opcode_getThreadId, cvec); incsp() ) | BICNullary {oper=BuiltIns.CheckRTSException} => ( (* Do nothing. This is done in the RTS call. *) ) | BICUnary { oper, arg1 } => let open BuiltIns val () = gencde (arg1, ToStack, NotEnd, loopAddr) in case oper of NotBoolean => genOpcode(opcode_notBoolean, cvec) | IsTaggedValue => genIsTagged cvec | MemoryCellLength => genOpcode(opcode_cellLength, cvec) | MemoryCellFlags => genOpcode(opcode_cellFlags, cvec) | ClearMutableFlag => genOpcode(opcode_clearMutable, cvec) | AtomicIncrement => genOpcode(opcode_atomicIncr, cvec) | AtomicDecrement => genOpcode(opcode_atomicDecr, cvec) | AtomicReset => genOpcode(opcode_atomicReset, cvec) | LongWordToTagged => genOpcode(opcode_longWToTagged, cvec) | SignedToLongWord => genOpcode(opcode_signedToLongW, cvec) | UnsignedToLongWord => genOpcode(opcode_unsignedToLongW, cvec) | RealAbs PrecDouble => genOpcode(opcode_realAbs, cvec) | RealNeg PrecDouble => genOpcode(opcode_realNeg, cvec) | RealFixedInt PrecDouble => genOpcode(opcode_fixedIntToReal, cvec) | RealAbs PrecSingle => genOpcode(opcode_floatAbs, cvec) | RealNeg PrecSingle => genOpcode(opcode_floatNeg, cvec) | RealFixedInt PrecSingle => genOpcode(opcode_fixedIntToFloat, cvec) | FloatToDouble => genOpcode(opcode_floatToReal, cvec) | DoubleToFloat rnding => genDoubleToFloat(rnding, cvec) | RealToInt (PrecDouble, rnding) => genRealToInt(rnding, cvec) | RealToInt (PrecSingle, rnding) => genFloatToInt(rnding, cvec) | TouchAddress => resetStack(1, false, cvec) (* Discard this *) | AllocCStack => genOpcode(opcode_allocCSpace, cvec) end | BICBinary { oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1, arg2=BICConstnt(w, _) } => let val () = gencde (arg1, ToStack, NotEnd, loopAddr) in genEqualWordConst(toShort w, cvec) end | BICBinary { oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1=BICConstnt(w, _), arg2 } => let val () = gencde (arg2, ToStack, NotEnd, loopAddr) in genEqualWordConst(toShort w, cvec) end | BICBinary { oper, arg1, arg2 } => let open BuiltIns val () = gencde (arg1, ToStack, NotEnd, loopAddr) val () = gencde (arg2, ToStack, NotEnd, loopAddr) in case oper of WordComparison{test=TestEqual, ...} => genOpcode(opcode_equalWord, cvec) | WordComparison{test=TestLess, isSigned=true} => genOpcode(opcode_lessSigned, cvec) | WordComparison{test=TestLessEqual, isSigned=true} => genOpcode(opcode_lessEqSigned, cvec) | WordComparison{test=TestGreater, isSigned=true} => genOpcode(opcode_greaterSigned, cvec) | WordComparison{test=TestGreaterEqual, isSigned=true} => genOpcode(opcode_greaterEqSigned, cvec) | WordComparison{test=TestLess, isSigned=false} => genOpcode(opcode_lessUnsigned, cvec) | WordComparison{test=TestLessEqual, isSigned=false} => genOpcode(opcode_lessEqUnsigned, cvec) | WordComparison{test=TestGreater, isSigned=false} => genOpcode(opcode_greaterUnsigned, cvec) | WordComparison{test=TestGreaterEqual, isSigned=false} => genOpcode(opcode_greaterEqUnsigned, cvec) | WordComparison{test=TestUnordered, ...} => raise InternalError "WordComparison: TestUnordered" | PointerEq => genOpcode(opcode_equalWord, cvec) | FixedPrecisionArith ArithAdd => genOpcode(opcode_fixedAdd, cvec) | FixedPrecisionArith ArithSub => genOpcode(opcode_fixedSub, cvec) | FixedPrecisionArith ArithMult => genOpcode(opcode_fixedMult, cvec) | FixedPrecisionArith ArithQuot => genOpcode(opcode_fixedQuot, cvec) | FixedPrecisionArith ArithRem => genOpcode(opcode_fixedRem, cvec) | FixedPrecisionArith ArithDiv => raise InternalError "TODO: FixedPrecisionArith ArithDiv" | FixedPrecisionArith ArithMod => raise InternalError "TODO: FixedPrecisionArith ArithMod" | WordArith ArithAdd => genOpcode(opcode_wordAdd, cvec) | WordArith ArithSub => genOpcode(opcode_wordSub, cvec) | WordArith ArithMult => genOpcode(opcode_wordMult, cvec) | WordArith ArithDiv => genOpcode(opcode_wordDiv, cvec) | WordArith ArithMod => genOpcode(opcode_wordMod, cvec) | WordArith _ => raise InternalError "WordArith - unimplemented instruction" | WordLogical LogicalAnd => genOpcode(opcode_wordAnd, cvec) | WordLogical LogicalOr => genOpcode(opcode_wordOr, cvec) | WordLogical LogicalXor => genOpcode(opcode_wordXor, cvec) | WordShift ShiftLeft => genOpcode(opcode_wordShiftLeft, cvec) | WordShift ShiftRightLogical => genOpcode(opcode_wordShiftRLog, cvec) | WordShift ShiftRightArithmetic => genOpcode(opcode_wordShiftRArith, cvec) | AllocateByteMemory => genOpcode(opcode_allocByteMem, cvec) | LargeWordComparison TestEqual => genOpcode(opcode_lgWordEqual, cvec) | LargeWordComparison TestLess => genOpcode(opcode_lgWordLess, cvec) | LargeWordComparison TestLessEqual => genOpcode(opcode_lgWordLessEq, cvec) | LargeWordComparison TestGreater => genOpcode(opcode_lgWordGreater, cvec) | LargeWordComparison TestGreaterEqual => genOpcode(opcode_lgWordGreaterEq, cvec) | LargeWordComparison TestUnordered => raise InternalError "LargeWordComparison: TestUnordered" | LargeWordArith ArithAdd => genOpcode(opcode_lgWordAdd, cvec) | LargeWordArith ArithSub => genOpcode(opcode_lgWordSub, cvec) | LargeWordArith ArithMult => genOpcode(opcode_lgWordMult, cvec) | LargeWordArith ArithDiv => genOpcode(opcode_lgWordDiv, cvec) | LargeWordArith ArithMod => genOpcode(opcode_lgWordMod, cvec) | LargeWordArith _ => raise InternalError "LargeWordArith - unimplemented instruction" | LargeWordLogical LogicalAnd => genOpcode(opcode_lgWordAnd, cvec) | LargeWordLogical LogicalOr => genOpcode(opcode_lgWordOr, cvec) | LargeWordLogical LogicalXor => genOpcode(opcode_lgWordXor, cvec) | LargeWordShift ShiftLeft => genOpcode(opcode_lgWordShiftLeft, cvec) | LargeWordShift ShiftRightLogical => genOpcode(opcode_lgWordShiftRLog, cvec) | LargeWordShift ShiftRightArithmetic => genOpcode(opcode_lgWordShiftRArith, cvec) | RealComparison (TestEqual, PrecDouble) => genOpcode(opcode_realEqual, cvec) | RealComparison (TestLess, PrecDouble) => genOpcode(opcode_realLess, cvec) | RealComparison (TestLessEqual, PrecDouble) => genOpcode(opcode_realLessEq, cvec) | RealComparison (TestGreater, PrecDouble) => genOpcode(opcode_realGreater, cvec) | RealComparison (TestGreaterEqual, PrecDouble) => genOpcode(opcode_realGreaterEq, cvec) | RealComparison (TestUnordered, PrecDouble) => genOpcode(opcode_realUnordered, cvec) | RealComparison (TestEqual, PrecSingle) => genOpcode(opcode_floatEqual, cvec) | RealComparison (TestLess, PrecSingle) => genOpcode(opcode_floatLess, cvec) | RealComparison (TestLessEqual, PrecSingle) => genOpcode(opcode_floatLessEq, cvec) | RealComparison (TestGreater, PrecSingle) => genOpcode(opcode_floatGreater, cvec) | RealComparison (TestGreaterEqual, PrecSingle) => genOpcode(opcode_floatGreaterEq, cvec) | RealComparison (TestUnordered, PrecSingle) => genOpcode(opcode_floatUnordered, cvec) | RealArith (ArithAdd, PrecDouble) => genOpcode(opcode_realAdd, cvec) | RealArith (ArithSub, PrecDouble) => genOpcode(opcode_realSub, cvec) | RealArith (ArithMult, PrecDouble) => genOpcode(opcode_realMult, cvec) | RealArith (ArithDiv, PrecDouble) => genOpcode(opcode_realDiv, cvec) | RealArith (ArithAdd, PrecSingle) => genOpcode(opcode_floatAdd, cvec) | RealArith (ArithSub, PrecSingle) => genOpcode(opcode_floatSub, cvec) | RealArith (ArithMult, PrecSingle) => genOpcode(opcode_floatMult, cvec) | RealArith (ArithDiv, PrecSingle) => genOpcode(opcode_floatDiv, cvec) | RealArith _ => raise InternalError "RealArith - unimplemented instruction" | FreeCStack => genOpcode(opcode_freeCSpace, cvec) ; decsp() (* Removes one item from the stack. *) end | BICAllocateWordMemory {numWords as BICConstnt(length, _), flags as BICConstnt(flagByte, _), initial } => if isShort length andalso toShort length = 0w1 andalso isShort flagByte andalso toShort flagByte = 0wx40 then (* This is a very common case. *) ( gencde (initial, ToStack, NotEnd, loopAddr); genOpcode(opcode_alloc_ref, cvec) ) else let val () = gencde (numWords, ToStack, NotEnd, loopAddr) val () = gencde (flags, ToStack, NotEnd, loopAddr) val () = gencde (initial, ToStack, NotEnd, loopAddr) in genOpcode(opcode_allocWordMemory, cvec); decsp(); decsp() end | BICAllocateWordMemory { numWords, flags, initial } => let val () = gencde (numWords, ToStack, NotEnd, loopAddr) val () = gencde (flags, ToStack, NotEnd, loopAddr) val () = gencde (initial, ToStack, NotEnd, loopAddr) in genOpcode(opcode_allocWordMemory, cvec); decsp(); decsp() end | BICLoadOperation { kind=LoadStoreMLWord _, address={base, index=NONE, offset}} => ( (* If the index is a constant, frequently zero, we can use indirection. The offset is a byte count so has to be divided by the word size but it should always be an exact multiple. *) gencde (base, ToStack, NotEnd, loopAddr); offset mod Word.toInt wordSize = 0 orelse raise InternalError "gencde: BICLoadOperation - not word multiple"; genIndirect (offset div Word.toInt wordSize, cvec) ) | BICLoadOperation { kind=LoadStoreMLWord _, address} => ( genMLAddress(address, Word.toInt wordSize); genOpcode(opcode_loadMLWord, cvec); decsp() ) | BICLoadOperation { kind=LoadStoreMLByte _, address} => ( genMLAddress(address, 1); genOpcode(opcode_loadMLByte, cvec); decsp() ) | BICLoadOperation { kind=LoadStoreC8, address} => ( genCAddress address; genOpcode(opcode_loadC8, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC16, address} => ( genCAddress address; genOpcode(opcode_loadC16, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC32, address} => ( genCAddress address; genOpcode(opcode_loadC32, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC64, address} => ( genCAddress address; genOpcode(opcode_loadC64, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreCFloat, address} => ( genCAddress address; genOpcode(opcode_loadCFloat, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreCDouble, address} => ( genCAddress address; genOpcode(opcode_loadCDouble, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreUntaggedUnsigned, address} => ( genMLAddress(address, Word.toInt wordSize); genOpcode(opcode_loadUntagged, cvec); decsp() ) | BICStoreOperation { kind=LoadStoreMLWord _, address, value } => ( genMLAddress(address, Word.toInt wordSize); gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeMLWord, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreMLByte _, address, value } => ( genMLAddress(address, 1); gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeMLByte, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC8, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC8, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC16, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC16, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC32, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC32, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC64, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC64, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreCFloat, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeCFloat, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreCDouble, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeCDouble, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreUntaggedUnsigned, address, value} => ( genMLAddress(address, Word.toInt wordSize); gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeUntagged, cvec); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpMove{isByteMove=true}, sourceLeft, destRight, length } => ( genMLAddress(sourceLeft, 1); genMLAddress(destRight, 1); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockMoveByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpMove{isByteMove=false}, sourceLeft, destRight, length } => ( genMLAddress(sourceLeft, Word.toInt wordSize); genMLAddress(destRight, Word.toInt wordSize); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockMoveWord, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpEqualByte, sourceLeft, destRight, length } => ( genMLAddress(sourceLeft, 1); genMLAddress(destRight, 1); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockEqualByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpCompareByte, sourceLeft, destRight, length } => ( genMLAddress(sourceLeft, 1); genMLAddress(destRight, 1); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockCompareByte, cvec); decsp(); decsp(); decsp(); decsp() ) - | BICArbitrary { longCall, ... } => - (* Just use the long-precision case in the interpreted version. *) - ( - gencde (longCall, whereto, tailKind, loopAddr) - ) + | BICArbitrary { oper, arg1, arg2, ... } => + let + open BuiltIns + val () = gencde (arg1, ToStack, NotEnd, loopAddr) + val () = gencde (arg2, ToStack, NotEnd, loopAddr) + in + case oper of + ArithAdd => genOpcode(opcode_arbAdd, cvec) + | ArithSub => genOpcode(opcode_arbSubtract, cvec) + | ArithMult => genOpcode(opcode_arbMultiply, cvec) + | _ => raise InternalError "Unknown arbitrary precision operation"; + decsp() (* Removes one item from the stack. *) + end in (* body of gencde *) (* This ensures that there is precisely one item on the stack if whereto = ToStack and no items if whereto = NoResult. There are two points to note carefully here: (1) Negative stack adjustments are legal if we have exited. This is because matchFailFn can cut the stack back too far for its immediately enclosing expression. This is harmless because the code actually exits that expression. (2) A stack adjustment of ~1 is legal if we're generating a declaration in "ToStack" mode, because not all declarations actually generate the dummy value that we expect. This used to be handled in resetStack itself, but it's more transparent to do it here. (In addition, there was a bug in resetStack - it accumulated the stack resets, but didn't correctly accumulate these "~1" dummy value pushes.) It's all much better now. SPF 9/1/97 *) case whereto of ToStack => let val newsp = oldsp + 1; val adjustment = !realstackptr - newsp val () = if adjustment = 0 then () else if adjustment < ~1 then raise InternalError ("gencde: bad adjustment " ^ Int.toString adjustment) (* Hack for declarations that should push values, but don't *) else if adjustment = ~1 then pushConst (DummyValue, cvec) else resetStack (adjustment, true, cvec) in realstackptr := newsp end | NoResult => let val adjustment = !realstackptr - oldsp val () = if adjustment = 0 then () else if adjustment < 0 then raise InternalError ("gencde: bad adjustment " ^ Int.toString adjustment) else resetStack (adjustment, false, cvec) in realstackptr := oldsp end end (* gencde *) (* doNext is only used for mutually recursive functions where a function may not be able to fill in its closure if it does not have all the remaining declarations. *) (* TODO: This always creates the closure on the heap even when makeClosure is false. *) and genProc ({ closure=[], localCount, body, argTypes, name, ...}: bicLambdaForm, mutualDecs, doNext: unit -> unit) : unit = let (* Create a one word item for the closure. This is returned for recursive references and filled in with the address of the code when we've finished. *) val closure = makeConstantClosure() val newCode : code = codeCreate(name, parameters); (* Code-gen function. No non-local references. *) val () = codegen (body, newCode, closure, List.length argTypes, localCount, parameters); val () = pushConst(closureAsAddress closure, cvec); val () = incsp(); in if mutualDecs then doNext () else () end | genProc ({ localCount, body, name, argTypes, closure, ...}, mutualDecs, doNext) = let (* Full closure required. *) val resClosure = makeConstantClosure() val newCode = codeCreate (name, parameters) (* Code-gen function. *) val () = codegen (body, newCode, resClosure, List.length argTypes, localCount, parameters) val closureVars = List.length closure (* Size excluding the code address *) in if mutualDecs then let (* Have to make the closure now and fill it in later. *) val () = pushConst(toMachineWord resClosure, cvec) val () = genAllocMutableClosure(closureVars, cvec) val () = incsp () val entryAddr : int = !realstackptr val () = doNext () (* Any mutually recursive functions. *) (* Push the address of the vector - If we have processed other closures the vector will no longer be on the top of the stack. *) val () = pushLocalStackValue (~ entryAddr) (* Load items for the closure. *) fun loadItems ([], _) = () | loadItems (v :: vs, addr : int) = let (* Generate an item and move it into the clsoure *) val () = gencde (BICExtract v, ToStack, NotEnd, NONE) (* The closure "address" excludes the code address. *) val () = genMoveToMutClosure(addr, cvec) val () = decsp () in loadItems (vs, addr + 1) end val () = loadItems (closure, 0) val () = genLock cvec (* Lock it. *) (* Remove the extra reference. *) val () = resetStack (1, false, cvec) in realstackptr := !realstackptr - 1 end else let (* Put it on the stack. *) val () = pushConst (toMachineWord resClosure, cvec) val () = incsp () val () = List.app (fn pt => gencde (BICExtract pt, ToStack, NotEnd, NONE)) closure val () = genClosure (closureVars, cvec) in realstackptr := !realstackptr - closureVars end end and genCond (testCode, thenCode, elseCode, whereto, tailKind, loopAddr) = let (* andalso and orelse are turned into conditionals with constants. Convert this into a series of tests. *) fun genTest(BICConstnt(w, _), jumpOn, targetLabel) = let val cVal = case toShort w of 0w0 => false | 0w1 => true | _ => raise InternalError "genTest" in if cVal = jumpOn then putBranchInstruction (Jump, targetLabel, cvec) else () end | genTest(BICUnary { oper=BuiltIns.NotBoolean, arg1 }, jumpOn, targetLabel) = genTest(arg1, not jumpOn, targetLabel) | genTest(BICCond (testPart, thenPart, elsePart), jumpOn, targetLabel) = let val toElse = createLabel() and exitJump = createLabel() in genTest(testPart, false, toElse); genTest(thenPart, jumpOn, targetLabel); putBranchInstruction (Jump, exitJump, cvec); setLabel (toElse, cvec); genTest(elsePart, jumpOn, targetLabel); setLabel (exitJump, cvec) end | genTest(testCode, jumpOn, targetLabel) = ( gencde (testCode, ToStack, NotEnd, loopAddr); putBranchInstruction(if jumpOn then JumpTrue else JumpFalse, targetLabel, cvec); decsp() (* conditional branch pops a value. *) ) val toElse = createLabel() and exitJump = createLabel() val () = genTest(testCode, false, toElse) val () = gencde (thenCode, whereto, tailKind, loopAddr) (* Get rid of the result from the stack. If there is a result then the ``else-part'' will push it. *) val () = case whereto of ToStack => decsp () | NoResult => () val () = putBranchInstruction (Jump, exitJump, cvec) (* start of "else part" *) val () = setLabel (toElse, cvec) val () = gencde (elseCode, whereto, tailKind, loopAddr) val () = setLabel (exitJump, cvec) in () end (* genCond *) and genEval (eval, tailKind : tail) : unit = let val argList : backendIC list = List.map #1 (#argList eval) val argsToPass : int = List.length argList; (* Load arguments *) fun loadArgs [] = () | loadArgs (v :: vs) = let (* Push each expression onto the stack. *) val () = gencde(v, ToStack, NotEnd, NONE) in loadArgs vs end; (* Called after the args and the closure to call have been pushed onto the stack. *) fun callClosure () : unit = case tailKind of NotEnd => (* Normal call. *) genCallClosure cvec | EndOfProc => (* Tail recursive call. *) let (* Get the return address onto the top of the stack. *) val () = pushLocalStackValue 0 (* Slide the return address, closure and args over the old closure, return address and args, and reset the stack. Then jump to the closure. *) val () = genTailCall(argsToPass + 2, !realstackptr - 1 + (numOfArgs - argsToPass), cvec); (* It's "-1" not "-2", because we didn't bump the realstackptr when we pushed the return address. SPF 3/1/97 *) in () end (* Have to guarantee that the expression to return the function is evaluated before the arguments. *) (* Returns true if evaluating it later is safe. *) fun safeToLeave (BICConstnt _) = true | safeToLeave (BICLambda _) = true | safeToLeave (BICExtract _) = true | safeToLeave (BICField {base, ...}) = safeToLeave base | safeToLeave (BICLoadContainer {base, ...}) = safeToLeave base | safeToLeave _ = false val () = if (case argList of [] => true | _ => safeToLeave (#function eval)) then let (* Can load the args first. *) val () = loadArgs argList in gencde (#function eval, ToStack, NotEnd, NONE) end else let (* The expression for the function is too complicated to risk leaving. It might have a side-effect and we must ensure that any side-effects it has are done before the arguments are loaded. *) val () = gencde(#function eval, ToStack, NotEnd, NONE); val () = loadArgs(argList); (* Load the function again. *) val () = genLocal(argsToPass, cvec); in incsp () end val () = callClosure () (* Call the function. *) (* Make sure we interpret when we return from the call *) val () = genEnterIntCall (cvec, argsToPass) in (* body of genEval *) realstackptr := !realstackptr - argsToPass (* Args popped by caller. *) end (* Generate the function. *) (* Assume we always want a result. There is otherwise a problem if the called routine returns a result of type void (i.e. no result) but the caller wants a result (e.g. the identity function). *) val () = gencde (pt, ToStack, EndOfProc, NONE) val () = genReturn (numOfArgs, cvec); in (* body of codegen *) (* Having code-generated the body of the function, it is copied into a new data segment. *) copyCode{code = cvec, maxStack = !maxStack, resultClosure=resultClosure, numberOfArguments=numOfArgs} end (* codegen *); fun gencodeLambda({ name, body, argTypes, localCount, ...}:bicLambdaForm, parameters, closure) = let (* make the code buffer for the new function. *) val newCode : code = codeCreate (name, parameters) (* This function must have no non-local references. *) in codegen (body, newCode, closure, List.length argTypes, localCount, parameters) end local val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" fun rtsCall makeCall (entryName: string, numOfArgs, debugArgs: Universal.universal list): machineWord = let open Address val cvec = codeCreate (entryName, debugArgs) val entryPointAddr = makeEntryPoint entryName (* Each argument is at the same offset, essentially we're just shifting them *) fun genLocals 0 = () | genLocals n = (genLocal(numOfArgs +1, cvec); genLocals (n-1)) val () = genLocals numOfArgs val () = pushConst(entryPointAddr, cvec) val () = makeCall(numOfArgs, cvec) val () = genReturn (numOfArgs, cvec) val closure = makeConstantClosure() val () = copyCode{code=cvec, maxStack=numOfArgs+1, numberOfArguments=numOfArgs, resultClosure=closure} in closureAsAddress closure end in structure Foreign = struct val rtsCallFast = rtsCall genRTSCallFast fun rtsCallFastRealtoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealtoReal c) (entryName, 1, debugArgs) and rtsCallFastRealRealtoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealRealtoReal c) (entryName, 2, debugArgs) and rtsCallFastGeneraltoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastGeneraltoReal c) (entryName, 1, debugArgs) and rtsCallFastRealGeneraltoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealGeneraltoReal c) (entryName, 2, debugArgs) fun rtsCallFastFloattoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloattoFloat c) (entryName, 1, debugArgs) and rtsCallFastFloatFloattoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloatFloattoFloat c) (entryName, 2, debugArgs) and rtsCallFastGeneraltoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastGeneraltoFloat c) (entryName, 1, debugArgs) and rtsCallFastFloatGeneraltoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloatGeneraltoFloat c) (entryName, 2, debugArgs) type abi = int (* This must match the type in Foreign.LowLevel. Once this is bootstrapped we could use that type but note that this is the type we use within the compiler and we build Foreign.LowLevel AFTER compiling this. *) datatype cTypeForm = CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } val abiList: unit -> (string * abi) list = RunCall.rtsCallFull0 "PolyInterpretedGetAbiList" type cif = Foreign.Memory.voidStar val createCIF: abi * cType * cType list -> cif= RunCall.rtsCallFull3 "PolyInterpretedCreateCIF" val callCFunction: cif * LargeWord.word * LargeWord.word * LargeWord.word -> unit = RunCall.rtsCallFull4 "PolyInterpretedCallFunction" (* foreignCall returns a function that actually calls the foreign function. *) fun foreignCall(abi, argTypes, resultType) = let val memocif = Foreign.Memory.memoise (fn () => createCIF(abi, resultType, argTypes)) () val closure = makeConstantClosure() (* For compatibility with the native code version we have to construct a function that takes three arguments rather than a single triple. *) val bodyCode = BICEval{function=BICConstnt(toMachineWord callCFunction, []), argList=[ (BICTuple[ BICEval{ function=BICConstnt(toMachineWord memocif, []), argList=[(BICConstnt(toMachineWord 0, []), GeneralType)], (* Unit. *) resultType=GeneralType }, BICExtract(BICLoadArgument 0), BICExtract(BICLoadArgument 2), BICExtract(BICLoadArgument 1)], GeneralType) ], resultType=GeneralType} val lambdaCode = { body = bodyCode, name = "foreignCall", closure=[], argTypes=[GeneralType, GeneralType, GeneralType], resultType = GeneralType, localCount=0, heapClosure=false} val () = gencodeLambda(lambdaCode, [], closure) in closureAsAddress closure end fun buildCallBack((*abi*) _, (*argTypes*) _, (*resultType*)_) = let fun buildClosure ((*mlFun*)_: LargeWord.word*LargeWord.word -> unit) = (* The result is the SysWord.word holding the C function. *) raise Foreign.Foreign "foreignCall not implemented" in Address.toMachineWord buildClosure end end end structure Sharing = struct open BACKENDTREE.Sharing type closureRef = closureRef end end;