diff --git a/libpolyml/arb.cpp b/libpolyml/arb.cpp index 0e5ddba3..0253927c 100644 --- a/libpolyml/arb.cpp +++ b/libpolyml/arb.cpp @@ -1,2031 +1,2032 @@ /* 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); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyAddArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySubtractArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyMultiplyArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyDivideArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRemainderArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2, POLYUNSIGNED arg3); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitraryPair(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYSIGNED PolyCompareArbitrary(POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGCDArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLCMArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLowOrderAsLargeWord(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyOrArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyAndArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXorArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2); } 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) +POLYUNSIGNED PolyAddArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolySubtractArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolyMultiplyArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolyDivideArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolyRemainderArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolyQuotRemArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2, POLYUNSIGNED 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()); + PolyWord::FromUnsigned(arg3).AsObjPtr()->Set(0, divHandle->Word()); + PolyWord::FromUnsigned(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) +POLYUNSIGNED PolyQuotRemArbitraryPair(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYSIGNED PolyCompareArbitrary(POLYUNSIGNED arg1, POLYUNSIGNED arg2) { - return TAGGED(compareLong(arg2, arg1)).AsSigned(); + return TAGGED(compareLong(PolyWord::FromUnsigned(arg2), PolyWord::FromUnsigned(arg1))).AsSigned(); } -POLYUNSIGNED PolyGCDArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyGCDArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolyLCMArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolyGetLowOrderAsLargeWord(POLYUNSIGNED threadId, POLYUNSIGNED argU) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); uintptr_t p = 0; + PolyWord arg = PolyWord::FromUnsigned(argU); 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) +POLYUNSIGNED PolyOrArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolyAndArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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) +POLYUNSIGNED PolyXorArbitrary(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED 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/arm64.cpp b/libpolyml/arm64.cpp index c2fb3666..abcc9bc2 100644 --- a/libpolyml/arm64.cpp +++ b/libpolyml/arm64.cpp @@ -1,1049 +1,1049 @@ /* Machine-dependent code for ARM64 Copyright David C.J. Matthews 2020-21. 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 */ // Currently this is just copied from the interpreted version. #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #include "globals.h" #include "machine_dep.h" #include "sys.h" #include "profiling.h" #include "arb.h" #include "processes.h" #include "run_time.h" #include "gc.h" #include "diagnostics.h" #include "polystring.h" #include "save_vec.h" #include "memmgr.h" #include "scanaddrs.h" #include "rtsentry.h" #include "bytecode.h" #include "int_opcodes.h" /* * ARM64 register use: * X0 First argument and return value * X1-X7 Second-eighth argument * X8 Indirect result (C), ML closure pointer on entry * X9-X15 Volatile scratch registers * X16-17 Intra-procedure-call (C). Only used for special cases in ML. * X18 Platform register. Not used in ML. * X19-X23 Non-volatile (C). Scratch registers (ML). * X24 Non-volatile (C). Scratch register (ML). Heap base in 32-in-64. * X25 ML Heap limit pointer * X26 ML assembly interface pointer. Non-volatile (C). * X27 ML Heap allocation pointer. Non-volatile (C). * X28 ML Stack pointer. Non-volatile (C). * X29 Frame pointer (C). Not used in ML * X30 Link register. * X31 Stack pointer (C). Only used when calling C. Also zero register. * * Floating point registers: * V0 First argument and return value * V1-V7 Second-eighth argument * V8-V15 Non volatile. Not currently used in ML. * V16-V31 Volatile. Not currently used in ML. * * The ML calling conventions generally follow the C ABI except that * all registers are volatile and X28 is used for the stack. */ /* the amount of ML stack space to reserve for registers, C exception handling etc. The compiler requires us to reserve 2 stack-frames worth (2 * 20 words). We actually reserve slightly more than this. */ // Arm64 instructions are all 32-bit values. typedef uint32_t arm64Instr, *arm64CodePointer; // Each function checks for space on the stack at the start. To reduce the // code size it assumes there are at least 10 words on the stack and only // checks the exact space if it requires more than that. For safety we // always make sure there are 50 words spare. #define OVERFLOW_STACK_SIZE 50 // X26 always points at this area when executing ML code. // The offsets are built into the assembly code and some are built into // the code generator so this must not be changed without checking these. typedef struct _AssemblyArgs { public: byte* enterInterpreter; // These are filled in with the functions. byte* heapOverFlowCall; byte* stackOverFlowCall; byte* stackOverFlowCallEx; byte* trapHandlerEntry; stackItem* handlerRegister; // Current exception handler stackItem* stackLimit; // Lower limit of stack stackItem exceptionPacket; // Set if there is an exception stackItem threadId; // My thread id. Saves having to call into RTS for it. (stackItem so it's 64-bits) stackItem registers[25]; // Save/load area for registers X0-X24 inclusive double fpRegisters[8]; // Save/load area for floating point regs D0-D7 PolyWord* localMbottom; // Base of memory + 1 word PolyWord* localMpointer; // X27 Allocation ptr + 1 word stackItem* stackPtr; // X28 Current stack pointer arm64CodePointer linkRegister; // X30 - Link register (return address) arm64CodePointer entryPoint; // PC address to return to byte returnReason; // Reason for returning from ML - Set by assembly code. } AssemblyArgs; class Arm64TaskData: public TaskData, ByteCodeInterpreter { public: Arm64TaskData(); ~Arm64TaskData() {} unsigned allocReg; // The register to take the allocated space. POLYUNSIGNED allocWords; // The words to allocate. AssemblyArgs assemblyInterface; uint32_t saveRegisterMask; // Registers that need to be updated by a GC. virtual void GarbageCollect(ScanAddress *process); void ScanStackAddress(ScanAddress *process, stackItem& val, StackSpace *stack); virtual void EnterPolyCode(); // Start running ML virtual void SetException(poly_exn *exc) { assemblyInterface.exceptionPacket = (PolyWord)exc; } virtual void InterruptCode(); // AddTimeProfileCount is used in time profiling. virtual bool AddTimeProfileCount(SIGNALCONTEXT *context); virtual void InitStackFrame(TaskData *newTask, Handle proc); // Atomically release a mutex using hardware interlock. virtual bool AtomicallyReleaseMutex(PolyObject* mutexp); // Return the minimum space occupied by the stack. Used when setting a limit. // N.B. This is PolyWords not native words. virtual uintptr_t currentStackSpace(void) const { return (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE; } virtual void addProfileCount(POLYUNSIGNED words) { addSynchronousCount(interpreterPc, words); } // PreRTSCall: After calling from ML to the RTS we need to save the current heap pointer virtual void PreRTSCall(void) { TaskData::PreRTSCall(); SaveMemRegisters(); } // PostRTSCall: Before returning we need to restore the heap pointer. // If there has been a GC in the RTS call we need to create a new heap area. virtual void PostRTSCall(void) { SetMemRegisters(); TaskData::PostRTSCall(); } virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length); void SetMemRegisters(); void SaveMemRegisters(); void HandleTrap(); // ByteCode overrides. The interpreter and native code states need to be in sync. // The interpreter is only used during the initial bootstrap. virtual void ClearExceptionPacket() { assemblyInterface.exceptionPacket = TAGGED(0); } virtual PolyWord GetExceptionPacket() { return assemblyInterface.exceptionPacket; } virtual stackItem* GetHandlerRegister() { return assemblyInterface.handlerRegister; } virtual void SetHandlerRegister(stackItem* hr) { assemblyInterface.handlerRegister = hr; } void Interpret(); void EndBootStrap() { mixedCode = true; } PLock interruptLock; virtual void HandleStackOverflow(uintptr_t space); }; class Arm64Dependent : public MachineDependent { public: Arm64Dependent() : mustInterpret(false) {} // Create a task data object. virtual TaskData* CreateTaskData(void) { return new Arm64TaskData(); } virtual void ScanConstantsWithinCode(PolyObject* addr, PolyObject* oldAddr, POLYUNSIGNED length, PolyWord* newConstAddr, PolyWord* oldConstAddr, POLYUNSIGNED numConsts, ScanAddress* process); virtual Architectures MachineArchitecture(void); virtual void SetBootArchitecture(char arch, unsigned wordLength); // The ARM has separate instruction and data caches. virtual void FlushInstructionCache(void* p, POLYUNSIGNED bytes); // During the first bootstrap phase this is interpreted. bool mustInterpret; #if defined(POLYML32IN64) virtual void UpdateGlobalHeapReference(PolyObject* addr); #else // Address of the constant segment from the code segment. This is complicated because // some OSs require the code to position-independent which means the code can only // contain relative offsets. This isn't a problem for 32-in-64 because the code is // copied before it is executed. // Set the address of the constant area. If this is within the code segment itself we use the // default, negative, byte offset. If the constant area has been split off we use a pair of // dummy ADRP/LDR instructions. They aren't ever executed but allow us to use relative addressing. virtual void SetAddressOfConstants(PolyObject* objAddr, PolyObject* writable, POLYUNSIGNED length, PolyWord* constAddr) { if (constAddr > (PolyWord*)objAddr && constAddr < (PolyWord*)objAddr + length) { int64_t offset = (byte*)constAddr - (byte*)objAddr - length * sizeof(PolyWord); writable->Set(length - 1, PolyWord::FromSigned(offset)); } else { PolyWord* last_word = objAddr->Offset(length - 1); // Last word in the code MemSpace* space = gMem.SpaceForAddress(last_word); uint32_t* pt = (uint32_t*)space->writeAble(last_word); pt[0] = toARMInstr(0x90000000); // Insert dummy ADRP and LDR pt[1] = toARMInstr(0xf9400000); ScanAddress::SetConstantValue((byte*)last_word, (PolyObject*)constAddr, PROCESS_RELOC_ARM64ADRPLDR); } } virtual void GetConstSegmentForCode(PolyObject* obj, POLYUNSIGNED obj_length, PolyWord*& cp, POLYUNSIGNED& count) const { PolyWord* last_word = obj->Offset(obj_length - 1); // Last word in the code if ((last_word[0].AsUnsigned() >> 56) == 0xff) { // If the high-order byte is 0xff it's a (-ve) byte offset. POLYSIGNED offset = last_word->AsSigned(); cp = last_word + 1 + offset / sizeof(PolyWord); count = cp[-1].AsUnsigned(); } else { PolyObject* addr = ScanAddress::GetConstantValue((byte*)last_word, PROCESS_RELOC_ARM64ADRPLDR, 0); cp = (PolyWord*)addr; count = addr->Length(); } } #endif }; static Arm64Dependent arm64Dependent; MachineDependent* machineDependent = &arm64Dependent; Architectures Arm64Dependent::MachineArchitecture(void) { // During the first phase of the bootstrap we // compile the interpreted version. if (mustInterpret) return MA_Interpreted; #if defined(POLYML32IN64) return MA_Arm64_32; #else return MA_Arm64; #endif } // Values for the returnReason byte. These values are put into returnReason by the assembly code // depending on which of the "trap" functions has been called. enum RETURN_REASON { RETURN_HEAP_OVERFLOW = 1, // Heap space check has failed. RETURN_STACK_OVERFLOW = 2, // Stack space check has failed (<= 10 words). RETURN_STACK_OVERFLOWEX = 3, // Stack space check has failed. Adjusted SP is in X9. RETURN_ENTER_INTERPRETER = 4 // Native code has entered interpreted code. }; extern "C" { // These are declared in the assembly code segment. void Arm64AsmEnterCompiledCode(void*); int Arm64AsmCallExtraRETURN_ENTER_INTERPRETER(void); int Arm64AsmCallExtraRETURN_HEAP_OVERFLOW(void); int Arm64AsmCallExtraRETURN_STACK_OVERFLOW(void); int Arm64AsmCallExtraRETURN_STACK_OVERFLOWEX(void); // This is declared here and called from the assembly code. // It avoids having a call to an external in the assembly code // which sometimes gives problems with position-indepent code. void Arm64TrapHandler(PolyWord threadId); }; Arm64TaskData::Arm64TaskData() : ByteCodeInterpreter(&assemblyInterface.stackPtr, &assemblyInterface.stackLimit), allocReg(0), allocWords(0), saveRegisterMask(0) { assemblyInterface.enterInterpreter = (byte*)Arm64AsmCallExtraRETURN_ENTER_INTERPRETER; assemblyInterface.heapOverFlowCall = (byte*)Arm64AsmCallExtraRETURN_HEAP_OVERFLOW; assemblyInterface.stackOverFlowCall = (byte*)Arm64AsmCallExtraRETURN_STACK_OVERFLOW; assemblyInterface.stackOverFlowCallEx = (byte*)Arm64AsmCallExtraRETURN_STACK_OVERFLOWEX; assemblyInterface.trapHandlerEntry = (byte*)Arm64TrapHandler; interpreterPc = 0; mixedCode = !arm64Dependent.mustInterpret; } void Arm64Dependent::SetBootArchitecture(char arch, unsigned wordLength) { if (arch == 'I') mustInterpret = true; else if (arch != 'A') Crash("Boot file has unexpected architecture code: %c", arch); } // The ARM has separate instruction and data caches so we must flush // the cache when creating or modifying code. void Arm64Dependent::FlushInstructionCache(void* p, POLYUNSIGNED bytes) { #ifdef _WIN32 ::FlushInstructionCache(GetCurrentProcess(), p, bytes); #elif defined (__GNUC__) __builtin___clear_cache((char*)p, (char*)p + bytes); #elif (defined (__clang__) && defined (__APPLE__)) sys_icache_invalidate(p, bytes); #else #error "No code to flush the instruction cache." #endif } void Arm64TaskData::GarbageCollect(ScanAddress *process) { TaskData::GarbageCollect(process); ByteCodeInterpreter::GarbageCollect(process); assemblyInterface.threadId = stackItem(threadObject); // threadObject updated by TaskData::GarbageCollect if (assemblyInterface.exceptionPacket.w().IsDataPtr()) { PolyObject* obj = assemblyInterface.exceptionPacket.w().AsObjPtr(); obj = process->ScanObjectAddress(obj); assemblyInterface.exceptionPacket = (PolyWord)obj; } if (stack != 0) { stackItem*stackPtr = assemblyInterface.stackPtr; // Now the values on the stack. for (stackItem* q = stackPtr; q < (stackItem*)stack->top; q++) ScanStackAddress(process, *q, stack); } // Register mask. There is a bit for each of the registers up to X24. for (int i = 0; i < 25; i++) { if (saveRegisterMask & (1 << i)) ScanStackAddress(process, assemblyInterface.registers[i], stack); } // Make sure the code is still reachable. Code addresses aren't updated. { stackItem code; code.codeAddr = (POLYCODEPTR)assemblyInterface.linkRegister; ScanStackAddress(process, code, stack); code.codeAddr = (POLYCODEPTR)assemblyInterface.entryPoint; ScanStackAddress(process, code, stack); } } // Process a value within the stack. void Arm64TaskData::ScanStackAddress(ScanAddress *process, stackItem& stackItem, StackSpace *stack) { // Code addresses on the ARM are always even, unlike the X86, so if it's tagged // it can't be an address. if (stackItem.w().IsTagged()) return; #ifdef POLYML32IN64 // In 32-in-64 we can have either absolute addresses or object indexes. // Absolute addresses always have the top 32-bits non-zero if (stackItem.argValue < ((uintptr_t)1 << 32)) { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } else { // Could be a code address or a stack address. MemSpace* space = gMem.SpaceForAddress(stackItem.codeAddr - 1); if (space == 0 || space->spaceType != ST_CODE) return; PolyObject* obj = gMem.FindCodeObject(stackItem.codeAddr); ASSERT(obj != 0); // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } #else MemSpace* space = gMem.SpaceForAddress(stackItem.codeAddr - 1); if (space->spaceType == ST_CODE) { PolyObject* obj = gMem.FindCodeObject(stackItem.codeAddr); // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } else if (space->spaceType == ST_LOCAL) // Local values must be word addresses. { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } #endif } // Copy a stack void Arm64TaskData::CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) { #ifdef POLYML32IN64 old_length = old_length / 2; new_length = new_length / 2; #endif /* Moves a stack, updating all references within the stack */ stackItem*old_base = (stackItem*)old_stack; stackItem*new_base = (stackItem*)new_stack; stackItem*old_top = old_base + old_length; /* Calculate the offset of the new stack from the old. If the frame is being extended objects in the new frame will be further up the stack than in the old one. */ uintptr_t offset = new_base - old_base + new_length - old_length; stackItem *oldSp = assemblyInterface.stackPtr; assemblyInterface.stackPtr = oldSp + offset; assemblyInterface.handlerRegister = assemblyInterface.handlerRegister + offset; /* Skip the unused part of the stack. */ uintptr_t i = oldSp - old_base; ASSERT(i <= old_length); i = old_length - i; stackItem *old = oldSp; stackItem *newp = assemblyInterface.stackPtr; while (i--) { stackItem old_word = *old++; if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) old_word.stackAddr = old_word.stackAddr + offset; else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) { stackItem* addr = (stackItem*)old_word.w().AsStackAddr(); if (addr >= old_base && addr <= old_top) { addr += offset; old_word = PolyWord::FromStackAddr((PolyWord*)addr); } } *newp++ = old_word; } ASSERT(old == ((stackItem*)old_stack) + old_length); ASSERT(newp == ((stackItem*)new_stack) + new_length); } void Arm64TaskData::EnterPolyCode() /* Called from "main" to enter the code. */ { assemblyInterface.stackLimit = (stackItem*)((PolyWord*)this->stack->stack() + OVERFLOW_STACK_SIZE); if (arm64Dependent.mustInterpret) { PolyWord closure = assemblyInterface.registers[8]; *(--assemblyInterface.stackPtr) = closure; /* Closure address */ interpreterPc = *(POLYCODEPTR*)closure.AsObjPtr(); Interpret(); ASSERT(0); // Should never return } SetMemRegisters(); // Jump into the ML code. This code sets up the registers and puts the // address of the assemblyInterface into X26 Arm64AsmEnterCompiledCode(&assemblyInterface); // This should never return ASSERT(0); } void Arm64TaskData::Interpret() { while (true) { switch (RunInterpreter(this)) { case ReturnCall: // After the call there will be an enter-int instruction so that when this // returns we will re-enter the interpreter. The number of arguments for // this call is after that. while ((uintptr_t)interpreterPc & 3) { ASSERT(interpreterPc[0] == INSTR_no_op); interpreterPc++; } ASSERT(interpreterPc[0] == 0xe9); numTailArguments = interpreterPc[12]; case ReturnTailCall: { ClearExceptionPacket(); // Pop the closure. PolyWord closureWord = *assemblyInterface.stackPtr++; PolyObject* closure = closureWord.AsObjPtr(); arm64CodePointer cp = *(arm64CodePointer*)closure; if (fromARMInstr(cp[0]) == 0xAA1E03E9 && fromARMInstr(cp[1]) == 0xF9400350 && fromARMInstr(cp[2]) == 0xD63F0200) { // If the code we're going to is interpreted push back the closure and // continue. interpreterPc = (POLYCODEPTR)cp; assemblyInterface.stackPtr--; HandleStackOverflow(128); // Make sure we have space since we're bypassing the check. continue; } assemblyInterface.registers[8] = closureWord; // Put closure in the closure reg. // Pop the return address. We may need to align this to a word boundary. POLYCODEPTR originalReturn = (POLYCODEPTR)((assemblyInterface.stackPtr++)->codeAddr); while ((uintptr_t)originalReturn & 3) { ASSERT(originalReturn[0] == INSTR_no_op); originalReturn++; } // Get the arguments into the correct registers. // Load the register arguments. The first 8 arguments go into X0-X7. // These will have been the first arguments to be pushed so will be // furthest away on the stack. // Note: we don't currently pass any arguments in the FP regs. for (unsigned i = 0; i < numTailArguments && i < 8; i++) assemblyInterface.registers[i] = assemblyInterface.stackPtr[numTailArguments - i - 1]; // If there are any more arguments these need to be shifted down the stack. while (numTailArguments > 8) { numTailArguments--; assemblyInterface.stackPtr[numTailArguments] = assemblyInterface.stackPtr[numTailArguments - 8]; } // Remove the register arguments assemblyInterface.stackPtr += numTailArguments > 8 ? 8 : numTailArguments; assemblyInterface.linkRegister = (arm64CodePointer)originalReturn; // Set the return address to caller assemblyInterface.entryPoint = *(arm64CodePointer*)closure; // Entry point to callee interpreterPc = 0; // No longer in the interpreter (See SaveMemRegs) return; } case ReturnReturn: { ClearExceptionPacket(); // Returning from an interpreted function. Normally we'll be returning to // interpreted code. if ((uintptr_t)interpreterPc & 3) // ARM64 addresses will always be 4-byte aligned. continue; arm64CodePointer cp = (arm64CodePointer)interpreterPc; if (fromARMInstr(cp[0]) == 0xAA1E03E9 && fromARMInstr(cp[1]) == 0xF9400350 && fromARMInstr(cp[2]) == 0xD63F0200) continue; // Pop the value we're returning. Set the entry point to the code we're returning to. assemblyInterface.registers[0] = *assemblyInterface.stackPtr++; assemblyInterface.entryPoint = cp; interpreterPc = 0; // No longer in the interpreter (See SaveMemRegs) return; } } } } // Called from the assembly code as a result of a trap i.e. a request for // a GC or to extend the stack. void Arm64TrapHandler(PolyWord threadId) { Arm64TaskData* taskData = (Arm64TaskData*)TaskData::FindTaskForId(threadId); taskData->HandleTrap(); } void Arm64TaskData::HandleTrap() { SaveMemRegisters(); // Update globals from the memory registers. switch (this->assemblyInterface.returnReason) { case RETURN_HEAP_OVERFLOW: { // The heap has overflowed. // The register mask is the word after the return. saveRegisterMask = fromARMInstr(*assemblyInterface.entryPoint++); // The generated code first subtracts the space required from x27 and puts the // result into a separate register. It then compares this with x25 and comes here if // it is not above that. Either way it is going to execute an instruction to put // this value back into x27. // Look at that instruction to find out the register. arm64Instr moveInstr = fromARMInstr(*assemblyInterface.entryPoint); ASSERT((moveInstr & 0xffe0ffff) == 0xaa0003fb); // mov x27,xN allocReg = (moveInstr >> 16) & 0x1f; allocWords = (allocPointer - (PolyWord*)assemblyInterface.registers[allocReg].stackAddr) + 1; assemblyInterface.registers[allocReg] = TAGGED(0); // Clear this - it's not a valid address. if (profileMode == kProfileStoreAllocation) addProfileCount(allocWords); // The actual allocation is done in SetMemRegisters. break; } case RETURN_STACK_OVERFLOW: case RETURN_STACK_OVERFLOWEX: { // The register mask is the word after the return. saveRegisterMask = fromARMInstr(*assemblyInterface.entryPoint++); uintptr_t min_size = 0; // Size in PolyWords if (assemblyInterface.returnReason == RETURN_STACK_OVERFLOW) { min_size = (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } else { // Stack limit overflow. If the required stack space is larger than // the fixed overflow size the code will calculate the limit in X9. stackItem* stackP = assemblyInterface.registers[9].stackAddr; min_size = (this->stack->top - (PolyWord*)stackP) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } HandleStackOverflow(min_size); break; } case RETURN_ENTER_INTERPRETER: { interpreterPc = (POLYCODEPTR)assemblyInterface.linkRegister; byte reasonCode = *interpreterPc++; // Sort out arguments. assemblyInterface.exceptionPacket = TAGGED(0); if (reasonCode == 0xff) { // Exception handler. assemblyInterface.exceptionPacket = assemblyInterface.registers[0]; // Get the exception packet // We need to leave the current handler in place. When we enter the interpreter it will // check the exception packet and if it is non-null will raise it. } else if (reasonCode >= 128) { // Start of function. unsigned numArgs = reasonCode - 128; // We need the stack to contain: // The closure, the return address, the arguments. // The stack will currently contain the stack arguments. // Add space for the register arguments if (numArgs > 8) assemblyInterface.stackPtr -= 8; else assemblyInterface.stackPtr -= numArgs; // Move up any stack arguments. for (unsigned n = 8; n < numArgs; n++) { assemblyInterface.stackPtr[n - 8] = assemblyInterface.stackPtr[n]; } // Store the register arguments for (unsigned n = 0; n < numArgs && n < 8; n++) assemblyInterface.stackPtr[numArgs - n - 1] = assemblyInterface.registers[n]; // Finally push the return address and closure pointer *(--assemblyInterface.stackPtr) = assemblyInterface.registers[9]; // Return address - value of X30 before enter-int *(--assemblyInterface.stackPtr) = assemblyInterface.registers[8]; // Closure } else { // Return from call. Push X0 *(--assemblyInterface.stackPtr) = assemblyInterface.registers[0]; } Interpret(); break; } default: Crash("Unknown return reason code %u", this->assemblyInterface.returnReason); } SetMemRegisters(); } void Arm64TaskData::HandleStackOverflow(uintptr_t space) { uintptr_t min_size = (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE + space; try { // The stack check has failed. This may either be because we really have // overflowed the stack or because the stack limit value has been adjusted // to result in a call here. CheckAndGrowStack(this, min_size); } catch (IOException&) { // We may get an exception while handling this if we run out of store } { PLocker l(&interruptLock); // Set the stack limit. This clears any interrupt and also sets the // correct value if we've grown the stack. assemblyInterface.stackLimit = (stackItem*)stack->bottom + OVERFLOW_STACK_SIZE; } try { processes->ProcessAsynchRequests(this); // Release and re-acquire use of the ML memory to allow another thread // to GC. processes->ThreadReleaseMLMemory(this); processes->ThreadUseMLMemory(this); } catch (IOException&) { } } void Arm64TaskData::InitStackFrame(TaskData* parentTask, Handle proc) /* Initialise stack frame. */ { StackSpace* space = this->stack; StackObject* stack = (StackObject*)space->stack(); uintptr_t stack_size = space->spaceSize() * sizeof(PolyWord) / sizeof(stackItem); assemblyInterface.stackPtr = (stackItem*)stack + stack_size; assemblyInterface.stackLimit = (stackItem*)space->bottom + OVERFLOW_STACK_SIZE; assemblyInterface.handlerRegister = assemblyInterface.stackPtr; // Store the argument and the closure. assemblyInterface.registers[8] = proc->Word(); // Closure assemblyInterface.registers[0] = TAGGED(0); // Argument assemblyInterface.linkRegister = (arm64CodePointer)1; // We never return. Use a tagged value because it may be pushed assemblyInterface.entryPoint = (arm64CodePointer)1; // Have to set the register mask in case we get a GC before the thread starts. saveRegisterMask = (1 << 8) | 1; // X8 and X0 #ifdef POLYML32IN64 // In 32-in-64 RBX always contains the heap base address. assemblyInterface.registers[24].stackAddr = (stackItem*)globalHeapBase; #endif } // This is called from a different thread so we have to be careful. void Arm64TaskData::InterruptCode() { PLocker l(&interruptLock); // Set the stack limit pointer to the top of the stack to cause // a trap when we next check for stack overflow. // We use a lock here to ensure that we always use the current value of the // stack. The thread we're interrupting could be growing the stack at this point. if (stack != 0) assemblyInterface.stackLimit = (stackItem*)(stack->top - 1); } // Called before entering ML code from the run-time system void Arm64TaskData::SetMemRegisters() { // Copy the current store limits into variables before we go into the assembly code. // If we haven't yet set the allocation area or we don't have enough we need // to create one (or a new one). if (allocPointer <= allocLimit + allocWords) { if (allocPointer < allocLimit) Crash("Bad length in heap overflow trap"); // Find some space to allocate in. Updates taskData->allocPointer and // returns a pointer to the newly allocated space (if allocWords != 0) PolyWord* space = processes->FindAllocationSpace(this, allocWords, true); if (space == 0) { // We will now raise an exception instead of returning. // Set allocWords to zero so we don't set the allocation register // since that could be holding the exception packet. allocWords = 0; } // Undo the allocation just now. allocPointer += allocWords; } if (this->allocWords != 0) { // If we have had a heap trap we actually do the allocation here. // We will have already garbage collected and recovered sufficient space. // This also happens if we have just trapped because of store profiling. allocPointer -= allocWords; // Now allocate // Set the allocation register to this area. N.B. This is an absolute address. assemblyInterface.registers[allocReg].codeAddr = (POLYCODEPTR)(allocPointer + 1); /* remember: it's off-by-one */ allocWords = 0; } // If we have run out of store, either just above or while allocating in the RTS, // allocPointer and allocLimit will have been set to zero as part of the GC. We will // now be raising an exception which may free some store but we need to come back here // before we allocate anything. The compiled code uses unsigned arithmetic to check for // heap overflow but only after subtracting the space required. We need to make sure // that the values are still non-negative after substracting any object size. if (allocPointer == 0) allocPointer += MAX_OBJECT_SIZE; if (allocLimit == 0) allocLimit += MAX_OBJECT_SIZE; assemblyInterface.localMbottom = allocLimit + 1; assemblyInterface.localMpointer = allocPointer + 1; // If we are profiling store allocation we set mem_hl so that a trap // will be generated. if (profileMode == kProfileStoreAllocation) assemblyInterface.localMbottom = assemblyInterface.localMpointer; assemblyInterface.threadId = stackItem(threadObject); } // This is called whenever we have returned from ML to C. void Arm64TaskData::SaveMemRegisters() { if (interpreterPc == 0) { // Not if we're already in the interpreter // The normal return is to the link register address. assemblyInterface.entryPoint = assemblyInterface.linkRegister; allocPointer = assemblyInterface.localMpointer - 1; } allocWords = 0; assemblyInterface.exceptionPacket = TAGGED(0); saveRegisterMask = 0; } // Process addresses in the code. The only case where we need to do that on the ARM64 is to deal // with spltting the constant area from the code in order to make the code position-independent. // We need to convert pc-relative LDR instructions into ADRP/LDR pairs. void Arm64Dependent::ScanConstantsWithinCode(PolyObject* addr, PolyObject* oldAddr, POLYUNSIGNED length, PolyWord* newConstAddr, PolyWord* oldConstAddr, POLYUNSIGNED numConsts, ScanAddress* process) { #ifndef POLYML32IN64 arm64CodePointer pt = (arm64CodePointer)addr; // If it begins with the enter-int sequence it's interpreted code. if (fromARMInstr(pt[0]) == 0xAA1E03E9 && fromARMInstr(pt[1]) == 0xF9400350 && fromARMInstr(pt[2]) == 0xD63F0200) return; // We only need a split if the constant area is not at the original offset. POLYSIGNED constAdjustment = (byte*)newConstAddr - (byte*)addr - ((byte*)oldConstAddr - (byte*)oldAddr); // If we have replaced the offset with a dummy ADRP/LDR pair we have to add a relocation. PolyWord* end = addr->Offset(length - 1); if ((end[0].AsUnsigned() >> 56) != 0xff) process->RelocateOnly(addr, (byte*)end, PROCESS_RELOC_ARM64ADRPLDR); while (*pt != 0) // The code ends with a UDF instruction (0) { arm64Instr instr0 = fromARMInstr(pt[0]); if ((instr0 & 0xbf000000) == 0x18000000) // LDR with pc-relative offset { // This could be a reference to the constant area or to the non-address area. // References to the constant area are followed by a nop if (constAdjustment != 0 && fromARMInstr(pt[1]) == 0xd503201f) { unsigned reg = instr0 & 0x1f; // The displacement is a signed multiple of 4 bytes but it will always be +ve ASSERT((instr0 & 0x00800000) == 0); // The constant address is relative to the new location of the code. byte* constAddress = (byte*)(pt + ((instr0 >> 5) & 0x7ffff)); byte* newAddress = (byte*)constAddress + constAdjustment; pt[0] = toARMInstr(0x90000000 + reg); // ADRP Xn, 0 pt[1] = toARMInstr(0xf9400000 + (reg << 5) + reg); // LDR Xn,[Xn+#0] ScanAddress::SetConstantValue((byte*)pt, (PolyObject*)newAddress, PROCESS_RELOC_ARM64ADRPLDR); } } else if ((instr0 & 0x9f000000) == 0x90000000) // ADRP instruction { // These only occur after we have converted LDRs above ASSERT((fromARMInstr(pt[1]) & 0xffc00000) == 0xf9400000); // The next should be the Load // If we're exporting code that has previously been exported we will // have already converted the LDR instructions. if (addr != oldAddr || newConstAddr != oldConstAddr) { // Look at the instruction at the original location, before it was copied, to // find out the address it referred to. byte* oldInstrAddress = (byte*)pt - (byte*)addr + (byte*)oldAddr; byte* constAddress = (byte*)ScanAddress::GetConstantValue(oldInstrAddress, PROCESS_RELOC_ARM64ADRPLDR, 0); // Convert that into an address in the new constant area before updating the copied code. byte* newAddress = (byte*)newConstAddr + (constAddress - (byte*)oldConstAddr); ScanAddress::SetConstantValue((byte*)pt, (PolyObject*)newAddress, PROCESS_RELOC_ARM64ADRPLDR); } process->RelocateOnly(addr, (byte*)pt, PROCESS_RELOC_ARM64ADRPLDR); } pt++; } #endif } // This is a special hack for FFI callbacks in 32-in-64. This is called // #ifdef POLYML32IN64 void Arm64Dependent::UpdateGlobalHeapReference(PolyObject* addr) { arm64CodePointer pt = (arm64CodePointer)addr; if (fromARMInstr(pt[0]) == 0xD503201F && (fromARMInstr(pt[1]) & 0xff000000) == 0x58000000) { // nop (special marker) followed by LDR Xn,pc-relative uint32_t pcOffset = (fromARMInstr(pt[1]) >> 5) & 0x3ffff; // This is a number of 32-bit words PolyWord* gHeapAddr = ((PolyWord*)addr) + pcOffset + 1; // PolyWords are 32-bits if (((PolyWord**)gHeapAddr)[0] != globalHeapBase) ((PolyWord**)gMem.SpaceForAddress(gHeapAddr)->writeAble(gHeapAddr))[0] = globalHeapBase; } } #endif // As far as possible we want locking and unlocking an ML mutex to be fast so // we try to implement the code in the assembly code using appropriate // interlocked instructions. That does mean that if we need to lock and // unlock an ML mutex in this code we have to use the same, machine-dependent, // code to do it. These are defaults that are used where there is no // machine-specific code. #if defined(_MSC_VER) // This saves having to define it in the MASM assembly code. static uintptr_t Arm64AsmAtomicExchange(PolyObject* mutexp, uintptr_t value) { # if (SIZEOF_POLYWORD == 8) return InterlockedExchange64((LONG64*)mutexp, value); # else return InterlockedExchange((LONG*)mutexp, value); # endif } #else extern "C" { // This is only defined in the GAS assembly code uintptr_t Arm64AsmAtomicExchange(PolyObject*, uintptr_t); } #endif bool Arm64TaskData::AtomicallyReleaseMutex(PolyObject* mutexp) { uintptr_t oldValue = Arm64AsmAtomicExchange(mutexp, 0); return oldValue == 1; } bool Arm64TaskData::AddTimeProfileCount(SIGNALCONTEXT *context) { stackItem* sp = 0; POLYCODEPTR pc = 0; if (context != 0) { #if defined(HAVE_WINDOWS_H) sp = (stackItem*)context->Sp; pc = (POLYCODEPTR)context->Pc; #elif defined(HAVE_UCONTEXT_T) #ifdef HAVE_MCONTEXT_T_REGS // Linux sp = (stackItem*)context->uc_mcontext.sp; pc = (POLYCODEPTR)context->uc_mcontext.pc; #endif #endif } if (pc != 0) { // See if the PC we've got is an ML code address. MemSpace* space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { incrementCountAsynch(pc); return true; } } // See if the sp value is in the current stack. if (sp >= (stackItem*)this->stack->bottom && sp < (stackItem*)this->stack->top) { // We may be in the assembly code. The top of the stack will be a return address. pc = sp[0].w().AsCodePtr(); MemSpace* space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { incrementCountAsynch(pc); return true; } } // See if the value of regSP is a valid stack pointer. // This works if we happen to be in an RTS call using a "Full" call. // It doesn't work if we've used a "Fast" call because that doesn't save the SP. sp = assemblyInterface.stackPtr; if (sp >= (stackItem*)this->stack->bottom && sp < (stackItem*)this->stack->top) { // We may be in the run-time system. pc = sp[0].w().AsCodePtr(); MemSpace* space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { incrementCountAsynch(pc); return true; } } return false; } extern "C" { POLYEXTERNALSYMBOL void* PolyArm64GetThreadData(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedEnterIntMode(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyEndBootstrapMode(FirstArgument threadId, PolyWord function); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyEndBootstrapMode(POLYUNSIGNED threadId, POLYUNSIGNED function); } // Return the address of assembly data for the current thread. This is normally in // X26 except if we are in a callback. void* PolyArm64GetThreadData() { // We should get the task data for the thread that is running this code. // If this thread has been created by the foreign code we will have to // create a new one here. TaskData* taskData = processes->GetTaskDataForThread(); if (taskData == 0) { try { taskData = processes->CreateNewTaskData(); } catch (std::bad_alloc&) { ::Exit("Unable to create thread data - insufficient memory"); } catch (MemoryException&) { ::Exit("Unable to create thread data - insufficient memory"); } } return &((Arm64TaskData*)taskData)->assemblyInterface; } // Do we require EnterInt instructions and if so for which architecture? // 0 = > None; 1 => X86_32, 2 => X86_64. 3 => X86_32_in_64. 4 => ARM_64. // ARM_64 in 32 is the same as ARM64. POLYUNSIGNED PolyInterpretedEnterIntMode() { return TAGGED(4).AsUnsigned(); } // End the first stage of bootstrap mode and run a new function. // The first stage is always interpreted. Once that is complete every function will have // at least an executable "enter-interpreter" stub so it can be called as machine code. -POLYUNSIGNED PolyEndBootstrapMode(FirstArgument threadId, PolyWord function) +POLYUNSIGNED PolyEndBootstrapMode(POLYUNSIGNED threadId, POLYUNSIGNED function) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle pushedFunction = taskData->saveVec.push(function); arm64Dependent.mustInterpret = false; ((Arm64TaskData*)taskData)->EndBootStrap(); taskData->InitStackFrame(taskData, pushedFunction); taskData->EnterPolyCode(); // Should never return. ASSERT(0); return TAGGED(0).AsUnsigned(); } // No machine-specific calls in the interpreter. struct _entrypts machineSpecificEPT[] = { { "PolyArm64GetThreadData", (polyRTSFunction)&PolyArm64GetThreadData }, { "PolyInterpretedEnterIntMode", (polyRTSFunction)&PolyInterpretedEnterIntMode }, { "PolyEndBootstrapMode", (polyRTSFunction)&PolyEndBootstrapMode }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/basicio.cpp b/libpolyml/basicio.cpp index dd43c068..86d9bfd5 100644 --- a/libpolyml/basicio.cpp +++ b/libpolyml/basicio.cpp @@ -1,1121 +1,1121 @@ /* Title: Basic IO. Copyright (c) 2000, 2015-2020 David C. J. Matthews Portions of this code are derived from the original stream io package copyright CUTS 1983-2000. 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 */ /* This module replaces the old stream IO based on stdio. It works at a lower level with the buffering being done in ML. Sockets are generally dealt with in network.c but it is convenient to use the same table for them particularly since it simplifies the implementation of "poll". Directory operations are also included in here. DCJM May 2000. */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_POLL_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_SYS_SELECT_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_DIRECT_H #include #endif #ifdef HAVE_STDIO_H #include #endif #include #ifndef INFTIM #define INFTIM (-1) #endif #ifdef HAVE_DIRENT_H # include # define NAMLEN(dirent) strlen((dirent)->d_name) #else # define dirent direct # define NAMLEN(dirent) (dirent)->d_namlen # if HAVE_SYS_NDIR_H # include # endif # if HAVE_SYS_DIR_H # include # endif # if HAVE_NDIR_H # include # endif #endif #include "globals.h" #include "basicio.h" #include "sys.h" #include "gc.h" #include "run_time.h" #include "machine_dep.h" #include "arb.h" #include "processes.h" #include "diagnostics.h" #include "io_internal.h" #include "scanaddrs.h" #include "polystring.h" #include "mpoly.h" #include "save_vec.h" #include "rts_module.h" #include "locking.h" #include "rtsentry.h" #include "timing.h" #define TOOMANYFILES EMFILE #define NOMEMORY ENOMEM #define STREAMCLOSED EBADF #define FILEDOESNOTEXIST ENOENT #define ERRORNUMBER errno #ifndef O_ACCMODE #define O_ACCMODE (O_RDONLY|O_RDWR|O_WRONLY) #endif #define SAVE(x) taskData->saveVec.push(x) #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVec, PolyWord bitVec, PolyWord maxMillisecs); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(FirstArgument threadId, PolyWord fd); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED strm, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(POLYUNSIGNED threadId, POLYUNSIGNED streamVec, POLYUNSIGNED bitVec, POLYUNSIGNED maxMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(POLYUNSIGNED threadId, POLYUNSIGNED fd); } static bool isAvailable(TaskData *taskData, int ioDesc) { #ifdef __CYGWIN__ static struct timeval poll = {0,1}; #else static struct timeval poll = {0,0}; #endif fd_set read_fds; int selRes; FD_ZERO(&read_fds); FD_SET(ioDesc, &read_fds); /* If there is something there we can return. */ selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll); if (selRes > 0) return true; /* Something waiting. */ else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr raise_syscall(taskData, "select error", ERRORNUMBER); else return false; } // The strm argument is a volatile word containing the descriptor. // Volatiles are set to zero on entry to indicate a closed descriptor. // Zero is a valid descriptor but -1 is not so we add 1 when storing and // subtract 1 when loading. // N.B. There are also persistent descriptors created with PolyPosixCreatePersistentFD Handle wrapFileDescriptor(TaskData *taskData, int fd) { return MakeVolatileWord(taskData, fd+1); } // Return a file descriptor or -1 if it is invalid. int getStreamFileDescriptorWithoutCheck(PolyWord strm) { return *(intptr_t*)(strm.AsObjPtr()) -1; } // Most of the time we want to raise an exception if the file descriptor // has been closed although this could be left to the system call. int getStreamFileDescriptor(TaskData *taskData, PolyWord strm) { int descr = getStreamFileDescriptorWithoutCheck(strm); if (descr == -1) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return descr; } /* Open a file in the required mode. */ static Handle open_file(TaskData *taskData, Handle filename, int mode, int access, int isPosix) { while (true) // Repeat only with certain kinds of errors { TempString cFileName(filename->Word()); // Get file name if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int stream = open(cFileName, mode, access); if (stream >= 0) { if (! isPosix) { /* Set the close-on-exec flag. We don't set this if we are being called from one of the low level functions in the Posix structure. I assume that if someone is using those functions they know what they're doing and would expect the behaviour to be close to that of the underlying function. */ fcntl(stream, F_SETFD, 1); } return wrapFileDescriptor(taskData, stream); } switch (errno) { case EINTR: // Just try the call. Is it possible to block here indefinitely? continue; default: raise_syscall(taskData, "Cannot open", ERRORNUMBER); /*NOTREACHED*/ return 0; } } } /* Close the stream unless it is stdin or stdout or already closed. */ static Handle close_file(TaskData *taskData, Handle stream) { int descr = getStreamFileDescriptorWithoutCheck(stream->Word()); // Don't close it if it's already closed or any of the standard streams if (descr > 2) { close(descr); *(intptr_t*)(stream->WordP()) = 0; // Mark as closed } return Make_fixed_precision(taskData, 0); } static void waitForAvailableInput(TaskData *taskData, Handle stream) { int fd = getStreamFileDescriptor(taskData, stream->Word()); while (!isAvailable(taskData, fd)) { WaitInputFD waiter(fd); processes->ThreadPauseForIO(taskData, &waiter); } } /* Read into an array. */ // We can't combine readArray and readString because we mustn't compute the // destination of the data in readArray until after any GC. static Handle readArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { /* The isText argument is ignored in both Unix and Windows but is provided for future use. Windows remembers the mode used when the file was opened to determine whether to translate CRLF into LF. */ // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); while (1) // Loop if interrupted. { // First test to see if we have input available. // These tests may result in a GC if another thread is running. // First test to see if we have input available. // These tests may result in a GC if another thread is running. waitForAvailableInput(taskData, stream); // We can now try to read without blocking. // Actually there's a race here in the unlikely situation that there // are multiple threads sharing the same low-level reader. They could // both detect that input is available but only one may succeed in // reading without blocking. This doesn't apply where the threads use // the higher-level IO interfaces in ML which have their own mutexes. int fd = getStreamFileDescriptor(taskData, stream->Word()); byte *base = DEREFHANDLE(args)->Get(0).AsObjPtr()->AsBytePtr(); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); ssize_t haveRead = read(fd, base + offset, length); if (haveRead >= 0) return Make_fixed_precision(taskData, haveRead); // Success. // If it failed because it was interrupted keep trying otherwise it's an error. if (errno != EINTR) raise_syscall(taskData, "Error while reading", ERRORNUMBER); } } /* Return input as a string. We don't actually need both readArray and readString but it's useful to have both to reduce unnecessary garbage. The IO library will construct one from the other but the higher levels choose the appropriate function depending on need. */ static Handle readString(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { size_t length = getPolyUnsigned(taskData, DEREFWORD(args)); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); while (1) // Loop if interrupted. { // First test to see if we have input available. // These tests may result in a GC if another thread is running. waitForAvailableInput(taskData, stream); // We can now try to read without blocking. int fd = getStreamFileDescriptor(taskData, stream->Word()); // We previously allocated the buffer on the stack but that caused // problems with multi-threading at least on Mac OS X because of // stack exhaustion. We limit the space to 100k. */ if (length > 102400) length = 102400; byte *buff = (byte*)malloc(length); if (buff == 0) raise_syscall(taskData, "Unable to allocate buffer", NOMEMORY); ssize_t haveRead = read(fd, buff, length); if (haveRead >= 0) { Handle result = SAVE(C_string_to_Poly(taskData, (char*)buff, haveRead)); free(buff); return result; } free(buff); // If it failed because it was interrupted keep trying otherwise it's an error. if (errno != EINTR) raise_syscall(taskData, "Error while reading", ERRORNUMBER); } } static Handle writeArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { /* The isText argument is ignored in both Unix and Windows but is provided for future use. Windows remembers the mode used when the file was opened to determine whether to translate LF into CRLF. */ PolyWord base = DEREFWORDHANDLE(args)->Get(0); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); int fd = getStreamFileDescriptor(taskData, stream->Word()); /* We don't actually handle cases of blocking on output. */ byte *toWrite = base.AsObjPtr()->AsBytePtr(); ssize_t haveWritten = write(fd, toWrite+offset, length); if (haveWritten < 0) raise_syscall(taskData, "Error while writing", ERRORNUMBER); return Make_fixed_precision(taskData, haveWritten); } // Test whether we can write without blocking. Returns false if it will block, // true if it will not. static bool canOutput(TaskData *taskData, Handle stream) { int fd = getStreamFileDescriptor(taskData, stream->Word()); /* Unix - use "select" to find out if output is possible. */ #ifdef __CYGWIN__ static struct timeval poll = {0,1}; #else static struct timeval poll = {0,0}; #endif fd_set read_fds, write_fds, except_fds; int sel; FD_ZERO(&read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); FD_SET(fd, &write_fds); sel = select(FD_SETSIZE,&read_fds,&write_fds,&except_fds,&poll); if (sel < 0 && errno != EINTR) raise_syscall(taskData, "select failed", ERRORNUMBER); return sel > 0; } static long seekStream(TaskData *taskData, int fd, long pos, int origin) { long lpos = lseek(fd, pos, origin); if (lpos < 0) raise_syscall(taskData, "Position error", ERRORNUMBER); return lpos; } /* Return the number of bytes available on the device. Works only for files since it is meaningless for other devices. */ static Handle bytesAvailable(TaskData *taskData, Handle stream) { int fd = getStreamFileDescriptor(taskData, stream->Word()); /* Remember our original position, seek to the end, then seek back. */ long original = seekStream(taskData, fd, 0L, SEEK_CUR); long endOfStream = seekStream(taskData, fd, 0L, SEEK_END); if (seekStream(taskData, fd, original, SEEK_SET) != original) raise_syscall(taskData, "Position error", ERRORNUMBER); return Make_fixed_precision(taskData, endOfStream-original); } static Handle fileKind(TaskData *taskData, Handle stream) { int fd = getStreamFileDescriptor(taskData, stream->Word()); struct stat statBuff; if (fstat(fd, &statBuff) < 0) raise_syscall(taskData, "Stat failed", ERRORNUMBER); switch (statBuff.st_mode & S_IFMT) { case S_IFIFO: return Make_fixed_precision(taskData, FILEKIND_PIPE); case S_IFCHR: case S_IFBLK: if (isatty(fd)) return Make_fixed_precision(taskData, FILEKIND_TTY); else return Make_fixed_precision(taskData, FILEKIND_DEV); case S_IFDIR: return Make_fixed_precision(taskData, FILEKIND_DIR); case S_IFREG: return Make_fixed_precision(taskData, FILEKIND_FILE); case S_IFLNK: return Make_fixed_precision(taskData, FILEKIND_LINK); case S_IFSOCK: return Make_fixed_precision(taskData, FILEKIND_SKT); default: return Make_fixed_precision(taskData, -1); } } /* Find out what polling options, if any, are allowed on this file descriptor. We assume that polling is allowed on all descriptors, either for reading or writing depending on how the stream was opened. */ Handle pollTest(TaskData *taskData, Handle stream) { // How do we test this? Assume all of them. return Make_fixed_precision(taskData, POLL_BIT_IN|POLL_BIT_OUT|POLL_BIT_PRI); } // Do the polling. Takes a vector of io descriptors, a vector of bits to test // and a time to wait and returns a vector of results. class WaitPoll: public Waiter{ public: WaitPoll(POLYUNSIGNED nDesc, struct pollfd *fds, unsigned maxMillisecs); virtual void Wait(unsigned maxMillisecs); int PollResult(void) { return pollResult; } int PollError(void) { return errorResult; } private: int pollResult; int errorResult; unsigned maxTime; struct pollfd *fdVec; POLYUNSIGNED nDescr; }; WaitPoll::WaitPoll(POLYUNSIGNED nDesc, struct pollfd *fds, unsigned maxMillisecs) { maxTime = maxMillisecs; pollResult = 0; errorResult = 0; nDescr = nDesc; fdVec = fds; } void WaitPoll::Wait(unsigned maxMillisecs) { // N.B. We use this for OS.Process.sleep with empty descriptor list. if (maxTime < maxMillisecs) maxMillisecs = maxTime; pollResult = poll(fdVec, nDescr, maxMillisecs); if (pollResult < 0) errorResult = ERRORNUMBER; } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVector, PolyWord bitVector, PolyWord maxMillisecs) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(POLYUNSIGNED threadId, POLYUNSIGNED streamVector, POLYUNSIGNED bitVector, POLYUNSIGNED maxMillisecs) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned(); Handle result = 0; try { PolyObject *strmVec = streamVector.AsObjPtr(); PolyObject *bitVec = bitVector.AsObjPtr(); POLYUNSIGNED nDesc = strmVec->Length(); ASSERT(nDesc == bitVec->Length()); struct pollfd * fds = 0; if (nDesc > 0) fds = (struct pollfd *)alloca(nDesc * sizeof(struct pollfd)); /* Set up the request vector. */ for (unsigned i = 0; i < nDesc; i++) { fds[i].fd = getStreamFileDescriptor(taskData, strmVec->Get(i)); POLYUNSIGNED bits = UNTAGGED(bitVec->Get(i)); fds[i].events = 0; if (bits & POLL_BIT_IN) fds[i].events |= POLLIN; /* | POLLRDNORM??*/ if (bits & POLL_BIT_OUT) fds[i].events |= POLLOUT; if (bits & POLL_BIT_PRI) fds[i].events |= POLLPRI; fds[i].revents = 0; } // Poll the descriptors. WaitPoll pollWait(nDesc, fds, maxMilliseconds); processes->ThreadPauseForIO(taskData, &pollWait); if (pollWait.PollResult() < 0) raise_syscall(taskData, "poll failed", pollWait.PollError()); // Construct the result vectors. result = alloc_and_save(taskData, nDesc); for (unsigned i = 0; i < nDesc; i++) { int res = 0; if (fds[i].revents & POLLIN) res = POLL_BIT_IN; if (fds[i].revents & POLLOUT) res = POLL_BIT_OUT; if (fds[i].revents & POLLPRI) res = POLL_BIT_PRI; DEREFWORDHANDLE(result)->Set(i, TAGGED(res)); } } catch (KillException &) { processes->ThreadExit(taskData); // TestAnyEvents may test for kill } 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(); } // Directory functions. static Handle openDirectory(TaskData *taskData, Handle dirname) { TempString dirName(dirname->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); while (1) { DIR *dirp = opendir(dirName); if (dirp != NULL) return MakeVolatileWord(taskData, dirp); switch (errno) { case EINTR: continue; // Just retry the call. default: raise_syscall(taskData, "opendir failed", ERRORNUMBER); } } } /* Return the next entry from the directory, ignoring current and parent arcs ("." and ".." in Windows and Unix) */ Handle readDirectory(TaskData *taskData, Handle stream) { DIR *pDir = *(DIR**)(stream->WordP()); // In a Volatile if (pDir == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); while (1) { struct dirent *dp = readdir(pDir); int len; if (dp == NULL) return taskData->saveVec.push(EmptyString(taskData)); len = NAMLEN(dp); if (!((len == 1 && strncmp(dp->d_name, ".", 1) == 0) || (len == 2 && strncmp(dp->d_name, "..", 2) == 0))) return SAVE(C_string_to_Poly(taskData, dp->d_name, len)); } } Handle rewindDirectory(TaskData *taskData, Handle stream, Handle dirname) { DIR *pDir = *(DIR**)(stream->WordP()); // In a Volatile if (pDir == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); rewinddir(pDir); return Make_fixed_precision(taskData, 0); } static Handle closeDirectory(TaskData *taskData, Handle stream) { DIR *pDir = *(DIR**)(stream->WordP()); // In a SysWord if (pDir != 0) { closedir(pDir); *((DIR**)stream->WordP()) = 0; // Clear this - no longer valid } return Make_fixed_precision(taskData, 0); } /* change_dirc - this is called directly and not via the dispatch function. */ static Handle change_dirc(TaskData *taskData, Handle name) /* Change working directory. */ { TempString cDirName(name->Word()); if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (chdir(cDirName) != 0) raise_syscall(taskData, "chdir failed", ERRORNUMBER); return SAVE(TAGGED(0)); } // External call -POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyChDir(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { (void)change_dirc(taskData, pushedArg); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Result is unit } /* Test for a directory. */ Handle isDir(TaskData *taskData, Handle name) { TempString cDirName(name->Word()); if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct stat fbuff; if (stat(cDirName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); if ((fbuff.st_mode & S_IFMT) == S_IFDIR) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } /* Get absolute canonical path name. */ Handle fullPath(TaskData *taskData, Handle filename) { TempString cFileName; /* Special case of an empty string. */ if (PolyStringLength(filename->Word()) == 0) cFileName = strdup("."); else cFileName = Poly_string_to_C_alloc(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); TempCString resBuf(realpath(cFileName, NULL)); if (resBuf == NULL) raise_syscall(taskData, "realpath failed", ERRORNUMBER); /* Some versions of Unix don't check the final component of a file. To be consistent try doing a "stat" of the resulting string to check it exists. */ struct stat fbuff; if (stat(resBuf, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); return(SAVE(C_string_to_Poly(taskData, resBuf))); } /* Get file modification time. This returns the value in the time units and from the base date used by timing.c. c.f. filedatec */ Handle modTime(TaskData *taskData, Handle filename) { TempString cFileName(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct stat fbuff; if (stat(cFileName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); /* Convert to microseconds. */ return Make_arb_from_pair_scaled(taskData, STAT_SECS(&fbuff,m), STAT_USECS(&fbuff,m), 1000000); } /* Get file size. */ Handle fileSize(TaskData *taskData, Handle filename) { TempString cFileName(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct stat fbuff; if (stat(cFileName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); return Make_arbitrary_precision(taskData, fbuff.st_size); } /* Set file modification and access times. */ Handle setTime(TaskData *taskData, Handle fileName, Handle fileTime) { TempString cFileName(fileName->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct timeval times[2]; /* We have a value in microseconds. We need to split it into seconds and microseconds. */ Handle hTime = fileTime; Handle hMillion = Make_arbitrary_precision(taskData, 1000000); /* N.B. Arguments to div_longc and rem_longc are in reverse order. */ unsigned secs = get_C_ulong(taskData, DEREFWORD(div_longc(taskData, hMillion, hTime))); unsigned usecs = get_C_ulong(taskData, DEREFWORD(rem_longc(taskData, hMillion, hTime))); times[0].tv_sec = times[1].tv_sec = secs; times[0].tv_usec = times[1].tv_usec = usecs; if (utimes(cFileName, times) != 0) raise_syscall(taskData, "utimes failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } /* Rename a file. */ Handle renameFile(TaskData *taskData, Handle oldFileName, Handle newFileName) { TempString oldName(oldFileName->Word()), newName(newFileName->Word()); if (oldName == 0 || newName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (rename(oldName, newName) != 0) raise_syscall(taskData, "rename failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } /* Access right requests passed in from ML. */ #define FILE_ACCESS_READ 1 #define FILE_ACCESS_WRITE 2 #define FILE_ACCESS_EXECUTE 4 /* Get access rights to a file. */ Handle fileAccess(TaskData *taskData, Handle name, Handle rights) { TempString fileName(name->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int rts = get_C_int(taskData, DEREFWORD(rights)); int mode = 0; if (rts & FILE_ACCESS_READ) mode |= R_OK; if (rts & FILE_ACCESS_WRITE) mode |= W_OK; if (rts & FILE_ACCESS_EXECUTE) mode |= X_OK; if (mode == 0) mode = F_OK; /* Return true if access is allowed, otherwise false for any other error. */ if (access(fileName, mode) == 0) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } /* IO_dispatchc. Called from assembly code module. */ static Handle IO_dispatch_c(TaskData *taskData, Handle args, Handle strm, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 0: /* Return standard input */ return wrapFileDescriptor(taskData, 0); case 1: /* Return standard output */ return wrapFileDescriptor(taskData, 1); case 2: /* Return standard error */ return wrapFileDescriptor(taskData, 2); case 3: /* Open file for text input. */ case 4: /* Open file for binary input. */ return open_file(taskData, args, O_RDONLY, 0666, 0); case 5: /* Open file for text output. */ case 6: /* Open file for binary output. */ return open_file(taskData, args, O_WRONLY | O_CREAT | O_TRUNC, 0666, 0); case 7: /* Close file */ return close_file(taskData, strm); case 8: /* Read text into an array. */ return readArray(taskData, strm, args, true); case 9: /* Read binary into an array. */ return readArray(taskData, strm, args, false); case 10: /* Get text as a string. */ return readString(taskData, strm, args, true); case 11: /* Write from memory into a text file. */ return writeArray(taskData, strm, args, true); case 12: /* Write from memory into a binary file. */ return writeArray(taskData, strm, args, false); case 13: /* Open text file for appending. */ /* The IO library definition leaves it open whether this should use "append mode" or not. */ case 14: /* Open binary file for appending. */ return open_file(taskData, args, O_WRONLY | O_CREAT | O_APPEND, 0666, 0); case 15: /* Return recommended buffer size. */ // This is a guess but 4k seems reasonable. return Make_fixed_precision(taskData, 4096); case 16: /* See if we can get some input. */ { int fd = getStreamFileDescriptor(taskData, strm->Word()); return Make_fixed_precision(taskData, isAvailable(taskData, fd) ? 1 : 0); } case 17: /* Return the number of bytes available. */ return bytesAvailable(taskData, strm); case 18: /* Get position on stream. */ { /* Get the current position in the stream. This is used to test for the availability of random access so it should raise an exception if setFilePos or endFilePos would fail. */ int fd = getStreamFileDescriptor(taskData, strm->Word()); long pos = seekStream(taskData, fd, 0L, SEEK_CUR); return Make_arbitrary_precision(taskData, pos); } case 19: /* Seek to position on stream. */ { long position = (long)get_C_long(taskData, DEREFWORD(args)); int fd = getStreamFileDescriptor(taskData, strm->Word()); (void)seekStream(taskData, fd, position, SEEK_SET); return Make_arbitrary_precision(taskData, 0); } case 20: /* Return position at end of stream. */ { int fd = getStreamFileDescriptor(taskData, strm->Word()); /* Remember our original position, seek to the end, then seek back. */ long original = seekStream(taskData, fd, 0L, SEEK_CUR); long endOfStream = seekStream(taskData, fd, 0L, SEEK_END); if (seekStream(taskData, fd, original, SEEK_SET) != original) raise_syscall(taskData, "Position error", ERRORNUMBER); return Make_arbitrary_precision(taskData, endOfStream); } case 21: /* Get the kind of device underlying the stream. */ return fileKind(taskData, strm); case 22: /* Return the polling options allowed on this descriptor. */ return pollTest(taskData, strm); // case 23: /* Poll the descriptor, waiting forever. */ // return pollDescriptors(taskData, args, 1); // case 24: /* Poll the descriptor, waiting for the time requested. */ // return pollDescriptors(taskData, args, 0); // case 25: /* Poll the descriptor, returning immediately.*/ // return pollDescriptors(taskData, args, 2); case 26: /* Get binary as a vector. */ return readString(taskData, strm, args, false); case 27: /* Block until input is available. */ // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); waitForAvailableInput(taskData, strm); return Make_fixed_precision(taskData, 0); case 28: /* Test whether output is possible. */ return Make_fixed_precision(taskData, canOutput(taskData, strm) ? 1:0); case 29: /* Block until output is possible. */ // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); while (true) { if (canOutput(taskData, strm)) return Make_fixed_precision(taskData, 0); // Use the default waiter for the moment since we don't have // one to test for output. processes->ThreadPauseForIO(taskData, Waiter::defaultWaiter); } /* Functions added for Posix structure. */ case 30: /* Return underlying file descriptor. */ /* This is now also used internally to test for stdIn, stdOut and stdErr. */ { int fd = getStreamFileDescriptor(taskData, strm->Word()); return Make_fixed_precision(taskData, fd); } case 31: /* Make an entry for a given descriptor. No longer used - previously used for Posix.FileSys.wordToFD. */ { int ioDesc = get_C_int(taskData, DEREFWORD(args)); return wrapFileDescriptor(taskData, ioDesc); } /* Directory functions. */ case 50: /* Open a directory. */ return openDirectory(taskData, args); case 51: /* Read a directory entry. */ return readDirectory(taskData, strm); case 52: /* Close the directory */ return closeDirectory(taskData, strm); case 53: /* Rewind the directory. */ return rewindDirectory(taskData, strm, args); case 54: /* Get current working directory. */ { size_t size = 4096; TempString string_buffer((char *)malloc(size * sizeof(char))); if (string_buffer == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); char *cwd; while ((cwd = getcwd(string_buffer, size)) == NULL && errno == ERANGE) { if (size > std::numeric_limits::max() / 2) raise_fail(taskData, "getcwd needs too large a buffer"); size *= 2; char *new_buf = (char *)realloc(string_buffer, size * sizeof(char)); if (new_buf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); string_buffer = new_buf; } if (cwd == NULL) raise_syscall(taskData, "getcwd failed", ERRORNUMBER); return SAVE(C_string_to_Poly(taskData, cwd)); } case 55: /* Create a new directory. */ { TempString dirName(args->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (mkdir(dirName, 0777) != 0) raise_syscall(taskData, "mkdir failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } case 56: /* Delete a directory. */ { TempString dirName(args->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (rmdir(dirName) != 0) raise_syscall(taskData, "rmdir failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } case 57: /* Test for directory. */ return isDir(taskData, args); case 58: /* Test for symbolic link. */ { TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); struct stat fbuff; if (lstat(fileName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); return Make_fixed_precision(taskData, ((fbuff.st_mode & S_IFMT) == S_IFLNK) ? 1 : 0); } case 59: /* Read a symbolic link. */ { int nLen; TempString linkName(args->Word()); if (linkName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); size_t size = 4096; TempString resBuf((char *)malloc(size * sizeof(char))); if (resBuf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // nLen is signed, so cast size to ssize_t to perform signed // comparison, avoiding an infinite loop when nLen is -1. while ((nLen = readlink(linkName, resBuf, size)) >= (ssize_t) size) { size *= 2; if (size > std::numeric_limits::max()) raise_fail(taskData, "readlink needs too large a buffer"); char *newBuf = (char *)realloc(resBuf, size * sizeof(char)); if (newBuf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); resBuf = newBuf; } if (nLen < 0) raise_syscall(taskData, "readlink failed", ERRORNUMBER); return(SAVE(C_string_to_Poly(taskData, resBuf, nLen))); } case 60: /* Return the full absolute path name. */ return fullPath(taskData, args); case 61: /* Modification time. */ return modTime(taskData, args); case 62: /* File size. */ return fileSize(taskData, args); case 63: /* Set file time. */ return setTime(taskData, strm, args); case 64: /* Delete a file. */ { TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (unlink(fileName) != 0) raise_syscall(taskData, "unlink failed", ERRORNUMBER); return Make_fixed_precision(taskData, 0); } case 65: /* rename a file. */ return renameFile(taskData, strm, args); case 66: /* Get access rights. */ return fileAccess(taskData, strm, args); case 67: /* Return a temporary file name. */ { const char *template_subdir = "/MLTEMPXXXXXX"; #ifdef P_tmpdir TempString buff((char *)malloc(strlen(P_tmpdir) + strlen(template_subdir) + 1)); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); strcpy(buff, P_tmpdir); #else const char *tmpdir = "/tmp"; TempString buff((char *)malloc(strlen(tmpdir) + strlen(template_subdir) + 1)); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); strcpy(buff, tmpdir); #endif strcat(buff, template_subdir); #if (defined(HAVE_MKSTEMP) && ! defined(UNICODE)) // mkstemp is present in the Mingw64 headers but only as ANSI not Unicode. // Set the umask to mask out access by anyone else. // mkstemp generally does this anyway. mode_t oldMask = umask(0077); int fd = mkstemp(buff); int wasError = ERRORNUMBER; (void)umask(oldMask); if (fd != -1) close(fd); else raise_syscall(taskData, "mkstemp failed", wasError); #else if (mktemp(buff) == 0) raise_syscall(taskData, "mktemp failed", ERRORNUMBER); int fd = open(buff, O_RDWR | O_CREAT | O_EXCL, 00600); if (fd != -1) close(fd); else raise_syscall(taskData, "Temporary file creation failed", ERRORNUMBER); #endif Handle res = SAVE(C_string_to_Poly(taskData, buff)); return res; } case 68: /* Get the file id. */ { struct stat fbuff; TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (stat(fileName, &fbuff) != 0) raise_syscall(taskData, "stat failed", ERRORNUMBER); /* Assume that inodes are always non-negative. */ return Make_arbitrary_precision(taskData, fbuff.st_ino); } case 69: // Return an index for a token. It is used in OS.IO.hash. // This is supposed to be well distributed for any 2^n but simply return // the stream number. return Make_fixed_precision(taskData, getStreamFileDescriptor(taskData, strm->Word())); case 70: /* Posix.FileSys.openf - open a file with given mode. */ { Handle name = taskData->saveVec.push(DEREFWORDHANDLE(args)->Get(0)); int mode = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(1)); return open_file(taskData, name, mode, 0666, 1); } case 71: /* Posix.FileSys.createf - create a file with given mode and access. */ { Handle name = taskData->saveVec.push(DEREFWORDHANDLE(args)->Get(0)); int mode = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(1)); int access = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(2)); return open_file(taskData, name, mode|O_CREAT, access, 1); } default: { char msg[100]; sprintf(msg, "Unknown io function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to IO. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg) +POLYUNSIGNED PolyBasicIOGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED strm, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedStrm = taskData->saveVec.push(strm); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = IO_dispatch_c(taskData, pushedArg, pushedStrm, pushedCode); } catch (KillException &) { processes->ThreadExit(taskData); // TestAnyEvents may test for kill } 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(); } // Create a persistent file descriptor value for Posix.FileSys.stdin etc. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(FirstArgument threadId, PolyWord fd) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(POLYUNSIGNED threadId, POLYUNSIGNED fd) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = alloc_and_save(taskData, WORDS(SIZEOF_VOIDP), F_BYTE_OBJ | F_MUTABLE_BIT | F_NO_OVERWRITE); *(POLYSIGNED*)(result->Word().AsCodePtr()) = fd.UnTagged() + 1; } catch (...) { } // If an ML exception is raised - could have run out of memory taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts basicIOEPT[] = { { "PolyChDir", (polyRTSFunction)&PolyChDir}, { "PolyBasicIOGeneral", (polyRTSFunction)&PolyBasicIOGeneral}, { "PolyPollIODescriptors", (polyRTSFunction)&PolyPollIODescriptors }, { "PolyPosixCreatePersistentFD", (polyRTSFunction)&PolyPosixCreatePersistentFD}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/bytecode.cpp b/libpolyml/bytecode.cpp index 30cdafee..1ee98011 100644 --- a/libpolyml/bytecode.cpp +++ b/libpolyml/bytecode.cpp @@ -1,2709 +1,2709 @@ /* 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-21. 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_STDLIB_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(*callFastRts1)(POLYUNSIGNED); + typedef POLYUNSIGNED(*callFastRts2)(POLYUNSIGNED, POLYUNSIGNED); + typedef POLYUNSIGNED(*callFastRts3)(POLYUNSIGNED, POLYUNSIGNED, POLYUNSIGNED); + typedef POLYUNSIGNED(*callFastRts4)(POLYUNSIGNED, POLYUNSIGNED, POLYUNSIGNED, POLYUNSIGNED); + typedef POLYUNSIGNED(*callFastRts5)(POLYUNSIGNED, POLYUNSIGNED, POLYUNSIGNED, POLYUNSIGNED, POLYUNSIGNED); 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 static PLock mutexLock; 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 */ { POLYCODEPTR entry = pc + *pc + 1; // Address of handler // This needs to be aligned for the ARM. This is only during development. while (((uintptr_t)entry & 3) && entry[0] == INSTR_no_op) entry++; (--sp)->codeAddr = entry; SetHandlerRegister(sp); pc += 1; break; } case INSTR_setHandler16: /* Set up a handler */ { POLYCODEPTR entry = pc + arg1 + 2; // This needs to be aligned for the ARM. This is only during development. while (((uintptr_t)entry & 3) && entry[0] == INSTR_no_op) entry++; (--sp)->codeAddr = entry; 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_callConstAddr8_8: closure = ((PolyWord*)(pc + pc[0] + 2))[pc[1] + 3].AsObjPtr(); pc += 2; goto CALL_CLOSURE; case INSTR_callConstAddr8_0: closure = ((PolyWord*)(pc + pc[0] + 1))[3].AsObjPtr(); pc += 1; goto CALL_CLOSURE; case INSTR_callConstAddr8_1: closure = ((PolyWord*)(pc + pc[0] + 1))[4].AsObjPtr(); pc += 1; goto CALL_CLOSURE; case INSTR_callConstAddr16_8: closure = ((PolyWord*)(pc + arg1 + 3))[pc[2] + 3].AsObjPtr(); pc += 3; 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_constAddr8_8: *(--sp) = ((PolyWord*)(pc + pc[0]+ 2))[pc[1] + 3]; pc += 2; break; case INSTR_constAddr8_0: *(--sp) = ((PolyWord*)(pc + pc[0] + 1))[3]; pc += 1; break; case INSTR_constAddr8_1: *(--sp) = ((PolyWord*)(pc + pc[0] + 1))[4]; pc += 1; break; case INSTR_constAddr16_8: *(--sp) = ((PolyWord*)(pc + arg1 + 3))[pc[2] + 3]; pc += 3; 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; + POLYUNSIGNED rtsArg1 = (*sp++).w().AsUnsigned(); 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; + POLYUNSIGNED rtsArg2 = (*sp++).w().AsUnsigned(); // Pop off the args, last arg first. + POLYUNSIGNED rtsArg1 = (*sp++).w().AsUnsigned(); 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; + POLYUNSIGNED rtsArg3 = (*sp++).w().AsUnsigned(); // Pop off the args, last arg first. + POLYUNSIGNED rtsArg2 = (*sp++).w().AsUnsigned(); + POLYUNSIGNED rtsArg1 = (*sp++).w().AsUnsigned(); 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; + POLYUNSIGNED rtsArg4 = (*sp++).w().AsUnsigned(); // Pop off the args, last arg first. + POLYUNSIGNED rtsArg3 = (*sp++).w().AsUnsigned(); + POLYUNSIGNED rtsArg2 = (*sp++).w().AsUnsigned(); + POLYUNSIGNED rtsArg1 = (*sp++).w().AsUnsigned(); 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; + POLYUNSIGNED rtsArg5 = (*sp++).w().AsUnsigned(); // Pop off the args, last arg first. + POLYUNSIGNED rtsArg4 = (*sp++).w().AsUnsigned(); + POLYUNSIGNED rtsArg3 = (*sp++).w().AsUnsigned(); + POLYUNSIGNED rtsArg2 = (*sp++).w().AsUnsigned(); + POLYUNSIGNED rtsArg1 = (*sp++).w().AsUnsigned(); 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: { // This is legacy code. Returns the result after the increment. PolyObject* p = (*sp).w().AsObjPtr(); PLocker pl(&mutexLock); POLYUNSIGNED newValue = p->Get(0).AsUnsigned() + 2; // Add tagged 1 with the tag removed. p->Set(0, PolyWord::FromUnsigned(newValue)); *sp = PolyWord::FromUnsigned(newValue); break; } case INSTR_atomicDecr: { // This is legacy code. Returns the result after the increment. PolyObject* p = (*sp).w().AsObjPtr(); PLocker pl(&mutexLock); POLYUNSIGNED newValue = p->Get(0).AsUnsigned() - 2; // Subtract tagged 1 with the tag removed. p->Set(0, PolyWord::FromUnsigned(newValue)); *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 { taskData->SetException((poly_exn*)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 { taskData->SetException((poly_exn*)overflowPacket); goto RAISE_EXCEPTION; } break; } case INSTR_fixedMult: { // There's no simple way to detect signed overflow in multiplication. // Unsigned multiplication is defined to wrap but signed is not and // GCC optimised away the previous test we had here. PolyWord x = *sp++; PolyWord y = (*sp); 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); if ((*sp).w().IsDataPtr()) { taskData->SetException((poly_exn*)overflowPacket); goto RAISE_EXCEPTION; } } catch (IOException&) { // We could run out of store goto RAISE_EXCEPTION; } 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: { // See comment on fixedMultiply above PolyWord x = *sp++; PolyWord y = (*sp); 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; for (POLYUNSIGNED i = sizeof(uintptr_t) / sizeof(PolyWord); i < length; i++) t->Set(i, TAGGED(0)); *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_atomicExchAdd: { // Now legacy code. PLocker pl(&mutexLock); PolyWord u = *sp++; PolyObject* p = (*sp).w().AsObjPtr(); // Returns the old value. PolyWord oldValue = p->Get(0); *sp = oldValue; p->Set(0, PolyWord::FromSigned(oldValue.AsSigned() + u.AsSigned() - 1)); break; } case EXTINSTR_createMutex: { // Allocate memory for a mutex. We allocate a single mutable word initialised to tagged 0. PolyObject* t = this->allocateMemory(taskData, 1, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(1, F_MUTABLE_BIT|F_NO_OVERWRITE|F_WEAK_BIT); t->Set(0, TAGGED(0)); *(--sp) = (PolyWord)t; break; } case EXTINSTR_lockMutex: { // TODO: We could put a spin-lock in here. PolyObject* p = (*sp).w().AsObjPtr(); PLocker pl(&mutexLock); // Lock the mutex by using an atomic increment. PolyWord oldValue = p->Get(0); *sp = oldValue.AsUnsigned() == TAGGED(0).AsUnsigned() ? True : False; p->Set(0, PolyWord::FromSigned(oldValue.AsSigned() + 2)); break; } case EXTINSTR_tryLockMutex: { PolyObject* p = (*sp).w().AsObjPtr(); PLocker pl(&mutexLock); POLYUNSIGNED oldValue = p->Get(0).AsUnsigned(); // If it is unlocked we lock it and return true otherwise we leave it and return false. if (oldValue == TAGGED(0).AsUnsigned()) { *sp = True; p->Set(0, TAGGED(1)); } else *sp = False; break; } case EXTINSTR_atomicReset: { // Reset the mutex and return a boolean result indicating if this thread was the only locker. PLocker pl(&mutexLock); PolyObject* p = (*sp).w().AsObjPtr(); POLYUNSIGNED oldValue = p->Get(0).AsUnsigned(); p->Set(0, TAGGED(0)); *sp = oldValue == TAGGED(1).AsUnsigned() ? True: False; // 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); POLYCODEPTR entry = pc + offset + 4; // Address of handler // This needs to be aligned for the ARM. This is only during development. while (((uintptr_t)entry & 3) && entry[0] == INSTR_no_op) entry++; (--sp)->codeAddr = entry; 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_constAddr32_16: { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); POLYUNSIGNED cNum = pc[4] + (pc[5] << 8) + 3; offset += cNum * sizeof(PolyWord); *(--sp) = *(PolyWord*)(pc + offset + 6); pc += 6; 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; for (POLYUNSIGNED i = sizeof(uintptr_t) / sizeof(PolyWord); i < length; i++) t->Set(i, TAGGED(0)); *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; case INSTR_enterIntArm64: pc += 12; break; case INSTR_no_op: // Only used for alignment for ARM64. 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); } // RTS call to unlock a mutex. bool ByteCodeInterpreter::InterpreterReleaseMutex(PolyObject* mutexp) { PLocker pl(&mutexLock); POLYUNSIGNED oldValue = mutexp->Get(0).AsUnsigned(); mutexp->Set(0, TAGGED(0)); return oldValue == TAGGED(1).AsUnsigned(); } 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); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedGetAbiList(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCreateCIF(POLYUNSIGNED threadId, POLYUNSIGNED abiValue, POLYUNSIGNED resultType, POLYUNSIGNED argTypes); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCallFunction(POLYUNSIGNED threadId, POLYUNSIGNED cifAddr, POLYUNSIGNED cFunAddr, POLYUNSIGNED resAddr, POLYUNSIGNED 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) +POLYUNSIGNED PolyInterpretedCreateCIF(POLYUNSIGNED threadId, POLYUNSIGNED abiValue, POLYUNSIGNED resultType, POLYUNSIGNED 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); + ffi_abi abi = (ffi_abi)get_C_ushort(taskData, PolyWord::FromUnsigned(abiValue)); try { unsigned nArgs = 0; - for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) + for (PolyWord p = PolyWord::FromUnsigned(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); + ffi_type* rtype = decodeType(PolyWord::FromUnsigned(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) + for (PolyWord p = PolyWord::FromUnsigned(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) +POLYUNSIGNED PolyInterpretedCallFunction(POLYUNSIGNED threadId, POLYUNSIGNED cifAddr, POLYUNSIGNED cFunAddr, POLYUNSIGNED resAddr, POLYUNSIGNED argVec) { - ffi_cif* cif = *(ffi_cif**)cifAddr.AsAddress(); - void* f = *(void**)cFunAddr.AsAddress(); - void* res = *(void**)resAddr.AsAddress(); - void* arg = *(void**)argVec.AsAddress(); + ffi_cif* cif = *(ffi_cif**)PolyWord::FromUnsigned(cifAddr).AsAddress(); + void* f = *(void**)PolyWord::FromUnsigned(cFunAddr).AsAddress(); + void* res = *(void**)PolyWord::FromUnsigned(resAddr).AsAddress(); + void* arg = *(void**)PolyWord::FromUnsigned(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. // Have to create a sysword result. -POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) +POLYUNSIGNED PolyInterpretedCreateCIF(POLYUNSIGNED threadId, POLYUNSIGNED abiValue, POLYUNSIGNED resultType, POLYUNSIGNED argTypes) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle result = 0; try { result = Make_sysword(taskData, (uintptr_t)0); } catch (...) {} // If an ML exception is raised taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) +POLYUNSIGNED PolyInterpretedCallFunction(POLYUNSIGNED threadId, POLYUNSIGNED cifAddr, POLYUNSIGNED cFunAddr, POLYUNSIGNED resAddr, POLYUNSIGNED 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) +POLYUNSIGNED PolyInterpretedGetAbiList(POLYUNSIGNED 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(); } struct _entrypts byteCodeEPT[] = { { "PolyInterpretedGetAbiList", (polyRTSFunction)&PolyInterpretedGetAbiList }, { "PolyInterpretedCreateCIF", (polyRTSFunction)&PolyInterpretedCreateCIF }, { "PolyInterpretedCallFunction", (polyRTSFunction)&PolyInterpretedCallFunction }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/exporter.cpp b/libpolyml/exporter.cpp index 5e7840b7..88560ea1 100644 --- a/libpolyml/exporter.cpp +++ b/libpolyml/exporter.cpp @@ -1,989 +1,989 @@ /* Title: exporter.cpp - Export a function as an object or C file Copyright (c) 2006-7, 2015, 2016-21 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #if (defined(_WIN32)) #include #else #define _T(x) x #define _tcslen strlen #define _tcscmp strcmp #define _tcscat strcat #endif #include "exporter.h" #include "save_vec.h" #include "polystring.h" #include "run_time.h" #include "osmem.h" #include "scanaddrs.h" #include "gc.h" #include "machine_dep.h" #include "diagnostics.h" #include "memmgr.h" #include "processes.h" // For IO_SPACING #include "sys.h" // For EXC_Fail #include "rtsentry.h" #include "pexport.h" #ifdef HAVE_PECOFF #include "pecoffexport.h" #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) #include "elfexport.h" #elif defined(HAVE_MACH_O_RELOC_H) #include "machoexport.h" #endif #if (defined(_WIN32)) #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #define ERRORNUMBER _doserrno #else #define NOMEMORY ENOMEM #define ERRORNUMBER errno #endif extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyExport(POLYUNSIGNED threadId, POLYUNSIGNED fileName, POLYUNSIGNED root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyExportPortable(POLYUNSIGNED threadId, POLYUNSIGNED fileName, POLYUNSIGNED root); } /* To export the function and everything reachable from it we need to copy all the objects into a new area. We leave tombstones in the original objects by overwriting the length word. That prevents us from copying an object twice and breaks loops. Once we've copied the objects we then have to go back over the memory and turn the tombstones back into length words. */ GraveYard::~GraveYard() { free(graves); } // Used to calculate the space required for the ordinary mutables // and the no-overwrite mutables. They are interspersed in local space. class MutSizes : public ScanAddress { public: MutSizes() : mutSize(0), noOverSize(0) {} virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; }// No Actually used virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord) { const POLYUNSIGNED words = OBJ_OBJECT_LENGTH(lengthWord) + 1; // Include length word if (OBJ_IS_NO_OVERWRITE(lengthWord)) noOverSize += words; else mutSize += words; } POLYUNSIGNED mutSize, noOverSize; }; CopyScan::CopyScan(unsigned h/*=0*/): hierarchy(h) { defaultImmSize = defaultMutSize = defaultCodeSize = defaultNoOverSize = 0; tombs = 0; graveYard = 0; } void CopyScan::initialise(bool isExport/*=true*/) { ASSERT(gMem.eSpaces.size() == 0); // Set the space sizes to a proportion of the space currently in use. // Computing these sizes is not obvious because CopyScan is used both // for export and for saved states. For saved states in particular we // want to use a smaller size because they are retained after we save // the state and if we have many child saved states it's important not // to waste memory. if (hierarchy == 0) { graveYard = new GraveYard[gMem.pSpaces.size()]; if (graveYard == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate graveyard, size: %lu.\n", gMem.pSpaces.size()); throw MemoryException(); } } for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->hierarchy >= hierarchy) { // Include this if we're exporting (hierarchy=0) or if we're saving a state // and will include this in the new state. size_t size = (space->top-space->bottom)/4; if (space->noOverwrite) defaultNoOverSize += size; else if (space->isMutable) defaultMutSize += size; else if (space->isCode) defaultCodeSize += size; else defaultImmSize += size; if (space->hierarchy == 0 && ! space->isMutable) { // We need a separate area for the tombstones because this is read-only graveYard[tombs].graves = (PolyWord*)calloc(space->spaceSize(), sizeof(PolyWord)); if (graveYard[tombs].graves == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate graveyard for permanent space, size: %lu.\n", space->spaceSize() * sizeof(PolyWord)); throw MemoryException(); } if (debugOptions & DEBUG_SAVING) Log("SAVE: Allocated graveyard for permanent space, %p size: %lu.\n", graveYard[tombs].graves, space->spaceSize() * sizeof(PolyWord)); graveYard[tombs].startAddr = space->bottom; graveYard[tombs].endAddr = space->top; tombs++; } } } for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; uintptr_t size = space->allocatedSpace(); // It looks as though the mutable size generally gets // overestimated while the immutable size is correct. if (space->isMutable) { MutSizes sizeMut; sizeMut.ScanAddressesInRegion(space->bottom, space->lowerAllocPtr); sizeMut.ScanAddressesInRegion(space->upperAllocPtr, space->top); defaultNoOverSize += sizeMut.noOverSize / 4; defaultMutSize += sizeMut.mutSize / 4; } else defaultImmSize += size/2; } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; uintptr_t size = space->spaceSize(); defaultCodeSize += size/2; } if (isExport) { // Minimum 1M words. if (defaultMutSize < 1024*1024) defaultMutSize = 1024*1024; if (defaultImmSize < 1024*1024) defaultImmSize = 1024*1024; if (defaultCodeSize < 1024*1024) defaultCodeSize = 1024*1024; #ifdef MACOSX // Limit the segment size for Mac OS X. The linker has a limit of 2^24 relocations // in a segment so this is a crude way of ensuring the limit isn't exceeded. // It's unlikely to be exceeded by the code itself. // Actually, from trial-and-error, the limit seems to be around 6M. if (defaultMutSize > 6 * 1024 * 1024) defaultMutSize = 6 * 1024 * 1024; if (defaultImmSize > 6 * 1024 * 1024) defaultImmSize = 6 * 1024 * 1024; #endif if (defaultNoOverSize < 4096) defaultNoOverSize = 4096; // Except for the no-overwrite area } else { // Much smaller minimum sizes for saved states. if (defaultMutSize < 1024) defaultMutSize = 1024; if (defaultImmSize < 4096) defaultImmSize = 4096; if (defaultCodeSize < 4096) defaultCodeSize = 4096; if (defaultNoOverSize < 4096) defaultNoOverSize = 4096; // Set maximum sizes as well. We may have insufficient contiguous space for // very large areas. if (defaultMutSize > 1024 * 1024) defaultMutSize = 1024 * 1024; if (defaultImmSize > 1024 * 1024) defaultImmSize = 1024 * 1024; if (defaultCodeSize > 1024 * 1024) defaultCodeSize = 1024 * 1024; if (defaultNoOverSize > 1024 * 1024) defaultNoOverSize = 1024 * 1024; } if (debugOptions & DEBUG_SAVING) Log("SAVE: Copyscan default sizes: Immutable: %" POLYUFMT ", Mutable: %" POLYUFMT ", Code: %" POLYUFMT ", No-overwrite %" POLYUFMT ".\n", defaultImmSize, defaultMutSize, defaultCodeSize, defaultNoOverSize); } CopyScan::~CopyScan() { gMem.DeleteExportSpaces(); if (graveYard) delete[](graveYard); } // This function is called for each address in an object // once it has been copied to its new location. We copy first // then scan to update the addresses. POLYUNSIGNED CopyScan::ScanAddressAt(PolyWord *pt) { PolyWord val = *pt; // Ignore integers. if (IS_INT(val) || val == PolyWord::FromUnsigned(0)) return 0; PolyObject *obj = val.AsObjPtr(); POLYUNSIGNED l = ScanAddress(&obj); *pt = obj; return l; } // This function is called for each address in an object // once it has been copied to its new location. We copy first // then scan to update the addresses. POLYUNSIGNED CopyScan::ScanAddress(PolyObject **pt) { PolyObject *obj = *pt; MemSpace *space = gMem.SpaceForObjectAddress(obj); ASSERT(space != 0); // We may sometimes get addresses that have already been updated // to point to the new area. e.g. (only?) in the case of constants // that have been updated in ScanConstantsWithinCode. if (space->spaceType == ST_EXPORT) return 0; // If this is at a lower level than the hierarchy we are saving // then leave it untouched. if (space->spaceType == ST_PERMANENT) { PermanentMemSpace *pmSpace = (PermanentMemSpace*)space; if (pmSpace->hierarchy < hierarchy) return 0; } // Have we already scanned this? if (obj->ContainsForwardingPtr()) { // Update the address to the new value. #ifdef POLYML32IN64 PolyObject *newAddr; if (space->isCode) newAddr = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else newAddr = obj->GetForwardingPtr(); #else PolyObject *newAddr = obj->GetForwardingPtr(); #endif *pt = newAddr; return 0; // No need to scan it again. } else if (space->spaceType == ST_PERMANENT) { // See if we have this in the grave-yard. for (unsigned i = 0; i < tombs; i++) { GraveYard *g = &graveYard[i]; if ((PolyWord*)obj >= g->startAddr && (PolyWord*)obj < g->endAddr) { PolyWord *tombAddr = g->graves + ((PolyWord*)obj - g->startAddr); PolyObject *tombObject = (PolyObject*)tombAddr; if (tombObject->ContainsForwardingPtr()) { #ifdef POLYML32IN64 PolyObject *newAddr; if (space->isCode) newAddr = (PolyObject*)(globalCodeBase + ((tombObject->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else newAddr = tombObject->GetForwardingPtr(); #else PolyObject *newAddr = tombObject->GetForwardingPtr(); #endif *pt = newAddr; return 0; } break; // No need to look further } } } // No, we need to copy it. ASSERT(space->spaceType == ST_LOCAL || space->spaceType == ST_PERMANENT || space->spaceType == ST_CODE); POLYUNSIGNED lengthWord = obj->LengthWord(); POLYUNSIGNED originalLengthWord = lengthWord; POLYUNSIGNED words = OBJ_OBJECT_LENGTH(lengthWord); enum _newAddrType naType; if (obj->IsMutable()) { if (obj->IsNoOverwriteObject()) naType = NANoOverwriteMutable; else naType = NAMutable; } else if (obj->IsCodeObject()) naType = NACode; else if (obj->IsByteObject()) naType = NAByte; else naType = NAWord; PolyObject* newObj; #if((defined(HOSTARCHITECTURE_X86_64) || defined(HOSTARCHITECTURE_AARCH64)) && ! defined(POLYML32IN64) && !defined(CODEISNOTEXECUTABLE) && !defined(_WIN32)) // SELinux, OpenBSD and Mac OS, at least on the ARM, require or prefer executavle code segments without // absolute addresses: position-independent code. // That means the constant area cannot be in the same segment as the code. We have to split the constant area // out and put it into the read-only, non-executable area. // Interpreted code and code for 32-in-64 aren't executable (32-in-64 code is copied during start-up). // We also don't need this on Windows, thankfully. if (obj->IsCodeObject() && hierarchy == 0) { PolyWord* constPtr; POLYUNSIGNED numConsts; machineDependent->GetConstSegmentForCode(obj, constPtr, numConsts); // Newly generated code will have the constants included with the code // but if this is in the executable the constants will have been extracted before. bool constsWereIncluded = constPtr > (PolyWord*)obj && constPtr < ((PolyWord*)obj) + words; POLYUNSIGNED codeAreaSize = words; if (constsWereIncluded) codeAreaSize -= numConsts + 1; newObj = newAddressForObject(codeAreaSize, NACode); PolyObject* writableObj = gMem.SpaceForObjectAddress(newObj)->writeAble(newObj); writableObj->SetLengthWord(codeAreaSize, F_CODE_OBJ); // set length word lengthWord = newObj->LengthWord(); // Get the actual length word used memcpy(writableObj, obj, codeAreaSize * sizeof(PolyWord)); PolyObject* newConsts = newAddressForObject(numConsts, NACodeConst); PolyObject* writableConsts = gMem.SpaceForObjectAddress(newConsts)->writeAble(newConsts); writableConsts->SetLengthWord(numConsts); memcpy(writableConsts, constPtr, numConsts * sizeof(PolyWord)); machineDependent->SetAddressOfConstants(newObj, writableObj, codeAreaSize, (PolyWord*)newConsts); } else #endif { newObj = newAddressForObject(words, naType); PolyObject* writAble = gMem.SpaceForObjectAddress(newObj)->writeAble(newObj); writAble->SetLengthWord(lengthWord); // copy length word if (hierarchy == 0 /* Exporting object module */ && obj->IsNoOverwriteObject() && ! obj->IsByteObject()) { // These are not exported. They are used for special values e.g. mutexes // that should be set to 0/nil/NONE at start-up. // Weak+No-overwrite byte objects are used for entry points and volatiles // in the foreign-function interface and have to be treated specially. // Note: this must not be done when exporting a saved state because the // copied version is used as the local data for the rest of the session. for (POLYUNSIGNED i = 0; i < words; i++) writAble->Set(i, TAGGED(0)); } else memcpy(writAble, obj, words * sizeof(PolyWord)); } if (space->spaceType == ST_PERMANENT && !space->isMutable && ((PermanentMemSpace*)space)->hierarchy == 0) { // The immutable permanent areas are read-only. unsigned m; for (m = 0; m < tombs; m++) { GraveYard *g = &graveYard[m]; if ((PolyWord*)obj >= g->startAddr && (PolyWord*)obj < g->endAddr) { PolyWord *tombAddr = g->graves + ((PolyWord*)obj - g->startAddr); PolyObject *tombObject = (PolyObject*)tombAddr; #ifdef POLYML32IN64 if (naType == NACode) { POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj - globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT); tombObject->SetLengthWord(ll); } else tombObject->SetForwardingPtr(newObj); #else tombObject->SetForwardingPtr(newObj); #endif break; // No need to look further } } ASSERT(m < tombs); // Should be there. } else if (naType == NACode) #ifdef POLYML32IN64 // If this is a code address we can't use the usual forwarding pointer format. // Instead we have to compute the offset relative to the base of the code. { POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj-globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT); gMem.SpaceForObjectAddress(obj)->writeAble(obj)->SetLengthWord(ll); } #else gMem.SpaceForObjectAddress(obj)->writeAble(obj)->SetForwardingPtr(newObj); #endif else obj->SetForwardingPtr(newObj); // Put forwarding pointer in old object. if (naType == NACode) { // We should flush the instruction cache here since we will execute the code // at this location if this is a saved state. machineDependent->FlushInstructionCache(newObj, newObj->Length()); // We have to update any relative addresses within the code // to take account of its new position. We have to do that now // even though ScanAddressesInObject will do it again because this // is the only point where we have both the old and the new addresses. PolyWord *oldConstAddr; POLYUNSIGNED count; machineDependent->GetConstSegmentForCode(obj, OBJ_OBJECT_LENGTH(originalLengthWord), oldConstAddr, count); PolyWord *newConstAddr = machineDependent->ConstPtrForCode(newObj); machineDependent->ScanConstantsWithinCode(newObj, obj, newObj->Length(), newConstAddr, oldConstAddr, count, this); } *pt = newObj; // Update it to the newly copied object. return lengthWord; // This new object needs to be scanned. } PolyObject* CopyScan::newAddressForObject(POLYUNSIGNED words, enum _newAddrType naType) { PolyObject* newObj = 0; // Allocate a new address for the object. for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { PermanentMemSpace* space = *i; bool match = false; switch (naType) { case NAWord: match = !space->isMutable && !space->byteOnly && !space->isCode; break; case NAMutable: match = space->isMutable && !space->noOverwrite; break; case NANoOverwriteMutable: match = space->isMutable && space->noOverwrite; break; case NAByte: match = !space->isMutable && space->byteOnly; break; case NACode: match = !space->isMutable && space->isCode && !space->constArea; break; case NACodeConst: match = !space->isMutable && space->isCode && space->constArea; break; } if (match) { ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom); size_t spaceLeft = space->top - space->topPointer; if (spaceLeft > words) { newObj = (PolyObject*)(space->topPointer + 1); space->topPointer += words + 1; #ifdef POLYML32IN64 // Maintain the odd-word alignment of topPointer if ((words & 1) == 0 && space->topPointer < space->top) { *space->writeAble(space->topPointer) = PolyWord::FromUnsigned(0); space->topPointer++; } #endif break; } } } if (newObj == 0) { // Didn't find room in the existing spaces. Create a new space. uintptr_t spaceWords; switch (naType) { case NAMutable: spaceWords = defaultMutSize; break; case NANoOverwriteMutable: spaceWords = defaultNoOverSize; break; case NACode: spaceWords = defaultCodeSize; break; case NACodeConst: spaceWords = defaultCodeSize; break; default: spaceWords = defaultImmSize; } if (spaceWords <= words) spaceWords = words + 1; // Make sure there's space for this object. PermanentMemSpace* space = gMem.NewExportSpace(spaceWords, naType == NAMutable || naType == NANoOverwriteMutable, naType == NANoOverwriteMutable, naType == NACode || naType == NACodeConst); if (naType == NAByte) space->byteOnly = true; if (naType == NACodeConst) space->constArea = true; if (space == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate export space, size: %lu.\n", spaceWords); // Unable to allocate this. throw MemoryException(); } newObj = (PolyObject*)(space->topPointer + 1); space->topPointer += words + 1; #ifdef POLYML32IN64 // Maintain the odd-word alignment of topPointer if ((words & 1) == 0 && space->topPointer < space->top) { *space->writeAble(space->topPointer) = PolyWord::FromUnsigned(0); space->topPointer++; } #endif ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom); } return newObj; } // The address of code in the code area. We treat this as a normal heap cell. // We will probably need to copy this and to process addresses within it. POLYUNSIGNED CopyScan::ScanCodeAddressAt(PolyObject **pt) { POLYUNSIGNED lengthWord = ScanAddress(pt); if (lengthWord) ScanAddressesInObject(*pt, lengthWord); return 0; } PolyObject *CopyScan::ScanObjectAddress(PolyObject *base) { PolyWord val = base; // Scan this as an address. POLYUNSIGNED lengthWord = CopyScan::ScanAddressAt(&val); if (lengthWord) ScanAddressesInObject(val.AsObjPtr(), lengthWord); return val.AsObjPtr(); } #define MAX_EXTENSION 4 // The longest extension we may need to add is ".obj" // Convert the forwarding pointers in a region back into length words. // Generally if this object has a forwarding pointer that's // because we've moved it into the export region. We can, // though, get multiple levels of forwarding if there is an object // that has been shifted up by a garbage collection, leaving a forwarding // pointer and then that object has been moved to the export region. // We mustn't turn locally forwarded values back into ordinary objects // because they could contain addresses that are no longer valid. static POLYUNSIGNED GetObjLength(PolyObject *obj) { if (obj->ContainsForwardingPtr()) { PolyObject *forwardedTo; #ifdef POLYML32IN64 { MemSpace *space = gMem.SpaceForObjectAddress(obj); if (space->isCode) forwardedTo = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else forwardedTo = obj->GetForwardingPtr(); } #else forwardedTo = obj->GetForwardingPtr(); #endif POLYUNSIGNED length = GetObjLength(forwardedTo); MemSpace *space = gMem.SpaceForObjectAddress(forwardedTo); if (space->spaceType == ST_EXPORT) { // If this is a code object whose constant area has been split off we // need to add the length of the constant area. if (forwardedTo->IsCodeObject()) { PolyWord* constPtr; POLYUNSIGNED numConsts; machineDependent->GetConstSegmentForCode(forwardedTo, constPtr, numConsts); if (!(constPtr > (PolyWord*)forwardedTo && constPtr < ((PolyWord*)forwardedTo) + OBJ_OBJECT_LENGTH(length))) length += numConsts + 1; } gMem.SpaceForObjectAddress(obj)->writeAble(obj)->SetLengthWord(length); } return length; } else { ASSERT(obj->ContainsNormalLengthWord()); return obj->LengthWord(); } } static void FixForwarding(PolyWord *pt, size_t space) { while (space) { pt++; PolyObject *obj = (PolyObject*)pt; #ifdef POLYML32IN64 if ((uintptr_t)obj & 4) { // Skip filler words needed to align to an even word space--; continue; // We've added 1 to pt so just loop. } #endif size_t length = OBJ_OBJECT_LENGTH(GetObjLength(obj)); pt += length; ASSERT(space > length); space -= length+1; } } class ExportRequest: public MainThreadRequest { public: ExportRequest(Handle root, Exporter *exp): MainThreadRequest(MTP_EXPORTING), exportRoot(root), exporter(exp) {} virtual void Perform() { exporter->RunExport(exportRoot->WordP()); } Handle exportRoot; Exporter *exporter; }; static void exporter(TaskData *taskData, Handle fileName, Handle root, const TCHAR *extension, Exporter *exports) { size_t extLen = _tcslen(extension); TempString fileNameBuff(Poly_string_to_T_alloc(fileName->Word(), extLen)); if (fileNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); size_t length = _tcslen(fileNameBuff); // Does it already have the extension? If not add it on. if (length < extLen || _tcscmp(fileNameBuff + length - extLen, extension) != 0) _tcscat(fileNameBuff, extension); #if (defined(_WIN32) && defined(UNICODE)) exports->exportFile = _wfopen(fileNameBuff, L"wb"); #else exports->exportFile = fopen(fileNameBuff, "wb"); #endif if (exports->exportFile == NULL) raise_syscall(taskData, "Cannot open export file", ERRORNUMBER); // Request a full GC to reduce the size of fix-ups. FullGC(taskData); // Request the main thread to do the export. ExportRequest request(root, exports); processes->MakeRootRequest(taskData, &request); if (exports->errorMessage) raise_fail(taskData, exports->errorMessage); } // This is called by the initial thread to actually do the export. void Exporter::RunExport(PolyObject *rootFunction) { Exporter *exports = this; PolyObject *copiedRoot = 0; CopyScan copyScan(hierarchy); try { copyScan.initialise(); // Copy the root and everything reachable from it into the temporary area. copiedRoot = copyScan.ScanObjectAddress(rootFunction); } catch (MemoryException &) { // If we ran out of memory. copiedRoot = 0; } // Fix the forwarding pointers. for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; // Local areas only have objects from the allocation pointer to the top. FixForwarding(space->bottom, space->lowerAllocPtr - space->bottom); FixForwarding(space->upperAllocPtr, space->top - space->upperAllocPtr); } for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. FixForwarding(space->bottom, space->top - space->bottom); } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { MemSpace *space = *i; // Code areas are filled with objects from the bottom. FixForwarding(space->bottom, space->top - space->bottom); } // Reraise the exception after cleaning up the forwarding pointers. if (copiedRoot == 0) { exports->errorMessage = "Insufficient Memory"; return; } // Copy the areas into the export object. size_t tableEntries = gMem.eSpaces.size(); unsigned memEntry = 0; if (hierarchy != 0) tableEntries += gMem.pSpaces.size(); exports->memTable = new memoryTableEntry[tableEntries]; // If we're constructing a module we need to include the global spaces. if (hierarchy != 0) { // Permanent spaces from the executable. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->hierarchy < hierarchy) { memoryTableEntry *entry = &exports->memTable[memEntry++]; entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom; entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord); entry->mtIndex = space->index; entry->mtFlags = 0; if (space->isMutable) entry->mtFlags |= MTF_WRITEABLE; if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; } } newAreas = memEntry; } for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { memoryTableEntry *entry = &exports->memTable[memEntry++]; PermanentMemSpace *space = *i; entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom; entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord); entry->mtIndex = hierarchy == 0 ? memEntry-1 : space->index; entry->mtFlags = 0; if (space->isMutable) { entry->mtFlags = MTF_WRITEABLE; if (space->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE; } if (space->isCode && !space->constArea) entry->mtFlags |= MTF_EXECUTABLE; if (space->byteOnly) entry->mtFlags |= MTF_BYTES; } ASSERT(memEntry == tableEntries); exports->memTableEntries = memEntry; exports->rootFunction = copiedRoot; try { // This can raise MemoryException at least in PExport::exportStore. exports->exportStore(); } catch (MemoryException &) { exports->errorMessage = "Insufficient Memory"; } } // Functions called via the RTS call. Handle exportNative(TaskData *taskData, Handle args) { #ifdef HAVE_PECOFF // Windows including Cygwin #if (defined(_WIN32)) const TCHAR *extension = _T(".obj"); // Windows #else const char *extension = ".o"; // Cygwin #endif PECOFFExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) // Most Unix including Linux, FreeBSD and Solaris. const char *extension = ".o"; ELFExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #elif defined(HAVE_MACH_O_RELOC_H) // Mac OS-X const char *extension = ".o"; MachoExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #else raise_exception_string (taskData, EXC_Fail, "Native export not available for this platform"); #endif return taskData->saveVec.push(TAGGED(0)); } Handle exportPortable(TaskData *taskData, Handle args) { PExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), _T(".txt"), &exports); return taskData->saveVec.push(TAGGED(0)); } -POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root) +POLYUNSIGNED PolyExport(POLYUNSIGNED threadId, POLYUNSIGNED fileName, POLYUNSIGNED root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedName = taskData->saveVec.push(fileName); Handle pushedRoot = taskData->saveVec.push(root); try { #ifdef HAVE_PECOFF // Windows including Cygwin #if (defined(_WIN32)) const TCHAR *extension = _T(".obj"); // Windows #else const char *extension = ".o"; // Cygwin #endif PECOFFExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) // Most Unix including Linux, FreeBSD and Solaris. const char *extension = ".o"; ELFExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #elif defined(HAVE_MACH_O_RELOC_H) // Mac OS-X const char *extension = ".o"; MachoExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #else raise_exception_string (taskData, EXC_Fail, "Native export not available for this platform"); #endif } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Returns unit } -POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord root) +POLYUNSIGNED PolyExportPortable(POLYUNSIGNED threadId, POLYUNSIGNED fileName, POLYUNSIGNED root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedName = taskData->saveVec.push(fileName); Handle pushedRoot = taskData->saveVec.push(root); try { PExport exports; exporter(taskData, pushedName, pushedRoot, _T(".txt"), &exports); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Returns unit } // Helper functions for exporting. We need to produce relocation information // and this code is common to every method. Exporter::Exporter(unsigned int h): exportFile(NULL), errorMessage(0), hierarchy(h), memTable(0), newAreas(0) { } Exporter::~Exporter() { delete[](memTable); if (exportFile) fclose(exportFile); } void Exporter::relocateValue(PolyWord *pt) { #ifndef POLYML32IN64 PolyWord q = *pt; if (IS_INT(q) || q == PolyWord::FromUnsigned(0)) {} else createRelocation(pt); #endif } void Exporter::createRelocation(PolyWord* pt) { *gMem.SpaceForAddress(pt)->writeAble(pt) = createRelocation(*pt, pt); } // Check through the areas to see where the address is. It must be // in one of them. unsigned Exporter::findArea(void *p) { for (unsigned i = 0; i < memTableEntries; i++) { if (p > memTable[i].mtOriginalAddr && p <= (char*)memTable[i].mtOriginalAddr + memTable[i].mtLength) return i; } { ASSERT(0); } return 0; } void Exporter::relocateObject(PolyObject *p) { if (p->IsByteObject()) { if (p->IsMutable() && p->IsWeakRefObject()) { // Weak mutable byte refs are used for external references and // also in the FFI for non-persistent values. bool isFuncPtr = true; const char *entryName = getEntryPointName(p, &isFuncPtr); if (entryName != 0) addExternalReference(p, entryName, isFuncPtr); // Clear the first word of the data. ASSERT(p->Length() >= sizeof(uintptr_t)/sizeof(PolyWord)); *(uintptr_t*)p = 0; } } else if (p->IsCodeObject()) { POLYUNSIGNED constCount; PolyWord *cp; ASSERT(! p->IsMutable() ); machineDependent->GetConstSegmentForCode(p, cp, constCount); /* Now the constants. */ for (POLYUNSIGNED i = 0; i < constCount; i++) relocateValue(&(cp[i])); } else // Closure and ordinary objects { POLYUNSIGNED length = p->Length(); for (POLYUNSIGNED i = 0; i < length; i++) relocateValue(p->Offset(i)); } } ExportStringTable::ExportStringTable(): strings(0), stringSize(0), stringAvailable(0) { } ExportStringTable::~ExportStringTable() { free(strings); } // Add a string to the string table, growing it if necessary. unsigned long ExportStringTable::makeEntry(const char *str) { unsigned len = (unsigned)strlen(str); unsigned long entry = stringSize; if (stringSize + len + 1 > stringAvailable) { stringAvailable = stringAvailable+stringAvailable/2; if (stringAvailable < stringSize + len + 1) stringAvailable = stringSize + len + 1 + 500; char* newStrings = (char*)realloc(strings, stringAvailable); if (newStrings == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to realloc string table, size: %lu.\n", stringAvailable); throw MemoryException(); } else strings = newStrings; } strcpy(strings + stringSize, str); stringSize += len + 1; return entry; } struct _entrypts exporterEPT[] = { { "PolyExport", (polyRTSFunction)&PolyExport}, { "PolyExportPortable", (polyRTSFunction)&PolyExportPortable}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/network.cpp b/libpolyml/network.cpp index e17b61eb..81a63506 100644 --- a/libpolyml/network.cpp +++ b/libpolyml/network.cpp @@ -1,2222 +1,2222 @@ /* Title: Network functions. Copyright (c) 2000-7, 2016, 2018, 2019 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 */ #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_ERRNO_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_UNISTD_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_NETDB_H #include #endif #ifdef HAVE_SYS_SOCKET_H #include #endif #ifdef HAVE_NETINET_IN_H #include #endif #ifdef HAVE_NETINET_TCP_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SYS_UN_H #include #endif #ifdef HAVE_SYS_FILIO_H #include #endif #ifdef HAVE_SYS_SOCKIO_H #include #endif #ifdef HAVE_SYS_SELECT_H #include #endif #ifdef HAVE_ARPA_INET_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #ifndef HAVE_SOCKLEN_T typedef int socklen_t; #endif #if (defined(_WIN32)) #include #include // For getaddrinfo #else typedef int SOCKET; #endif #ifdef HAVE_WINDOWS_H #include #endif #include #include "globals.h" #include "gc.h" #include "arb.h" #include "run_time.h" #include "mpoly.h" #include "processes.h" #include "network.h" #include "io_internal.h" #include "sys.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "machine_dep.h" #include "errors.h" #include "rtsentry.h" #include "timing.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddrList(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSockTypeList(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateSocket(FirstArgument threadId, PolyWord af, PolyWord st, PolyWord prot); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSetOption(FirstArgument threadId, PolyWord code, PolyWord sock, PolyWord opt); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetOption(FirstArgument threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSetLinger(FirstArgument threadId, PolyWord sock, PolyWord linger); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetLinger(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetPeerName(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSockName(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkBytesAvailable(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAtMark(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkBind(FirstArgument threadId, PolyWord sock, PolyWord addr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkListen(FirstArgument threadId, PolyWord sock, PolyWord back); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkShutdown(FirstArgument threadId, PolyWord skt, PolyWord smode); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateSocketPair(FirstArgument threadId, PolyWord af, PolyWord st, PolyWord prot); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkUnixPathToSockAddr(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkUnixSockAddrToPath(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByName(FirstArgument threadId, PolyWord servName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(FirstArgument threadId, PolyWord servName, PolyWord protName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPort(FirstArgument threadId, PolyWord portNo); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(FirstArgument threadId, PolyWord portNo, PolyWord protName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByName(FirstArgument threadId, PolyWord protocolName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByNo(FirstArgument threadId, PolyWord protoNo); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostName(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddrInfo(FirstArgument threadId, PolyWord hostName, PolyWord addrFamily); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetNameInfo(FirstArgument threadId, PolyWord sockAddr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCloseSocket(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(FirstArgument threadId, PolyWord fdVecTriple, PolyWord maxMillisecs); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSocketError(FirstArgument threadId, PolyWord skt); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(FirstArgument threadId, PolyWord skt, PolyWord addr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(FirstArgument threadId, PolyWord skt); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(FirstArgument threadId, PolyWord args); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(FirstArgument threadId, PolyWord args); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(FirstArgument threadId, PolyWord args); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(FirstArgument threadId, PolyWord args); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetFamilyFromAddress(PolyWord sockAddress); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP4(FirstArgument threadId, PolyWord sockAddress); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP4Address(FirstArgument threadId, PolyWord ip4Address, PolyWord portNumber); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP4AddressAny(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP6(FirstArgument threadId, PolyWord sockAddress); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP6Address(FirstArgument threadId, PolyWord ip6Address, PolyWord portNumber); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP6AddressAny(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkIP6AddressToString(FirstArgument threadId, PolyWord ip6Address); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkStringToIP6Address(FirstArgument threadId, PolyWord stringRep); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddrList(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSockTypeList(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateSocket(POLYUNSIGNED threadId, POLYUNSIGNED af, POLYUNSIGNED st, POLYUNSIGNED prot); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSetOption(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED sock, POLYUNSIGNED opt); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetOption(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSetLinger(POLYUNSIGNED threadId, POLYUNSIGNED sock, POLYUNSIGNED linger); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetLinger(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetPeerName(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSockName(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkBytesAvailable(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAtMark(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkBind(POLYUNSIGNED threadId, POLYUNSIGNED sock, POLYUNSIGNED addr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkListen(POLYUNSIGNED threadId, POLYUNSIGNED sock, POLYUNSIGNED back); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkShutdown(POLYUNSIGNED threadId, POLYUNSIGNED skt, POLYUNSIGNED smode); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateSocketPair(POLYUNSIGNED threadId, POLYUNSIGNED af, POLYUNSIGNED st, POLYUNSIGNED prot); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkUnixPathToSockAddr(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkUnixSockAddrToPath(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByName(POLYUNSIGNED threadId, POLYUNSIGNED servName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(POLYUNSIGNED threadId, POLYUNSIGNED servName, POLYUNSIGNED protName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPort(POLYUNSIGNED threadId, POLYUNSIGNED portNo); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(POLYUNSIGNED threadId, POLYUNSIGNED portNo, POLYUNSIGNED protName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByName(POLYUNSIGNED threadId, POLYUNSIGNED protocolName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByNo(POLYUNSIGNED threadId, POLYUNSIGNED protoNo); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostName(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddrInfo(POLYUNSIGNED threadId, POLYUNSIGNED hostName, POLYUNSIGNED addrFamily); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetNameInfo(POLYUNSIGNED threadId, POLYUNSIGNED sockAddr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCloseSocket(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(POLYUNSIGNED threadId, POLYUNSIGNED fdVecTriple, POLYUNSIGNED maxMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSocketError(POLYUNSIGNED threadId, POLYUNSIGNED skt); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(POLYUNSIGNED threadId, POLYUNSIGNED skt, POLYUNSIGNED addr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(POLYUNSIGNED threadId, POLYUNSIGNED skt); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(POLYUNSIGNED threadId, POLYUNSIGNED args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(POLYUNSIGNED threadId, POLYUNSIGNED args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(POLYUNSIGNED threadId, POLYUNSIGNED args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(POLYUNSIGNED threadId, POLYUNSIGNED args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetFamilyFromAddress(POLYUNSIGNED sockAddress); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP4(POLYUNSIGNED threadId, POLYUNSIGNED sockAddress); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP4Address(POLYUNSIGNED threadId, POLYUNSIGNED ip4Address, POLYUNSIGNED portNumber); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP4AddressAny(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP6(POLYUNSIGNED threadId, POLYUNSIGNED sockAddress); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP6Address(POLYUNSIGNED threadId, POLYUNSIGNED ip6Address, POLYUNSIGNED portNumber); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP6AddressAny(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkIP6AddressToString(POLYUNSIGNED threadId, POLYUNSIGNED ip6Address); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkStringToIP6Address(POLYUNSIGNED threadId, POLYUNSIGNED stringRep); } #define SAVE(x) taskData->saveVec.push(x) #define ALLOC(n) alloc_and_save(taskData, n) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) #if (defined(_WIN32)) static int winsock_init = 0; /* Check that it has been initialised. */ #else #define INVALID_SOCKET (-1) #define SOCKET_ERROR (-1) #endif #ifndef HAVE_SOCKLEN_T typedef int socklen_t; // This must be int for Windows at least #endif #ifndef SHUT_RD #define SHUT_RD 0 #endif #ifndef SHUT_WR #define SHUT_WR 1 #endif #ifndef SHUT_RDWR #define SHUT_RDWR 2 #endif /* Address families. Although this table is in ascending numerical order of address family nothing depends on that. The only requirement is that "INET" => AF_INET must always be present and "UNIX" => AF_UNIX must be present on Unix. Other entries are entirely optional and are for amusement only. */ struct af_tab_struct { const char *af_name; int af_num; } af_table[] = { #ifdef AF_UNIX { "UNIX", AF_UNIX }, /* This is nearly always there. */ #endif #ifdef AF_LOCAL { "LOCAL", AF_LOCAL }, #endif { "INET", AF_INET }, /* This one should always be there. */ #ifdef AF_IMPLINK { "IMPLINK", AF_IMPLINK }, #endif #ifdef AF_PUP { "PUP", AF_PUP }, #endif #ifdef AF_CHAOS { "CHAOS", AF_CHAOS }, #endif #ifdef AF_IPX { "IPX", AF_IPX }, #endif #ifdef AF_NS { "NS", AF_NS }, #endif #ifdef AF_ISO { "ISO", AF_ISO }, #endif #ifdef AF_OSI { "OSI", AF_OSI }, #endif #ifdef AF_ECMA { "ECMA", AF_ECMA }, #endif #ifdef AF_DATAKIT { "DATAKIT", AF_DATAKIT }, #endif #ifdef AF_CCITT { "CCITT", AF_CCITT }, #endif #ifdef AF_SNA { "SNA", AF_SNA }, #endif #ifdef AF_DECnet { "DECnet", AF_DECnet }, #endif #ifdef AF_DLI { "DLI", AF_DLI }, #endif #ifdef AF_LAT { "LAT", AF_LAT }, #endif #ifdef AF_HYLINK { "HYLINK", AF_HYLINK }, #endif #ifdef AF_APPLETALK { "APPLETALK", AF_APPLETALK }, #endif #ifdef AF_NETBIOS { "NETBIOS", AF_NETBIOS }, #endif #ifdef AF_ROUTE { "ROUTE", AF_ROUTE }, #endif #ifdef AF_VOICEVIEW { "VOICEVIEW", AF_VOICEVIEW }, #endif #ifdef AF_FIREFOX { "FIREFOX", AF_FIREFOX }, #endif #ifdef AF_BAN { "BAN", AF_BAN }, #endif #ifdef AF_LINK { "LINK", AF_LINK }, #endif #ifdef AF_COIP { "COIP", AF_COIP }, #endif #ifdef AF_CNT { "CNT", AF_CNT }, #endif #ifdef AF_SIP { "SIP", AF_SIP }, #endif #ifdef AF_ISDN { "ISDN", AF_ISDN }, #endif #ifdef AF_E164 { "E164", AF_E164 }, #endif #ifdef AF_INET6 { "INET6", AF_INET6 }, // This one should always be there. #endif #ifdef AF_NATM { "NATM", AF_NATM }, #endif #ifdef AF_ATM { "ATM", AF_ATM }, #endif #ifdef AF_NETGRAPH { "NETGRAPH", AF_NETGRAPH }, #endif #ifdef AF_CLUSTER { "CLUSTER", AF_CLUSTER }, #endif #ifdef AF_12844 { "12844", AF_12844 }, #endif #ifdef AF_IRDA { "IRDA", AF_IRDA }, #endif #ifdef AF_NETDES { "NETDES", AF_NETDES }, #endif #ifdef AF_TCNPROCESS { "TCNPROCESS", AF_TCNPROCESS }, #endif #ifdef AF_TCNMESSAGE { "TCNMESSAGE", AF_TCNMESSAGE }, #endif #ifdef AF_ICLFXBM { "ICLFXBM", AF_ICLFXBM }, #endif #ifdef AF_BTH { "BTH", AF_BTH }, #endif #ifdef AF_HYPERV { "HYPERV", AF_HYPERV }, #endif #ifdef AF_FILE { "FILE", AF_FILE }, #endif #ifdef AF_AX25 { "AX25", AF_AX25 }, #endif #ifdef AF_NETROM { "NETROM", AF_NETROM }, #endif #ifdef AF_BRIDGE { "BRIDGE", AF_BRIDGE }, #endif #ifdef AF_ATMPVC { "ATMPVC", AF_ATMPVC }, #endif #ifdef AF_X25 { "X25", AF_X25 }, #endif #ifdef AF_ROSE { "ROSE", AF_ROSE }, #endif #ifdef AF_NETBEUI { "NETBEUI", AF_NETBEUI }, #endif #ifdef AF_SECURITY { "SECURITY", AF_SECURITY }, #endif #ifdef AF_KEY { "KEY", AF_KEY }, #endif #ifdef AF_NETLINK { "NETLINK", AF_NETLINK }, #endif #ifdef AF_PACKET { "PACKET", AF_PACKET }, #endif #ifdef AF_ASH { "ASH", AF_ASH }, #endif #ifdef AF_ECONET { "ECONET", AF_ECONET }, #endif #ifdef AF_ATMSVC { "ATMSVC", AF_ATMSVC }, #endif #ifdef AF_RDS { "RDS", AF_RDS }, #endif #ifdef AF_PPPOX { "PPPOX", AF_PPPOX }, #endif #ifdef AF_WANPIPE { "WANPIPE", AF_WANPIPE }, #endif #ifdef AF_LLC { "LLC", AF_LLC }, #endif #ifdef AF_IB { "IB", AF_IB }, #endif #ifdef AF_MPLS { "MPLS", AF_MPLS }, #endif #ifdef AF_CAN { "CAN", AF_CAN }, #endif #ifdef AF_TIPC { "TIPC", AF_TIPC }, #endif #ifdef AF_BLUETOOTH { "BLUETOOTH", AF_BLUETOOTH }, #endif #ifdef AF_IUCV { "IUCV", AF_IUCV }, #endif #ifdef AF_RXRPC { "RXRPC", AF_RXRPC }, #endif #ifdef AF_PHONET { "PHONET", AF_PHONET }, #endif #ifdef AF_IEEE802154 { "IEEE802154", AF_IEEE802154 }, #endif #ifdef AF_CAIF { "CAIF", AF_CAIF }, #endif #ifdef AF_ALG { "ALG", AF_ALG }, #endif #ifdef AF_NFC { "NFC", AF_NFC }, #endif #ifdef AF_VSOCK { "VSOCK", AF_VSOCK }, #endif #ifdef AF_KCM { "KCM", AF_KCM }, #endif }; /* Socket types. Only STREAM and DGRAM are required. */ struct sk_tab_struct { const char *sk_name; int sk_num; } sk_table[] = { { "STREAM", SOCK_STREAM }, { "DGRAM", SOCK_DGRAM }, { "RAW", SOCK_RAW }, { "RDM", SOCK_RDM }, { "SEQPACKET", SOCK_SEQPACKET }, #ifdef SOCK_DCCP { "DCCP", SOCK_DCCP }, #endif }; static Handle makeProtoEntry(TaskData *taskData, struct protoent *proto); static Handle mkAftab(TaskData *taskData, void*, char *p); static Handle mkSktab(TaskData *taskData, void*, char *p); static Handle setSocketOption(TaskData *taskData, Handle sockHandle, Handle optHandle, int level, int opt); static Handle getSocketOption(TaskData *taskData, Handle args, int level, int opt); #if (defined(_WIN32)) #define GETERROR (WSAGetLastError()) #define TOOMANYFILES WSAEMFILE #define NOMEMORY WSA_NOT_ENOUGH_MEMORY #define STREAMCLOSED WSA_INVALID_HANDLE #define WOULDBLOCK WSAEWOULDBLOCK #define INPROGRESS WSAEINPROGRESS #define CALLINTERRUPTED WSAEINTR #undef EBADF #undef EMFILE #undef EAGAIN #undef EINTR #undef EWOULDBLOCK #undef ENOMEM #else #define GETERROR (errno) #define TOOMANYFILES EMFILE #define NOMEMORY ENOMEM #define STREAMCLOSED EBADF #define ERRORNUMBER errno #define FILEDOESNOTEXIST ENOENT #define WOULDBLOCK EWOULDBLOCK #define INPROGRESS EINPROGRESS #define CALLINTERRUPTED EINTR #endif // Wait until "select" returns. In Windows this is used only for networking. class WaitSelect: public Waiter { public: WaitSelect(unsigned maxMillisecs=(unsigned)-1); virtual void Wait(unsigned maxMillisecs); void SetRead(SOCKET fd) { FD_SET(fd, &readSet); } void SetWrite(SOCKET fd) { FD_SET(fd, &writeSet); } void SetExcept(SOCKET fd) { FD_SET(fd, &exceptSet); } bool IsSetRead(SOCKET fd) { return FD_ISSET(fd, &readSet) != 0; } bool IsSetWrite(SOCKET fd) { return FD_ISSET(fd, &writeSet) != 0; } bool IsSetExcept(SOCKET fd) { return FD_ISSET(fd, &exceptSet) != 0; } // Save the result of the select call and any associated error int SelectResult(void) { return selectResult; } int SelectError(void) { return errorResult; } private: fd_set readSet, writeSet, exceptSet; int selectResult; int errorResult; unsigned maxTime; }; WaitSelect::WaitSelect(unsigned maxMillisecs) { FD_ZERO(&readSet); FD_ZERO(&writeSet); FD_ZERO(&exceptSet); selectResult = 0; errorResult = 0; maxTime = maxMillisecs; } void WaitSelect::Wait(unsigned maxMillisecs) { if (maxTime < maxMillisecs) maxMillisecs = maxTime; struct timeval toWait = { 0, 0 }; toWait.tv_sec = maxMillisecs / 1000; toWait.tv_usec = (maxMillisecs % 1000) * 1000; selectResult = select(FD_SETSIZE, &readSet, &writeSet, &exceptSet, &toWait); if (selectResult < 0) errorResult = GETERROR; } #if (defined(_WIN32)) class WinSocket : public WinStreamBase { public: WinSocket(SOCKET skt) : socket(skt) {} virtual SOCKET getSocket() { return socket; } virtual int pollTest() { // We can poll for any of these. return POLL_BIT_IN | POLL_BIT_OUT | POLL_BIT_PRI; } virtual int poll(TaskData *taskData, int test); public: SOCKET socket; }; // Poll without blocking. int WinSocket::poll(TaskData *taskData, int bits) { int result = 0; if (bits & POLL_BIT_PRI) { u_long atMark = 0; if (ioctlsocket(socket, SIOCATMARK, &atMark) != 0) raise_syscall(taskData, "ioctlsocket failed", GETERROR); if (atMark) { result |= POLL_BIT_PRI; } } if (bits & (POLL_BIT_IN | POLL_BIT_OUT)) { FD_SET readFds, writeFds; TIMEVAL poll = { 0, 0 }; FD_ZERO(&readFds); FD_ZERO(&writeFds); if (bits & POLL_BIT_IN) FD_SET(socket, &readFds); if (bits & POLL_BIT_OUT) FD_SET(socket, &writeFds); int selRes = select(FD_SETSIZE, &readFds, &writeFds, NULL, &poll); if (selRes < 0) raise_syscall(taskData, "select failed", GETERROR); else if (selRes > 0) { // N.B. select only tells us about out-of-band data if SO_OOBINLINE is FALSE. */ if (FD_ISSET(socket, &readFds)) result |= POLL_BIT_IN; if (FD_ISSET(socket, &writeFds)) result |= POLL_BIT_OUT; } } return result; } static SOCKET getStreamSocket(TaskData *taskData, PolyWord strm) { WinSocket *winskt = *(WinSocket**)(strm.AsObjPtr()); if (winskt == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return winskt->getSocket(); } static Handle wrapStreamSocket(TaskData *taskData, SOCKET skt) { try { WinSocket *winskt = new WinSocket(skt); return MakeVolatileWord(taskData, winskt); } catch (std::bad_alloc&) { raise_syscall(taskData, "Insufficient memory", NOMEMORY); } } #else static SOCKET getStreamSocket(TaskData *taskData, PolyWord strm) { return getStreamFileDescriptor(taskData, strm); } static Handle wrapStreamSocket(TaskData *taskData, SOCKET skt) { return wrapFileDescriptor(taskData, skt); } #endif static Handle makeProtoEntry(TaskData *taskData, struct protoent *proto) { int i; char **p; Handle aliases, name, protocol, result; /* Canonical name. */ name = SAVE(C_string_to_Poly(taskData, proto->p_name)); /* Aliases. */ for (i=0, p = proto->p_aliases; *p != NULL; p++, i++); aliases = convert_string_list(taskData, i, proto->p_aliases); /* Protocol number. */ protocol = Make_fixed_precision(taskData, proto->p_proto); /* Make the result structure. */ result = ALLOC(3); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, aliases->Word()); DEREFHANDLE(result)->Set(2, protocol->Word()); return result; } static Handle makeServEntry(TaskData *taskData, struct servent *serv) { int i; char **p; Handle aliases, name, protocol, result, port; /* Canonical name. */ name = SAVE(C_string_to_Poly(taskData, serv->s_name)); /* Aliases. */ for (i=0, p = serv->s_aliases; *p != NULL; p++, i++); aliases = convert_string_list(taskData, i, serv->s_aliases); /* Port number. */ port = Make_fixed_precision(taskData, ntohs(serv->s_port)); /* Protocol name. */ protocol = SAVE(C_string_to_Poly(taskData, serv->s_proto)); /* Make the result structure. */ result = ALLOC(4); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, aliases->Word()); DEREFHANDLE(result)->Set(2, port->Word()); DEREFHANDLE(result)->Set(3, protocol->Word()); return result; } static Handle mkAftab(TaskData *taskData, void *arg, char *p) { struct af_tab_struct *af = (struct af_tab_struct *)p; Handle result, name, num; /* Construct a pair of the string and the number. */ name = SAVE(C_string_to_Poly(taskData, af->af_name)); num = Make_fixed_precision(taskData, af->af_num); result = ALLOC(2); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, num->Word()); return result; } static Handle mkSktab(TaskData *taskData, void *arg, char *p) { struct sk_tab_struct *sk = (struct sk_tab_struct *)p; Handle result, name, num; /* Construct a pair of the string and the number. */ name = SAVE(C_string_to_Poly(taskData, sk->sk_name)); num = Make_fixed_precision(taskData, sk->sk_num); result = ALLOC(2); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, num->Word()); return result; } /* This sets an option and can also be used to set an integer. */ static Handle setSocketOption(TaskData *taskData, Handle sockHandle, Handle optHandle, int level, int opt) { SOCKET sock = getStreamSocket(taskData, sockHandle->Word()); int onOff = get_C_int(taskData, optHandle->Word()); if (setsockopt(sock, level, opt, (char*)&onOff, sizeof(int)) != 0) raise_syscall(taskData, "setsockopt failed", GETERROR); return Make_fixed_precision(taskData, 0); } // Get a socket option as an integer. static Handle getSocketOption(TaskData *taskData, Handle args, int level, int opt) { SOCKET sock = getStreamSocket(taskData, args->Word()); int optVal = 0; socklen_t size = sizeof(int); if (getsockopt(sock, level, opt, (char*)&optVal, &size) != 0) raise_syscall(taskData, "getsockopt failed", GETERROR); return Make_fixed_precision(taskData, optVal); } // Get and clear the error state for the socket. Returns a SysWord.word value. -POLYUNSIGNED PolyNetworkGetSocketError(FirstArgument threadId, PolyWord skt) +POLYUNSIGNED PolyNetworkGetSocketError(POLYUNSIGNED threadId, POLYUNSIGNED skt) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - SOCKET sock = getStreamSocket(taskData, skt); + SOCKET sock = getStreamSocket(taskData, PolyWord::FromUnsigned(skt)); int intVal = 0; socklen_t size = sizeof(int); if (getsockopt(sock, SOL_SOCKET, SO_ERROR, (char*)&intVal, &size) != 0) raise_syscall(taskData, "getsockopt failed", GETERROR); result = Make_sysword(taskData, intVal); } 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(); } // Helper function for selectCall. Creates the result vector of active sockets. static bool testBit(int offset, SOCKET fd, WaitSelect *pSelect) { switch (offset) { case 0: return pSelect->IsSetRead(fd); case 1: return pSelect->IsSetWrite(fd); case 2: return pSelect->IsSetExcept(fd); default: return false; } } static Handle getSelectResult(TaskData *taskData, Handle args, int offset, WaitSelect *pSelect) { /* Construct the result vectors. */ PolyObject *inVec = DEREFHANDLE(args)->Get(offset).AsObjPtr(); POLYUNSIGNED nVec = inVec->Length(); int nRes = 0; POLYUNSIGNED i; for (i = 0; i < nVec; i++) { SOCKET sock = getStreamSocket(taskData, inVec->Get(i)); if (testBit(offset, sock, pSelect)) nRes++; } if (nRes == 0) return ALLOC(0); /* None - return empty vector. */ else { Handle result = ALLOC(nRes); inVec = DEREFHANDLE(args)->Get(offset).AsObjPtr(); /* It could have moved as a result of a gc. */ nRes = 0; for (i = 0; i < nVec; i++) { SOCKET sock = getStreamSocket(taskData, inVec->Get(i)); if (testBit(offset, sock, pSelect)) DEREFWORDHANDLE(result)->Set(nRes++, inVec->Get(i)); } return result; } } /* Wrapper for "select" call. The arguments are arrays of socket ids. These arrays are updated so that "active" sockets are left unchanged and inactive sockets are set to minus one. */ -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(FirstArgument threadId, PolyWord fdVecTriple, PolyWord maxMillisecs) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(POLYUNSIGNED threadId, POLYUNSIGNED fdVecTriple, POLYUNSIGNED maxMillisecs) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; - POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned(); + POLYUNSIGNED maxMilliseconds = PolyWord::FromUnsigned(maxMillisecs).UnTaggedUnsigned(); Handle fdVecTripleHandle = taskData->saveVec.push(fdVecTriple); /* Set up the bitmaps for the select call from the arrays. */ try { WaitSelect waitSelect((unsigned int)maxMilliseconds); PolyObject *readVec = fdVecTripleHandle->WordP()->Get(0).AsObjPtr(); PolyObject *writeVec = fdVecTripleHandle->WordP()->Get(1).AsObjPtr(); PolyObject *excVec = fdVecTripleHandle->WordP()->Get(2).AsObjPtr(); for (POLYUNSIGNED i = 0; i < readVec->Length(); i++) waitSelect.SetRead(getStreamSocket(taskData, readVec->Get(i))); for (POLYUNSIGNED i = 0; i < writeVec->Length(); i++) waitSelect.SetWrite(getStreamSocket(taskData, writeVec->Get(i))); for (POLYUNSIGNED i = 0; i < excVec->Length(); i++) waitSelect.SetExcept(getStreamSocket(taskData, excVec->Get(i))); // Do the select. This may return immediately if the maximum time-out is short. processes->ThreadPauseForIO(taskData, &waitSelect); if (waitSelect.SelectResult() < 0) raise_syscall(taskData, "select failed", waitSelect.SelectError()); // Construct the result vectors. Handle rdResult = getSelectResult(taskData, fdVecTripleHandle, 0, &waitSelect); Handle wrResult = getSelectResult(taskData, fdVecTripleHandle, 1, &waitSelect); Handle exResult = getSelectResult(taskData, fdVecTripleHandle, 2, &waitSelect); result = ALLOC(3); DEREFHANDLE(result)->Set(0, rdResult->Word()); DEREFHANDLE(result)->Set(1, wrResult->Word()); DEREFHANDLE(result)->Set(2, exResult->Word()); } 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(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(FirstArgument threadId, PolyWord skt, PolyWord addr) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(POLYUNSIGNED threadId, POLYUNSIGNED skt, POLYUNSIGNED addr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - SOCKET sock = getStreamSocket(taskData, skt); - PolyStringObject * psAddr = (PolyStringObject *)(addr.AsObjPtr()); + SOCKET sock = getStreamSocket(taskData, PolyWord::FromUnsigned(skt)); + PolyStringObject * psAddr = (PolyStringObject *)(PolyWord::FromUnsigned(addr).AsObjPtr()); struct sockaddr *psock = (struct sockaddr *)&psAddr->chars; // Begin the connection. The socket is always non-blocking so this will return immediately. if (connect(sock, psock, (int)psAddr->length) != 0) raise_syscall(taskData, "connect failed", GETERROR); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Always returns unit } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(FirstArgument threadId, PolyWord skt) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(POLYUNSIGNED threadId, POLYUNSIGNED skt) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - SOCKET sock = getStreamSocket(taskData, skt); + SOCKET sock = getStreamSocket(taskData, PolyWord::FromUnsigned(skt)); struct sockaddr_storage resultAddr; socklen_t addrLen = sizeof(resultAddr); SOCKET resultSkt = accept(sock, (struct sockaddr*)&resultAddr, &addrLen); if (resultSkt == INVALID_SOCKET) raise_syscall(taskData, "accept failed", GETERROR); if (addrLen > sizeof(resultAddr)) addrLen = sizeof(resultAddr); Handle addrHandle = taskData->saveVec.push(C_string_to_Poly(taskData, (char*)&resultAddr, addrLen)); // Return a pair of the new socket and the address. Handle resSkt = wrapStreamSocket(taskData, resultSkt); result = alloc_and_save(taskData, 2); result->WordP()->Set(0, resSkt->Word()); result->WordP()->Set(1, addrHandle->Word()); } 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(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(FirstArgument threadId, PolyWord argsAsWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(POLYUNSIGNED threadId, POLYUNSIGNED argsAsWord) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle args = taskData->saveVec.push(argsAsWord); #if(defined(_WIN32) && ! defined(_CYGWIN)) int sent = 0; #else ssize_t sent = 0; #endif try { SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); PolyWord pBase = DEREFHANDLE(args)->Get(1); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); #if(defined(_WIN32) && ! defined(_CYGWIN)) int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); #else ssize_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); #endif unsigned int dontRoute = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); int flags = 0; if (dontRoute != 0) flags |= MSG_DONTROUTE; if (outOfBand != 0) flags |= MSG_OOB; char *base = (char*)pBase.AsObjPtr()->AsBytePtr(); sent = send(sock, base + offset, length, flags); if (sent == SOCKET_ERROR) raise_syscall(taskData, "send failed", GETERROR); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(sent).AsUnsigned(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(FirstArgument threadId, PolyWord argsAsWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(POLYUNSIGNED threadId, POLYUNSIGNED argsAsWord) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle args = taskData->saveVec.push(argsAsWord); #if(defined(_WIN32) && ! defined(_CYGWIN)) int sent = 0; #else ssize_t sent = 0; #endif try { SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); PolyStringObject * psAddr = (PolyStringObject *)args->WordP()->Get(1).AsObjPtr(); PolyWord pBase = DEREFHANDLE(args)->Get(2); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); #if(defined(_WIN32) && ! defined(_CYGWIN)) int length = get_C_int(taskData, DEREFHANDLE(args)->Get(4)); #else size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(4)); #endif unsigned int dontRoute = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(6)); int flags = 0; if (dontRoute != 0) flags |= MSG_DONTROUTE; if (outOfBand != 0) flags |= MSG_OOB; char *base = (char*)pBase.AsObjPtr()->AsBytePtr(); sent = sendto(sock, base + offset, length, flags, (struct sockaddr *)psAddr->chars, (int)psAddr->length); if (sent == SOCKET_ERROR) raise_syscall(taskData, "sendto failed", GETERROR); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(sent).AsUnsigned(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(FirstArgument threadId, PolyWord argsAsWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(POLYUNSIGNED threadId, POLYUNSIGNED argsAsWord) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle args = taskData->saveVec.push(argsAsWord); #if(defined(_WIN32) && ! defined(_CYGWIN)) int recvd = 0; #else ssize_t recvd = 0; #endif try { SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); char *base = (char*)DEREFHANDLE(args)->Get(1).AsObjPtr()->AsBytePtr(); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); #if(defined(_WIN32) && ! defined(_CYGWIN)) int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); #else size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); #endif unsigned int peek = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); int flags = 0; if (peek != 0) flags |= MSG_PEEK; if (outOfBand != 0) flags |= MSG_OOB; recvd = recv(sock, base + offset, length, flags); if (recvd == SOCKET_ERROR) raise_syscall(taskData, "recv failed", GETERROR); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(recvd).AsUnsigned(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(FirstArgument threadId, PolyWord argsAsWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(POLYUNSIGNED threadId, POLYUNSIGNED argsAsWord) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle args = taskData->saveVec.push(argsAsWord); Handle result = 0; try { SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); char *base = (char*)DEREFHANDLE(args)->Get(1).AsObjPtr()->AsBytePtr(); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2)); #if(defined(_WIN32) && ! defined(_CYGWIN)) int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); #else size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3)); #endif unsigned int peek = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4)); unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5)); int flags = 0; struct sockaddr_storage resultAddr; socklen_t addrLen = sizeof(resultAddr); if (peek != 0) flags |= MSG_PEEK; if (outOfBand != 0) flags |= MSG_OOB; #if(defined(_WIN32) && ! defined(_CYGWIN)) int recvd; #else ssize_t recvd; #endif recvd = recvfrom(sock, base + offset, length, flags, (struct sockaddr*)&resultAddr, &addrLen); if (recvd == SOCKET_ERROR) raise_syscall(taskData, "recvfrom failed", GETERROR); if (recvd > (int)length) recvd = length; Handle lengthHandle = Make_fixed_precision(taskData, recvd); if (addrLen > sizeof(resultAddr)) addrLen = sizeof(resultAddr); Handle addrHandle = SAVE(C_string_to_Poly(taskData, (char*)&resultAddr, addrLen)); result = ALLOC(2); DEREFHANDLE(result)->Set(0, lengthHandle->Word()); DEREFHANDLE(result)->Set(1, addrHandle->Word()); } 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(); } /* Return a list of known address families. */ -POLYUNSIGNED PolyNetworkGetAddrList(FirstArgument threadId) +POLYUNSIGNED PolyNetworkGetAddrList(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = makeList(taskData, sizeof(af_table) / sizeof(af_table[0]), (char*)af_table, sizeof(af_table[0]), 0, mkAftab); } 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(); } /* Return a list of known socket types. */ -POLYUNSIGNED PolyNetworkGetSockTypeList(FirstArgument threadId) +POLYUNSIGNED PolyNetworkGetSockTypeList(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = makeList(taskData, sizeof(sk_table) / sizeof(sk_table[0]), (char*)sk_table, sizeof(sk_table[0]), 0, mkSktab); } 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(); } // Create a socket */ -POLYUNSIGNED PolyNetworkCreateSocket(FirstArgument threadId, PolyWord family, PolyWord st, PolyWord prot) +POLYUNSIGNED PolyNetworkCreateSocket(POLYUNSIGNED threadId, POLYUNSIGNED family, POLYUNSIGNED st, POLYUNSIGNED prot) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; - int af = (int)family.UnTagged(); - int type = (int)st.UnTagged(); - int proto = (int)prot.UnTagged(); + int af = (int)PolyWord::FromUnsigned(family).UnTagged(); + int type = (int)PolyWord::FromUnsigned(st).UnTagged(); + int proto = (int)PolyWord::FromUnsigned(prot).UnTagged(); try { SOCKET skt = 0; do { skt = socket(af, type, proto); } while (skt == INVALID_SOCKET && GETERROR == CALLINTERRUPTED); if (skt == INVALID_SOCKET) raise_syscall(taskData, "socket failed", GETERROR); /* Set the socket to non-blocking mode. */ #if (defined(_WIN32) && ! defined(__CYGWIN__)) unsigned long onOff = 1; if (ioctlsocket(skt, FIONBIO, &onOff) != 0) #else int onOff = 1; if (ioctl(skt, FIONBIO, &onOff) < 0) #endif { #if (defined(_WIN32) && ! defined(__CYGWIN__)) closesocket(skt); #else close(skt); #endif raise_syscall(taskData, "ioctl failed", GETERROR); } result = wrapStreamSocket(taskData, skt); } 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(); } -POLYUNSIGNED PolyNetworkSetOption(FirstArgument threadId, PolyWord code, PolyWord sock, PolyWord opt) +POLYUNSIGNED PolyNetworkSetOption(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED sock, POLYUNSIGNED opt) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedSock = taskData->saveVec.push(sock); Handle pushedOpt = taskData->saveVec.push(opt); try { - switch (UNTAGGED(code)) + switch (UNTAGGED(PolyWord::FromUnsigned(code))) { case 15: /* Set TCP No-delay option. */ setSocketOption(taskData, pushedSock, pushedOpt, IPPROTO_TCP, TCP_NODELAY); break; case 17: /* Set Debug option. */ setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_DEBUG); break; case 19: /* Set REUSEADDR option. */ setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_REUSEADDR); break; case 21: /* Set KEEPALIVE option. */ setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_KEEPALIVE); break; case 23: /* Set DONTROUTE option. */ setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_DONTROUTE); break; case 25: /* Set BROADCAST option. */ setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_BROADCAST); break; case 27: /* Set OOBINLINE option. */ setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_OOBINLINE); break; case 29: /* Set SNDBUF size. */ setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_SNDBUF); break; case 31: /* Set RCVBUF size. */ setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_RCVBUF); break; } } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetOption(FirstArgument threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyNetworkGetOption(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { - switch (UNTAGGED(code)) + switch (UNTAGGED(PolyWord::FromUnsigned(code))) { case 16: /* Get TCP No-delay option. */ result = getSocketOption(taskData, pushedArg, IPPROTO_TCP, TCP_NODELAY); break; case 18: /* Get Debug option. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_DEBUG); break; case 20: /* Get REUSEADDR option. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_REUSEADDR); break; case 22: /* Get KEEPALIVE option. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_KEEPALIVE); break; case 24: /* Get DONTROUTE option. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_DONTROUTE); break; case 26: /* Get BROADCAST option. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_BROADCAST); break; case 28: /* Get OOBINLINE option. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_OOBINLINE); break; case 30: /* Get SNDBUF size. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_SNDBUF); break; case 32: /* Get RCVBUF size. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_RCVBUF); break; case 33: /* Get socket type e.g. SOCK_STREAM. */ result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_TYPE); break; } } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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(); } /* Set Linger time. */ -POLYUNSIGNED PolyNetworkSetLinger(FirstArgument threadId, PolyWord sock, PolyWord lingerTime) +POLYUNSIGNED PolyNetworkSetLinger(POLYUNSIGNED threadId, POLYUNSIGNED sock, POLYUNSIGNED lingerTime) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - SOCKET skt = getStreamSocket(taskData, sock); - int lTime = get_C_int(taskData, lingerTime); + SOCKET skt = getStreamSocket(taskData, PolyWord::FromUnsigned(sock)); + int lTime = get_C_int(taskData, PolyWord::FromUnsigned(lingerTime)); struct linger linger; /* We pass in a negative value to turn the option off, zero or positive to turn it on. */ if (lTime < 0) { linger.l_onoff = 0; linger.l_linger = 0; } else { linger.l_onoff = 1; linger.l_linger = lTime; } if (setsockopt(skt, SOL_SOCKET, SO_LINGER, (char*)& linger, sizeof(linger)) != 0) raise_syscall(taskData, "setsockopt failed", GETERROR); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* Get Linger time. */ -POLYUNSIGNED PolyNetworkGetLinger(FirstArgument threadId, PolyWord sock) +POLYUNSIGNED PolyNetworkGetLinger(POLYUNSIGNED threadId, POLYUNSIGNED sock) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - SOCKET skt = getStreamSocket(taskData, sock); + SOCKET skt = getStreamSocket(taskData, PolyWord::FromUnsigned(sock)); socklen_t size = sizeof(linger); int lTime = 0; struct linger linger; if (getsockopt(skt, SOL_SOCKET, SO_LINGER, (char*)& linger, &size) != 0) raise_syscall(taskData, "getsockopt failed", GETERROR); /* If the option is off return a negative. */ if (linger.l_onoff == 0) lTime = -1; else lTime = linger.l_linger; result = Make_arbitrary_precision(taskData, lTime); // Returns LargeInt.int } 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(); } /* Get peer name. */ -POLYUNSIGNED PolyNetworkGetPeerName(FirstArgument threadId, PolyWord sock) +POLYUNSIGNED PolyNetworkGetPeerName(POLYUNSIGNED threadId, POLYUNSIGNED sock) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - SOCKET skt = getStreamSocket(taskData, sock); + SOCKET skt = getStreamSocket(taskData, PolyWord::FromUnsigned(sock)); struct sockaddr_storage sockA; socklen_t size = sizeof(sockA); if (getpeername(skt, (struct sockaddr*) & sockA, &size) != 0) raise_syscall(taskData, "getpeername failed", GETERROR); if (size > sizeof(sockA)) size = sizeof(sockA); /* Addresses are treated as strings. */ result = (SAVE(C_string_to_Poly(taskData, (char*)& sockA, size))); } 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(); } /* Get socket name. */ -POLYUNSIGNED PolyNetworkGetSockName(FirstArgument threadId, PolyWord sock) +POLYUNSIGNED PolyNetworkGetSockName(POLYUNSIGNED threadId, POLYUNSIGNED sock) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - SOCKET skt = getStreamSocket(taskData, sock); + SOCKET skt = getStreamSocket(taskData, PolyWord::FromUnsigned(sock)); struct sockaddr_storage sockA; socklen_t size = sizeof(sockA); if (getsockname(skt, (struct sockaddr*) & sockA, &size) != 0) raise_syscall(taskData, "getsockname failed", GETERROR); if (size > sizeof(sockA)) size = sizeof(sockA); result = (SAVE(C_string_to_Poly(taskData, (char*)& sockA, size))); } 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(); } /* Find number of bytes available. */ -POLYUNSIGNED PolyNetworkBytesAvailable(FirstArgument threadId, PolyWord sock) +POLYUNSIGNED PolyNetworkBytesAvailable(POLYUNSIGNED threadId, POLYUNSIGNED sock) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - SOCKET skt = getStreamSocket(taskData, sock); + SOCKET skt = getStreamSocket(taskData, PolyWord::FromUnsigned(sock)); #if (defined(_WIN32) && ! defined(__CYGWIN__)) unsigned long readable; if (ioctlsocket(skt, FIONREAD, &readable) != 0) raise_syscall(taskData, "ioctlsocket failed", GETERROR); #else int readable; if (ioctl(skt, FIONREAD, &readable) < 0) raise_syscall(taskData, "ioctl failed", GETERROR); #endif result = Make_fixed_precision(taskData, readable); } 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(); } /* Find out if we are at the mark. */ -POLYUNSIGNED PolyNetworkGetAtMark(FirstArgument threadId, PolyWord sock) +POLYUNSIGNED PolyNetworkGetAtMark(POLYUNSIGNED threadId, POLYUNSIGNED sock) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - SOCKET skt = getStreamSocket(taskData, sock); + SOCKET skt = getStreamSocket(taskData, PolyWord::FromUnsigned(sock)); #if (defined(_WIN32) && ! defined(__CYGWIN__)) unsigned long atMark; if (ioctlsocket(skt, SIOCATMARK, &atMark) != 0) raise_syscall(taskData, "ioctlsocket failed", GETERROR); #else int atMark; if (ioctl(skt, SIOCATMARK, &atMark) < 0) raise_syscall(taskData, "ioctl failed", GETERROR); #endif result = Make_fixed_precision(taskData, atMark == 0 ? 0 : 1); } 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(); } /* Bind an address to a socket. */ -POLYUNSIGNED PolyNetworkBind(FirstArgument threadId, PolyWord sock, PolyWord addr) +POLYUNSIGNED PolyNetworkBind(POLYUNSIGNED threadId, POLYUNSIGNED sock, POLYUNSIGNED addr) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - SOCKET skt = getStreamSocket(taskData, sock); - PolyStringObject* psAddr = (PolyStringObject*)addr.AsObjPtr(); + SOCKET skt = getStreamSocket(taskData, PolyWord::FromUnsigned(sock)); + PolyStringObject* psAddr = (PolyStringObject*)PolyWord::FromUnsigned(addr).AsObjPtr(); struct sockaddr* psock = (struct sockaddr*) & psAddr->chars; if (bind(skt, psock, (int)psAddr->length) != 0) raise_syscall(taskData, "bind failed", GETERROR); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* Put socket into listening mode. */ -POLYUNSIGNED PolyNetworkListen(FirstArgument threadId, PolyWord skt, PolyWord back) +POLYUNSIGNED PolyNetworkListen(POLYUNSIGNED threadId, POLYUNSIGNED skt, POLYUNSIGNED back) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - SOCKET sock = getStreamSocket(taskData, skt); - int backlog = get_C_int(taskData, back); + SOCKET sock = getStreamSocket(taskData, PolyWord::FromUnsigned(skt)); + int backlog = get_C_int(taskData, PolyWord::FromUnsigned(back)); if (listen(sock, backlog) != 0) raise_syscall(taskData, "listen failed", GETERROR); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* Shutdown the socket. */ -POLYUNSIGNED PolyNetworkShutdown(FirstArgument threadId, PolyWord skt, PolyWord smode) +POLYUNSIGNED PolyNetworkShutdown(POLYUNSIGNED threadId, POLYUNSIGNED skt, POLYUNSIGNED smode) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - SOCKET sock = getStreamSocket(taskData, skt); + SOCKET sock = getStreamSocket(taskData, PolyWord::FromUnsigned(skt)); int mode = 0; - switch (get_C_ulong(taskData, smode)) + switch (get_C_ulong(taskData, PolyWord::FromUnsigned(smode))) { case 1: mode = SHUT_RD; break; case 2: mode = SHUT_WR; break; case 3: mode = SHUT_RDWR; } if (shutdown(sock, mode) != 0) raise_syscall(taskData, "shutdown failed", GETERROR); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* Create a socket pair. */ -POLYUNSIGNED PolyNetworkCreateSocketPair(FirstArgument threadId, PolyWord family, PolyWord st, PolyWord prot) +POLYUNSIGNED PolyNetworkCreateSocketPair(POLYUNSIGNED threadId, POLYUNSIGNED family, POLYUNSIGNED st, POLYUNSIGNED prot) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* Not implemented. */ raise_syscall(taskData, "socketpair not implemented", WSAEAFNOSUPPORT); #else int af = family.UnTagged(); int type = st.UnTagged(); int proto = prot.UnTagged(); SOCKET skt[2]; int skPRes = 0; do { skPRes = socketpair(af, type, proto, skt); } while (skPRes != 0 && GETERROR == CALLINTERRUPTED); int onOff = 1; /* Set the sockets to non-blocking mode. */ if (ioctl(skt[0], FIONBIO, &onOff) < 0 || ioctl(skt[1], FIONBIO, &onOff) < 0) { close(skt[0]); close(skt[1]); raise_syscall(taskData, "ioctl failed", GETERROR); } Handle str_token1 = wrapStreamSocket(taskData, skt[0]); Handle str_token2 = wrapStreamSocket(taskData, skt[1]); /* Return the two streams as a pair. */ result = ALLOC(2); DEREFHANDLE(result)->Set(0, DEREFWORD(str_token1)); DEREFHANDLE(result)->Set(1, DEREFWORD(str_token2)); #endif } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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(); } /* Create a Unix socket address from a string. */ -POLYUNSIGNED PolyNetworkUnixPathToSockAddr(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyNetworkUnixPathToSockAddr(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* Not implemented. */ raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT); #else struct sockaddr_un addr; memset(&addr, 0, sizeof(addr)); addr.sun_family = AF_UNIX; #ifdef HAVE_STRUCT_SOCKADDR_UN_SUN_LEN addr.sun_len = sizeof(addr); // Used in FreeBSD only. #endif POLYUNSIGNED length = Poly_string_to_C(arg, addr.sun_path, sizeof(addr.sun_path)); if (length > (int)sizeof(addr.sun_path)) raise_syscall(taskData, "Address too long", ENAMETOOLONG); result = SAVE(C_string_to_Poly(taskData, (char*)& addr, sizeof(addr))); #endif } 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(); } /* Get the file name from a Unix socket address. */ -POLYUNSIGNED PolyNetworkUnixSockAddrToPath(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyNetworkUnixSockAddrToPath(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* Not implemented. */ raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT); #else PolyStringObject* psAddr = (PolyStringObject*)arg.AsObjPtr(); struct sockaddr_un* psock = (struct sockaddr_un*) & psAddr->chars; result = SAVE(C_string_to_Poly(taskData, psock->sun_path)); #endif } 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(); } -POLYUNSIGNED PolyNetworkGetServByName(FirstArgument threadId, PolyWord serviceName) +POLYUNSIGNED PolyNetworkGetServByName(POLYUNSIGNED threadId, POLYUNSIGNED serviceName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Get service given service name only. */ - TempCString servName(Poly_string_to_C_alloc(serviceName)); + TempCString servName(Poly_string_to_C_alloc(PolyWord::FromUnsigned(serviceName))); struct servent *serv = getservbyname (servName, NULL); // If this fails the ML function returns NONE Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(FirstArgument threadId, PolyWord serviceName, PolyWord protName) +POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(POLYUNSIGNED threadId, POLYUNSIGNED serviceName, POLYUNSIGNED protName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Get service given service name and protocol name. */ - TempCString servName(Poly_string_to_C_alloc(serviceName)); - TempCString protoName(Poly_string_to_C_alloc(protName)); + TempCString servName(Poly_string_to_C_alloc(PolyWord::FromUnsigned(serviceName))); + TempCString protoName(Poly_string_to_C_alloc(PolyWord::FromUnsigned(protName))); struct servent *serv = getservbyname (servName, protoName); Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetServByPort(FirstArgument threadId, PolyWord portNo) +POLYUNSIGNED PolyNetworkGetServByPort(POLYUNSIGNED threadId, POLYUNSIGNED portNo) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Get service given port number only. */ - long port = htons(get_C_ushort(taskData, portNo)); + long port = htons(get_C_ushort(taskData, PolyWord::FromUnsigned(portNo))); struct servent *serv = getservbyport(port, NULL); Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(FirstArgument threadId, PolyWord portNo, PolyWord protName) +POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(POLYUNSIGNED threadId, POLYUNSIGNED portNo, POLYUNSIGNED protName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Get service given port number and protocol name. */ - long port = htons(get_C_ushort(taskData, portNo)); - TempCString protoName(Poly_string_to_C_alloc(protName)); + long port = htons(get_C_ushort(taskData, PolyWord::FromUnsigned(portNo))); + TempCString protoName(Poly_string_to_C_alloc(PolyWord::FromUnsigned(protName))); struct servent *serv = getservbyport (port, protoName); Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetProtByName(FirstArgument threadId, PolyWord protocolName) +POLYUNSIGNED PolyNetworkGetProtByName(POLYUNSIGNED threadId, POLYUNSIGNED protocolName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Look up protocol entry. */ - TempCString protoName(Poly_string_to_C_alloc(protocolName)); + TempCString protoName(Poly_string_to_C_alloc(PolyWord::FromUnsigned(protocolName))); struct protoent *proto = getprotobyname(protoName); // If this fails the ML function returns NONE Handle result = proto == NULL ? 0 : makeProtoEntry(taskData, proto); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetProtByNo(FirstArgument threadId, PolyWord protoNo) +POLYUNSIGNED PolyNetworkGetProtByNo(POLYUNSIGNED threadId, POLYUNSIGNED protoNo) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Look up protocol entry. */ - int pNum = get_C_int(taskData, protoNo); + int pNum = get_C_int(taskData, PolyWord::FromUnsigned(protoNo)); struct protoent *proto = getprotobynumber(pNum); Handle result = proto == NULL ? 0 : makeProtoEntry(taskData, proto); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetHostName(FirstArgument threadId) +POLYUNSIGNED PolyNetworkGetHostName(POLYUNSIGNED threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { /* Get the current host name. */ // Since the maximum length of a FQDN is 256 bytes it should fit in the buffer. #ifdef HOST_NAME_MAX char hostName[HOST_NAME_MAX+1]; #else char hostName[1024]; #endif int err = gethostname(hostName, sizeof(hostName)); if (err != 0) raise_syscall(taskData, "gethostname failed", GETERROR); // Add a null at the end just in case. See gethostname man page. hostName[sizeof(hostName) - 1] = 0; result = SAVE(C_string_to_Poly(taskData, hostName)); } 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(); } -POLYUNSIGNED PolyNetworkGetNameInfo(FirstArgument threadId, PolyWord sockAddr) +POLYUNSIGNED PolyNetworkGetNameInfo(POLYUNSIGNED threadId, POLYUNSIGNED sockAddr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - PolyStringObject* psAddr = (PolyStringObject*)sockAddr.AsObjPtr(); + PolyStringObject* psAddr = (PolyStringObject*)PolyWord::FromUnsigned(sockAddr).AsObjPtr(); struct sockaddr* psock = (struct sockaddr*) & psAddr->chars; // Since the maximum length of a FQDN is 256 bytes it should fit in the buffer. char hostName[1024]; int gniRes = getnameinfo(psock, (socklen_t)psAddr->length, hostName, sizeof(hostName), NULL, 0, 0); if (gniRes != 0) { #if (defined(_WIN32) && ! defined(__CYGWIN__)) raise_syscall(taskData, "getnameinfo failed", GETERROR); #else if (gniRes == EAI_SYSTEM) raise_syscall(taskData, "getnameinfo failed", GETERROR); else raise_syscall(taskData, gai_strerror(gniRes), 0); #endif } result = SAVE(C_string_to_Poly(taskData, hostName)); } 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(); } // Copy addrInfo data into ML memory. We copy this although most of it // is currently unused. static Handle extractAddrInfo(TaskData *taskData, struct addrinfo *ainfo) { if (ainfo == 0) return taskData->saveVec.push(ListNull); Handle reset = taskData->saveVec.mark(); Handle tail = extractAddrInfo(taskData, ainfo->ai_next); Handle name = 0; // Only the first entry may have a canonical name. if (ainfo->ai_canonname == 0) name = taskData->saveVec.push(C_string_to_Poly(taskData, "")); else name = taskData->saveVec.push(C_string_to_Poly(taskData, ainfo->ai_canonname)); Handle address = taskData->saveVec.push(C_string_to_Poly(taskData, (char*)ainfo->ai_addr, ainfo->ai_addrlen)); Handle value = alloc_and_save(taskData, 6); value->WordP()->Set(0, TAGGED(ainfo->ai_flags)); value->WordP()->Set(1, TAGGED(ainfo->ai_family)); value->WordP()->Set(2, TAGGED(ainfo->ai_socktype)); value->WordP()->Set(3, TAGGED(ainfo->ai_protocol)); value->WordP()->Set(4, address->Word()); value->WordP()->Set(5, name->Word()); ML_Cons_Cell *next = (ML_Cons_Cell*)alloc(taskData, SIZEOF(ML_Cons_Cell)); next->h = value->Word(); next->t = tail->Word(); taskData->saveVec.reset(reset); return taskData->saveVec.push(next); } -POLYUNSIGNED PolyNetworkGetAddrInfo(FirstArgument threadId, PolyWord hName, PolyWord addrFamily) +POLYUNSIGNED PolyNetworkGetAddrInfo(POLYUNSIGNED threadId, POLYUNSIGNED hName, POLYUNSIGNED addrFamily) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; struct addrinfo *resAddr = 0; try { - TempCString hostName(Poly_string_to_C_alloc(hName)); + TempCString hostName(Poly_string_to_C_alloc(PolyWord::FromUnsigned(hName))); struct addrinfo hints; memset(&hints, 0, sizeof(hints)); - hints.ai_family = (int)UNTAGGED(addrFamily); // AF_INET or AF_INET6 or, possibly, AF_UNSPEC. + hints.ai_family = (int)UNTAGGED(PolyWord::FromUnsigned(addrFamily)); // AF_INET or AF_INET6 or, possibly, AF_UNSPEC. hints.ai_flags = AI_CANONNAME; int gaiRes = getaddrinfo(hostName, 0, &hints, &resAddr); if (gaiRes != 0) { #if (defined(_WIN32) && ! defined(__CYGWIN__)) raise_syscall(taskData, "getaddrinfo failed", GETERROR); #else if (gaiRes == EAI_SYSTEM) raise_syscall(taskData, "getnameinfo failed", GETERROR); else raise_syscall(taskData, gai_strerror(gaiRes), 0); #endif } result = extractAddrInfo(taskData, resAddr); } catch (...) { } // Could raise an exception if we run out of heap space if (resAddr) freeaddrinfo(resAddr); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkCloseSocket(FirstArgument threadId, PolyWord strm) +POLYUNSIGNED PolyNetworkCloseSocket(POLYUNSIGNED threadId, POLYUNSIGNED strm) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; Handle pushedStream = taskData->saveVec.push(strm); try { // This is defined to raise an exception if the socket has already been closed #if (defined(_WIN32)) WinSocket *winskt = *(WinSocket**)(pushedStream->WordP()); if (winskt != 0) { if (closesocket(winskt->getSocket()) != 0) raise_syscall(taskData, "Error during close", GETERROR); } else raise_syscall(taskData, "Socket is closed", WSAEBADF); *(WinSocket **)(pushedStream->WordP()) = 0; // Mark as closed #else int descr = getStreamFileDescriptorWithoutCheck(pushedStream->Word()); if (descr >= 0) { if (close(descr) != 0) raise_syscall(taskData, "Error during close", GETERROR); } else raise_syscall(taskData, "Socket is closed", EBADF); *(int*)(pushedStream->WordP()) = 0; // Mark as closed #endif result = Make_fixed_precision(taskData, 0); } 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(); } // Return the family -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetFamilyFromAddress(PolyWord sockAddress) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetFamilyFromAddress(POLYUNSIGNED sockAddress) { - PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr(); + PolyStringObject* psAddr = (PolyStringObject*)PolyWord::FromUnsigned(sockAddress).AsObjPtr(); struct sockaddr* psock = (struct sockaddr*) & psAddr->chars; return TAGGED(psock->sa_family).AsUnsigned(); } // Return internet address and port from an internet socket address. // Assumes that we've already checked the address family. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP4(FirstArgument threadId, PolyWord sockAddress) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP4(POLYUNSIGNED threadId, POLYUNSIGNED sockAddress) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr(); + PolyStringObject* psAddr = (PolyStringObject*)PolyWord::FromUnsigned(sockAddress).AsObjPtr(); struct sockaddr_in* psock = (struct sockaddr_in*) & psAddr->chars; Handle ipAddr = Make_arbitrary_precision(taskData, ntohl(psock->sin_addr.s_addr)); // IPv4 addr is LargeInt.int result = alloc_and_save(taskData, 2); result->WordP()->Set(0, ipAddr->Word()); result->WordP()->Set(1, TAGGED(ntohs(psock->sin_port))); } 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(); } // Create a socket address from a port number and internet address. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP4Address(FirstArgument threadId, PolyWord ip4Address, PolyWord portNumber) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP4Address(POLYUNSIGNED threadId, POLYUNSIGNED ip4Address, POLYUNSIGNED portNumber) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { struct sockaddr_in sockaddr; memset(&sockaddr, 0, sizeof(sockaddr)); sockaddr.sin_family = AF_INET; - sockaddr.sin_port = htons(get_C_ushort(taskData, portNumber)); - sockaddr.sin_addr.s_addr = htonl(get_C_unsigned(taskData, ip4Address)); + sockaddr.sin_port = htons(get_C_ushort(taskData, PolyWord::FromUnsigned(portNumber))); + sockaddr.sin_addr.s_addr = htonl(get_C_unsigned(taskData, PolyWord::FromUnsigned(ip4Address))); result = SAVE(C_string_to_Poly(taskData, (char*)&sockaddr, sizeof(sockaddr))); } 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(); } // Return the value of INADDR_ANY. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP4AddressAny(FirstArgument threadId) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP4AddressAny(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = Make_arbitrary_precision(taskData, INADDR_ANY); // IPv4 addr is LargeInt.int } 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(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP6(FirstArgument threadId, PolyWord sockAddress) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP6(POLYUNSIGNED threadId, POLYUNSIGNED sockAddress) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr(); + PolyStringObject* psAddr = (PolyStringObject*)PolyWord::FromUnsigned(sockAddress).AsObjPtr(); if (psAddr->length != sizeof(struct sockaddr_in6)) raise_fail(taskData, "Invalid length"); struct sockaddr_in6* psock = (struct sockaddr_in6*) & psAddr->chars; Handle ipAddr = SAVE(C_string_to_Poly(taskData, (const char*)&psock->sin6_addr, sizeof(struct in6_addr))); result = alloc_and_save(taskData, 2); result->WordP()->Set(0, ipAddr->Word()); result->WordP()->Set(1, TAGGED(ntohs(psock->sin6_port))); } 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(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP6Address(FirstArgument threadId, PolyWord ip6Address, PolyWord portNumber) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP6Address(POLYUNSIGNED threadId, POLYUNSIGNED ip6Address, POLYUNSIGNED portNumber) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { struct sockaddr_in6 addr; memset(&addr, 0, sizeof(addr)); result = SAVE(C_string_to_Poly(taskData, (const char*)&addr, sizeof(struct in6_addr))); addr.sin6_family = AF_INET6; - addr.sin6_port = htons(get_C_ushort(taskData, portNumber)); - PolyStringObject* addrAsString = (PolyStringObject*)ip6Address.AsObjPtr(); + addr.sin6_port = htons(get_C_ushort(taskData, PolyWord::FromUnsigned(portNumber))); + PolyStringObject* addrAsString = (PolyStringObject*)PolyWord::FromUnsigned(ip6Address).AsObjPtr(); if (addrAsString->length != sizeof(addr.sin6_addr)) raise_fail(taskData, "Invalid address length"); memcpy(&addr.sin6_addr, addrAsString->chars, sizeof(addr.sin6_addr)); result = SAVE(C_string_to_Poly(taskData, (char*)&addr, sizeof(addr))); } 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(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP6AddressAny(FirstArgument threadId) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP6AddressAny(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = SAVE(C_string_to_Poly(taskData, (const char*)&in6addr_any, sizeof(struct in6_addr))); } 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(); } // Convert an IPV6 address to string. This could be done in ML but the rules // for converting zeros to double-colon are complicated. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkIP6AddressToString(FirstArgument threadId, PolyWord ip6Address) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkIP6AddressToString(POLYUNSIGNED threadId, POLYUNSIGNED ip6Address) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { char buffer[80]; // 40 should actually be enough: 32 hex bytes, 7 colons and a null. - PolyStringObject* addrAsString = (PolyStringObject*)ip6Address.AsObjPtr(); + PolyStringObject* addrAsString = (PolyStringObject*)PolyWord::FromUnsigned(ip6Address).AsObjPtr(); if (addrAsString->length != sizeof(struct in6_addr)) raise_fail(taskData, "Invalid address length"); if (inet_ntop(AF_INET6, addrAsString->chars, buffer, sizeof(buffer)) == 0) raise_syscall(taskData, "inet_ntop", GETERROR); result = SAVE(C_string_to_Poly(taskData, buffer)); } 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(); } // Convert a string to an IPv6 address. The parsing has to be done in ML. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkStringToIP6Address(FirstArgument threadId, PolyWord stringRep) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkStringToIP6Address(POLYUNSIGNED threadId, POLYUNSIGNED stringRep) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { struct in6_addr address; - TempCString stringAddr(Poly_string_to_C_alloc(stringRep)); + TempCString stringAddr(Poly_string_to_C_alloc(PolyWord::FromUnsigned(stringRep))); if (inet_pton(AF_INET6, stringAddr, &address) != 1) raise_fail(taskData, "Invalid IPv6 address"); result = taskData->saveVec.push(C_string_to_Poly(taskData, (const char *)&address, sizeof(struct in6_addr))); } 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(); } struct _entrypts networkingEPT[] = { { "PolyNetworkGetAddrList", (polyRTSFunction)&PolyNetworkGetAddrList}, { "PolyNetworkGetSockTypeList", (polyRTSFunction)&PolyNetworkGetSockTypeList}, { "PolyNetworkCreateSocket", (polyRTSFunction)&PolyNetworkCreateSocket}, { "PolyNetworkSetOption", (polyRTSFunction)&PolyNetworkSetOption}, { "PolyNetworkGetOption", (polyRTSFunction)&PolyNetworkGetOption}, { "PolyNetworkSetLinger", (polyRTSFunction)&PolyNetworkSetLinger}, { "PolyNetworkGetLinger", (polyRTSFunction)&PolyNetworkGetLinger}, { "PolyNetworkGetPeerName", (polyRTSFunction)&PolyNetworkGetPeerName}, { "PolyNetworkGetSockName", (polyRTSFunction)&PolyNetworkGetSockName}, { "PolyNetworkBytesAvailable", (polyRTSFunction)&PolyNetworkBytesAvailable}, { "PolyNetworkGetAtMark", (polyRTSFunction)&PolyNetworkGetAtMark}, { "PolyNetworkBind", (polyRTSFunction)&PolyNetworkBind}, { "PolyNetworkListen", (polyRTSFunction)&PolyNetworkListen}, { "PolyNetworkShutdown", (polyRTSFunction)&PolyNetworkShutdown}, { "PolyNetworkCreateSocketPair", (polyRTSFunction)&PolyNetworkCreateSocketPair}, { "PolyNetworkUnixPathToSockAddr", (polyRTSFunction)&PolyNetworkUnixPathToSockAddr}, { "PolyNetworkUnixSockAddrToPath", (polyRTSFunction)&PolyNetworkUnixSockAddrToPath}, { "PolyNetworkGetServByName", (polyRTSFunction)&PolyNetworkGetServByName}, { "PolyNetworkGetServByNameAndProtocol", (polyRTSFunction)&PolyNetworkGetServByNameAndProtocol}, { "PolyNetworkGetServByPort", (polyRTSFunction)&PolyNetworkGetServByPort}, { "PolyNetworkGetServByPortAndProtocol", (polyRTSFunction)&PolyNetworkGetServByPortAndProtocol}, { "PolyNetworkGetProtByName", (polyRTSFunction)&PolyNetworkGetProtByName}, { "PolyNetworkGetProtByNo", (polyRTSFunction)&PolyNetworkGetProtByNo}, { "PolyNetworkGetHostName", (polyRTSFunction)&PolyNetworkGetHostName}, { "PolyNetworkGetNameInfo", (polyRTSFunction)&PolyNetworkGetNameInfo}, { "PolyNetworkCloseSocket", (polyRTSFunction)&PolyNetworkCloseSocket }, { "PolyNetworkSelect", (polyRTSFunction)&PolyNetworkSelect }, { "PolyNetworkGetSocketError", (polyRTSFunction)&PolyNetworkGetSocketError }, { "PolyNetworkConnect", (polyRTSFunction)&PolyNetworkConnect }, { "PolyNetworkAccept", (polyRTSFunction)&PolyNetworkAccept }, { "PolyNetworkSend", (polyRTSFunction)&PolyNetworkSend }, { "PolyNetworkSendTo", (polyRTSFunction)&PolyNetworkSendTo }, { "PolyNetworkReceive", (polyRTSFunction)&PolyNetworkReceive }, { "PolyNetworkReceiveFrom", (polyRTSFunction)&PolyNetworkReceiveFrom }, { "PolyNetworkGetAddrInfo", (polyRTSFunction)&PolyNetworkGetAddrInfo }, { "PolyNetworkGetFamilyFromAddress", (polyRTSFunction)&PolyNetworkGetFamilyFromAddress }, { "PolyNetworkGetAddressAndPortFromIP4", (polyRTSFunction)&PolyNetworkGetAddressAndPortFromIP4 }, { "PolyNetworkCreateIP4Address", (polyRTSFunction)&PolyNetworkCreateIP4Address }, { "PolyNetworkReturnIP4AddressAny", (polyRTSFunction)&PolyNetworkReturnIP4AddressAny }, { "PolyNetworkGetAddressAndPortFromIP6", (polyRTSFunction)&PolyNetworkGetAddressAndPortFromIP6 }, { "PolyNetworkCreateIP6Address", (polyRTSFunction)&PolyNetworkCreateIP6Address }, { "PolyNetworkReturnIP6AddressAny", (polyRTSFunction)&PolyNetworkReturnIP4AddressAny }, { "PolyNetworkIP6AddressToString", (polyRTSFunction)&PolyNetworkIP6AddressToString }, { "PolyNetworkStringToIP6Address", (polyRTSFunction)&PolyNetworkStringToIP6Address }, { NULL, NULL} // End of list. }; class Networking: public RtsModule { public: virtual void Init(void); virtual void Stop(void); }; // Declare this. It will be automatically added to the table. static Networking networkingModule; void Networking::Init(void) { #if (defined(_WIN32)) #define WINSOCK_MAJOR_VERSION 2 #define WINSOCK_MINOR_VERSION 2 WSADATA wsaData; WORD wVersion = MAKEWORD(WINSOCK_MINOR_VERSION, WINSOCK_MAJOR_VERSION); /* Initialise the system and check that the version it supplied is the one we requested. */ if(WSAStartup(wVersion, &wsaData) == 0) { if (wsaData.wVersion == wVersion) winsock_init = 1; else WSACleanup(); } #endif } void Networking::Stop(void) { #if (defined(_WIN32)) if (winsock_init) WSACleanup(); winsock_init = 0; #endif } diff --git a/libpolyml/objsize.cpp b/libpolyml/objsize.cpp index 879b4c56..6566e83b 100644 --- a/libpolyml/objsize.cpp +++ b/libpolyml/objsize.cpp @@ -1,436 +1,436 @@ /* Title: Object size Copyright (c) 2000 Cambridge University Technical Services Limited Further development David C.J. Matthews 2016, 2017, 2021 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_SYS_TYPES_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "arb.h" #include "run_time.h" #include "machine_dep.h" #include "objsize.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "bitmap.h" #include "memmgr.h" #include "mpoly.h" #include "processes.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjSize(FirstArgument threadId, PolyWord obj); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowSize(FirstArgument threadId, PolyWord obj); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjProfile(FirstArgument threadId, PolyWord obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjSize(POLYUNSIGNED threadId, POLYUNSIGNED obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowSize(POLYUNSIGNED threadId, POLYUNSIGNED obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjProfile(POLYUNSIGNED threadId, POLYUNSIGNED obj); } extern FILE *polyStdout; #define MAX_PROF_LEN 100 // Profile lengths between 1 and this class ProcessVisitAddresses: public ScanAddress { public: virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt) { return ShowWord(*pt); } virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { return ShowObject(*pt); } virtual PolyObject *ScanObjectAddress(PolyObject *base); POLYUNSIGNED ShowWord(PolyWord w) { if (w.IsTagged() || w == PolyWord::FromUnsigned(0)) return 0; else return ShowObject(w.AsObjPtr()); } POLYUNSIGNED ShowObject(PolyObject *p); ProcessVisitAddresses(bool show); ~ProcessVisitAddresses(); VisitBitmap *FindBitmap(PolyObject *p); void ShowBytes(PolyObject *start); void ShowCode(PolyObject *start); void ShowWords(PolyObject *start); POLYUNSIGNED total_length; bool show_size; VisitBitmap **bitmaps; unsigned nBitmaps; // Counts of objects of each size for mutable and immutable data. unsigned iprofile[MAX_PROF_LEN+1]; unsigned mprofile[MAX_PROF_LEN+1]; }; ProcessVisitAddresses::ProcessVisitAddresses(bool show) { // Need to get the allocation lock here. Another thread // could allocate new local areas resulting in gMem.nlSpaces // and gMem.lSpaces changing under our feet. PLocker lock(&gMem.allocLock); total_length = 0; show_size = show; // Create a bitmap for each of the areas apart from the IO area nBitmaps = (unsigned)(gMem.lSpaces.size()+gMem.pSpaces.size()+gMem.cSpaces.size()); // bitmaps = new VisitBitmap*[nBitmaps]; unsigned bm = 0; for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; bitmaps[bm++] = new VisitBitmap(space->bottom, space->top); } ASSERT(bm == nBitmaps); // Clear the profile counts. for (unsigned i = 0; i < MAX_PROF_LEN+1; i++) { iprofile[i] = mprofile[i] = 0; } } ProcessVisitAddresses::~ProcessVisitAddresses() { if (bitmaps) { for (unsigned i = 0; i < nBitmaps; i++) delete(bitmaps[i]); delete[](bitmaps); } } // Return the bitmap corresponding to the address or NULL if it isn't there. VisitBitmap *ProcessVisitAddresses::FindBitmap(PolyObject *p) { for (unsigned i = 0; i < nBitmaps; i++) { VisitBitmap *bm = bitmaps[i]; if (bm->InRange((PolyWord*)p)) return bm; } return 0; } void ProcessVisitAddresses::ShowBytes(PolyObject *start) { POLYUNSIGNED bytes = start->Length() * sizeof(PolyWord); char *array = (char *) start; putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); fprintf(polyStdout, "BYTES:%p:%" POLYUFMT "\n", array, bytes); POLYUNSIGNED i, n; for (i = 0, n = 0; n < bytes; n++) { fprintf(polyStdout, "%02x ",array[n] & 0xff); i++; if (i == 16) { putc('\n', polyStdout); i = 0; } } if (i != 0) putc('\n', polyStdout); } #define MAXNAME 500 void ProcessVisitAddresses::ShowCode(PolyObject *start) { POLYUNSIGNED length = start->Length(); putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); char buffer[MAXNAME+1]; PolyWord *consts = machineDependent->ConstPtrForCode(start); PolyWord string = consts[0]; if (string == TAGGED(0)) strcpy(buffer, ""); else (void) Poly_string_to_C(string, buffer, sizeof(buffer)); fprintf(polyStdout, "CODE:%p:%" POLYUFMT " %s\n", start, length, buffer); POLYUNSIGNED i, n; for (i = 0, n = 0; n < length; n++) { if (i != 0) putc('\t', polyStdout); fprintf(polyStdout, "%8p ", start->Get(n).AsObjPtr()); i++; if (i == 4) { putc('\n', polyStdout); i = 0; } } // TODO: This will only print the constants if they are part of // the code. If they have been split off they will still be scanned // but they won't be printed and their size won't be included. if (i != 0) putc('\n', polyStdout); } void ProcessVisitAddresses::ShowWords(PolyObject *start) { POLYUNSIGNED length = start->Length(); putc('\n', polyStdout); if (start->IsMutable()) fprintf(polyStdout, "MUTABLE "); fprintf(polyStdout, "%s:%p:%" POLYUFMT "\n", start->IsClosureObject() ? "CLOSURE" : "WORDS", start, length); POLYUNSIGNED i, n; for (i = 0, n = 0; n < length; ) { if (i != 0) putc('\t', polyStdout); if (start->IsClosureObject() && n == 0) { fprintf(polyStdout, "%8p ", *(PolyObject**)start); n += sizeof(PolyObject*) / sizeof(PolyWord); } else { PolyWord p = start->Get(n); if (p.IsTagged()) fprintf(polyStdout, "%08" POLYUFMT " ", p.AsUnsigned()); else fprintf(polyStdout, "%8p ", p.AsObjPtr()); n++; } i++; if (i == 4) { putc('\n', polyStdout); i = 0; } } if (i != 0) putc('\n', polyStdout); } // This is called initially to print the top-level object. // Since we don't process stacks it probably doesn't get called elsewhere. PolyObject *ProcessVisitAddresses::ScanObjectAddress(PolyObject *base) { POLYUNSIGNED lengthWord = ShowWord(base); if (lengthWord) ScanAddressesInObject(base, lengthWord); return base; } // Handle the normal case. Print the object at this word and // return true is it must be handled recursively. POLYUNSIGNED ProcessVisitAddresses::ShowObject(PolyObject *p) { VisitBitmap *bm = FindBitmap(p); if (bm == 0) { fprintf(polyStdout, "Bad address " ZERO_X "%p found\n", p); return 0; } /* Have we already visited this object? */ if (bm->AlreadyVisited(p)) return 0; bm->SetVisited(p); POLYUNSIGNED obj_length = p->Length(); // Increment the appropriate size profile count. if (p->IsMutable()) { if (obj_length > MAX_PROF_LEN) mprofile[MAX_PROF_LEN]++; else mprofile[obj_length]++; } else { if (obj_length > MAX_PROF_LEN) iprofile[MAX_PROF_LEN]++; else iprofile[obj_length]++; } total_length += obj_length + 1; /* total space needed for object */ if (p->IsByteObject()) { if (show_size) ShowBytes(p); return 0; } else if (p->IsCodeObject()) { PolyWord *cp; POLYUNSIGNED const_count; machineDependent->GetConstSegmentForCode(p, cp, const_count); if (show_size) ShowCode(p); return p->LengthWord(); // Process addresses in it. } else // Word or closure object { if (show_size) ShowWords(p); return p->LengthWord(); // Process addresses in it. } } Handle ObjSize(TaskData *taskData, Handle obj) { ProcessVisitAddresses process(false); process.ScanObjectAddress(obj->WordP()); return Make_arbitrary_precision(taskData, process.total_length); } Handle ShowSize(TaskData *taskData, Handle obj) { ProcessVisitAddresses process(true); process.ScanObjectAddress(obj->WordP()); fflush(polyStdout); /* We need this for Windows at least. */ return Make_arbitrary_precision(taskData, process.total_length); } static void printfprof(unsigned *counts) { for(unsigned i = 0; i < MAX_PROF_LEN+1; i++) { if (counts[i] != 0) { if (i == MAX_PROF_LEN) fprintf(polyStdout, ">%d\t%u\n", MAX_PROF_LEN, counts[i]); else fprintf(polyStdout, "%d\t%u\n", i, counts[i]); } } } -POLYUNSIGNED PolyObjSize(FirstArgument threadId, PolyWord obj) +POLYUNSIGNED PolyObjSize(POLYUNSIGNED threadId, POLYUNSIGNED obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(false); - if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); + if (!PolyWord::FromUnsigned(obj).IsTagged()) process.ScanObjectAddress(PolyWord::FromUnsigned(obj).AsObjPtr()); Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyShowSize(FirstArgument threadId, PolyWord obj) +POLYUNSIGNED PolyShowSize(POLYUNSIGNED threadId, POLYUNSIGNED obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(true); - if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); + if (!PolyWord::FromUnsigned(obj).IsTagged()) process.ScanObjectAddress(PolyWord::FromUnsigned(obj).AsObjPtr()); fflush(polyStdout); /* We need this for Windows at least. */ Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyObjProfile(FirstArgument threadId, PolyWord obj) +POLYUNSIGNED PolyObjProfile(POLYUNSIGNED threadId, POLYUNSIGNED obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(false); - if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); + if (!PolyWord::FromUnsigned(obj).IsTagged()) process.ScanObjectAddress(PolyWord::FromUnsigned(obj).AsObjPtr()); fprintf(polyStdout, "\nImmutable object sizes and counts\n"); printfprof(process.iprofile); fprintf(polyStdout, "\nMutable object sizes and counts\n"); printfprof(process.mprofile); fflush(polyStdout); /* We need this for Windows at least. */ Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } struct _entrypts objSizeEPT[] = { { "PolyObjSize", (polyRTSFunction)&PolyObjSize}, { "PolyShowSize", (polyRTSFunction)&PolyShowSize}, { "PolyObjProfile", (polyRTSFunction)&PolyObjProfile}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/poly_specific.cpp b/libpolyml/poly_specific.cpp index 0a098c51..fd8f738c 100644 --- a/libpolyml/poly_specific.cpp +++ b/libpolyml/poly_specific.cpp @@ -1,480 +1,480 @@ /* Title: poly_specific.cpp - Poly/ML specific RTS calls. Copyright (c) 2006, 2015-17, 2019, 2021 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 */ /* This module is used for various run-time calls that are either in the PolyML structure or otherwise specific to Poly/ML. */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #include "globals.h" #include "poly_specific.h" #include "arb.h" #include "mpoly.h" #include "sys.h" #include "machine_dep.h" #include "polystring.h" #include "run_time.h" #include "version.h" #include "save_vec.h" #include "version.h" #include "memmgr.h" #include "processes.h" #include "gc.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure); - POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord c, PolyWord flags); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeConstant(PolyWord closure, PolyWord offset, PolyWord flags); - POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(PolyWord closure, PolyWord offset, PolyWord c); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset); - POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(PolyWord array); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetHeapBase(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(POLYUNSIGNED threadId, POLYUNSIGNED closure); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToClosure(POLYUNSIGNED threadId, POLYUNSIGNED byteVec, POLYUNSIGNED closure); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeConstant(POLYUNSIGNED closure, POLYUNSIGNED offset, POLYUNSIGNED c, POLYUNSIGNED flags); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeConstant(POLYUNSIGNED closure, POLYUNSIGNED offset, POLYUNSIGNED flags); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(POLYUNSIGNED closure, POLYUNSIGNED offset, POLYUNSIGNED c); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(POLYUNSIGNED closure, POLYUNSIGNED offset); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(POLYUNSIGNED array); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetHeapBase(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2, POLYUNSIGNED arg3, POLYUNSIGNED arg4); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2, POLYUNSIGNED arg3, POLYUNSIGNED arg4, POLYUNSIGNED arg5); } #define SAVE(x) taskData->saveVec.push(x) #ifndef GIT_VERSION #define GIT_VERSION "" #endif Handle poly_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 9: // Return the GIT version if appropriate { return SAVE(C_string_to_Poly(taskData, GIT_VERSION)); } case 10: // Return the RTS version string. { const char *version; switch (machineDependent->MachineArchitecture()) { case MA_Interpreted: version = "Portable-" TextVersion; break; case MA_I386: version = "I386-" TextVersion; break; case MA_X86_64: version = "X86_64-" TextVersion; break; case MA_X86_64_32: version = "X86_64_32-" TextVersion; break; case MA_Arm64: version = "Arm64-" TextVersion; break; case MA_Arm64_32: version = "Arm64_32-" TextVersion; break; default: version = "Unknown-" TextVersion; break; } return SAVE(C_string_to_Poly(taskData, version)); } case 12: // Return the architecture // Used in InitialPolyML.ML for PolyML.architecture { const char *arch; switch (machineDependent->MachineArchitecture()) { case MA_Interpreted: arch = "Interpreted"; break; case MA_I386: arch = "I386"; break; case MA_X86_64: arch = "X86_64"; break; case MA_X86_64_32: arch = "X86_64_32"; break; case MA_Arm64: arch = "Arm64"; break; case MA_Arm64_32: arch = "Arm64_32"; break; default: arch = "Unknown"; break; } return SAVE(C_string_to_Poly(taskData, arch)); } case 19: // Return the RTS argument help string. return SAVE(C_string_to_Poly(taskData, RTSArgHelp())); default: { char msg[100]; sprintf(msg, "Unknown poly-specific function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to poly-specific. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolySpecificGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = poly_dispatch_c(taskData, pushedArg, pushedCode); } 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(); } // Return the ABI - i.e. the calling conventions used when calling external functions. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI() { // Return the ABI. For 64-bit we need to know if this is Windows. #if (SIZEOF_VOIDP == 8) #if (defined(_WIN32) || defined(__CYGWIN__)) return TAGGED(2).AsUnsigned(); // 64-bit Windows #else return TAGGED(1).AsUnsigned(); // 64-bit Unix #endif #else return TAGGED(0).AsUnsigned(); // 32-bit Unix and Windows #endif } // Code generation - Code is initially allocated in a byte segment. When all the // values have been set apart from any addresses the byte segment is copied into // a mutable code segment. // Copy the byte vector into code space. -POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure) +POLYUNSIGNED PolyCopyByteVecToClosure(POLYUNSIGNED threadId, POLYUNSIGNED byteVec, POLYUNSIGNED closure) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedByteVec = taskData->saveVec.push(byteVec); Handle pushedClosure = taskData->saveVec.push(closure); PolyObject *result = 0; #ifdef HAVE_PTHREAD_JIT_WRITE_PROTECT_NP pthread_jit_write_protect_np(false); #endif try { if (!pushedByteVec->WordP()->IsByteObject()) raise_fail(taskData, "Not byte data area"); if (pushedClosure->WordP()->Length() != sizeof(PolyObject*)/sizeof(PolyWord)) raise_fail(taskData, "Invalid closure size"); if (!pushedClosure->WordP()->IsMutable()) raise_fail(taskData, "Closure is not mutable"); do { PolyObject *initCell = pushedByteVec->WordP(); POLYUNSIGNED requiredSize = initCell->Length(); result = gMem.AllocCodeSpace(requiredSize); if (result == 0) { // Could not allocate - must GC. if (!QuickGC(taskData, pushedByteVec->WordP()->Length())) raise_fail(taskData, "Insufficient memory"); } else memcpy(gMem.SpaceForObjectAddress(result)->writeAble((byte*)result), initCell, requiredSize * sizeof(PolyWord)); } while (result == 0); } catch (...) {} // If an ML exception is raised // Store the code address in the closure. *((PolyObject**)pushedClosure->WordP()) = result; // Lock the closure. pushedClosure->WordP()->SetLengthWord(pushedClosure->WordP()->LengthWord() & ~_OBJ_MUTABLE_BIT); #ifdef HAVE_PTHREAD_JIT_WRITE_PROTECT_NP pthread_jit_write_protect_np(true); #endif taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Code generation - Lock a mutable code segment and return the original address. // Currently this does not allocate so other than the exception it could // be a fast call. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(POLYUNSIGNED threadId, POLYUNSIGNED closure) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); - PolyObject *codeObj = *(PolyObject**)(closure.AsObjPtr()); + PolyObject *codeObj = *(PolyObject**)(PolyWord::FromUnsigned(closure).AsObjPtr()); #ifdef HAVE_PTHREAD_JIT_WRITE_PROTECT_NP pthread_jit_write_protect_np(false); #endif try { if (!codeObj->IsCodeObject() || !codeObj->IsMutable()) raise_fail(taskData, "Not mutable code area"); POLYUNSIGNED segLength = codeObj->Length(); gMem.SpaceForObjectAddress(codeObj)->writeAble(codeObj)->SetLengthWord(segLength, F_CODE_OBJ); // Flush cache on ARM at least. machineDependent->FlushInstructionCache(codeObj, segLength * sizeof(PolyWord)); // In the future it may be necessary to return a different address here. // N.B. The code area should only have execute permission in the native // code version, not the interpreted version. } catch (...) {} // If an ML exception is raised #ifdef HAVE_PTHREAD_JIT_WRITE_PROTECT_NP pthread_jit_write_protect_np(true); #endif taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Set code constant. This can be a fast call. // This is in the RTS both because we pass a closure in here and cannot have // code addresses in 32-in-64 and also because we need to ensure there is no // possibility of a GC while the code is an inconsistent state. -POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord cWord, PolyWord flags) +POLYUNSIGNED PolySetCodeConstant(POLYUNSIGNED closure, POLYUNSIGNED offset, POLYUNSIGNED cWord, POLYUNSIGNED flags) { byte *pointer; #ifdef HAVE_PTHREAD_JIT_WRITE_PROTECT_NP pthread_jit_write_protect_np(false); #endif // Previously we passed the code address in here and we need to // retain that for legacy code. This is now the closure. - if (closure.AsObjPtr()->IsCodeObject()) - pointer = closure.AsCodePtr(); - else pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); + if (PolyWord::FromUnsigned(closure).AsObjPtr()->IsCodeObject()) + pointer = PolyWord::FromUnsigned(closure).AsCodePtr(); + else pointer = *(POLYCODEPTR*)(PolyWord::FromUnsigned(closure).AsObjPtr()); // pointer is the start of the code segment. // c will usually be an address. // offset is a byte offset - pointer += offset.UnTaggedUnsigned(); + pointer += PolyWord::FromUnsigned(offset).UnTaggedUnsigned(); byte* writeable = gMem.SpaceForAddress(pointer)->writeAble(pointer); - switch (UNTAGGED(flags)) + switch (UNTAGGED(PolyWord::FromUnsigned(flags))) { case 0: // Absolute constant - size PolyWord { - POLYUNSIGNED c = cWord.AsUnsigned(); + POLYUNSIGNED c = PolyWord::FromUnsigned(cWord).AsUnsigned(); #ifdef WORDS_BIGENDIAN // This is used to store constants in the constant area // on the interpreted version. for (unsigned i = sizeof(PolyWord); i > 0; i--) { writeable[i-1] = (byte)(c & 255); c >>= 8; } #else for (unsigned i = 0; i < sizeof(PolyWord); i++) { writeable[i] = (byte)(c & 255); c >>= 8; } #endif break; } case 1: // Relative constant - X86 - size 4 bytes { // The offset is relative to the END of the constant. byte *target; // In 32-in-64 we pass in the closure address here // rather than the code address. - if (cWord.AsObjPtr()->IsCodeObject()) - target = cWord.AsCodePtr(); - else target = *(POLYCODEPTR*)(cWord.AsObjPtr()); + if (PolyWord::FromUnsigned(cWord).AsObjPtr()->IsCodeObject()) + target = PolyWord::FromUnsigned(cWord).AsCodePtr(); + else target = *(POLYCODEPTR*)(PolyWord::FromUnsigned(cWord).AsObjPtr()); size_t c = target - pointer - 4; for (unsigned i = 0; i < 4; i++) { writeable[i] = (byte)(c & 255); c >>= 8; } break; } case 2: // Absolute constant - size uintptr_t // This is the same as case 0 except in 32-in-64 when // it is an absolute address rather than an object pointer. { - uintptr_t c = (uintptr_t)(cWord.AsObjPtr()); + uintptr_t c = (uintptr_t)(PolyWord::FromUnsigned(cWord).AsObjPtr()); for (unsigned i = 0; i < sizeof(uintptr_t); i++) { pointer[i] = (byte)(c & 255); c >>= 8; } break; } } #ifdef HAVE_PTHREAD_JIT_WRITE_PROTECT_NP pthread_jit_write_protect_np(true); #endif return TAGGED(0).AsUnsigned(); } // Get a code constant. This is only used for debugging. -POLYUNSIGNED PolyGetCodeConstant(PolyWord closure, PolyWord offset, PolyWord flags) +POLYUNSIGNED PolyGetCodeConstant(POLYUNSIGNED closure, POLYUNSIGNED offset, POLYUNSIGNED flags) { - byte* pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); + byte* pointer = *(POLYCODEPTR*)(PolyWord::FromUnsigned(closure).AsObjPtr()); // offset is a byte offset - pointer += offset.UnTaggedUnsigned(); - switch (UNTAGGED(flags)) + pointer += PolyWord::FromUnsigned(offset).UnTaggedUnsigned(); + switch (UNTAGGED(PolyWord::FromUnsigned(flags))) { case 0: // Absolute constant - size PolyWord { POLYUNSIGNED c = 0; #ifdef WORDS_BIGENDIAN for (unsigned i = 0; i < sizeof(PolyWord); i++) c = (c << 8) | pointer[i]; #else for (unsigned i = sizeof(PolyWord); i > 0; i--) c = (c << 8) | pointer[i-1]; #endif return c; } } // For the moment just handle that case. return TAGGED(0).AsUnsigned(); } // Set a code byte. This needs to be in the RTS because it uses the closure -POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(PolyWord closure, PolyWord offset, PolyWord cWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(POLYUNSIGNED closure, POLYUNSIGNED offset, POLYUNSIGNED cWord) { - byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); + byte *pointer = *(POLYCODEPTR*)(PolyWord::FromUnsigned(closure).AsObjPtr()); byte* writable = gMem.SpaceForAddress(pointer)->writeAble(pointer); - writable[UNTAGGED_UNSIGNED(offset)] = (byte)UNTAGGED_UNSIGNED(cWord); + writable[UNTAGGED_UNSIGNED(PolyWord::FromUnsigned(offset))] = (byte)UNTAGGED_UNSIGNED(PolyWord::FromUnsigned(cWord)); return TAGGED(0).AsUnsigned(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(POLYUNSIGNED closure, POLYUNSIGNED offset) { - byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); - return TAGGED(pointer[UNTAGGED_UNSIGNED(offset)]).AsUnsigned(); + byte *pointer = *(POLYCODEPTR*)(PolyWord::FromUnsigned(closure).AsObjPtr()); + return TAGGED(pointer[UNTAGGED_UNSIGNED(PolyWord::FromUnsigned(offset))]).AsUnsigned(); } static int compare(const void *a, const void *b) { PolyWord *av = (PolyWord*)a; PolyWord *bv = (PolyWord*)b; if ((*av).IsTagged() || (*bv).IsTagged()) return 0; // Shouldn't happen PolyObject *ao = (*av).AsObjPtr(), *bo = (*bv).AsObjPtr(); if (ao->Length() < 1 || bo->Length() < 1) return 0; // Shouldn't happen if (ao->Get(0).AsUnsigned() < bo->Get(0).AsUnsigned()) return -1; if (ao->Get(0).AsUnsigned() > bo->Get(0).AsUnsigned()) return 1; return 0; } // Sort an array of addresses. This is used in the code-generator to search for // duplicates in the address area. The argument is an array of pairs. The first // item of each pair is an address, the second is an identifier of some kind. -POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(PolyWord array) +POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(POLYUNSIGNED array) { - if (!array.IsDataPtr()) return(TAGGED(0)).AsUnsigned(); - PolyObject *arrayP = array.AsObjPtr(); + if (!PolyWord::FromUnsigned(array).IsDataPtr()) return(TAGGED(0)).AsUnsigned(); + PolyObject *arrayP = PolyWord::FromUnsigned(array).AsObjPtr(); POLYUNSIGNED numberOfItems = arrayP->Length(); if (!arrayP->IsMutable()) return(TAGGED(0)).AsUnsigned(); qsort(arrayP, numberOfItems, sizeof(PolyWord), compare); return (TAGGED(1)).AsUnsigned(); } // Return the value of globalHeapBase as a SysWord value. // This is used in just one place: when compiling an FFI callback stub in ARM 32-in-64. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetHeapBase(FirstArgument threadId) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetHeapBase(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle result = 0; try { #ifdef POLYML32IN64 result = Make_sysword(taskData, (uintptr_t)globalHeapBase); #else result = Make_sysword(taskData, 0); #endif } catch (...) {} // If an ML exception is raised taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2, POLYUNSIGNED arg3, POLYUNSIGNED arg4) { - switch (arg1.UnTaggedUnsigned()) + switch (PolyWord::FromUnsigned(arg1).UnTaggedUnsigned()) { - case 1: return arg1.AsUnsigned(); - case 2: return arg2.AsUnsigned(); - case 3: return arg3.AsUnsigned(); - case 4: return arg4.AsUnsigned(); + case 1: return arg1; + case 2: return arg2; + case 3: return arg3; + case 4: return arg4; default: return TAGGED(0).AsUnsigned(); } } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(POLYUNSIGNED threadId, POLYUNSIGNED arg1, POLYUNSIGNED arg2, POLYUNSIGNED arg3, POLYUNSIGNED arg4, POLYUNSIGNED arg5) { - switch (arg1.UnTaggedUnsigned()) + switch (PolyWord::FromUnsigned(arg1).UnTaggedUnsigned()) { - case 1: return arg1.AsUnsigned(); - case 2: return arg2.AsUnsigned(); - case 3: return arg3.AsUnsigned(); - case 4: return arg4.AsUnsigned(); - case 5: return arg5.AsUnsigned(); + case 1: return arg1; + case 2: return arg2; + case 3: return arg3; + case 4: return arg4; + case 5: return arg5; default: return TAGGED(0).AsUnsigned(); } } struct _entrypts polySpecificEPT[] = { { "PolySpecificGeneral", (polyRTSFunction)&PolySpecificGeneral}, { "PolyGetABI", (polyRTSFunction)&PolyGetABI }, { "PolyCopyByteVecToClosure", (polyRTSFunction)&PolyCopyByteVecToClosure }, { "PolyLockMutableClosure", (polyRTSFunction)&PolyLockMutableClosure }, { "PolySetCodeConstant", (polyRTSFunction)&PolySetCodeConstant }, { "PolyGetCodeConstant", (polyRTSFunction)&PolyGetCodeConstant }, { "PolySetCodeByte", (polyRTSFunction)&PolySetCodeByte }, { "PolyGetCodeByte", (polyRTSFunction)&PolyGetCodeByte }, { "PolySortArrayOfAddresses", (polyRTSFunction)&PolySortArrayOfAddresses }, { "PolyGetHeapBase", (polyRTSFunction)&PolyGetHeapBase }, { "PolyTest4", (polyRTSFunction)&PolyTest4 }, { "PolyTest5", (polyRTSFunction)&PolyTest5 }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/polyffi.cpp b/libpolyml/polyffi.cpp index 2a3e7aff..e4a39574 100644 --- a/libpolyml/polyffi.cpp +++ b/libpolyml/polyffi.cpp @@ -1,410 +1,410 @@ /* Title: New Foreign Function Interface Copyright (c) 2015, 2018, 2019 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_DLFCN_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_STRING_H #include #endif #include "globals.h" // TODO: Do we need this?? // We need to include globals.h before in mingw64 otherwise // it messes up POLYUFMT/POLYSFMT. #include #include "arb.h" #include "save_vec.h" #include "polyffi.h" #include "run_time.h" #include "sys.h" #include "processes.h" #include "polystring.h" #if (defined(_WIN32)) #include #include "winstartup.h" /* For hApplicationInstance. */ #endif #include "scanaddrs.h" #include "diagnostics.h" #include "reals.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeFloat(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeDouble(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeShort(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeInt(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeLong(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetError(PolyWord addr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFISetError(PolyWord err); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL void PolyFFICallbackException(PolyWord exnMessage); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIMalloc(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIFree(PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFILoadLibrary(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFILoadExecutable(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIUnloadLibrary(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetSymbolAddress(FirstArgument threadId, PolyWord moduleAddress, PolyWord symbolName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetError(POLYUNSIGNED addr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFISetError(POLYUNSIGNED err); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL void PolyFFICallbackException(POLYUNSIGNED exnMessage); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIMalloc(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIFree(POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFILoadLibrary(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFILoadExecutable(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIUnloadLibrary(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetSymbolAddress(POLYUNSIGNED threadId, POLYUNSIGNED moduleAddress, POLYUNSIGNED symbolName); } static Handle toSysWord(TaskData *taskData, void *p) { return Make_sysword(taskData, (uintptr_t)p); } // Malloc memory - Needs to allocate the SysWord.word value on the heap. -POLYUNSIGNED PolyFFIMalloc(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyFFIMalloc(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - POLYUNSIGNED size = getPolyUnsigned(taskData, arg); + POLYUNSIGNED size = getPolyUnsigned(taskData, PolyWord::FromUnsigned(arg)); result = toSysWord(taskData, malloc(size)); } 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(); } // Free memory. Not currently used: freed memory is just added back to the free list. -POLYUNSIGNED PolyFFIFree(PolyWord arg) +POLYUNSIGNED PolyFFIFree(POLYUNSIGNED arg) { - void* mem = *(void**)(arg.AsObjPtr()); + void* mem = *(void**)(PolyWord::FromUnsigned(arg).AsObjPtr()); free(mem); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyFFILoadLibrary(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyFFILoadLibrary(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - TempString libName(arg); + TempString libName(PolyWord::FromUnsigned(arg)); #if (defined(_WIN32)) HINSTANCE lib = LoadLibrary(libName); if (lib == NULL) { char buf[256]; #if (defined(UNICODE)) _snprintf(buf, sizeof(buf), "Loading <%S> failed. Error %lu", (LPCTSTR)libName, GetLastError()); #else _snprintf(buf, sizeof(buf), "Loading <%s> failed. Error %lu", (const char*)libName, GetLastError()); #endif buf[sizeof(buf) - 1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #else void* lib = dlopen(libName, RTLD_LAZY); if (lib == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "Loading <%s> failed: %s", (const char*)libName, dlerror()); buf[sizeof(buf) - 1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif result = toSysWord(taskData, lib); } 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(); } // Get the address of the executable as a library. -POLYUNSIGNED PolyFFILoadExecutable(FirstArgument threadId) +POLYUNSIGNED PolyFFILoadExecutable(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32)) HINSTANCE lib = hApplicationInstance; #else void* lib = dlopen(NULL, RTLD_LAZY); if (lib == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "Loading address of executable failed: %s", dlerror()); buf[sizeof(buf) - 1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif result = toSysWord(taskData, lib); } 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(); } // Unload library - Is this actually going to be used? -POLYUNSIGNED PolyFFIUnloadLibrary(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyFFIUnloadLibrary(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { #if (defined(_WIN32)) - HMODULE hMod = *(HMODULE*)(arg.AsObjPtr()); + HMODULE hMod = *(HMODULE*)(PolyWord::FromUnsigned(arg).AsObjPtr()); if (!FreeLibrary(hMod)) raise_syscall(taskData, "FreeLibrary failed", GetLastError()); #else - void* lib = *(void**)(arg.AsObjPtr()); + void* lib = *(void**)(PolyWord::FromUnsigned(arg).AsObjPtr()); if (dlclose(lib) != 0) { char buf[256]; snprintf(buf, sizeof(buf), "dlclose failed: %s", dlerror()); buf[sizeof(buf) - 1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Load the address of a symbol from a library. -POLYUNSIGNED PolyFFIGetSymbolAddress(FirstArgument threadId, PolyWord moduleAddress, PolyWord symbolName) +POLYUNSIGNED PolyFFIGetSymbolAddress(POLYUNSIGNED threadId, POLYUNSIGNED moduleAddress, POLYUNSIGNED symbolName) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - TempCString symName(symbolName); + TempCString symName(PolyWord::FromUnsigned(symbolName)); #if (defined(_WIN32)) - HMODULE hMod = *(HMODULE*)(moduleAddress.AsObjPtr()); + HMODULE hMod = *(HMODULE*)(PolyWord::FromUnsigned(moduleAddress).AsObjPtr()); void* sym = (void*)GetProcAddress(hMod, symName); if (sym == NULL) { char buf[256]; _snprintf(buf, sizeof(buf), "Loading symbol <%s> failed. Error %lu", (LPCSTR)symName, GetLastError()); buf[sizeof(buf) - 1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #else - void* lib = *(void**)(moduleAddress.AsObjPtr()); + void* lib = *(void**)(PolyWord::FromUnsigned(moduleAddress).AsObjPtr()); void* sym = dlsym(lib, symName); if (sym == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "load_sym <%s> : %s", (const char*)symName, dlerror()); buf[sizeof(buf) - 1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif result = toSysWord(taskData, sym); } 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(); } // These functions are needed in the compiler POLYUNSIGNED PolySizeFloat() { return TAGGED((POLYSIGNED)sizeof(float)).AsUnsigned(); } POLYUNSIGNED PolySizeDouble() { return TAGGED((POLYSIGNED)sizeof(double)).AsUnsigned(); } POLYUNSIGNED PolySizeShort() { return TAGGED((POLYSIGNED)sizeof(short)).AsUnsigned(); } POLYUNSIGNED PolySizeInt() { return TAGGED((POLYSIGNED)sizeof(int)).AsUnsigned(); } POLYUNSIGNED PolySizeLong() { return TAGGED((POLYSIGNED)sizeof(long)).AsUnsigned(); } // Get either errno or GetLastError -POLYUNSIGNED PolyFFIGetError(PolyWord addr) +POLYUNSIGNED PolyFFIGetError(POLYUNSIGNED addr) { #if (defined(_WIN32)) - addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned(GetLastError())); + PolyWord::FromUnsigned(addr).AsObjPtr()->Set(0, PolyWord::FromUnsigned(GetLastError())); #else - addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned((POLYUNSIGNED)errno)); + PolyWord::FromUnsigned(addr).AsObjPtr()->Set(0, PolyWord::FromUnsigned((POLYUNSIGNED)errno)); #endif return 0; } // The argument is a SysWord.word value i.e. the address of a byte cell. -POLYUNSIGNED PolyFFISetError(PolyWord err) +POLYUNSIGNED PolyFFISetError(POLYUNSIGNED err) { #if (defined(_WIN32)) - SetLastError((DWORD)(err.AsObjPtr()->Get(0).AsUnsigned())); + SetLastError((DWORD)(PolyWord::FromUnsigned(err).AsObjPtr()->Get(0).AsUnsigned())); #else - errno = err.AsObjPtr()->Get(0).AsSigned(); + errno = PolyWord::FromUnsigned(err).AsObjPtr()->Get(0).AsSigned(); #endif return 0; } // Create an external function reference. The value returned has space for // an address followed by the name of the external symbol. Because the // address comes at the beginning it can be used in the same way as the // SysWord value returned by the get-symbol call from a library. -POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyFFICreateExtFn(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = creatEntryPointObject(taskData, pushedArg, true); } 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(); } // Create an external reference to data. On a small number of platforms // different forms of relocation are needed for data and for functions. -POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyFFICreateExtData(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = creatEntryPointObject(taskData, pushedArg, false); } 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(); } // Called if a callback raises an exception. There's nothing we // can do because we don't have anything to pass back to C. -void PolyFFICallbackException(PolyWord exnMessage) +void PolyFFICallbackException(POLYUNSIGNED exnMessage) { - TempCString exception(exnMessage); + TempCString exception(PolyWord::FromUnsigned(exnMessage)); Crash("An ML function called from foreign code raised an exception: (%s). Unable to continue.", (const char *)exception); } struct _entrypts polyFFIEPT[] = { { "PolySizeFloat", (polyRTSFunction)&PolySizeFloat}, { "PolySizeDouble", (polyRTSFunction)&PolySizeDouble}, { "PolySizeShort", (polyRTSFunction)&PolySizeShort}, { "PolySizeInt", (polyRTSFunction)&PolySizeInt}, { "PolySizeLong", (polyRTSFunction)&PolySizeLong}, { "PolyFFIGetError", (polyRTSFunction)&PolyFFIGetError}, { "PolyFFISetError", (polyRTSFunction)&PolyFFISetError}, { "PolyFFICreateExtFn", (polyRTSFunction)&PolyFFICreateExtFn}, { "PolyFFICreateExtData", (polyRTSFunction)&PolyFFICreateExtData }, { "PolyFFICallbackException", (polyRTSFunction)&PolyFFICallbackException }, { "PolyFFIMalloc", (polyRTSFunction)&PolyFFIMalloc }, { "PolyFFIFree", (polyRTSFunction)&PolyFFIFree }, { "PolyFFILoadLibrary", (polyRTSFunction)&PolyFFILoadLibrary }, { "PolyFFILoadExecutable", (polyRTSFunction)&PolyFFILoadExecutable }, { "PolyFFIUnloadLibrary", (polyRTSFunction)&PolyFFIUnloadLibrary }, { "PolyFFIGetSymbolAddress", (polyRTSFunction)&PolyFFIGetSymbolAddress }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/process_env.cpp b/libpolyml/process_env.cpp index 145594d1..a22150fb 100644 --- a/libpolyml/process_env.cpp +++ b/libpolyml/process_env.cpp @@ -1,669 +1,669 @@ /* Title: Process environment. Copyright (c) 2000-8, 2016-17, 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 */ #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_ERRNO_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_WAIT_H #include #endif #if (defined(__CYGWIN__) || defined(_WIN32)) #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif // Include this next before errors.h since in WinCE at least the winsock errors are defined there. #if (defined(_WIN32)) #include #include #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #undef ENOMEM #else typedef char TCHAR; #define _tgetenv getenv #define NOMEMORY ENOMEM #endif #include "globals.h" #include "sys.h" #include "run_time.h" #include "process_env.h" #include "arb.h" #include "mpoly.h" #include "gc.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "process_env.h" #include "rts_module.h" #include "machine_dep.h" #include "processes.h" #include "locking.h" #include "errors.h" #include "rtsentry.h" #include "version.h" extern "C" { - POLYEXTERNALSYMBOL void PolyFinish(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL void PolyTerminate(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord syserr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord syserr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord string); + POLYEXTERNALSYMBOL void PolyFinish(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL void PolyTerminate(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorName(POLYUNSIGNED threadId, POLYUNSIGNED syserr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorMessage(POLYUNSIGNED threadId, POLYUNSIGNED syserr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorFromString(POLYUNSIGNED threadId, POLYUNSIGNED string); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxAllocationSize(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetProcessName(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCommandlineArguments(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnv(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnvironment(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSuccessValue(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvFailureValue(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSystem(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(POLYUNSIGNED threadId, POLYUNSIGNED fnAddr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetProcessName(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCommandlineArguments(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnv(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnvironment(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSuccessValue(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvFailureValue(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSystem(POLYUNSIGNED threadId, POLYUNSIGNED arg); } #define SAVE(x) taskData->saveVec.push(x) #define ALLOC(n) alloc_and_save(taskData, n) #if (defined(_WIN32)) #define ISPATHSEPARATOR(c) ((c) == '\\' || (c) == '/') #define DEFAULTSEPARATOR "\\" #else #define ISPATHSEPARATOR(c) ((c) == '/') #define DEFAULTSEPARATOR "/" #endif #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif // "environ" is declared in the headers on some systems but not all. // Oddly, declaring it within process_env_dispatch_c causes problems // on mingw where "environ" is actually a function. #if __APPLE__ // On Mac OS X there may be problems accessing environ directly. #include #define environ (*_NSGetEnviron()) #else extern char **environ; #endif #ifdef __CYGWIN__ // Cygwin requires spawnvp to avoid the significant overhead of vfork // but it doesn't seem to be thread-safe. Run it on the main thread // to be sure. class CygwinSpawnRequest: public MainThreadRequest { public: CygwinSpawnRequest(char **argv): MainThreadRequest(MTP_CYGWINSPAWN), spawnArgv(argv) {} virtual void Perform(); char **spawnArgv; int pid; }; void CygwinSpawnRequest::Perform() { pid = spawnvp(_P_NOWAIT, "/bin/sh", spawnArgv); } #endif // These are now just legacy calls. static Handle process_env_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 1: /* Return the argument list. */ // This is used in the pre-built compilers. return convert_string_list(taskData, userOptions.user_arg_count, userOptions.user_arg_strings); default: { char msg[100]; sprintf(msg, "Unknown environment function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to process-env. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyProcessEnvGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = process_env_dispatch_c(taskData, pushedArg, pushedCode); } catch (KillException &) { processes->ThreadExit(taskData); // May test for kill } 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(); } // Terminate normally with a result code. -void PolyFinish(FirstArgument threadId, PolyWord arg) +void PolyFinish(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); - int i = get_C_int(taskData, arg); + int i = get_C_int(taskData, PolyWord::FromUnsigned(arg)); // Cause the other threads to exit and set the result code. processes->RequestProcessExit(i); // Exit this thread processes->ThreadExit(taskData); // Doesn't return. } // Terminate without running the atExit list or flushing buffers -void PolyTerminate(FirstArgument threadId, PolyWord arg) +void PolyTerminate(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); - int i = get_C_int(taskData, arg); + int i = get_C_int(taskData, PolyWord::FromUnsigned(arg)); _exit(i); // Doesn't return. } // Get the name of a numeric error message. -POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord syserr) +POLYUNSIGNED PolyProcessEnvErrorName(POLYUNSIGNED threadId, POLYUNSIGNED syserr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - int e = (int)syserr.AsObjPtr()->Get(0).AsSigned(); + int e = (int)PolyWord::FromUnsigned(syserr).AsObjPtr()->Get(0).AsSigned(); // First look to see if we have the name in the error table. They should generally all be there. const char *errorMsg = stringFromErrorCode(e); if (errorMsg != NULL) result = taskData->saveVec.push(C_string_to_Poly(taskData, errorMsg)); else { // If it isn't in the table. char buff[40]; sprintf(buff, "ERROR%0d", e); result = taskData->saveVec.push(C_string_to_Poly(taskData, buff)); } } 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(); } /* Get the explanatory message for an error. */ -POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord syserr) +POLYUNSIGNED PolyProcessEnvErrorMessage(POLYUNSIGNED threadId, POLYUNSIGNED syserr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - result = errorMsg(taskData, (int)syserr.AsObjPtr()->Get(0).AsSigned()); + result = errorMsg(taskData, (int)PolyWord::FromUnsigned(syserr).AsObjPtr()->Get(0).AsSigned()); } 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(); } // Try to convert an error string to an error number. -POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord string) +POLYUNSIGNED PolyProcessEnvErrorFromString(POLYUNSIGNED threadId, POLYUNSIGNED string) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { char buff[40]; // Get the string. - Poly_string_to_C(string, buff, sizeof(buff)); + Poly_string_to_C(PolyWord::FromUnsigned(string), buff, sizeof(buff)); // Look the string up in the table. int err = 0; if (errorCodeFromString(buff, &err)) result = Make_sysword(taskData, err); else if (strncmp(buff, "ERROR", 5) == 0) // If we don't find it then it may have been a constructed error name. result = Make_sysword(taskData, atoi(buff+5)); else result = Make_sysword(taskData, 0); // Return 0w0 if it isn't there. } 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(); } // Return the maximum size of a cell that can be allocated on the heap. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxAllocationSize() { return TAGGED(MAX_OBJECT_SIZE).AsUnsigned(); } // Return the maximum string size (in bytes). // It is the maximum number of bytes in a segment less one word for the length field. POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize() { return TAGGED((MAX_OBJECT_SIZE) * sizeof(PolyWord) - sizeof(PolyWord)).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber() { return TAGGED(POLY_version_number).AsUnsigned(); } // Return the function name associated with a piece of compiled code. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(POLYUNSIGNED threadId, POLYUNSIGNED fnAddr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - if (fnAddr.IsTagged()) raise_fail(taskData, "Not a code pointer"); - PolyObject *pt = fnAddr.AsObjPtr(); + if (PolyWord::FromUnsigned(fnAddr).IsTagged()) raise_fail(taskData, "Not a code pointer"); + PolyObject *pt = PolyWord::FromUnsigned(fnAddr).AsObjPtr(); // In 32-in-64 this may be a closure and the first word is the absolute address of the code. if (pt->IsClosureObject()) { // It may not be set yet. pt = *(PolyObject**)pt; if (((uintptr_t)pt & 1) == 1) raise_fail(taskData, "Not a code pointer"); } if (pt->IsCodeObject()) /* Should now be a code object. */ { /* Compiled code. This is the first constant in the constant area. */ PolyWord *codePt = machineDependent->ConstPtrForCode(pt); PolyWord name = codePt[0]; /* May be zero indicating an anonymous segment - return null string. */ if (name == PolyWord::FromUnsigned(0)) result = taskData->saveVec.push(C_string_to_Poly(taskData, "")); else result = taskData->saveVec.push(name); } else raise_fail(taskData, "Not a code pointer"); } 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(); } // Get the command line process name. -POLYUNSIGNED PolyGetProcessName(FirstArgument threadId) +POLYUNSIGNED PolyGetProcessName(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = taskData->saveVec.push(C_string_to_Poly(taskData, userOptions.programName)); } 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(); } // Get the command line arguments. -POLYUNSIGNED PolyGetCommandlineArguments(FirstArgument threadId) +POLYUNSIGNED PolyGetCommandlineArguments(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = convert_string_list(taskData, userOptions.user_arg_count, userOptions.user_arg_strings); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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(); } /* Return a string from the environment. */ -POLYUNSIGNED PolyGetEnv(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyGetEnv(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { TempString buff(pushedArg->Word()); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); TCHAR * res = _tgetenv(buff); if (res == NULL) raise_syscall(taskData, "Not Found", 0); result = taskData->saveVec.push(C_string_to_Poly(taskData, res)); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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(); } // Return the whole environment. Only available in Posix.ProcEnv. -POLYUNSIGNED PolyGetEnvironment(FirstArgument threadId) +POLYUNSIGNED PolyGetEnvironment(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { /* Count the environment strings */ int env_count = 0; while (environ[env_count] != NULL) env_count++; result = convert_string_list(taskData, env_count, environ); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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(); } /* Return the success value. */ -POLYUNSIGNED PolyProcessEnvSuccessValue(FirstArgument threadId) +POLYUNSIGNED PolyProcessEnvSuccessValue(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = Make_fixed_precision(taskData, EXIT_SUCCESS); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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(); } /* Return a failure value. */ -POLYUNSIGNED PolyProcessEnvFailureValue(FirstArgument threadId) +POLYUNSIGNED PolyProcessEnvFailureValue(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = Make_fixed_precision(taskData, EXIT_FAILURE); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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(); } /* Run command. */ -POLYUNSIGNED PolyProcessEnvSystem(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyProcessEnvSystem(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { TempString buff(pushedArg->Word()); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int res = -1; #if (defined(_WIN32) && ! defined(__CYGWIN__)) // Windows. TCHAR * argv[4]; argv[0] = _tgetenv(_T("COMSPEC")); // Default CLI. if (argv[0] == 0) argv[0] = (TCHAR*)_T("cmd.exe"); // Win NT etc. argv[1] = (TCHAR*)_T("/c"); argv[2] = buff; argv[3] = NULL; // If _P_NOWAIT is given the result is the process handle. // spawnvp does any necessary path searching if argv[0] // does not contain a full path. intptr_t pid = _tspawnvp(_P_NOWAIT, argv[0], argv); if (pid == -1) raise_syscall(taskData, "Function system failed", errno); #else // Cygwin and Unix char* argv[4]; argv[0] = (char*)"sh"; argv[1] = (char*)"-c"; argv[2] = buff; argv[3] = NULL; #if (defined(__CYGWIN__)) CygwinSpawnRequest request(argv); processes->MakeRootRequest(taskData, &request); int pid = request.pid; if (pid < 0) raise_syscall(taskData, "Function system failed", errno); #else // We need to break this down so that we can unblock signals in the // child process. // The Unix "system" function seems to set SIGINT and SIGQUIT to // SIG_IGN in the parent so that the wait will not be interrupted. // That may make sense in a single-threaded application but is // that right here? int pid = vfork(); if (pid == -1) raise_syscall(taskData, "Function system failed", errno); else if (pid == 0) { // In child sigset_t sigset; sigemptyset(&sigset); sigprocmask(SIG_SETMASK, &sigset, 0); // Reset other signals? execv("/bin/sh", argv); _exit(1); } #endif #endif while (true) { try { // Test to see if the child has returned. #if (defined(_WIN32) && ! defined(__CYGWIN__)) DWORD dwWait = WaitForSingleObject((HANDLE)pid, 0); if (dwWait == WAIT_OBJECT_0) { DWORD dwResult; BOOL fResult = GetExitCodeProcess((HANDLE)pid, &dwResult); if (!fResult) raise_syscall(taskData, "Function system failed", GetLastError()); CloseHandle((HANDLE)pid); result = Make_fixed_precision(taskData, dwResult); break; } else if (dwWait == WAIT_FAILED) raise_syscall(taskData, "Function system failed", GetLastError()); else { // Wait for the process to exit or for the timeout WaitHandle waiter((HANDLE)pid, 1000); processes->ThreadPauseForIO(taskData, &waiter); } #else int wRes = waitpid(pid, &res, WNOHANG); if (wRes > 0) break; else if (wRes < 0) { raise_syscall(taskData, "Function system failed", errno); } // In Unix the best we can do is wait. This may be interrupted // by SIGCHLD depending on where signals are processed. // One possibility is for the main thread to somehow wake-up // the thread when it processes a SIGCHLD. else processes->ThreadPause(taskData); #endif } catch (...) { // Either IOException or KillException. // We're abandoning the wait. This will leave // a zombie in Unix. #if (defined(_WIN32) && ! defined(__CYGWIN__)) CloseHandle((HANDLE)pid); #endif throw; } } result = Make_fixed_precision(taskData, res); } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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 processEnvEPT[] = { { "PolyFinish", (polyRTSFunction)&PolyFinish}, { "PolyTerminate", (polyRTSFunction)&PolyTerminate}, { "PolyProcessEnvGeneral", (polyRTSFunction)&PolyProcessEnvGeneral}, { "PolyProcessEnvErrorName", (polyRTSFunction)&PolyProcessEnvErrorName}, { "PolyProcessEnvErrorMessage", (polyRTSFunction)&PolyProcessEnvErrorMessage}, { "PolyProcessEnvErrorFromString", (polyRTSFunction)&PolyProcessEnvErrorFromString}, { "PolyGetMaxAllocationSize", (polyRTSFunction)&PolyGetMaxAllocationSize }, { "PolyGetMaxStringSize", (polyRTSFunction)&PolyGetMaxStringSize }, { "PolyGetPolyVersionNumber", (polyRTSFunction)&PolyGetPolyVersionNumber }, { "PolyGetFunctionName", (polyRTSFunction)&PolyGetFunctionName }, { "PolyGetProcessName", (polyRTSFunction)&PolyGetProcessName }, { "PolyGetCommandlineArguments", (polyRTSFunction)&PolyGetCommandlineArguments }, { "PolyGetEnv", (polyRTSFunction)& PolyGetEnv }, { "PolyGetEnvironment", (polyRTSFunction)& PolyGetEnvironment }, { "PolyProcessEnvSuccessValue", (polyRTSFunction)& PolyProcessEnvSuccessValue }, { "PolyProcessEnvFailureValue", (polyRTSFunction)& PolyProcessEnvFailureValue }, { "PolyProcessEnvSystem", (polyRTSFunction)& PolyProcessEnvSystem }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/processes.cpp b/libpolyml/processes.cpp index 44297042..5c8f5add 100644 --- a/libpolyml/processes.cpp +++ b/libpolyml/processes.cpp @@ -1,2166 +1,2167 @@ /* Title: Thread functions Author: David C.J. Matthews Copyright (c) 2007,2008,2013-15, 2017, 2019-21 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 */ #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_ERRNO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_PROCESS_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_UNISTD_H #include // Want unistd for _SC_NPROCESSORS_ONLN at least #endif #ifdef HAVE_SYS_SELECT_H #include #endif #ifdef HAVE_WINDOWS_H #include #endif #if (!defined(_WIN32)) #include #endif #ifdef HAVE_SYS_SYSCTL_H // Used determine number of processors in Mac OS X. #include #endif #if (defined(_WIN32)) #include #endif #include #include /************************************************************************ * * Include runtime headers * ************************************************************************/ #include "globals.h" #include "gc.h" #include "mpoly.h" #include "arb.h" #include "machine_dep.h" #include "diagnostics.h" #include "processes.h" #include "run_time.h" #include "sys.h" #include "sighandler.h" #include "scanaddrs.h" #include "save_vec.h" #include "rts_module.h" #include "noreturn.h" #include "memmgr.h" #include "locking.h" #include "profiling.h" #include "sharedata.h" #include "exporter.h" #include "statistics.h" #include "rtsentry.h" #include "gc_progress.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillSelf(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexBlock(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexUnlock(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWait(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWaitUntil(FirstArgument threadId, PolyWord lockArg, PolyWord timeArg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWake(PolyWord targetThread); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadForkThread(FirstArgument threadId, PolyWord function, PolyWord attrs, PolyWord stack); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadIsActive(PolyWord targetThread); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadInterruptThread(PolyWord targetThread); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillThread(PolyWord targetThread); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadBroadcastInterrupt(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillSelf(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexBlock(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexUnlock(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWait(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWaitUntil(POLYUNSIGNED threadId, POLYUNSIGNED lockArg, POLYUNSIGNED timeArg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWake(POLYUNSIGNED targetThread); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadForkThread(POLYUNSIGNED threadId, POLYUNSIGNED function, POLYUNSIGNED attrs, POLYUNSIGNED stack); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadIsActive(POLYUNSIGNED targetThread); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadInterruptThread(POLYUNSIGNED targetThread); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillThread(POLYUNSIGNED targetThread); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadBroadcastInterrupt(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadTestInterrupt(POLYUNSIGNED threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumProcessors(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumPhysicalProcessors(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMaxStackSize(FirstArgument threadId, PolyWord newSize); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMaxStackSize(POLYUNSIGNED threadId, POLYUNSIGNED newSize); } #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) // These values are stored in the second word of thread id object as // a tagged integer. They may be set and read by the thread in the ML // code. #define PFLAG_BROADCAST 1 // If set, accepts a broadcast // How to handle interrrupts #define PFLAG_IGNORE 0 // Ignore interrupts completely #define PFLAG_SYNCH 2 // Handle synchronously #define PFLAG_ASYNCH 4 // Handle asynchronously #define PFLAG_ASYNCH_ONCE 6 // First handle asynchronously then switch to synch. #define PFLAG_INTMASK 6 // Mask of the above bits struct _entrypts processesEPT[] = { { "PolyThreadKillSelf", (polyRTSFunction)&PolyThreadKillSelf}, { "PolyThreadMutexBlock", (polyRTSFunction)&PolyThreadMutexBlock}, { "PolyThreadMutexUnlock", (polyRTSFunction)&PolyThreadMutexUnlock}, { "PolyThreadCondVarWait", (polyRTSFunction)&PolyThreadCondVarWait}, { "PolyThreadCondVarWaitUntil", (polyRTSFunction)&PolyThreadCondVarWaitUntil}, { "PolyThreadCondVarWake", (polyRTSFunction)&PolyThreadCondVarWake}, { "PolyThreadForkThread", (polyRTSFunction)&PolyThreadForkThread}, { "PolyThreadIsActive", (polyRTSFunction)&PolyThreadIsActive}, { "PolyThreadInterruptThread", (polyRTSFunction)&PolyThreadInterruptThread}, { "PolyThreadKillThread", (polyRTSFunction)&PolyThreadKillThread}, { "PolyThreadBroadcastInterrupt", (polyRTSFunction)&PolyThreadBroadcastInterrupt}, { "PolyThreadTestInterrupt", (polyRTSFunction)&PolyThreadTestInterrupt}, { "PolyThreadNumProcessors", (polyRTSFunction)&PolyThreadNumProcessors}, { "PolyThreadNumPhysicalProcessors",(polyRTSFunction)&PolyThreadNumPhysicalProcessors}, { "PolyThreadMaxStackSize", (polyRTSFunction)&PolyThreadMaxStackSize}, { NULL, NULL} // End of list. }; class Processes: public ProcessExternal, public RtsModule { public: Processes(); // RtsModule overrides virtual void Init(void); virtual void Stop(void); virtual void GarbageCollect(ScanAddress *process); virtual void ForkChild(void) { singleThreaded = true; } // After a Unix fork this is single threaded public: void BroadcastInterrupt(void); void BeginRootThread(PolyObject *rootFunction); void RequestProcessExit(int n); // Request all ML threads to exit and set the process result code. // Called when a thread has completed - doesn't return. virtual NORETURNFN(void ThreadExit(TaskData *taskData)); // Called when a thread may block. Returns some time later when perhaps // the input is available. virtual void ThreadPauseForIO(TaskData *taskData, Waiter *pWait); // Return the task data for the current thread. virtual TaskData *GetTaskDataForThread(void); // Create a new task data object for the current thread. virtual TaskData *CreateNewTaskData(); // Create a new thread. The "args" argument is only used for threads // created in the RTS by the signal handler. Handle ForkThread(TaskData *taskData, Handle threadFunction, PolyWord flags, PolyWord stacksize); // Process general RTS requests from ML. Handle ThreadDispatch(TaskData *taskData, Handle args, Handle code); virtual void ThreadUseMLMemory(TaskData *taskData); virtual void ThreadReleaseMLMemory(TaskData *taskData); virtual poly_exn* GetInterrupt(void) { return interrupt_exn; } // If the schedule lock is already held we need to use these functions. void ThreadUseMLMemoryWithSchedLock(TaskData *taskData); void ThreadReleaseMLMemoryWithSchedLock(TaskData *taskData); // Requests from the threads for actions that need to be performed by // the root thread. Make the request and wait until it has completed. virtual void MakeRootRequest(TaskData *taskData, MainThreadRequest *request); // Deal with any interrupt or kill requests. virtual bool ProcessAsynchRequests(TaskData *taskData); // Process an interrupt request synchronously. virtual void TestSynchronousRequests(TaskData *taskData); // Process any events, synchronous or asynchronous. virtual void TestAnyEvents(TaskData *taskData); // Set a thread to be interrupted or killed. Wakes up the // thread if necessary. MUST be called with schedLock held. void MakeRequest(TaskData *p, ThreadRequests request); // Profiling control. virtual void StartProfiling(void); virtual void StopProfiling(void); #ifdef HAVE_WINDOWS_H // Windows: Called every millisecond while profiling is on. void ProfileInterrupt(void); #else // Unix: Start a profile timer for a thread. void StartProfilingTimer(void); #endif // Memory allocation. Tries to allocate space. If the allocation succeeds it // may update the allocation values in the taskData object. If the heap is exhausted // it may set this thread (or other threads) to raise an exception. PolyWord *FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg); // Get the task data value from the task reference. // The task data reference is a volatile ref containing the // address of the C++ task data. // N.B. This is updated when the thread exits and the TaskData object // is deleted. TaskData *TaskForIdentifier(PolyObject *taskId) { return *(TaskData**)(((ThreadObject*)taskId)->threadRef.AsObjPtr()); } // Signal handling support. The ML signal handler thread blocks until it is // woken up by the signal detection thread. virtual bool WaitForSignal(TaskData *taskData, PLock *sigLock); virtual void SignalArrived(void); // Operations on mutexes void MutexBlock(TaskData *taskData, Handle hMutex); void MutexUnlock(TaskData *taskData, Handle hMutex); // Operations on condition variables. void WaitInfinite(TaskData *taskData, Handle hMutex); void WaitUntilTime(TaskData *taskData, Handle hMutex, Handle hTime); bool WakeThread(PolyObject *targetThread); // Generally, the system runs with multiple threads. After a // fork, though, there is only one thread. bool singleThreaded; // Each thread has an entry in this vector. std::vector taskArray; /* schedLock: This lock must be held when making scheduling decisions. It must also be held before adding items to taskArray, removing them or scanning the vector. It must also be held before deleting a TaskData object or using it in a thread other than the "owner" */ PLock schedLock; #if (!defined(_WIN32)) pthread_key_t tlsId; #else DWORD tlsId; #endif // We make an exception packet for Interrupt and store it here. // This exception can be raised if we run out of store so we need to // make sure we have the packet before we do. poly_exn *interrupt_exn; /* initialThreadWait: The initial thread waits on this for wake-ups from the ML threads requesting actions such as GC or close-down. */ PCondVar initialThreadWait; // A requesting thread sets this to indicate the request. This value // is only reset once the request has been satisfied. MainThreadRequest *threadRequest; PCondVar mlThreadWait; // All the threads block on here until the request has completed. int exitResult; bool exitRequest; #ifdef HAVE_WINDOWS_H /* Windows including Cygwin */ // Used in profiling HANDLE hStopEvent; /* Signalled to stop all threads. */ HANDLE profilingHd; HANDLE mainThreadHandle; // Handle for main thread LONGLONG lastCPUTime; // CPU used by main thread. #endif TaskData *sigTask; // Pointer to current signal task. }; // Global process data. static Processes processesModule; ProcessExternal *processes = &processesModule; Processes::Processes(): singleThreaded(false), schedLock("Scheduler"), interrupt_exn(0), threadRequest(0), exitResult(0), exitRequest(false), sigTask(0) { #ifdef HAVE_WINDOWS_H hStopEvent = NULL; profilingHd = NULL; lastCPUTime = 0; mainThreadHandle = NULL; #endif } enum _mainThreadPhase mainThreadPhase = MTP_USER_CODE; // Get the attribute flags. static POLYUNSIGNED ThreadAttrs(TaskData *taskData) { return UNTAGGED_UNSIGNED(taskData->threadObject->flags); } -POLYUNSIGNED PolyThreadMutexBlock(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyThreadMutexBlock(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); if (profileMode == kProfileMutexContention) taskData->addProfileCount(1); try { processesModule.MutexBlock(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyThreadMutexUnlock(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyThreadMutexUnlock(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { processesModule.MutexUnlock(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* A mutex was locked i.e. the count was ~1 or less. We will have set it to ~1. This code blocks if the count is still ~1. It does actually return if another thread tries to lock the mutex and hasn't yet set the value to ~1 but that doesn't matter since whenever we return we simply try to get the lock again. */ void Processes::MutexBlock(TaskData *taskData, Handle hMutex) { PLocker lock(&schedLock); // We have to check the value again with schedLock held rather than // simply waiting because otherwise the unlocking thread could have // set the variable back to 0 (unlocked) and signalled any waiters // before we actually got to wait. if (UNTAGGED(DEREFHANDLE(hMutex)->Get(0)) > 1) { // Set this so we can see what we're blocked on. taskData->blockMutex = DEREFHANDLE(hMutex); // Now release the ML memory. A GC can start. ThreadReleaseMLMemoryWithSchedLock(taskData); // Wait until we're woken up. We mustn't block if we have been // interrupted, and are processing interrupts asynchronously, or // we've been killed. switch (taskData->requests) { case kRequestKill: // We've been killed. Handle this later. break; case kRequestInterrupt: { // We've been interrupted. POLYUNSIGNED attrs = ThreadAttrs(taskData) & PFLAG_INTMASK; if (attrs == PFLAG_ASYNCH || attrs == PFLAG_ASYNCH_ONCE) break; // If we're ignoring interrupts or handling them synchronously // we don't do anything here. } case kRequestNone: globalStats.incCount(PSC_THREADS_WAIT_MUTEX); taskData->threadLock.Wait(&schedLock); globalStats.decCount(PSC_THREADS_WAIT_MUTEX); } taskData->blockMutex = 0; // No longer blocked. ThreadUseMLMemoryWithSchedLock(taskData); } // Test to see if we have been interrupted and if this thread // processes interrupts asynchronously we should raise an exception // immediately. Perhaps we do that whenever we exit from the RTS. } /* Unlock a mutex. Called after decrementing the count and discovering that at least one other thread has tried to lock it. We may need to wake up threads that are blocked. */ void Processes::MutexUnlock(TaskData *taskData, Handle hMutex) { // The caller has already set the variable to 1 (unlocked). // We need to acquire schedLock so that we can // be sure that any thread that is trying to lock sees either // the updated value (and so doesn't wait) or has successfully // waited on its threadLock (and so will be woken up). PLocker lock(&schedLock); // Unlock any waiters. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; // If the thread is blocked on this mutex we can signal the thread. if (p && p->blockMutex == DEREFHANDLE(hMutex)) p->threadLock.Signal(); } } -POLYUNSIGNED PolyThreadCondVarWait(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyThreadCondVarWait(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { processesModule.WaitInfinite(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyThreadCondVarWaitUntil(FirstArgument threadId, PolyWord lockArg, PolyWord timeArg) +POLYUNSIGNED PolyThreadCondVarWaitUntil(POLYUNSIGNED threadId, POLYUNSIGNED lockArg, POLYUNSIGNED timeArg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedLockArg = taskData->saveVec.push(lockArg); Handle pushedTimeArg = taskData->saveVec.push(timeArg); try { processesModule.WaitUntilTime(taskData, pushedLockArg, pushedTimeArg); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Atomically drop a mutex and wait for a wake up. // It WILL NOT RAISE AN EXCEPTION unless it is set to handle exceptions // asynchronously (which it shouldn't do if the ML caller code is correct). // It may return as a result of any of the following: // an explicit wake up. // an interrupt, either direct or broadcast // a trap i.e. a request to handle an asynchronous event. void Processes::WaitInfinite(TaskData *taskData, Handle hMutex) { PLocker lock(&schedLock); // Atomically release the mutex. This is atomic because we hold schedLock // so no other thread can call signal or broadcast. if (! taskData->AtomicallyReleaseMutex(hMutex->WordP())) { // The mutex was locked so we have to release any waiters. // Unlock any waiters. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; // If the thread is blocked on this mutex we can signal the thread. if (p && p->blockMutex == DEREFHANDLE(hMutex)) p->threadLock.Signal(); } } // Wait until we're woken up. Don't block if we have been interrupted // or killed. if (taskData->requests == kRequestNone) { // Now release the ML memory. A GC can start. ThreadReleaseMLMemoryWithSchedLock(taskData); globalStats.incCount(PSC_THREADS_WAIT_CONDVAR); taskData->threadLock.Wait(&schedLock); globalStats.decCount(PSC_THREADS_WAIT_CONDVAR); // We want to use the memory again. ThreadUseMLMemoryWithSchedLock(taskData); } } // Atomically drop a mutex and wait for a wake up or a time to wake up void Processes::WaitUntilTime(TaskData *taskData, Handle hMutex, Handle hWakeTime) { // Convert the time into the correct format for WaitUntil before acquiring // schedLock. div_longc could do a GC which requires schedLock. #if (defined(_WIN32)) // On Windows it is the number of 100ns units since the epoch FILETIME tWake; getFileTimeFromArb(taskData, hWakeTime, &tWake); #else // Unix style times. struct timespec tWake; // On Unix we represent times as a number of microseconds. Handle hMillion = Make_arbitrary_precision(taskData, 1000000); tWake.tv_sec = get_C_ulong(taskData, DEREFWORD(div_longc(taskData, hMillion, hWakeTime))); tWake.tv_nsec = 1000*get_C_ulong(taskData, DEREFWORD(rem_longc(taskData, hMillion, hWakeTime))); #endif PLocker lock(&schedLock); // Atomically release the mutex. This is atomic because we hold schedLock // so no other thread can call signal or broadcast. if (!taskData->AtomicallyReleaseMutex(hMutex->WordP())) { // The mutex was locked so we have to release any waiters. // Unlock any waiters. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; // If the thread is blocked on this mutex we can signal the thread. if (p && p->blockMutex == DEREFHANDLE(hMutex)) p->threadLock.Signal(); } } // Wait until we're woken up. Don't block if we have been interrupted // or killed. if (taskData->requests == kRequestNone) { // Now release the ML memory. A GC can start. ThreadReleaseMLMemoryWithSchedLock(taskData); globalStats.incCount(PSC_THREADS_WAIT_CONDVAR); (void)taskData->threadLock.WaitUntil(&schedLock, &tWake); globalStats.decCount(PSC_THREADS_WAIT_CONDVAR); // We want to use the memory again. ThreadUseMLMemoryWithSchedLock(taskData); } } bool Processes::WakeThread(PolyObject *targetThread) { bool result = false; // Default to failed. // Acquire the schedLock first. This ensures that this is // atomic with respect to waiting. PLocker lock(&schedLock); TaskData *p = TaskForIdentifier(targetThread); if (p && p->threadObject == targetThread) { POLYUNSIGNED attrs = ThreadAttrs(p) & PFLAG_INTMASK; if (p->requests == kRequestNone || (p->requests == kRequestInterrupt && attrs == PFLAG_IGNORE)) { p->threadLock.Signal(); result = true; } } return result; } -POLYUNSIGNED PolyThreadCondVarWake(PolyWord targetThread) +POLYUNSIGNED PolyThreadCondVarWake(POLYUNSIGNED targetThread) { - if (processesModule.WakeThread(targetThread.AsObjPtr())) + if (processesModule.WakeThread(PolyWord::FromUnsigned(targetThread).AsObjPtr())) return TAGGED(1).AsUnsigned(); else return TAGGED(0).AsUnsigned(); } // Test if a thread is active. -POLYUNSIGNED PolyThreadIsActive(PolyWord targetThread) +POLYUNSIGNED PolyThreadIsActive(POLYUNSIGNED targetThread) { // There's a race here: the thread may be exiting but since we're not doing // anything with the TaskData object we don't need a lock. - TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr()); + TaskData *p = processesModule.TaskForIdentifier(PolyWord::FromUnsigned(targetThread).AsObjPtr()); if (p != 0) return TAGGED(1).AsUnsigned(); else return TAGGED(0).AsUnsigned(); } // Send an interrupt to a specific thread -POLYUNSIGNED PolyThreadInterruptThread(PolyWord targetThread) +POLYUNSIGNED PolyThreadInterruptThread(POLYUNSIGNED targetThread) { // Must lock here because the thread may be exiting. processesModule.schedLock.Lock(); - TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr()); + TaskData *p = processesModule.TaskForIdentifier(PolyWord::FromUnsigned(targetThread).AsObjPtr()); if (p) processesModule.MakeRequest(p, kRequestInterrupt); processesModule.schedLock.Unlock(); // If the thread cannot be identified return false. // The caller can then raise an exception if (p == 0) return TAGGED(0).AsUnsigned(); else return TAGGED(1).AsUnsigned(); } // Kill a specific thread -POLYUNSIGNED PolyThreadKillThread(PolyWord targetThread) +POLYUNSIGNED PolyThreadKillThread(POLYUNSIGNED targetThread) { processesModule.schedLock.Lock(); - TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr()); + TaskData *p = processesModule.TaskForIdentifier(PolyWord::FromUnsigned(targetThread).AsObjPtr()); if (p) processesModule.MakeRequest(p, kRequestKill); processesModule.schedLock.Unlock(); // If the thread cannot be identified return false. // The caller can then raise an exception if (p == 0) return TAGGED(0).AsUnsigned(); else return TAGGED(1).AsUnsigned(); } -POLYUNSIGNED PolyThreadBroadcastInterrupt(FirstArgument /*threadId*/) +POLYUNSIGNED PolyThreadBroadcastInterrupt(POLYUNSIGNED /*threadId*/) { processesModule.BroadcastInterrupt(); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument threadId) +POLYUNSIGNED PolyThreadTestInterrupt(POLYUNSIGNED threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { processesModule.TestSynchronousRequests(taskData); // Also process any asynchronous requests that may be pending. // These will be handled "soon" but if we have just switched from deferring // interrupts this guarantees that any deferred interrupts will be handled now. if (processesModule.ProcessAsynchRequests(taskData)) throw IOException(); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Return the number of processors. // Returns 1 if there is any problem. POLYUNSIGNED PolyThreadNumProcessors(void) { return TAGGED(NumberOfProcessors()).AsUnsigned(); } // Return the number of physical processors. // Returns 0 if there is any problem. POLYUNSIGNED PolyThreadNumPhysicalProcessors(void) { return TAGGED(NumberOfPhysicalProcessors()).AsUnsigned(); } // Set the maximum stack size. -POLYUNSIGNED PolyThreadMaxStackSize(FirstArgument threadId, PolyWord newSize) +POLYUNSIGNED PolyThreadMaxStackSize(POLYUNSIGNED threadId, POLYUNSIGNED newSizeU) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); + PolyWord newSize = PolyWord::FromUnsigned(newSizeU); try { taskData->threadObject->mlStackSize = newSize; if (newSize != TAGGED(0)) { uintptr_t current = taskData->currentStackSpace(); // Current size in words uintptr_t newWords = getPolyUnsigned(taskData, newSize); if (current > newWords) raise_exception0(taskData, EXC_interrupt); } } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Old dispatch function. This is only required because the pre-built compiler // may use some of these e.g. fork. Handle Processes::ThreadDispatch(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, code->Word()); TaskData *ptaskData = taskData; switch (c) { case 1: MutexBlock(taskData, args); return SAVE(TAGGED(0)); case 2: MutexUnlock(taskData, args); return SAVE(TAGGED(0)); case 7: // Fork a new thread. The arguments are the function to run and the attributes. return ForkThread(ptaskData, SAVE(args->WordP()->Get(0)), args->WordP()->Get(1), // For backwards compatibility we check the length here args->WordP()->Length() <= 2 ? TAGGED(0) : args->WordP()->Get(2)); case 10: // Broadcast an interrupt to all threads that are interested. BroadcastInterrupt(); return SAVE(TAGGED(0)); default: { char msg[100]; sprintf(msg, "Unknown thread function: %u", c); raise_fail(taskData, msg); return 0; } } } // Fill unused allocation space with a dummy object to preserve the invariant // that memory is always valid. void TaskData::FillUnusedSpace(void) { if (allocPointer > allocLimit) gMem.FillUnusedSpace(allocLimit, allocPointer-allocLimit); } TaskData::TaskData(): allocPointer(0), allocLimit(0), allocSize(MIN_HEAP_SIZE), allocCount(0), stack(0), threadObject(0), signalStack(0), requests(kRequestNone), blockMutex(0), inMLHeap(false), runningProfileTimer(false) { #ifdef HAVE_WINDOWS_H lastCPUTime = 0; #endif #ifdef HAVE_WINDOWS_H threadHandle = 0; #endif threadExited = false; } TaskData::~TaskData() { if (signalStack) free(signalStack); if (stack) gMem.DeleteStackSpace(stack); #ifdef HAVE_WINDOWS_H if (threadHandle) CloseHandle(threadHandle); #endif } // Broadcast an interrupt to all relevant threads. void Processes::BroadcastInterrupt(void) { // If a thread is set to accept broadcast interrupts set it to // "interrupted". PLocker lock(&schedLock); for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; if (p) { POLYUNSIGNED attrs = ThreadAttrs(p); if (attrs & PFLAG_BROADCAST) MakeRequest(p, kRequestInterrupt); } } } // Set the asynchronous request variable for the thread. Must be called // with the schedLock held. Tries to wake the thread up if possible. void Processes::MakeRequest(TaskData *p, ThreadRequests request) { // We don't override a request to kill by an interrupt request. if (p->requests < request) { p->requests = request; p->InterruptCode(); p->threadLock.Signal(); // Set the value in the ML object as well so the ML code can see it p->threadObject->requestCopy = TAGGED(request); } } void Processes::ThreadExit(TaskData *taskData) { if (debugOptions & DEBUG_THREADS) Log("THREAD: Thread %p exiting\n", taskData); #if (!defined(_WIN32)) // Block any profile interrupt from now on. We're deleting the ML stack for this thread. sigset_t block_sigs; sigemptyset(&block_sigs); sigaddset(&block_sigs, SIGVTALRM); pthread_sigmask(SIG_BLOCK, &block_sigs, NULL); // Remove the thread-specific data since it's no // longer valid. pthread_setspecific(tlsId, 0); #endif if (singleThreaded) finish(0); schedLock.Lock(); ThreadReleaseMLMemoryWithSchedLock(taskData); // Allow a GC if it was waiting for us. taskData->threadExited = true; initialThreadWait.Signal(); // Tell it we've finished. schedLock.Unlock(); #if (!defined(_WIN32)) pthread_exit(0); #else ExitThread(0); #endif } // These two functions are used for calls from outside where // the lock has not yet been acquired. void Processes::ThreadUseMLMemory(TaskData *taskData) { // Trying to acquire the lock here may block if a GC is in progress PLocker lock(&schedLock); ThreadUseMLMemoryWithSchedLock(taskData); } void Processes::ThreadReleaseMLMemory(TaskData *taskData) { PLocker lock(&schedLock); ThreadReleaseMLMemoryWithSchedLock(taskData); } // Called when a thread wants to resume using the ML heap. That could // be after a wait for some reason or after executing some foreign code. // Since there could be a GC in progress already at this point we may either // be blocked waiting to acquire schedLock or we may need to wait until // we are woken up at the end of the GC. void Processes::ThreadUseMLMemoryWithSchedLock(TaskData *taskData) { TaskData *ptaskData = taskData; // If there is a request outstanding we have to wait for it to // complete. We notify the root thread and wait for it. while (threadRequest != 0) { initialThreadWait.Signal(); // Wait for the GC to happen mlThreadWait.Wait(&schedLock); } ASSERT(! ptaskData->inMLHeap); ptaskData->inMLHeap = true; } // Called to indicate that the thread has temporarily finished with the // ML memory either because it is going to wait for something or because // it is going to run foreign code. If there is an outstanding GC request // that can proceed. void Processes::ThreadReleaseMLMemoryWithSchedLock(TaskData *taskData) { TaskData *ptaskData = taskData; ASSERT(ptaskData->inMLHeap); ptaskData->inMLHeap = false; // Put a dummy object in any unused space. This maintains the // invariant that the allocated area is filled with valid objects. ptaskData->FillUnusedSpace(); // if (threadRequest != 0) initialThreadWait.Signal(); } // Make a request to the root thread. void Processes::MakeRootRequest(TaskData *taskData, MainThreadRequest *request) { if (singleThreaded) { mainThreadPhase = request->mtp; ThreadReleaseMLMemoryWithSchedLock(taskData); // Primarily to call FillUnusedSpace request->Perform(); ThreadUseMLMemoryWithSchedLock(taskData); mainThreadPhase = MTP_USER_CODE; } else { PLocker locker(&schedLock); // Wait for any other requests. while (threadRequest != 0) { // Deal with any pending requests. ThreadReleaseMLMemoryWithSchedLock(taskData); ThreadUseMLMemoryWithSchedLock(taskData); // Drops schedLock while waiting. } // Now the other requests have been dealt with (and we have schedLock). request->completed = false; threadRequest = request; // Wait for it to complete. while (! request->completed) { ThreadReleaseMLMemoryWithSchedLock(taskData); ThreadUseMLMemoryWithSchedLock(taskData); // Drops schedLock while waiting. } } } // Find space for an object. Returns a pointer to the start. "words" must include // the length word and the result points at where the length word will go. PolyWord *Processes::FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg) { bool triedInterrupt = false; #ifdef POLYML32IN64 if (words & 1) words++; // Must always be an even number of words. #endif while (1) { // After a GC allocPointer and allocLimit are zero and when allocating the // heap segment we request a minimum of zero words. if (taskData->allocPointer != 0 && taskData->allocPointer >= taskData->allocLimit + words) { // There's space in the current segment, taskData->allocPointer -= words; #ifdef POLYML32IN64 // Zero the last word. If we've rounded up an odd number the caller won't set it. if (words != 0) taskData->allocPointer[words-1] = PolyWord::FromUnsigned(0); ASSERT((uintptr_t)taskData->allocPointer & 4); // Must be odd-word aligned #endif return taskData->allocPointer; } else // Insufficient space in this area. { if (words > taskData->allocSize && ! alwaysInSeg) { // If the object we want is larger than the heap segment size // we allocate it separately rather than in the segment. PolyWord *foundSpace = gMem.AllocHeapSpace(words); if (foundSpace) return foundSpace; } else { // Fill in any unused space in the existing segment taskData->FillUnusedSpace(); // Get another heap segment with enough space for this object. uintptr_t requestSpace = taskData->allocSize+words; uintptr_t spaceSize = requestSpace; // Get the space and update spaceSize with the actual size. PolyWord *space = gMem.AllocHeapSpace(words, spaceSize); if (space) { // Double the allocation size for the next time if // we succeeded in allocating the whole space. taskData->allocCount++; if (spaceSize == requestSpace) taskData->allocSize = taskData->allocSize*2; taskData->allocLimit = space; taskData->allocPointer = space+spaceSize; // Actually allocate the object taskData->allocPointer -= words; #ifdef POLYML32IN64 ASSERT((uintptr_t)taskData->allocPointer & 4); // Must be odd-word aligned #endif return taskData->allocPointer; } } // It's possible that another thread has requested a GC in which case // we will have memory when that happens. We don't want to start // another GC. if (! singleThreaded) { PLocker locker(&schedLock); if (threadRequest != 0) { ThreadReleaseMLMemoryWithSchedLock(taskData); ThreadUseMLMemoryWithSchedLock(taskData); continue; // Try again } } // Try garbage-collecting. If this failed return 0. if (! QuickGC(taskData, words)) { extern FILE *polyStderr; if (! triedInterrupt) { triedInterrupt = true; fprintf(polyStderr,"Run out of store - interrupting threads\n"); if (debugOptions & DEBUG_THREADS) Log("THREAD: Run out of store, interrupting threads\n"); BroadcastInterrupt(); try { if (ProcessAsynchRequests(taskData)) return 0; // Has been interrupted. } catch(KillException &) { // The thread may have been killed. ThreadExit(taskData); } // Not interrupted: pause this thread to allow for other // interrupted threads to free something. #if defined(_WIN32) Sleep(5000); #else sleep(5); #endif // Try again. } else { // That didn't work. Exit. fprintf(polyStderr,"Failed to recover - exiting\n"); RequestProcessExit(1); // Begins the shutdown process ThreadExit(taskData); // And terminate this thread. } } // Try again. There should be space now. } } } #ifdef _MSC_VER // Don't tell me that exitThread has a non-void type. #pragma warning(disable:4646) #endif Handle exitThread(TaskData *taskData) /* A call to this is put on the stack of a new thread so when the thread function returns the thread goes away. */ { processesModule.ThreadExit(taskData); } // Terminate the current thread. Never returns. -POLYUNSIGNED PolyThreadKillSelf(FirstArgument threadId) +POLYUNSIGNED PolyThreadKillSelf(POLYUNSIGNED threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); // Possibly not needed since we never return processesModule.ThreadExit(taskData); return 0; } /* Called when a thread is about to block, usually because of IO. If this is interruptable (currently only used for Posix functions) the process will be set to raise an exception if any signal is handled. It may also raise an exception if another thread has called broadcastInterrupt. */ void Processes::ThreadPauseForIO(TaskData *taskData, Waiter *pWait) { TestAnyEvents(taskData); // Consider this a blocking call that may raise Interrupt ThreadReleaseMLMemory(taskData); globalStats.incCount(PSC_THREADS_WAIT_IO); pWait->Wait(1000); // Wait up to a second globalStats.decCount(PSC_THREADS_WAIT_IO); ThreadUseMLMemory(taskData); TestAnyEvents(taskData); // Check if we've been interrupted. } // Default waiter: simply wait for the time. In Unix it may be woken // up by a signal. void Waiter::Wait(unsigned maxMillisecs) { // Since this is used only when we can't monitor the source directly // we set this to 10ms so that we're not waiting too long. if (maxMillisecs > 10) maxMillisecs = 10; #if (defined(_WIN32)) Sleep(maxMillisecs); #else // Unix fd_set read_fds, write_fds, except_fds; struct timeval toWait = { 0, 0 }; toWait.tv_sec = maxMillisecs / 1000; toWait.tv_usec = (maxMillisecs % 1000) * 1000; FD_ZERO(&read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); select(FD_SETSIZE, &read_fds, &write_fds, &except_fds, &toWait); #endif } static Waiter defWait; Waiter *Waiter::defaultWaiter = &defWait; #ifdef _WIN32 // Wait for the specified handle to be signalled. void WaitHandle::Wait(unsigned maxMillisecs) { // Wait until we get input or we're woken up. if (maxMillisecs > m_maxWait) maxMillisecs = m_maxWait; if (m_Handle == NULL) Sleep(maxMillisecs); else WaitForSingleObject(m_Handle, maxMillisecs); } #else // Unix and Cygwin: Wait for a file descriptor on input. void WaitInputFD::Wait(unsigned maxMillisecs) { fd_set read_fds, write_fds, except_fds; struct timeval toWait = { 0, 0 }; toWait.tv_sec = maxMillisecs / 1000; toWait.tv_usec = (maxMillisecs % 1000) * 1000; FD_ZERO(&read_fds); if (m_waitFD >= 0) FD_SET(m_waitFD, &read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); select(FD_SETSIZE, &read_fds, &write_fds, &except_fds, &toWait); } #endif // Get the task data for the current thread. This is held in // thread-local storage. Normally this is passed in taskData but // in a few cases this isn't available. TaskData *Processes::GetTaskDataForThread(void) { #if (!defined(_WIN32)) return (TaskData *)pthread_getspecific(tlsId); #else return (TaskData *)TlsGetValue(tlsId); #endif } // Called to create a task data object in the current thread. // This is currently only used if a thread created in foreign code calls // a callback. TaskData *Processes::CreateNewTaskData() { TaskData *taskData = machineDependent->CreateTaskData(); #if defined(HAVE_WINDOWS_H) HANDLE thisProcess = GetCurrentProcess(); DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess, &(taskData->threadHandle), THREAD_ALL_ACCESS, FALSE, 0); #endif unsigned thrdIndex; { PLocker lock(&schedLock); // See if there's a spare entry in the array. for (thrdIndex = 0; thrdIndex < taskArray.size() && taskArray[thrdIndex] != 0; thrdIndex++); if (thrdIndex == taskArray.size()) // Need to expand the array { try { taskArray.push_back(taskData); } catch (std::bad_alloc&) { delete(taskData); throw MemoryException(); } } else { taskArray[thrdIndex] = taskData; } } taskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize()); if (taskData->stack == 0) { delete(taskData); throw MemoryException(); } // TODO: Check that there isn't a problem if we try to allocate // memory here and result in a GC. taskData->InitStackFrame(taskData, 0); ThreadUseMLMemory(taskData); // Make a thread reference to point to this taskData object. Handle threadRef = MakeVolatileWord(taskData, taskData); // Make a thread object. Since it's in the thread table it can't be garbage collected. taskData->threadObject = (ThreadObject*)alloc(taskData, sizeof(ThreadObject)/sizeof(PolyWord), F_MUTABLE_BIT); taskData->threadObject->threadRef = threadRef->Word(); taskData->threadObject->flags = TAGGED(PFLAG_SYNCH); taskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store taskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state taskData->threadObject->mlStackSize = TAGGED(0); // Unlimited stack size for (unsigned i = 0; i < sizeof(taskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++) taskData->threadObject->debuggerSlots[i] = TAGGED(0); #if (!defined(_WIN32)) initThreadSignals(taskData); pthread_setspecific(tlsId, taskData); #else TlsSetValue(tlsId, taskData); #endif globalStats.incCount(PSC_THREADS); return taskData; } // This function is run when a new thread has been forked. The // parameter is the taskData value for the new thread. This function // is also called directly for the main thread. #if (!defined(_WIN32)) static void *NewThreadFunction(void *parameter) { TaskData *taskData = (TaskData *)parameter; #ifdef HAVE_WINDOWS_H // Cygwin: Get the Windows thread handle in case it's needed for profiling. HANDLE thisProcess = GetCurrentProcess(); DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess, &(taskData->threadHandle), THREAD_ALL_ACCESS, FALSE, 0); #endif initThreadSignals(taskData); pthread_setspecific(processesModule.tlsId, taskData); taskData->saveVec.init(); // Remove initial data globalStats.incCount(PSC_THREADS); processes->ThreadUseMLMemory(taskData); try { taskData->EnterPolyCode(); // Will normally (always?) call ExitThread. } catch (KillException &) { processesModule.ThreadExit(taskData); } return 0; } #else static DWORD WINAPI NewThreadFunction(void *parameter) { TaskData *taskData = (TaskData *)parameter; TlsSetValue(processesModule.tlsId, taskData); taskData->saveVec.init(); // Removal initial data globalStats.incCount(PSC_THREADS); processes->ThreadUseMLMemory(taskData); try { taskData->EnterPolyCode(); } catch (KillException &) { processesModule.ThreadExit(taskData); } return 0; } #endif // Sets up the initial thread from the root function. This is run on // the initial thread of the process so it will work if we don't // have pthreads. // When multithreading this thread also deals with all garbage-collection // and similar operations and the ML threads send it requests to deal with // that. These require all the threads to pause until the operation is complete // since they affect all memory but they are also sometimes highly recursive. // On Mac OS X and on Linux if the stack limit is set to unlimited only the // initial thread has a large stack and newly created threads have smaller // stacks. We need to make sure that any significant stack usage occurs only // on the inital thread. void Processes::BeginRootThread(PolyObject *rootFunction) { int exitLoopCount = 100; // Maximum 100 * 400 ms. if (taskArray.size() < 1) { try { taskArray.push_back(0); } catch (std::bad_alloc&) { ::Exit("Unable to create the initial thread - insufficient memory"); } } try { // We can't use ForkThread because we don't have a taskData object before we start TaskData *taskData = machineDependent->CreateTaskData(); Handle threadRef = MakeVolatileWord(taskData, taskData); taskData->threadObject = (ThreadObject*)alloc(taskData, sizeof(ThreadObject) / sizeof(PolyWord), F_MUTABLE_BIT); taskData->threadObject->threadRef = threadRef->Word(); // The initial thread is set to accept broadcast interrupt requests // and handle them synchronously. This is for backwards compatibility. taskData->threadObject->flags = TAGGED(PFLAG_BROADCAST|PFLAG_ASYNCH); // Flags taskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store taskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state taskData->threadObject->mlStackSize = TAGGED(0); // Unlimited stack size for (unsigned i = 0; i < sizeof(taskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++) taskData->threadObject->debuggerSlots[i] = TAGGED(0); #if defined(HAVE_WINDOWS_H) taskData->threadHandle = mainThreadHandle; #endif taskArray[0] = taskData; taskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize()); if (taskData->stack == 0) ::Exit("Unable to create the initial thread - insufficient memory"); taskData->InitStackFrame(taskData, taskData->saveVec.push(rootFunction)); // Create a packet for the Interrupt exception once so that we don't have to // allocate when we need to raise it. // We can only do this once the taskData object has been created. if (interrupt_exn == 0) interrupt_exn = makeExceptionPacket(taskData, EXC_interrupt); if (singleThreaded) { // If we don't have threading enter the code as if this were a new thread. // This will call finish so will never return. NewThreadFunction(taskData); } schedLock.Lock(); int errorCode = 0; #if (!defined(_WIN32)) if (pthread_create(&taskData->threadId, NULL, NewThreadFunction, taskData) != 0) errorCode = errno; #else taskData->threadHandle = CreateThread(NULL, 0, NewThreadFunction, taskData, 0, NULL); if (taskData->threadHandle == NULL) errorCode = GetLastError(); #endif if (errorCode != 0) { // Thread creation failed. taskArray[0] = 0; delete(taskData); ExitWithError("Unable to create initial thread:", errorCode); } if (debugOptions & DEBUG_THREADS) Log("THREAD: Forked initial root thread %p\n", taskData); } catch (std::bad_alloc &) { ::Exit("Unable to create the initial thread - insufficient memory"); } // Wait until the threads terminate or make a request. // We only release schedLock while waiting. while (1) { // Look at the threads to see if they are running. bool allStopped = true; bool noUserThreads = true; bool signalThreadRunning = false; for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; if (p) { if (p == sigTask) signalThreadRunning = true; else if (! p->threadExited) noUserThreads = false; if (p->inMLHeap) { allStopped = false; // It must be running - interrupt it if we are waiting. if (threadRequest != 0) p->InterruptCode(); } else if (p->threadExited) // Has the thread terminated? { // Wait for it to actually stop then delete the task data. #if (!defined(_WIN32)) pthread_join(p->threadId, NULL); #else WaitForSingleObject(p->threadHandle, INFINITE); #endif // The thread ref is no longer valid. *(TaskData**)(p->threadObject->threadRef.AsObjPtr()) = 0; delete(p); // Delete the task Data *i = 0; globalStats.decCount(PSC_THREADS); } } } if (noUserThreads) { // If all threads apart from the signal thread have exited then // we can finish but we must make sure that the signal thread has // exited before we finally finish and deallocate the memory. if (signalThreadRunning) exitRequest = true; else break; // Really no threads. } if (allStopped && threadRequest != 0) { mainThreadPhase = threadRequest->mtp; gcProgressBeginOtherGC(); // The default unless we're doing a GC. gMem.ProtectImmutable(false); // GC, sharing and export may all write to the immutable area threadRequest->Perform(); gMem.ProtectImmutable(true); mainThreadPhase = MTP_USER_CODE; gcProgressReturnToML(); threadRequest->completed = true; threadRequest = 0; // Allow a new request. mlThreadWait.Signal(); } // Have we had a request to stop? This may have happened while in the GC. if (exitRequest) { // Set this to kill the threads. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *taskData = *i; if (taskData && taskData->requests != kRequestKill) MakeRequest(taskData, kRequestKill); } // Leave exitRequest set so that if we're in the process of // creating a new thread we will request it to stop when the // taskData object has been added to the table. } // Now release schedLock and wait for a thread // to wake us up or for the timer to expire to update the statistics. if (! initialThreadWait.WaitFor(&schedLock, 400)) { // We didn't receive a request in the last 400ms if (exitRequest) { if (--exitLoopCount < 0) { // The loop count has expired and there is at least one thread that hasn't exited. // Assume we've deadlocked. #if defined(HAVE_WINDOWS_H) ExitProcess(1); #else _exit(1); // Something is stuck. Get out without calling destructors. #endif } } } // Update the periodic stats. // Calculate the free memory. We have to be careful here because although // we have the schedLock we don't have any lock that prevents a thread // from allocating a new segment. Since these statistics are only // very rough it doesn't matter if there's a glitch. // One possibility would be see if the value of // gMem.GetFreeAllocSpace() has changed from what it was at the // start and recalculate if it has. // We also count the number of threads in ML code. Taking the // lock in EnterPolyCode on every RTS call turned out to be // expensive. uintptr_t freeSpace = 0; unsigned threadsInML = 0; for (std::vector::iterator j = taskArray.begin(); j != taskArray.end(); j++) { TaskData *taskData = *j; if (taskData) { // This gets the values last time it was in the RTS. PolyWord *limit = taskData->allocLimit, *ptr = taskData->allocPointer; if (limit < ptr && (uintptr_t)(ptr-limit) < taskData->allocSize) freeSpace += ptr-limit; if (taskData->inMLHeap) threadsInML++; } } // Add the space in the allocation areas after calculating the sizes for the // threads in case a thread has allocated some more. freeSpace += gMem.GetFreeAllocSpace(); globalStats.updatePeriodicStats(freeSpace, threadsInML); // Process the profile queue if necessary. processProfileQueue(); } schedLock.Unlock(); finish(exitResult); // Close everything down and exit. } // Create a new thread. Returns the ML thread identifier object if it succeeds. // May raise an exception. Handle Processes::ForkThread(TaskData *taskData, Handle threadFunction, PolyWord flags, PolyWord stacksize) { if (singleThreaded) raise_exception_string(taskData, EXC_thread, "Threads not available"); try { // Create a taskData object for the new thread TaskData *newTaskData = machineDependent->CreateTaskData(); // We allocate the thread object in the PARENT's space Handle threadRef = MakeVolatileWord(taskData, newTaskData); Handle threadId = alloc_and_save(taskData, sizeof(ThreadObject) / sizeof(PolyWord), F_MUTABLE_BIT); newTaskData->threadObject = (ThreadObject*)DEREFHANDLE(threadId); newTaskData->threadObject->threadRef = threadRef->Word(); newTaskData->threadObject->flags = flags; // Flags newTaskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store newTaskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state newTaskData->threadObject->mlStackSize = stacksize; for (unsigned i = 0; i < sizeof(newTaskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++) newTaskData->threadObject->debuggerSlots[i] = TAGGED(0); unsigned thrdIndex; schedLock.Lock(); // Before forking a new thread check to see whether we have been asked // to exit. Processes::Exit sets the current set of threads to exit but won't // see a new thread. if (taskData->requests == kRequestKill) { schedLock.Unlock(); // Raise an exception although the thread may exit before we get there. raise_exception_string(taskData, EXC_thread, "Thread is exiting"); } // See if there's a spare entry in the array. for (thrdIndex = 0; thrdIndex < taskArray.size() && taskArray[thrdIndex] != 0; thrdIndex++); if (thrdIndex == taskArray.size()) // Need to expand the array { try { taskArray.push_back(newTaskData); } catch (std::bad_alloc&) { delete(newTaskData); schedLock.Unlock(); raise_exception_string(taskData, EXC_thread, "Too many threads"); } } else { taskArray[thrdIndex] = newTaskData; } schedLock.Unlock(); newTaskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize()); if (newTaskData->stack == 0) { delete(newTaskData); raise_exception_string(taskData, EXC_thread, "Unable to allocate thread stack"); } // Allocate anything needed for the new stack in the parent's heap. // The child still has inMLHeap set so mustn't GC. newTaskData->InitStackFrame(taskData, threadFunction); // Now actually fork the thread. bool success = false; schedLock.Lock(); #if (!defined(_WIN32)) success = pthread_create(&newTaskData->threadId, NULL, NewThreadFunction, newTaskData) == 0; #else newTaskData->threadHandle = CreateThread(NULL, 0, NewThreadFunction, newTaskData, 0, NULL); success = newTaskData->threadHandle != NULL; #endif if (success) { schedLock.Unlock(); if (debugOptions & DEBUG_THREADS) Log("THREAD: Forking new thread %p from thread %p\n", newTaskData, taskData); return threadId; } // Thread creation failed. taskArray[thrdIndex] = 0; delete(newTaskData); schedLock.Unlock(); if (debugOptions & DEBUG_THREADS) Log("THREAD: Fork from thread %p failed\n", taskData); raise_exception_string(taskData, EXC_thread, "Thread creation failed"); } catch (std::bad_alloc &) { raise_exception_string(taskData, EXC_thread, "Insufficient memory"); } } -POLYUNSIGNED PolyThreadForkThread(FirstArgument threadId, PolyWord function, PolyWord attrs, PolyWord stack) +POLYUNSIGNED PolyThreadForkThread(POLYUNSIGNED threadId, POLYUNSIGNED function, POLYUNSIGNED attrs, POLYUNSIGNED stack) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedFunction = taskData->saveVec.push(function); Handle result = 0; try { - result = processesModule.ForkThread(taskData, pushedFunction, attrs, stack); + result = processesModule.ForkThread(taskData, pushedFunction, PolyWord::FromUnsigned(attrs), PolyWord::FromUnsigned(stack)); } catch (KillException &) { processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill } 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(); } // Deal with any interrupt or kill requests. bool Processes::ProcessAsynchRequests(TaskData *taskData) { bool wasInterrupted = false; TaskData *ptaskData = taskData; schedLock.Lock(); switch (ptaskData->requests) { case kRequestNone: schedLock.Unlock(); break; case kRequestInterrupt: { // Handle asynchronous interrupts only. // We've been interrupted. POLYUNSIGNED attrs = ThreadAttrs(ptaskData); POLYUNSIGNED intBits = attrs & PFLAG_INTMASK; if (intBits == PFLAG_ASYNCH || intBits == PFLAG_ASYNCH_ONCE) { if (intBits == PFLAG_ASYNCH_ONCE) { // Set this so from now on it's synchronous. // This word is only ever set by the thread itself so // we don't need to synchronise. attrs = (attrs & (~PFLAG_INTMASK)) | PFLAG_SYNCH; ptaskData->threadObject->flags = TAGGED(attrs); } ptaskData->requests = kRequestNone; // Clear this ptaskData->threadObject->requestCopy = TAGGED(0); // And in the ML copy schedLock.Unlock(); // Don't actually throw the exception here. taskData->SetException(interrupt_exn); wasInterrupted = true; } else schedLock.Unlock(); } break; case kRequestKill: // The thread has been asked to stop. schedLock.Unlock(); throw KillException(); // Doesn't return. } #ifndef HAVE_WINDOWS_H // Start the profile timer if needed. if (profileMode == kProfileTime) { if (! ptaskData->runningProfileTimer) { ptaskData->runningProfileTimer = true; StartProfilingTimer(); } } else ptaskData->runningProfileTimer = false; // The timer will be stopped next time it goes off. #endif return wasInterrupted; } // If this thread is processing interrupts synchronously and has been // interrupted clear the interrupt and raise the exception. This is // called from IO routines which may block. void Processes::TestSynchronousRequests(TaskData *taskData) { TaskData *ptaskData = taskData; schedLock.Lock(); switch (ptaskData->requests) { case kRequestNone: schedLock.Unlock(); break; case kRequestInterrupt: { // Handle synchronous interrupts only. // We've been interrupted. POLYUNSIGNED attrs = ThreadAttrs(ptaskData); POLYUNSIGNED intBits = attrs & PFLAG_INTMASK; if (intBits == PFLAG_SYNCH) { ptaskData->requests = kRequestNone; // Clear this ptaskData->threadObject->requestCopy = TAGGED(0); schedLock.Unlock(); taskData->SetException(interrupt_exn); throw IOException(); } else schedLock.Unlock(); } break; case kRequestKill: // The thread has been asked to stop. schedLock.Unlock(); throw KillException(); // Doesn't return. } } // Check for asynchronous or synchronous events void Processes::TestAnyEvents(TaskData *taskData) { TestSynchronousRequests(taskData); if (ProcessAsynchRequests(taskData)) throw IOException(); } // Request that the process should exit. // This will usually be called from an ML thread as a result of // a call to OS.Process.exit but on Windows it can be called from the GUI thread. void Processes::RequestProcessExit(int n) { if (singleThreaded) finish(n); exitResult = n; exitRequest = true; PLocker lock(&schedLock); // Lock so we know the main thread is waiting initialThreadWait.Signal(); // Wake it if it's sleeping. } #if !defined(HAVE_WINDOWS_H) // N.B. This may be called either by an ML thread or by the main thread. // On the main thread taskData will be null. static void catchVTALRM(SIG_HANDLER_ARGS(sig, context)) { ASSERT(sig == SIGVTALRM); if (profileMode != kProfileTime) { // We stop the timer for this thread on the next signal after we end profile static struct itimerval stoptime = {{0, 0}, {0, 0}}; /* Stop the timer */ setitimer(ITIMER_VIRTUAL, & stoptime, NULL); } else { TaskData *taskData = processes->GetTaskDataForThread(); handleProfileTrap(taskData, (SIGNALCONTEXT*)context); } } #else /* Windows including Cygwin */ // This runs as a separate thread. Every millisecond it checks the CPU time used // by each ML thread and increments the count for each thread that has used a // millisecond of CPU time. static bool testCPUtime(HANDLE hThread, LONGLONG &lastCPUTime) { FILETIME cTime, eTime, kTime, uTime; // Try to get the thread CPU time if possible. This isn't supported // in Windows 95/98 so if it fails we just include this thread anyway. if (GetThreadTimes(hThread, &cTime, &eTime, &kTime, &uTime)) { LONGLONG totalTime = 0; LARGE_INTEGER li; li.LowPart = kTime.dwLowDateTime; li.HighPart = kTime.dwHighDateTime; totalTime += li.QuadPart; li.LowPart = uTime.dwLowDateTime; li.HighPart = uTime.dwHighDateTime; totalTime += li.QuadPart; if (totalTime - lastCPUTime >= 10000) { lastCPUTime = totalTime; return true; } return false; } else return true; // Failed to get thread time, maybe Win95. } void Processes::ProfileInterrupt(void) { // Wait for millisecond or until the stop event is signalled. while (WaitForSingleObject(hStopEvent, 1) == WAIT_TIMEOUT) { // We need to hold schedLock to examine the taskArray but // that is held during garbage collection. if (schedLock.Trylock()) { for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *p = *i; if (p && p->threadHandle) { if (testCPUtime(p->threadHandle, p->lastCPUTime)) { CONTEXT context; SuspendThread(p->threadHandle); context.ContextFlags = CONTEXT_CONTROL; /* Get Eip and Esp */ if (GetThreadContext(p->threadHandle, &context)) { handleProfileTrap(p, &context); } ResumeThread(p->threadHandle); } } } schedLock.Unlock(); } // Check the CPU time used by the main thread. This is used for GC // so we need to check that as well. if (testCPUtime(mainThreadHandle, lastCPUTime)) handleProfileTrap(NULL, NULL); } } DWORD WINAPI ProfilingTimer(LPVOID parm) { processesModule.ProfileInterrupt(); return 0; } #endif // Profiling control. Called by the root thread. void Processes::StartProfiling(void) { #ifdef HAVE_WINDOWS_H DWORD threadId; extern FILE *polyStdout; if (profilingHd) return; ResetEvent(hStopEvent); profilingHd = CreateThread(NULL, 0, ProfilingTimer, NULL, 0, &threadId); if (profilingHd == NULL) { fputs("Creating ProfilingTimer thread failed.\n", polyStdout); return; } /* Give this a higher than normal priority so it pre-empts the main thread. Without this it will tend only to be run when the main thread blocks for some reason. */ SetThreadPriority(profilingHd, THREAD_PRIORITY_ABOVE_NORMAL); #else // In Linux, at least, we need to run a timer in each thread. // We request each to enter the RTS so that it will start the timer. // Since this is being run by the main thread while all the ML threads // are paused this may not actually be necessary. for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { TaskData *taskData = *i; if (taskData) { taskData->InterruptCode(); } } StartProfilingTimer(); // Start the timer in the root thread. #endif } void Processes::StopProfiling(void) { #ifdef HAVE_WINDOWS_H if (hStopEvent) SetEvent(hStopEvent); // Wait for the thread to stop if (profilingHd) { WaitForSingleObject(profilingHd, 10000); CloseHandle(profilingHd); } profilingHd = NULL; #endif } // Called by the ML signal handling thread. It blocks until a signal // arrives. There should only be a single thread waiting here. bool Processes::WaitForSignal(TaskData *taskData, PLock *sigLock) { TaskData *ptaskData = taskData; // We need to hold the signal lock until we have acquired schedLock. PLocker lock(&schedLock); sigLock->Unlock(); if (sigTask != 0) { return false; } sigTask = ptaskData; if (ptaskData->requests == kRequestNone) { // Now release the ML memory. A GC can start. ThreadReleaseMLMemoryWithSchedLock(ptaskData); globalStats.incCount(PSC_THREADS_WAIT_SIGNAL); ptaskData->threadLock.Wait(&schedLock); globalStats.decCount(PSC_THREADS_WAIT_SIGNAL); // We want to use the memory again. ThreadUseMLMemoryWithSchedLock(ptaskData); } sigTask = 0; return true; } // Called by the signal detection thread to wake up the signal handler // thread. Must be called AFTER releasing sigLock. void Processes::SignalArrived(void) { PLocker locker(&schedLock); if (sigTask) sigTask->threadLock.Signal(); } #if (!defined(_WIN32)) // This is called when the thread exits in foreign code and // ThreadExit has not been called. static void threaddata_destructor(void *p) { TaskData *pt = (TaskData *)p; pt->threadExited = true; // This doesn't actually wake the main thread and relies on the // regular check to release the task data. } #endif void Processes::Init(void) { #if (!defined(_WIN32)) pthread_key_create(&tlsId, threaddata_destructor); #else tlsId = TlsAlloc(); #endif #if defined(HAVE_WINDOWS_H) /* Windows including Cygwin. */ // Create stop event for time profiling. hStopEvent = CreateEvent(NULL, TRUE, FALSE, NULL); // Get the thread handle for this thread. HANDLE thisProcess = GetCurrentProcess(); DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess, &mainThreadHandle, THREAD_ALL_ACCESS, FALSE, 0); #else // Set up a signal handler. This will be the same for all threads. markSignalInuse(SIGVTALRM); setSignalHandler(SIGVTALRM, catchVTALRM); #endif } #ifndef HAVE_WINDOWS_H // On Linux, at least, each thread needs to run this. void Processes::StartProfilingTimer(void) { // set virtual timer to go off every millisecond struct itimerval starttime; starttime.it_interval.tv_sec = starttime.it_value.tv_sec = 0; starttime.it_interval.tv_usec = starttime.it_value.tv_usec = 1000; setitimer(ITIMER_VIRTUAL,&starttime,NULL); } #endif void Processes::Stop(void) { #if (!defined(_WIN32)) pthread_key_delete(tlsId); #else TlsFree(tlsId); #endif #if defined(HAVE_WINDOWS_H) /* Stop the timer and profiling threads. */ if (hStopEvent) SetEvent(hStopEvent); if (profilingHd) { WaitForSingleObject(profilingHd, 10000); CloseHandle(profilingHd); profilingHd = NULL; } if (hStopEvent) CloseHandle(hStopEvent); hStopEvent = NULL; if (mainThreadHandle) CloseHandle(mainThreadHandle); mainThreadHandle = NULL; #else profileMode = kProfileOff; // Make sure the timer is not running struct itimerval stoptime; memset(&stoptime, 0, sizeof(stoptime)); setitimer(ITIMER_VIRTUAL, &stoptime, NULL); #endif } void Processes::GarbageCollect(ScanAddress *process) /* Ensures that all the objects are retained and their addresses updated. */ { /* The interrupt exn */ if (interrupt_exn != 0) { PolyObject *p = interrupt_exn; process->ScanRuntimeAddress(&p, ScanAddress::STRENGTH_STRONG); interrupt_exn = (PolyException*)p; } for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++) { if (*i) (*i)->GarbageCollect(process); } } void TaskData::GarbageCollect(ScanAddress *process) { saveVec.gcScan(process); if (threadObject != 0) { PolyObject *p = threadObject; process->ScanRuntimeAddress(&p, ScanAddress::STRENGTH_STRONG); threadObject = (ThreadObject*)p; } if (blockMutex != 0) process->ScanRuntimeAddress(&blockMutex, ScanAddress::STRENGTH_STRONG); // The allocation spaces are no longer valid. allocPointer = 0; allocLimit = 0; // Divide the allocation size by four. If we have made a single allocation // since the last GC the size will have been doubled after the allocation. // On average for each thread, apart from the one that ran out of space // and requested the GC, half of the space will be unused so reducing by // four should give a good estimate for next time. if (allocCount != 0) { // Do this only once for each GC. allocCount = 0; allocSize = allocSize/4; if (allocSize < MIN_HEAP_SIZE) allocSize = MIN_HEAP_SIZE; } } // Return the number of processors. extern unsigned NumberOfProcessors(void) { #if (defined(_WIN32)) SYSTEM_INFO info; memset(&info, 0, sizeof(info)); GetSystemInfo(&info); if (info.dwNumberOfProcessors == 0) // Just in case info.dwNumberOfProcessors = 1; return info.dwNumberOfProcessors; #elif(defined(_SC_NPROCESSORS_ONLN)) long res = sysconf(_SC_NPROCESSORS_ONLN); if (res <= 0) res = 1; return res; #elif(defined(HAVE_SYSCTL) && defined(CTL_HW) && defined(HW_NCPU)) static int mib[2] = { CTL_HW, HW_NCPU }; int nCPU = 1; size_t len = sizeof(nCPU); if (sysctl(mib, 2, &nCPU, &len, NULL, 0) == 0 && len == sizeof(nCPU)) return nCPU; else return 1; #else // Can't determine. return 1; #endif } // Return the number of physical processors. If hyperthreading is // enabled this returns less than NumberOfProcessors. Returns zero if // it cannot be determined. // This can be used in Cygwin as well as native Windows. #if (defined(HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION)) typedef BOOL (WINAPI *GETP)(SYSTEM_LOGICAL_PROCESSOR_INFORMATION*, PDWORD); // Windows - use GetLogicalProcessorInformation if it's available. static unsigned WinNumPhysicalProcessors(void) { GETP getProcInfo = (GETP) GetProcAddress(GetModuleHandle(_T("kernel32")), "GetLogicalProcessorInformation"); if (getProcInfo == 0) return 0; // It's there - use it. SYSTEM_LOGICAL_PROCESSOR_INFORMATION *buff = 0; DWORD space = 0; while (getProcInfo(buff, &space) == FALSE) { if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) { free(buff); return 0; } free(buff); buff = (PSYSTEM_LOGICAL_PROCESSOR_INFORMATION)malloc(space); if (buff == 0) return 0; } // Calculate the number of full entries in case it's truncated. unsigned nItems = space / sizeof(SYSTEM_LOGICAL_PROCESSOR_INFORMATION); unsigned numProcs = 0; for (unsigned i = 0; i < nItems; i++) { if (buff[i].Relationship == RelationProcessorCore) numProcs++; } free(buff); return numProcs; } #endif // Read and parse /proc/cpuinfo static unsigned LinuxNumPhysicalProcessors(void) { // Find out the total. This should be the maximum. unsigned nProcs = NumberOfProcessors(); // If there's only one we don't need to check further. if (nProcs <= 1) return nProcs; long *cpus = (long*)calloc(nProcs, sizeof(long)); if (cpus == 0) return 0; FILE *cpuInfo = fopen("/proc/cpuinfo", "r"); if (cpuInfo == NULL) { free(cpus); return 0; } char line[40]; unsigned count = 0; while (fgets(line, sizeof(line), cpuInfo) != NULL) { if (strncmp(line, "core id\t\t:", 10) == 0) { long n = strtol(line+10, NULL, 10); unsigned i = 0; // Skip this id if we've seen it already while (i < count && cpus[i] != n) i++; if (i == count) cpus[count++] = n; } if (strchr(line, '\n') == 0) { int ch; do { ch = getc(cpuInfo); } while (ch != '\n' && ch != EOF); } } fclose(cpuInfo); free(cpus); return count; } extern unsigned NumberOfPhysicalProcessors(void) { unsigned numProcs = 0; #if (defined(HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION)) numProcs = WinNumPhysicalProcessors(); if (numProcs != 0) return numProcs; #endif #if (defined(HAVE_SYSCTLBYNAME) && defined(HAVE_SYS_SYSCTL_H)) // Mac OS X int nCores; size_t len = sizeof(nCores); if (sysctlbyname("hw.physicalcpu", &nCores, &len, NULL, 0) == 0) return (unsigned)nCores; #endif numProcs = LinuxNumPhysicalProcessors(); if (numProcs != 0) return numProcs; // Any other cases? return numProcs; } diff --git a/libpolyml/processes.h b/libpolyml/processes.h index 1fb6734e..b99f5ae1 100644 --- a/libpolyml/processes.h +++ b/libpolyml/processes.h @@ -1,349 +1,354 @@ /* Title: Lightweight process library Author: David C.J. Matthews Copyright (c) 2007-8, 2012, 2015, 2017, 2019-21 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 _PROCESSES_H_ #define _PROCESSES_H_ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #include "globals.h" #include "rts_module.h" #include "save_vec.h" #include "noreturn.h" #include "locking.h" class SaveVecEntry; typedef SaveVecEntry *Handle; class StackSpace; class PolyWord; class ScanAddress; class MDTaskData; class Exporter; class StackObject; #ifdef HAVE_WINDOWS_H typedef void *HANDLE; #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_UCONTEXT_H #include #endif #ifdef HAVE_PTHREAD_H #include #endif // SIGNALCONTEXT is the argument type that is passed to GetPCandSPFromContext // to get the actual PC and SP in a profiling trap. #if defined(HAVE_WINDOWS_H) // First because it's used in both native Windows and Cygwin. #include #define SIGNALCONTEXT CONTEXT // This is the thread context. #elif defined(HAVE_UCONTEXT_T) #define SIGNALCONTEXT ucontext_t #elif defined(HAVE_STRUCT_SIGCONTEXT) #define SIGNALCONTEXT struct sigcontext #else #define SIGNALCONTEXT void #endif #define MIN_HEAP_SIZE 4096 // Minimum and initial heap segment size (words) // This is the ML "thread identifier" object. The fields // are read and set by the ML code. class ThreadObject: public PolyObject { public: PolyWord threadRef; // Weak ref containing the address of the thread data. Not used by ML PolyWord flags; // Tagged integer containing flags indicating how interrupts // are handled. Set by ML but only by the thread itself PolyWord threadLocal; // Head of a list of thread-local store items. // Handled entirely by ML but only by the thread. PolyWord requestCopy; // A tagged integer copy of the "requests" field. // This is provided so that ML can easily test if there // is an interrupt pending. PolyWord mlStackSize; // A tagged integer with the maximum ML stack size in bytes PolyWord debuggerSlots[4]; // These are used by the debugger. }; // Other threads may make requests to a thread. typedef enum { kRequestNone = 0, // Increasing severity kRequestInterrupt = 1, kRequestKill = 2 } ThreadRequests; // Per-thread data. This is subclassed for each architecture. class TaskData { public: TaskData(); virtual ~TaskData(); void FillUnusedSpace(void); virtual void GarbageCollect(ScanAddress *process); virtual void EnterPolyCode() = 0; // Start running ML virtual void InterruptCode() = 0; virtual bool AddTimeProfileCount(SIGNALCONTEXT *context) = 0; // Initialise the stack for a new thread. The parent task object is passed in because any // allocation that needs to be made must be made in the parent. virtual void InitStackFrame(TaskData *parentTask, Handle proc) = 0; virtual void SetException(poly_exn *exc) = 0; // Atomically release a mutex, returning false if the mutex was previously // locked by more than one thread and we need to check for waiting threads. // This is used in waiting for a condition variable. It is important that // the same atomic operations are used here as the code-generator uses, virtual bool AtomicallyReleaseMutex(PolyObject *mutexp) = 0; virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) = 0; virtual uintptr_t currentStackSpace(void) const = 0; // Add a count to the local function if we are using store profiling. virtual void addProfileCount(POLYUNSIGNED words) = 0; // Functions called before and after an RTS call. virtual void PreRTSCall(void) {} virtual void PostRTSCall(void) {} SaveVec saveVec; PolyWord *allocPointer; // Allocation pointer - decremented towards... PolyWord *allocLimit; // ... lower limit of allocation uintptr_t allocSize; // The preferred heap segment size unsigned allocCount; // The number of allocations since the last GC StackSpace *stack; ThreadObject *threadObject; // Pointer to the thread object. int lastError; // Last error from foreign code. void *signalStack; // Stack to handle interrupts (Unix only) // Get a TaskData pointer given the ML taskId. // This is called at the start of every RTS function that may allocate memory. // It is can be called safely to get the thread's own TaskData object without // a lock but any call to get the TaskData for another thread must take the // schedLock first in case the thread is exiting. static TaskData *FindTaskForId(PolyWord taskId) { return *(TaskData**)(((ThreadObject*)taskId.AsObjPtr())->threadRef.AsObjPtr()); } + // Overloading for usual RTS call case. + static TaskData* FindTaskForId(POLYUNSIGNED taskId) { + return FindTaskForId(PolyWord::FromUnsigned(taskId)); + } + private: // If a thread has to block it will block on this. PCondVar threadLock; // External requests made are stored here until they // can be actioned. ThreadRequests requests; // Pointer to the mutex when blocked. Set to NULL when it doesn't apply. PolyObject *blockMutex; // This is set to false when a thread blocks or enters foreign code, // While it is true the thread can manipulate ML memory so no other // thread can garbage collect. bool inMLHeap; // In Linux, at least, we need to run a separate timer in each thread bool runningProfileTimer; #ifdef HAVE_WINDOWS_H LONGLONG lastCPUTime; // Used for profiling #endif public: bool threadExited; private: #ifdef HAVE_PTHREAD_H pthread_t threadId; #endif #ifdef HAVE_WINDOWS_H public: // Because, on Cygwin, it's used in NewThreadFunction HANDLE threadHandle; private: #endif friend class Processes; }; NORETURNFN(extern Handle exitThread(TaskData *mdTaskData)); class ScanAddress; // Indicate what the main thread is doing if the profile // timer goes off. extern enum _mainThreadPhase { MTP_USER_CODE=0, MTP_GCPHASESHARING, MTP_GCPHASEMARK, MTP_GCPHASECOMPACT, MTP_GCPHASEUPDATE, MTP_GCQUICK, MTP_SHARING, MTP_EXPORTING, MTP_SAVESTATE, MTP_LOADSTATE, MTP_PROFILING, MTP_SIGHANDLER, MTP_CYGWINSPAWN, MTP_STOREMODULE, MTP_LOADMODULE, MTP_MAXENTRY } mainThreadPhase; // Data structure used for requests from a thread to the root // thread. These are GCs or similar. class MainThreadRequest { public: MainThreadRequest (enum _mainThreadPhase phase): mtp(phase), completed(false) {} virtual ~MainThreadRequest () {} // Suppress silly GCC warning const enum _mainThreadPhase mtp; bool completed; virtual void Perform() = 0; }; class PLock; // Class to wait for a given time or for an event, whichever comes first. // // A pointer to this class or a subclass is passed to ThreadPauseForIO. // Because a thread may be interrupted or killed by another ML thread we // don't allow any thread to block indefinitely. Instead whenever a // thread wants to do an operation that may block we have it enter a // loop that polls for the desired condition and if it is not ready it // calls ThreadPauseForIO. The default action is to block for a short // period and then return so that the caller can poll again. That can // limit performance when, for example, reading from a pipe so where possible // we use a sub-class that waits until either input is available or it times // out, whichever comes first, using "select" in Unix or MsgWaitForMultipleObjects // in Windows. // During a call to Waiter::Wait the thread is set as "not using ML memory" // so a GC can happen while this thread is blocked. class Waiter { public: Waiter() {} virtual ~Waiter() {} virtual void Wait(unsigned maxMillisecs); static Waiter *defaultWaiter; }; #ifdef _WIN32 class WaitHandle: public Waiter { public: WaitHandle(HANDLE h, unsigned maxWait): m_Handle(h), m_maxWait(maxWait) {} virtual void Wait(unsigned maxMillisecs); private: HANDLE m_Handle; unsigned m_maxWait; }; #else // Unix: Wait until a file descriptor is available for input class WaitInputFD: public Waiter { public: WaitInputFD(int fd): m_waitFD(fd) {} virtual void Wait(unsigned maxMillisecs); private: int m_waitFD; }; #endif // External interface to the Process module. These functions are all implemented // by the Processes class. class ProcessExternal { public: virtual ~ProcessExternal() {} // Defined to suppress a warning from GCC virtual TaskData *GetTaskDataForThread(void) = 0; virtual TaskData *CreateNewTaskData() = 0; // Request all ML threads to exit and set the result code. Does not cause // the calling thread itself to exit since this may be called on the GUI thread. virtual void RequestProcessExit(int n) = 0; // Exit from this thread. virtual NORETURNFN(void ThreadExit(TaskData *taskData)) = 0; virtual void BroadcastInterrupt(void) = 0; virtual void BeginRootThread(PolyObject *rootFunction) = 0; // Called when a thread may block. Returns some time later when perhaps // the input is available. virtual void ThreadPauseForIO(TaskData *taskData, Waiter *pWait) = 0; // As ThreadPauseForIO but when there is no stream virtual void ThreadPause(TaskData *taskData) { ThreadPauseForIO(taskData, Waiter::defaultWaiter); } // If a thread is blocking for some time it should release its use // of the ML memory. That allows a GC. ThreadUseMLMemory returns true if // a GC was in progress. virtual void ThreadUseMLMemory(TaskData *taskData) = 0; virtual void ThreadReleaseMLMemory(TaskData *taskData) = 0; // Requests from the threads for actions that need to be performed by // the root thread. virtual void MakeRootRequest(TaskData *taskData, MainThreadRequest *request) = 0; // Deal with any interrupt or kill requests. virtual bool ProcessAsynchRequests(TaskData *taskData) = 0; // Process an interrupt request synchronously. virtual void TestSynchronousRequests(TaskData *taskData) = 0; // Process any events, synchronous or asynchronous. virtual void TestAnyEvents(TaskData *taskData) = 0; // Profiling control. virtual void StartProfiling(void) = 0; virtual void StopProfiling(void) = 0; // Find space for an object. Returns a pointer to the start. "words" must include // the length word and the result points at where the length word will go. // If the allocation succeeds it may update the allocation values in the taskData object. // If the heap is exhausted it may set this thread (or other threads) to raise an exception. virtual PolyWord *FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg) = 0; // Signal handling support. The ML signal handler thread blocks until it is // woken up by the signal detection thread. virtual bool WaitForSignal(TaskData *taskData, PLock *sigLock) = 0; virtual void SignalArrived(void) = 0; virtual poly_exn* GetInterrupt(void) = 0; }; // Return the number of processors. Used when configuring multi-threaded GC. extern unsigned NumberOfProcessors(void); extern unsigned NumberOfPhysicalProcessors(void); extern ProcessExternal *processes; extern struct _entrypts processesEPT[]; #endif diff --git a/libpolyml/profiling.cpp b/libpolyml/profiling.cpp index 2da164f0..1824aba5 100644 --- a/libpolyml/profiling.cpp +++ b/libpolyml/profiling.cpp @@ -1,615 +1,615 @@ /* Title: Profiling Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited Further development copyright (c) David C.J. Matthews 2011, 2015, 2020-21 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_STDLIB_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include "globals.h" #include "arb.h" #include "processes.h" #include "polystring.h" #include "profiling.h" #include "save_vec.h" #include "rts_module.h" #include "memmgr.h" #include "scanaddrs.h" #include "locking.h" #include "run_time.h" #include "sys.h" #include "rtsentry.h" #include "machine_dep.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProfiling(POLYUNSIGNED threadId, POLYUNSIGNED mode); } static long mainThreadCounts[MTP_MAXENTRY]; static const char* const mainThreadText[MTP_MAXENTRY] = { "UNKNOWN", "GARBAGE COLLECTION (sharing phase)", "GARBAGE COLLECTION (mark phase)", "GARBAGE COLLECTION (copy phase)", "GARBAGE COLLECTION (update phase)", "GARBAGE COLLECTION (minor collection)", "Common data sharing", "Exporting", "Saving state", "Loading saved state", "Profiling", "Setting signal handler", "Cygwin spawn", "Storing module", "Loading module" }; // Entries for store profiling enum _extraStore { EST_CODE = 0, EST_STRING, EST_BYTE, EST_WORD, EST_MUTABLE, EST_MUTABLEBYTE, EST_MAX_ENTRY }; static POLYUNSIGNED extraStoreCounts[EST_MAX_ENTRY]; static const char * const extraStoreText[EST_MAX_ENTRY] = { "Function code", "Strings", "Byte data (long precision ints etc)", "Unidentified word data", "Unidentified mutable data", "Mutable byte data (profiling counts)" }; // Poly strings for "standard" counts. These are generated from the C strings // above the first time profiling is activated. static PolyWord psRTSString[MTP_MAXENTRY], psExtraStrings[EST_MAX_ENTRY], psGCTotal; ProfileMode profileMode; // If we are just profiling a single thread, this is the thread data. static TaskData *singleThreadProfile = 0; // The queue is processed every 400ms and an entry can be // added every ms of CPU time by each thread. #define PCQUEUESIZE 4000 static long queuePtr = 0; static POLYCODEPTR pcQueue[PCQUEUESIZE]; static PLock queueLock; typedef struct _PROFENTRY { POLYUNSIGNED count; PolyWord functionName; struct _PROFENTRY *nextEntry; } PROFENTRY, *PPROFENTRY; class ProfileRequest: public MainThreadRequest { public: ProfileRequest(unsigned prof, TaskData *pTask): MainThreadRequest(MTP_PROFILING), mode(prof), pCallingThread(pTask), pTab(0), errorMessage(0) {} ~ProfileRequest(); virtual void Perform(); Handle extractAsList(TaskData *taskData); private: void getResults(void); void getProfileResults(PolyWord *bottom, PolyWord *top); PPROFENTRY newProfileEntry(void); private: unsigned mode; TaskData *pCallingThread; PPROFENTRY pTab; public: const char *errorMessage; }; ProfileRequest::~ProfileRequest() { PPROFENTRY p = pTab; while (p != 0) { PPROFENTRY toFree = p; p = p->nextEntry; free(toFree); } } // Lock to serialise updates of counts. Only used during update. // Not required when we print the counts since there's only one thread // running then. static PLock countLock; // Get the profile object associated with a piece of code. Returns null if // there isn't one, in particular if this is in the old format. static PolyObject *getProfileObjectForCode(PolyObject *code) { ASSERT(code->IsCodeObject()); PolyWord *consts; POLYUNSIGNED constCount; machineDependent->GetConstSegmentForCode(code, consts, constCount); if (constCount < 2 || consts[1].AsUnsigned() == 0 || ! consts[1].IsDataPtr()) return 0; PolyObject *profObject = consts[1].AsObjPtr(); if (profObject->IsMutable() && profObject->IsByteObject() && profObject->Length() == 1) return profObject; else return 0; } // Adds incr to the profile count for the function pointed at by // pc or by one of its callers. void addSynchronousCount(POLYCODEPTR fpc, POLYUNSIGNED incr) { // Check that the pc value is within the heap. It could be // in the assembly code. PolyObject *codeObj = gMem.FindCodeObject(fpc); if (codeObj) { PolyObject *profObject = getProfileObjectForCode(codeObj); if (profObject) { PLocker locker(&countLock); profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + incr)); } } // Didn't find it. else { PLocker locker(&countLock); mainThreadCounts[MTP_USER_CODE]++; } } // newProfileEntry - Make a new entry in the list PPROFENTRY ProfileRequest::newProfileEntry(void) { PPROFENTRY newEntry = (PPROFENTRY)malloc(sizeof(PROFENTRY)); if (newEntry == 0) { errorMessage = "Insufficient memory"; return 0; } newEntry->nextEntry = pTab; pTab = newEntry; return newEntry; } // We don't use ScanAddress here because we're only interested in the // objects themselves not the addresses in them. // We have to build the list of results in C memory rather than directly in // ML memory because we can't allocate in ML memory in the root thread. void ProfileRequest::getProfileResults(PolyWord *bottom, PolyWord *top) { PolyWord *ptr = bottom; while (ptr < top) { ptr++; // Skip the length word PolyObject *obj = (PolyObject*)ptr; if (obj->ContainsForwardingPtr()) { // This used to be necessary when code objects were held in the // general heap. Now that we only ever scan code and permanent // areas it's probably not needed. while (obj->ContainsForwardingPtr()) obj = obj->GetForwardingPtr(); ASSERT(obj->ContainsNormalLengthWord()); ptr += obj->Length(); } else { ASSERT(obj->ContainsNormalLengthWord()); if (obj->IsCodeObject()) { PolyWord *firstConstant = machineDependent->ConstPtrForCode(obj); PolyWord name = firstConstant[0]; PolyObject *profCount = getProfileObjectForCode(obj); if (profCount) { POLYUNSIGNED count = profCount->Get(0).AsUnsigned(); if (count != 0) { if (name != TAGGED(0)) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; pEnt->count = count; pEnt->functionName = name; } profCount->Set(0, PolyWord::FromUnsigned(0)); } } } /* code object */ ptr += obj->Length(); } /* else */ } /* while */ } void ProfileRequest::getResults(void) // Print profiling information and reset profile counts. { for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. getProfileResults(space->bottom, space->top); // Bottom to top } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; getProfileResults(space->bottom, space->top); } { POLYUNSIGNED gc_count = mainThreadCounts[MTP_GCPHASESHARING]+ mainThreadCounts[MTP_GCPHASEMARK]+ mainThreadCounts[MTP_GCPHASECOMPACT] + mainThreadCounts[MTP_GCPHASEUPDATE] + mainThreadCounts[MTP_GCQUICK]; if (gc_count) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = gc_count; pEnt->functionName = psGCTotal; } } for (unsigned k = 0; k < MTP_MAXENTRY; k++) { if (mainThreadCounts[k]) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = mainThreadCounts[k]; pEnt->functionName = psRTSString[k]; mainThreadCounts[k] = 0; } } for (unsigned l = 0; l < EST_MAX_ENTRY; l++) { if (extraStoreCounts[l]) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = extraStoreCounts[l]; pEnt->functionName = psExtraStrings[l]; extraStoreCounts[l] = 0; } } } // Extract the accumulated results as an ML list of pairs of the count and the string. Handle ProfileRequest::extractAsList(TaskData *taskData) { Handle saved = taskData->saveVec.mark(); Handle list = taskData->saveVec.push(ListNull); for (PPROFENTRY p = pTab; p != 0; p = p->nextEntry) { Handle pair = alloc_and_save(taskData, 2); Handle countValue = Make_arbitrary_precision(taskData, p->count); pair->WordP()->Set(0, countValue->Word()); pair->WordP()->Set(1, p->functionName); Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell) / sizeof(PolyWord)); DEREFLISTHANDLE(next)->h = pair->Word(); DEREFLISTHANDLE(next)->t =list->Word(); taskData->saveVec.reset(saved); list = taskData->saveVec.push(next->Word()); } return list; } // We have had an asynchronous interrupt and found a potential PC but // we're in a signal handler. void incrementCountAsynch(POLYCODEPTR pc) { PLocker locker(&queueLock); int q = queuePtr++; if (q < PCQUEUESIZE) pcQueue[q] = pc; } // Called by the main thread to process the queue of PC values void processProfileQueue() { while (1) { POLYCODEPTR pc = 0; { PLocker locker(&queueLock); if (queuePtr == 0) return; if (queuePtr < PCQUEUESIZE) pc = pcQueue[queuePtr]; queuePtr--; } if (pc != 0) addSynchronousCount(pc, 1); else { PLocker locker(&countLock); mainThreadCounts[MTP_USER_CODE]++; } } } // Handle a SIGVTALRM or the simulated equivalent in Windows. This may be called // at any time so we have to be careful. In particular in Linux this may be // executed by a thread while holding a mutex so we must not do anything, such // calling malloc, that could require locking. void handleProfileTrap(TaskData *taskData, SIGNALCONTEXT *context) { if (singleThreadProfile != 0 && singleThreadProfile != taskData) return; if (mainThreadPhase == MTP_USER_CODE) { if (taskData == 0 || !taskData->AddTimeProfileCount(context)) { PLocker lock(&countLock); mainThreadCounts[MTP_USER_CODE]++; } // On Mac OS X all virtual timer interrupts seem to be directed to the root thread // so all the counts will be "unknown". } else { PLocker lock(&countLock); mainThreadCounts[mainThreadPhase]++; } } // Called from the GC when allocation profiling is on. void AddObjectProfile(PolyObject *obj) { ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED length = obj->Length(); if (obj->IsWordObject() && OBJ_HAS_PROFILE(obj->LengthWord())) { // It has a profile pointer. The last word should point to the // closure or code of the allocating function. Add the size of this to the count. ASSERT(length != 0); PolyWord profWord = obj->Get(length-1); ASSERT(profWord.IsDataPtr()); PolyObject *profObject = profWord.AsObjPtr(); ASSERT(profObject->IsMutable() && profObject->IsByteObject() && profObject->Length() == 1); profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + length + 1)); } // If it doesn't have a profile pointer add it to the appropriate count. else if (obj->IsMutable()) { if (obj->IsByteObject()) extraStoreCounts[EST_MUTABLEBYTE] += length+1; else extraStoreCounts[EST_MUTABLE] += length+1; } else if (obj->IsCodeObject()) extraStoreCounts[EST_CODE] += length+1; else if (obj->IsClosureObject()) { ASSERT(0); } else if (obj->IsByteObject()) { // Try to separate strings from other byte data. This is only // approximate. if (OBJ_IS_NEGATIVE(obj->LengthWord())) extraStoreCounts[EST_BYTE] += length+1; else { PolyStringObject *possString = (PolyStringObject*)obj; POLYUNSIGNED bytes = length * sizeof(PolyWord); // If the length of the string as given in the first word is sufficient // to fit in the exact number of words then it's probably a string. if (length >= 2 && possString->length <= bytes - sizeof(POLYUNSIGNED) && possString->length > bytes - 2 * sizeof(POLYUNSIGNED)) extraStoreCounts[EST_STRING] += length+1; else { extraStoreCounts[EST_BYTE] += length+1; } } } else extraStoreCounts[EST_WORD] += length+1; } // Called from ML to control profiling. static Handle profilerc(TaskData *taskData, Handle mode_handle) /* Profiler - generates statistical profiles of the code. The parameter is an integer which determines the value to be profiled. When profiler is called it always resets the profiling and prints out any values which have been accumulated. If the parameter is 0 this is all it does, if the parameter is 1 then it produces time profiling, if the parameter is 2 it produces store profiling. 3 - arbitrary precision emulation traps. */ { unsigned mode = get_C_unsigned(taskData, mode_handle->Word()); { // Create any strings we need. We only need to do this once but // it must be done by a non-root thread since it needs a taskData object. // Don't bother locking. At worst we'll create some garbage. for (unsigned k = 0; k < MTP_MAXENTRY; k++) { if (psRTSString[k] == TAGGED(0)) psRTSString[k] = C_string_to_Poly(taskData, mainThreadText[k]); } for (unsigned k = 0; k < EST_MAX_ENTRY; k++) { if (psExtraStrings[k] == TAGGED(0)) psExtraStrings[k] = C_string_to_Poly(taskData, extraStoreText[k]); } if (psGCTotal == TAGGED(0)) psGCTotal = C_string_to_Poly(taskData, "GARBAGE COLLECTION (total)"); } // All these actions are performed by the root thread. Only profile // printing needs to be performed with all the threads stopped but it's // simpler to serialise all requests. ProfileRequest request(mode, taskData); processes->MakeRootRequest(taskData, &request); if (request.errorMessage != 0) raise_exception_string(taskData, EXC_Fail, request.errorMessage); return request.extractAsList(taskData); } -POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode) +POLYUNSIGNED PolyProfiling(POLYUNSIGNED threadId, POLYUNSIGNED mode) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedMode = taskData->saveVec.push(mode); Handle result = 0; try { result = profilerc(taskData, pushedMode); } 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(); } // This is called from the root thread when all the ML threads have been paused. void ProfileRequest::Perform() { if (mode != kProfileOff && profileMode != kProfileOff) { // Profiling must be stopped first. errorMessage = "Profiling is currently active"; return; } singleThreadProfile = 0; // Unless kProfileTimeThread is given this should be 0 switch (mode) { case kProfileOff: // Turn off old profiling mechanism and print out accumulated results profileMode = kProfileOff; processes->StopProfiling(); getResults(); // Remove all the bitmaps to free up memory gMem.RemoveProfilingBitmaps(); break; case kProfileTimeThread: singleThreadProfile = pCallingThread; // And drop through to kProfileTime case kProfileTime: profileMode = kProfileTime; processes->StartProfiling(); break; case kProfileStoreAllocation: profileMode = kProfileStoreAllocation; break; case kProfileEmulation: profileMode = kProfileEmulation; break; case kProfileLiveData: profileMode = kProfileLiveData; break; case kProfileLiveMutables: profileMode = kProfileLiveMutables; break; case kProfileMutexContention: profileMode = kProfileMutexContention; break; default: /* do nothing */ break; } } struct _entrypts profilingEPT[] = { // Profiling { "PolyProfiling", (polyRTSFunction)&PolyProfiling}, { NULL, NULL} // End of list. }; class Profiling: public RtsModule { public: virtual void Init(void); virtual void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static Profiling profileModule; void Profiling::Init(void) { // Reset profiling counts. profileMode = kProfileOff; for (unsigned k = 0; k < MTP_MAXENTRY; k++) mainThreadCounts[k] = 0; } void Profiling::GarbageCollect(ScanAddress *process) { // Process any strings in the table. for (unsigned k = 0; k < MTP_MAXENTRY; k++) process->ScanRuntimeWord(&psRTSString[k]); for (unsigned k = 0; k < EST_MAX_ENTRY; k++) process->ScanRuntimeWord(&psExtraStrings[k]); process->ScanRuntimeWord(&psGCTotal); } diff --git a/libpolyml/reals.cpp b/libpolyml/reals.cpp index 4d06a194..b0a7204c 100644 --- a/libpolyml/reals.cpp +++ b/libpolyml/reals.cpp @@ -1,1070 +1,1070 @@ /* Title: Real number package. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 Cambridge University Technical Services Limited Further work copyright David C.J. Matthews 2011, 2016-19 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_IEEEFP_H /* Other operating systems include "finite" in math.h, but Solaris doesn't? */ #include #endif #ifdef HAVE_FPU_CONTROL_H #include #endif #ifdef HAVE_FENV_H #include #endif #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_MATH_H #include #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STDINT_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include // Currently just for isnan. #include "globals.h" #include "run_time.h" #include "reals.h" #include "arb.h" #include "sys.h" #include "realconv.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "machine_dep.h" #include "processes.h" #include "rtsentry.h" /* The Standard Basis Library assumes IEEE representation for reals. Among other things it does not permit equality on reals. That simplifies things considerably since we don't have to worry about there being two different representations of zero as 0 and ~0. We also don't need to check that the result is finite since NaN is allowed as a result. This code could do with being checked by someone who really understands IEEE floating point arithmetic. */ extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToString(FirstArgument threadId, PolyWord arg, PolyWord mode, PolyWord digits); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedFromString(FirstArgument threadId, PolyWord str); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToLongInt(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToString(POLYUNSIGNED threadId, POLYUNSIGNED arg, POLYUNSIGNED mode, POLYUNSIGNED digits); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedFromString(POLYUNSIGNED threadId, POLYUNSIGNED str); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToLongInt(POLYUNSIGNED threadId, POLYUNSIGNED arg); POLYEXTERNALSYMBOL double PolyRealSqrt(double arg); POLYEXTERNALSYMBOL double PolyRealSin(double arg); POLYEXTERNALSYMBOL double PolyRealCos(double arg); POLYEXTERNALSYMBOL double PolyRealArctan(double arg); POLYEXTERNALSYMBOL double PolyRealExp(double arg); POLYEXTERNALSYMBOL double PolyRealLog(double arg); POLYEXTERNALSYMBOL double PolyRealTan(double arg); POLYEXTERNALSYMBOL double PolyRealArcSin(double arg); POLYEXTERNALSYMBOL double PolyRealArcCos(double arg); POLYEXTERNALSYMBOL double PolyRealLog10(double arg); POLYEXTERNALSYMBOL double PolyRealSinh(double arg); POLYEXTERNALSYMBOL double PolyRealCosh(double arg); POLYEXTERNALSYMBOL double PolyRealTanh(double arg); POLYEXTERNALSYMBOL double PolyRealFloor(double arg); POLYEXTERNALSYMBOL double PolyRealCeil(double arg); POLYEXTERNALSYMBOL double PolyRealTrunc(double arg); POLYEXTERNALSYMBOL double PolyRealRound(double arg); POLYEXTERNALSYMBOL double PolyRealRem(double arg1, double arg2); - POLYEXTERNALSYMBOL double PolyFloatArbitraryPrecision(PolyWord arg); - POLYEXTERNALSYMBOL POLYSIGNED PolyGetRoundingMode(PolyWord); - POLYEXTERNALSYMBOL POLYSIGNED PolySetRoundingMode(PolyWord); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealSize(PolyWord); + POLYEXTERNALSYMBOL double PolyFloatArbitraryPrecision(POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYSIGNED PolyGetRoundingMode(POLYUNSIGNED); + POLYEXTERNALSYMBOL POLYSIGNED PolySetRoundingMode(POLYUNSIGNED); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealSize(POLYUNSIGNED); POLYEXTERNALSYMBOL double PolyRealAtan2(double arg1, double arg2); POLYEXTERNALSYMBOL double PolyRealPow(double arg1, double arg2); POLYEXTERNALSYMBOL double PolyRealCopySign(double arg1, double arg2); POLYEXTERNALSYMBOL double PolyRealNextAfter(double arg1, double arg2); - POLYEXTERNALSYMBOL double PolyRealLdexp(double arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealFrexp(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL double PolyRealLdexp(double arg1, POLYUNSIGNED arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealFrexp(POLYUNSIGNED threadId, POLYUNSIGNED arg); POLYEXTERNALSYMBOL float PolyRealFSqrt(float arg); POLYEXTERNALSYMBOL float PolyRealFSin(float arg); POLYEXTERNALSYMBOL float PolyRealFCos(float arg); POLYEXTERNALSYMBOL float PolyRealFArctan(float arg); POLYEXTERNALSYMBOL float PolyRealFExp(float arg); POLYEXTERNALSYMBOL float PolyRealFLog(float arg); POLYEXTERNALSYMBOL float PolyRealFTan(float arg); POLYEXTERNALSYMBOL float PolyRealFArcSin(float arg); POLYEXTERNALSYMBOL float PolyRealFArcCos(float arg); POLYEXTERNALSYMBOL float PolyRealFLog10(float arg); POLYEXTERNALSYMBOL float PolyRealFSinh(float arg); POLYEXTERNALSYMBOL float PolyRealFCosh(float arg); POLYEXTERNALSYMBOL float PolyRealFTanh(float arg); POLYEXTERNALSYMBOL float PolyRealFAtan2(float arg1, float arg2); POLYEXTERNALSYMBOL float PolyRealFPow(float arg1, float arg2); POLYEXTERNALSYMBOL float PolyRealFCopySign(float arg1, float arg2); POLYEXTERNALSYMBOL float PolyRealFFloor(float arg); POLYEXTERNALSYMBOL float PolyRealFCeil(float arg); POLYEXTERNALSYMBOL float PolyRealFTrunc(float arg); POLYEXTERNALSYMBOL float PolyRealFRound(float arg); POLYEXTERNALSYMBOL float PolyRealFRem(float arg1, float arg2); POLYEXTERNALSYMBOL float PolyRealFNextAfter(float arg1, float arg2); } static Handle Real_strc(TaskData *mdTaskData, Handle hDigits, Handle hMode, Handle arg); static Handle Real_convc(TaskData *mdTaskData, Handle str); // Positive and negative infinities and (positive) NaN. double posInf, negInf, notANumber; float posInfF, negInfF, notANumberF; /* Real numbers are represented by the address of the value. */ #define DBLE sizeof(double)/sizeof(POLYUNSIGNED) union db { double dble; POLYUNSIGNED words[DBLE]; }; double real_arg(Handle x) { union db r_arg_x; for (unsigned i = 0; i < DBLE; i++) { r_arg_x.words[i] = x->WordP()->Get(i).AsUnsigned(); } return r_arg_x.dble; } Handle real_result(TaskData *mdTaskData, double x) { union db argx; argx.dble = x; PolyObject *v = alloc(mdTaskData, DBLE, F_BYTE_OBJ); /* Copy as words in case the alignment is wrong. */ for(unsigned i = 0; i < DBLE; i++) { v->Set(i, PolyWord::FromUnsigned(argx.words[i])); } return mdTaskData->saveVec.push(v); } // 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; }; #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 float_arg(Handle x) { union flt argx; argx.i = x->Word().AsSigned() >> FLT_SHIFT; return argx.fl; } Handle float_result(TaskData *mdTaskData, float x) { union flt argx; argx.fl = x; return mdTaskData->saveVec.push(PolyWord::FromSigned(((POLYSIGNED)argx.i << FLT_SHIFT) + 1)); } #else // Typically for 32-bit mode. Use a boxed representation. float float_arg(Handle x) { union flt argx; argx.i = (int32_t)x->WordP()->Get(0).AsSigned(); return argx.fl; } Handle float_result(TaskData *mdTaskData, float x) { union flt argx; argx.fl = x; PolyObject *v = alloc(mdTaskData, 1, F_BYTE_OBJ); v->Set(0, PolyWord::FromSigned(argx.i)); return mdTaskData->saveVec.push(v); } #endif -POLYEXTERNALSYMBOL double PolyFloatArbitraryPrecision(PolyWord arg) +POLYEXTERNALSYMBOL double PolyFloatArbitraryPrecision(POLYUNSIGNED arg) { - return get_arbitrary_precision_as_real(arg); + return get_arbitrary_precision_as_real(PolyWord::FromUnsigned(arg)); } // Convert a boxed real to a long precision int. -POLYUNSIGNED PolyRealBoxedToLongInt(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyRealBoxedToLongInt(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); double dx = real_arg(pushedArg); int64_t i = (int64_t)dx; Handle result = Make_arbitrary_precision(taskData, i); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // RTS call for square-root. double PolyRealSqrt(double arg) { return sqrt(arg); } // RTS call for sine. double PolyRealSin(double arg) { return sin(arg); } // RTS call for cosine. double PolyRealCos(double arg) { return cos(arg); } // RTS call for arctan. double PolyRealArctan(double arg) { return atan(arg); } // RTS call for exp. double PolyRealExp(double arg) { return exp(arg); } // RTS call for ln. double PolyRealLog(double arg) { // Make sure the result conforms to the definition. // If the argument is a Nan each of the first two tests will fail. if (arg > 0.0) return log(arg); else if (arg == 0.0) // x may be +0.0 or -0.0 return negInf; // -infinity. else return notANumber; } // These were handled by the general dispatch function double PolyRealTan(double arg) { return tan(arg); } double PolyRealArcSin(double arg) { if (arg >= -1.0 && arg <= 1.0) return asin(arg); else return notANumber; } double PolyRealArcCos(double arg) { if (arg >= -1.0 && arg <= 1.0) return acos(arg); else return notANumber; } double PolyRealLog10(double arg) { // Make sure the result conforms to the definition. // If the argument is a Nan each of the first two tests will fail. if (arg > 0.0) return log10(arg); else if (arg == 0.0) // x may be +0.0 or -0.0 return negInf; // -infinity. else return notANumber; } double PolyRealSinh(double arg) { return sinh(arg); } double PolyRealCosh(double arg) { return cosh(arg); } double PolyRealTanh(double arg) { return tanh(arg); } double PolyRealFloor(double arg) { return floor(arg); } double PolyRealCeil(double arg) { return ceil(arg); } double PolyRealTrunc(double arg) { // Truncate towards zero if (arg >= 0.0) return floor(arg); else return ceil(arg); } double PolyRealRound(double arg) { // Round to nearest integral value. double drem = fmod(arg, 2.0); if (drem == 0.5 || drem == -1.5) // If the value was exactly positive even + 0.5 or // negative odd -0.5 round it down, otherwise round it up. return ceil(arg-0.5); else return floor(arg+0.5); } double PolyRealRem(double arg1, double arg2) { return fmod(arg1, arg2); } double PolyRealAtan2(double arg1, double arg2) { return atan2(arg1, arg2); } double PolyRealPow(double x, double y) { /* Some of the special cases are defined and don't seem to match the C pow function (at least as implemented in MS C). */ /* Maybe handle all this in ML? */ if (std::isnan(x)) { if (y == 0.0) return 1.0; else return notANumber; } else if (std::isnan(y)) return y; /* i.e. nan. */ else if (x == 0.0 && y < 0.0) { /* This case is not handled correctly in Solaris. It always returns -infinity. */ int iy = (int)floor(y); /* If x is -0.0 and y is an odd integer the result is -infinity. */ if (copysign(1.0, x) < 0.0 && (double)iy == y && (iy & 1)) return negInf; /* -infinity. */ else return posInf; /* +infinity. */ } return pow(x, y); } double PolyRealCopySign(double arg1, double arg2) { return copysign(arg1, arg2); } double PolyRealNextAfter(double arg1, double arg2) { return nextafter(arg1, arg2); } -double PolyRealLdexp(double arg1, PolyWord arg2) +double PolyRealLdexp(double arg1, POLYUNSIGNED arg2) { - POLYSIGNED exponent = arg2.UnTagged(); + POLYSIGNED exponent = PolyWord::FromUnsigned(arg2).UnTagged(); #if (SIZEOF_POLYWORD > SIZEOF_INT) // We've already checked for arbitrary precision values where necessary and // for zero and non-finite mantissa. Check the exponent fits in an int. if (exponent > 2 * DBL_MAX_EXP) return copysign(INFINITY, arg1); if (exponent < -2 * DBL_MAX_EXP) return copysign(0.0, arg1); #endif return ldexp(arg1, (int)exponent); } // Return the normalised fraction and the exponent. -POLYUNSIGNED PolyRealFrexp(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyRealFrexp(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { int exp = 0; // The value of exp is not always defined. Handle mantH = real_result(taskData, frexp(real_arg(pushedArg), &exp)); // Allocate a pair for the result result = alloc_and_save(taskData, 2); result->WordP()->Set(0, TAGGED(exp)); result->WordP()->Set(1, mantH->Word()); } 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(); } // RTS call for square-root. float PolyRealFSqrt(float arg) { return sqrtf(arg); } // RTS call for sine. float PolyRealFSin(float arg) { return sinf(arg); } // RTS call for cosine. float PolyRealFCos(float arg) { return cosf(arg); } // RTS call for arctan. float PolyRealFArctan(float arg) { return atanf(arg); } // RTS call for exp. float PolyRealFExp(float arg) { return expf(arg); } // RTS call for ln. float PolyRealFLog(float arg) { // Make sure the result conforms to the definition. // If the argument is a Nan each of the first two tests will fail. if (arg > 0.0) return logf(arg); else if (arg == 0.0) // x may be +0.0 or -0.0 return negInfF; // -infinity. else return notANumberF; } float PolyRealFTan(float arg) { return tanf(arg); } float PolyRealFArcSin(float arg) { if (arg >= -1.0 && arg <= 1.0) return asinf(arg); else return notANumberF; } float PolyRealFArcCos(float arg) { if (arg >= -1.0 && arg <= 1.0) return acosf(arg); else return notANumberF; } float PolyRealFLog10(float arg) { // Make sure the result conforms to the definition. // If the argument is a Nan each of the first two tests will fail. if (arg > 0.0) return log10f(arg); else if (arg == 0.0) // x may be +0.0 or -0.0 return negInfF; // -infinity. else return notANumberF; } float PolyRealFSinh(float arg) { return sinhf(arg); } float PolyRealFCosh(float arg) { return coshf(arg); } float PolyRealFTanh(float arg) { return tanhf(arg); } float PolyRealFAtan2(float arg1, float arg2) { return atan2f(arg1, arg2); } float PolyRealFPow(float x, float y) { /* Some of the special cases are defined and don't seem to match the C pow function (at least as implemented in MS C). */ /* Maybe handle all this in ML? */ if (std::isnan(x)) { if (y == 0.0) return 1.0; else return notANumberF; } else if (std::isnan(y)) return y; /* i.e. nan. */ else if (x == 0.0 && y < 0.0) { /* This case is not handled correctly in Solaris. It always returns -infinity. */ int iy = (int)floorf(y); /* If x is -0.0 and y is an odd integer the result is -infinity. */ if (copysign(1.0, x) < 0.0 && (float)iy == y && (iy & 1)) return negInfF; /* -infinity. */ else return posInfF; /* +infinity. */ } return powf(x, y); } float PolyRealFFloor(float arg) { return floorf(arg); } float PolyRealFCeil(float arg) { return ceilf(arg); } float PolyRealFTrunc(float arg) { // Truncate towards zero if (arg >= 0.0) return floorf(arg); else return ceilf(arg); } float PolyRealFRound(float arg) { // Round to nearest integral value. float drem = fmodf(arg, 2.0); if (drem == 0.5 || drem == -1.5) // If the value was exactly positive even + 0.5 or // negative odd -0.5 round it down, otherwise round it up. return ceilf(arg - 0.5f); else return floorf(arg + 0.5f); } float PolyRealFRem(float arg1, float arg2) { return fmodf(arg1, arg2); } float PolyRealFCopySign(float arg1, float arg2) { return copysignf(arg1, arg2); } float PolyRealFNextAfter(float arg1, float arg2) { return nextafterf(arg1, arg2); } /* CALL_IO1(Real_conv, REF, NOIND) */ Handle Real_convc(TaskData *mdTaskData, Handle str) /* string to real */ { double result; int i; char *finish; TempCString string_buffer(Poly_string_to_C_alloc(str->Word())); /* Scan the string turning '~' into '-' */ for(i = 0; string_buffer[i] != '\0'; i ++) { if (string_buffer[i] == '~') string_buffer[i] = '-'; } /* Now convert it */ #ifdef HAVE_STRTOD result = strtod(string_buffer, &finish); #else result = poly_strtod(string_buffer, &finish); #endif // We no longer detect overflow and underflow and instead return // (signed) zeros for underflow and (signed) infinities for overflow. if (*finish != '\0') raise_exception_string(mdTaskData, EXC_conversion, ""); return real_result(mdTaskData, result); }/* Real_conv */ // Convert a string to a boxed real. This should really return an unboxed real. -POLYUNSIGNED PolyRealBoxedFromString(FirstArgument threadId, PolyWord str) +POLYUNSIGNED PolyRealBoxedFromString(POLYUNSIGNED threadId, POLYUNSIGNED str) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedString = taskData->saveVec.push(str); Handle result = 0; try { result = Real_convc(taskData, pushedString); } 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(); } #if defined(__SOFTFP__) // soft-float lacks proper rounding mode support // While some systems will support fegetround/fesetround, it will have no // effect on the actual rounding performed, as the software implementation only // ever rounds to nearest. int getrounding() { return POLY_ROUND_TONEAREST; } int setrounding(int rounding) { switch (rounding) { case POLY_ROUND_TONEAREST: return 0; // The only mode supported } return -1; // Error - unsupported } // It would be nice to be able to use autoconf to test for these as functions // but they are frequently inlined #elif defined(HAVE_FENV_H) // C99 version. This is becoming the most common. int getrounding() { switch (fegetround()) { case FE_TONEAREST: return POLY_ROUND_TONEAREST; #ifndef HOSTARCHITECTURE_SH case FE_DOWNWARD: return POLY_ROUND_DOWNWARD; case FE_UPWARD: return POLY_ROUND_UPWARD; #endif case FE_TOWARDZERO: return POLY_ROUND_TOZERO; } return POLY_ROUND_TONEAREST; } int setrounding(int rounding) { switch (rounding) { case POLY_ROUND_TONEAREST: fesetround(FE_TONEAREST); return 0; // Choose nearest #ifndef HOSTARCHITECTURE_SH case POLY_ROUND_DOWNWARD: fesetround(FE_DOWNWARD); return 0; // Towards negative infinity case POLY_ROUND_UPWARD: fesetround(FE_UPWARD); return 0; // Towards positive infinity #endif case POLY_ROUND_TOZERO: fesetround(FE_TOWARDZERO); return 0; // Truncate towards zero default: return -1; } } #elif (defined(HAVE_IEEEFP_H) && ! defined(__CYGWIN__)) // Older FreeBSD. Cygwin has the ieeefp.h header but not the functions! int getrounding() { switch (fpgetround()) { case FP_RN: return POLY_ROUND_TONEAREST; case FP_RM: return POLY_ROUND_DOWNWARD; case FP_RP: return POLY_ROUND_UPWARD; case FP_RZ: return POLY_ROUND_TOZERO; default: return POLY_ROUND_TONEAREST; /* Shouldn't happen. */ } } int setrounding(int rounding) { switch (rounding) { case POLY_ROUND_TONEAREST: fpsetround(FP_RN); break; /* Choose nearest */ case POLY_ROUND_DOWNWARD: fpsetround(FP_RM); break; /* Towards negative infinity */ case POLY_ROUND_UPWARD: fpsetround(FP_RP); break; /* Towards positive infinity */ case POLY_ROUND_TOZERO: fpsetround(FP_RZ); break; /* Truncate towards zero */ } return 0 } #elif defined(_WIN32) // Windows version int getrounding() { switch (_controlfp(0,0) & _MCW_RC) { case _RC_NEAR: return POLY_ROUND_TONEAREST; case _RC_DOWN: return POLY_ROUND_DOWNWARD; case _RC_UP: return POLY_ROUND_UPWARD; case _RC_CHOP: return POLY_ROUND_TOZERO; } return POLY_ROUND_TONEAREST; } int setrounding(int rounding) { switch (rounding) { case POLY_ROUND_TONEAREST: _controlfp(_RC_NEAR, _MCW_RC); return 0; // Choose nearest case POLY_ROUND_DOWNWARD: _controlfp(_RC_DOWN, _MCW_RC); return 0; // Towards negative infinity case POLY_ROUND_UPWARD: _controlfp(_RC_UP, _MCW_RC); return 0; // Towards positive infinity case POLY_ROUND_TOZERO: _controlfp(_RC_CHOP, _MCW_RC); return 0; // Truncate towards zero } return -1; } #elif defined(_FPU_GETCW) && defined(_FPU_SETCW) // Older Linux version int getrounding() { fpu_control_t ctrl; _FPU_GETCW(ctrl); switch (ctrl & _FPU_RC_ZERO) { case _FPU_RC_NEAREST: return POLY_ROUND_TONEAREST; case _FPU_RC_DOWN: return POLY_ROUND_DOWNWARD; case _FPU_RC_UP: return POLY_ROUND_UPWARD; case _FPU_RC_ZERO: return POLY_ROUND_TOZERO; } return POLY_ROUND_TONEAREST; /* Never reached but this avoids warning message. */ } int setrounding(int rounding) { fpu_control_t ctrl; _FPU_GETCW(ctrl); ctrl &= ~_FPU_RC_ZERO; /* Mask off any existing rounding. */ switch (rounding) { case POLY_ROUND_TONEAREST: ctrl |= _FPU_RC_NEAREST; case POLY_ROUND_DOWNWARD: ctrl |= _FPU_RC_DOWN; case POLY_ROUND_UPWARD: ctrl |= _FPU_RC_UP; case POLY_ROUND_TOZERO: ctrl |= _FPU_RC_ZERO; } _FPU_SETCW(ctrl); return 0; } #else // Give up. Assume that we only support TO_NEAREST int getrounding() { return POLY_ROUND_TONEAREST; } int setrounding(int rounding) { if (rounding == POLY_ROUND_TONEAREST) return 0; else return -1; } #endif -POLYSIGNED PolyGetRoundingMode(PolyWord) +POLYSIGNED PolyGetRoundingMode(POLYUNSIGNED) { // Get the rounding and turn the result into a tagged integer. return TAGGED(getrounding()).AsSigned(); } -POLYSIGNED PolySetRoundingMode(PolyWord arg) +POLYSIGNED PolySetRoundingMode(POLYUNSIGNED arg) { - return TAGGED(setrounding((int)arg.UnTagged())).AsSigned(); + return TAGGED(setrounding((int)PolyWord::FromUnsigned(arg).UnTagged())).AsSigned(); } Handle Real_strc(TaskData *mdTaskData, Handle hDigits, Handle hMode, Handle arg) { double dx = real_arg(arg); int decpt, sign; int mode = get_C_int(mdTaskData, hMode->Word()); int digits = get_C_int(mdTaskData, hDigits->Word()); /* Compute the shortest string which gives the required value. */ /* */ char *chars = poly_dtoa(dx, mode, digits, &decpt, &sign, NULL); /* We have to be careful in case an allocation causes a garbage collection. */ PolyWord pStr = C_string_to_Poly(mdTaskData, chars); poly_freedtoa(chars); Handle ppStr = mdTaskData->saveVec.push(pStr); /* Allocate a triple for the results. */ PolyObject *result = alloc(mdTaskData, 3); result->Set(0, ppStr->Word()); result->Set(1, TAGGED(decpt)); result->Set(2, TAGGED(sign)); return mdTaskData->saveVec.push(result); } // Convert boxed real to string. This should be changed to use an unboxed real argument. -POLYUNSIGNED PolyRealBoxedToString(FirstArgument threadId, PolyWord arg, PolyWord mode, PolyWord digits) +POLYUNSIGNED PolyRealBoxedToString(POLYUNSIGNED threadId, POLYUNSIGNED arg, POLYUNSIGNED mode, POLYUNSIGNED digits) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle pushedMode = taskData->saveVec.push(mode); Handle pushedDigits = taskData->saveVec.push(digits); Handle result = 0; try { result = Real_strc(taskData, pushedDigits, pushedMode, pushedArg); } catch (...) { } // Can this raise an exception? taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This used to be used for all the functions. It now only contains calls // used when the Real structure is defined to get the values of constants. static Handle Real_dispatchc(TaskData *mdTaskData, Handle args, Handle code) { unsigned c = get_C_unsigned(mdTaskData, code->Word()); switch (c) { /* Floating point representation queries. */ #ifdef _DBL_RADIX case 11: /* Value of radix */ return mdTaskData->saveVec.push(TAGGED(_DBL_RADIX)); #else case 11: /* Value of radix */ return mdTaskData->saveVec.push(TAGGED(FLT_RADIX)); #endif case 12: /* Value of precision */ return mdTaskData->saveVec.push(TAGGED(DBL_MANT_DIG)); case 13: /* Maximum number */ return real_result(mdTaskData, DBL_MAX); case 14: /* Minimum normalised number. */ return real_result(mdTaskData, DBL_MIN); case 15: // Minimum number. #ifdef DBL_TRUE_MIN return real_result(mdTaskData, DBL_TRUE_MIN); #else return real_result(mdTaskData, DBL_MIN*DBL_EPSILON); #endif // Constants for float (Real32.real) case 30: /* Value of radix */ return mdTaskData->saveVec.push(TAGGED(FLT_RADIX)); case 31: /* Value of precision */ return mdTaskData->saveVec.push(TAGGED(FLT_MANT_DIG)); case 32: /* Maximum number */ return float_result(mdTaskData, FLT_MAX); case 33: /* Minimum normalised number. */ return float_result(mdTaskData, FLT_MIN); case 34: // Minimum number. #ifdef FLT_TRUE_MIN return float_result(mdTaskData, FLT_TRUE_MIN); #else return float_result(mdTaskData, FLT_MIN*FLT_EPSILON); #endif default: { char msg[100]; sprintf(msg, "Unknown real arithmetic function: %d", c); raise_exception_string(mdTaskData, EXC_Fail, msg); return 0; } } } -POLYUNSIGNED PolyRealSize(PolyWord) +POLYUNSIGNED PolyRealSize(POLYUNSIGNED) { // Return the number of bytes for a real. This is used in PackRealBig/Little. return TAGGED(sizeof(double)).AsUnsigned(); } -POLYUNSIGNED PolyRealGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyRealGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = Real_dispatchc(taskData, pushedArg, pushedCode); } 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(); } struct _entrypts realsEPT[] = { { "PolyRealBoxedToString", (polyRTSFunction)&PolyRealBoxedToString}, { "PolyRealGeneral", (polyRTSFunction)&PolyRealGeneral}, { "PolyRealBoxedFromString", (polyRTSFunction)&PolyRealBoxedFromString}, { "PolyRealBoxedToLongInt", (polyRTSFunction)&PolyRealBoxedToLongInt}, { "PolyRealSqrt", (polyRTSFunction)&PolyRealSqrt}, { "PolyRealSin", (polyRTSFunction)&PolyRealSin}, { "PolyRealCos", (polyRTSFunction)&PolyRealCos}, { "PolyRealArctan", (polyRTSFunction)&PolyRealArctan}, { "PolyRealExp", (polyRTSFunction)&PolyRealExp}, { "PolyRealLog", (polyRTSFunction)&PolyRealLog}, { "PolyRealTan", (polyRTSFunction)&PolyRealTan}, { "PolyRealArcSin", (polyRTSFunction)&PolyRealArcSin}, { "PolyRealArcCos", (polyRTSFunction)&PolyRealArcCos}, { "PolyRealLog10", (polyRTSFunction)&PolyRealLog10}, { "PolyRealSinh", (polyRTSFunction)&PolyRealSinh}, { "PolyRealCosh", (polyRTSFunction)&PolyRealCosh}, { "PolyRealTanh", (polyRTSFunction)&PolyRealTanh}, { "PolyRealFloor", (polyRTSFunction)&PolyRealFloor}, { "PolyRealCeil", (polyRTSFunction)&PolyRealCeil}, { "PolyRealTrunc", (polyRTSFunction)&PolyRealTrunc}, { "PolyRealRound", (polyRTSFunction)&PolyRealRound}, { "PolyRealRem", (polyRTSFunction)&PolyRealRem }, { "PolyFloatArbitraryPrecision", (polyRTSFunction)&PolyFloatArbitraryPrecision}, { "PolyGetRoundingMode", (polyRTSFunction)&PolyGetRoundingMode}, { "PolySetRoundingMode", (polyRTSFunction)&PolySetRoundingMode}, { "PolyRealSize", (polyRTSFunction)&PolyRealSize}, { "PolyRealAtan2", (polyRTSFunction)&PolyRealAtan2 }, { "PolyRealPow", (polyRTSFunction)&PolyRealPow }, { "PolyRealCopySign", (polyRTSFunction)&PolyRealCopySign }, { "PolyRealNextAfter", (polyRTSFunction)&PolyRealNextAfter }, { "PolyRealLdexp", (polyRTSFunction)&PolyRealLdexp }, { "PolyRealFrexp", (polyRTSFunction)&PolyRealFrexp }, { "PolyRealFSqrt", (polyRTSFunction)&PolyRealFSqrt }, { "PolyRealFSin", (polyRTSFunction)&PolyRealFSin }, { "PolyRealFCos", (polyRTSFunction)&PolyRealFCos }, { "PolyRealFArctan", (polyRTSFunction)&PolyRealFArctan }, { "PolyRealFExp", (polyRTSFunction)&PolyRealFExp }, { "PolyRealFLog", (polyRTSFunction)&PolyRealFLog }, { "PolyRealFTan", (polyRTSFunction)&PolyRealFTan }, { "PolyRealFArcSin", (polyRTSFunction)&PolyRealFArcSin }, { "PolyRealFArcCos", (polyRTSFunction)&PolyRealFArcCos }, { "PolyRealFLog10", (polyRTSFunction)&PolyRealFLog10 }, { "PolyRealFSinh", (polyRTSFunction)&PolyRealFSinh }, { "PolyRealFCosh", (polyRTSFunction)&PolyRealFCosh }, { "PolyRealFTanh", (polyRTSFunction)&PolyRealFTanh }, { "PolyRealFAtan2", (polyRTSFunction)&PolyRealFAtan2 }, { "PolyRealFPow", (polyRTSFunction)&PolyRealFPow }, { "PolyRealFCopySign", (polyRTSFunction)&PolyRealFCopySign }, { "PolyRealFFloor", (polyRTSFunction)&PolyRealFFloor }, { "PolyRealFCeil", (polyRTSFunction)&PolyRealFCeil }, { "PolyRealFTrunc", (polyRTSFunction)&PolyRealFTrunc }, { "PolyRealFRound", (polyRTSFunction)&PolyRealFRound }, { "PolyRealFRem", (polyRTSFunction)&PolyRealFRem }, { "PolyRealFNextAfter", (polyRTSFunction)&PolyRealFNextAfter }, { NULL, NULL} // End of list. }; class RealArithmetic: public RtsModule { public: virtual void Init(void); }; // Declare this. It will be automatically added to the table. static RealArithmetic realModule; void RealArithmetic::Init(void) { /* Some compilers object to overflow in constants so we compute the values here. */ #if (HAVE_DECL_FPSETMASK && ! defined(__CYGWIN__)) /* In FreeBSD 3.4 at least, we sometimes get floating point exceptions if we don't clear the mask. Maybe need to do this on other platforms as well just to be sure. */ // N.B. fpsetmask is defined in the headers on Cygwin but there's no function! fpsetmask(0); #endif // NAN and INFINITY are defined in GCC but not in Visual C++. #if (defined(INFINITY)) posInf = INFINITY; negInf = -(INFINITY); posInfF = INFINITY; negInfF = -(INFINITY); #else { double zero = 0.0; posInf = 1.0 / zero; negInf = -1.0 / zero; float zeroF = 0.0; posInfF = 1.0 / zeroF; negInfF = -1.0 / zeroF; } #endif #if (defined(NAN)) notANumber = NAN; #else { double zero = 0.0; notANumber = zero / zero; float zeroF = 0.0; notANumberF = zeroF / zeroF; } #endif // Make sure this is a positive NaN since we return it from "abs". // "Positive" in this context is copysign(1.0, x) > 0.0 because that's // how we test the sign so we test it first and then try to change the // sign if it's wrong. if (copysign(1.0, notANumber) < 0) notANumber = copysign(notANumber, 1.0); if (copysignf(1.0, notANumberF) < 0) notANumberF = copysignf(notANumberF, 1.0); } diff --git a/libpolyml/rtsentry.cpp b/libpolyml/rtsentry.cpp index 18a73e3c..57044c4d 100644 --- a/libpolyml/rtsentry.cpp +++ b/libpolyml/rtsentry.cpp @@ -1,202 +1,202 @@ /* Title: rtsentry.cpp - Entry points to the run-time system Copyright (c) 2016, 2017 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "rtsentry.h" #include "save_vec.h" #include "processes.h" #include "run_time.h" #include "polystring.h" #include "arb.h" #include "basicio.h" #include "polyffi.h" #include "xwindows.h" #include "os_specific.h" #include "timing.h" #include "sighandler.h" #include "sharedata.h" #include "run_time.h" #include "reals.h" #include "profiling.h" #include "processes.h" #include "process_env.h" #include "poly_specific.h" #include "objsize.h" #include "network.h" #include "machine_dep.h" #include "exporter.h" #include "statistics.h" #include "savestate.h" #include "bytecode.h" extern struct _entrypts rtsCallEPT[]; static entrypts entryPointTable[] = { rtsCallEPT, arbitraryPrecisionEPT, basicIOEPT, polyFFIEPT, xwindowsEPT, osSpecificEPT, timingEPT, sigHandlerEPT, shareDataEPT, runTimeEPT, realsEPT, profilingEPT, processesEPT, processEnvEPT, polySpecificEPT, objSizeEPT, networkingEPT, exporterEPT, statisticsEPT, savestateEPT, machineSpecificEPT, byteCodeEPT, NULL }; extern "C" { #ifdef _MSC_VER __declspec(dllexport) #endif - POLYUNSIGNED PolyCreateEntryPointObject(FirstArgument threadId, PolyWord arg); + POLYUNSIGNED PolyCreateEntryPointObject(POLYUNSIGNED threadId, POLYUNSIGNED arg); }; // Create an entry point containing the address of the entry and the // string name. Having the string in there allows us to export the entry. Handle creatEntryPointObject(TaskData *taskData, Handle entryH, bool isFuncPtr) { TempCString entryName(Poly_string_to_C_alloc(entryH->Word())); if ((const char *)entryName == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); // Create space for the address followed by the name as a C string. uintptr_t space = 1 + (strlen(entryName) + 1 + (isFuncPtr ? 0 : 1) + sizeof(polyRTSFunction*) - 1) / sizeof(PolyWord); // Allocate a byte, weak, mutable, no-overwrite cell. It's not clear if // it actually needs to be mutable but if it is it needs to be no-overwrite. Handle refH = alloc_and_save(taskData, space, F_BYTE_OBJ|F_WEAK_BIT|F_MUTABLE_BIT|F_NO_OVERWRITE); PolyObject *p = refH->WordP(); *(polyRTSFunction*)p = 0; // Clear it char *entryPtr = (char*)(p->AsBytePtr() + sizeof(polyRTSFunction*)); if (! isFuncPtr) *entryPtr++ = 1; // Put in a type entry strcpy(entryPtr, entryName); return refH; } // Return the string entry point. const char *getEntryPointName(PolyObject *p, bool *isFuncPtr) { if (p->Length() <= sizeof(polyRTSFunction*)/sizeof(PolyWord)) return 0; // Doesn't contain an entry point const char *entryPtr = (const char*)(p->AsBytePtr() + sizeof(polyRTSFunction*)); *isFuncPtr = *entryPtr != 1; // If the type is 1 it is a data entry point if (*entryPtr < ' ') entryPtr++; // Skip the type byte return entryPtr; } // Sets the address of the entry point in an entry point object. bool setEntryPoint(PolyObject *p) { if (p->Length() == 0) return false; *(polyRTSFunction*)p = 0; // Clear it by default if (p->Length() == 1) return false; const char *entryName = (const char*)(p->AsBytePtr()+sizeof(polyRTSFunction*)); if (*entryName < ' ') entryName++; // Skip the type byte // Search the entry point table list. for (entrypts *ept=entryPointTable; *ept != NULL; ept++) { entrypts entryPtTable = *ept; if (entryPtTable != 0) { for (struct _entrypts *ep = entryPtTable; ep->entry != NULL; ep++) { if (strcmp(entryName, ep->name) == 0) { polyRTSFunction entry = ep->entry; *(polyRTSFunction*)p = entry; return true; } } } } return false; } // External call -POLYUNSIGNED PolyCreateEntryPointObject(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyCreateEntryPointObject(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = creatEntryPointObject(taskData, pushedArg, true /* Always functions */); if (!setEntryPoint(result->WordP())) { // Include the name of the symbol. It's often helpful. char buff[100]; strncpy(buff, "entry point not found: ", sizeof(buff) - 1); size_t length = strlen(buff); Poly_string_to_C(pushedArg->Word(), buff+ length, sizeof(buff) - length-1); raise_fail(taskData, buff); } } 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 rtsCallEPT[] = { { "PolyCreateEntryPointObject", (polyRTSFunction)&PolyCreateEntryPointObject}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/rtsentry.h b/libpolyml/rtsentry.h index abeaa269..61e84e50 100644 --- a/libpolyml/rtsentry.h +++ b/libpolyml/rtsentry.h @@ -1,65 +1,49 @@ /* Title: rtsentry.h - Entry points to the run-time system Copyright (c) 2016 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 RTSENTRY_H_INCLUDED #define RTSENTRY_H_INCLUDED class SaveVecEntry; class TaskData; class PolyObject; typedef SaveVecEntry *Handle; extern Handle creatEntryPointObject(TaskData *taskData, Handle entryH, bool isFuncPtr); extern const char *getEntryPointName(PolyObject *p, bool *isFuncPtr); extern bool setEntryPoint(PolyObject *p); typedef void (*polyRTSFunction)(); typedef struct _entrypts { const char *name; polyRTSFunction entry; } *entrypts; // Ensure that the RTS calls can be found by the linker. #ifndef POLYEXTERNALSYMBOL #ifdef _MSC_VER #define POLYEXTERNALSYMBOL __declspec(dllexport) #else #define POLYEXTERNALSYMBOL #endif #endif -#ifdef POLYML32IN64 -// This is needed for legacy only. RTS calls previously passed the -// real address of the thread ID. They now pass a PolyWord containing -// the thread ID. -// Once we've fully bootstrapped FirstArgument can be replaced with PolyWord. -union firstArgFull -{ - operator PolyWord() - { if (value >= 0x100000000) return (PolyWord)((PolyObject*)value); else return PolyWord::FromUnsigned((POLYUNSIGNED)value); } - uintptr_t value; -}; -typedef union firstArgFull FirstArgument; -#else -typedef PolyWord FirstArgument; -#endif - #endif diff --git a/libpolyml/run_time.cpp b/libpolyml/run_time.cpp index c4c3732b..b1fe6e47 100644 --- a/libpolyml/run_time.cpp +++ b/libpolyml/run_time.cpp @@ -1,422 +1,422 @@ /* Title: Run-time system. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 Cambridge University Technical Services Limited Further work copyright David C. J. Matthews 2009, 2012, 2015-18 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_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include "globals.h" #include "gc.h" #include "mpoly.h" #include "arb.h" #include "diagnostics.h" #include "processes.h" #include "profiling.h" #include "run_time.h" #include "sys.h" #include "polystring.h" #include "save_vec.h" #include "rtsentry.h" #include "memmgr.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFullGC(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFullGC(POLYUNSIGNED threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyIsBigEndian(); } #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) // This is the storage allocator for allocating heap objects in the RTS. PolyObject *alloc(TaskData *taskData, uintptr_t data_words, unsigned flags) /* Allocate a number of words. */ { // Check the size. This might possibly happen with a long string. if (data_words > MAX_OBJECT_SIZE) raise_exception0(taskData, EXC_size); POLYUNSIGNED words = (POLYUNSIGNED)data_words + 1; if (profileMode == kProfileStoreAllocation) taskData->addProfileCount(words); PolyWord *foundSpace = processes->FindAllocationSpace(taskData, words, false); if (foundSpace == 0) { // Failed - the thread is set to raise an exception. throw IOException(); } PolyObject *pObj = (PolyObject*)(foundSpace + 1); pObj->SetLengthWord((POLYUNSIGNED)data_words, flags); // Must initialise object here, because GC doesn't clean store. // Is this necessary any more? This used to be necessary when we used // structural equality and wanted to make sure that unused bytes were cleared. // N.B. This sets the store to zero NOT TAGGED(0). for (POLYUNSIGNED i = 0; i < data_words; i++) pObj->Set(i, PolyWord::FromUnsigned(0)); return pObj; } Handle alloc_and_save(TaskData *taskData, uintptr_t size, unsigned flags) /* Allocate and save the result on the vector. */ { return taskData->saveVec.push(alloc(taskData, size, flags)); } -POLYUNSIGNED PolyFullGC(FirstArgument threadId) +POLYUNSIGNED PolyFullGC(POLYUNSIGNED threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); try { // Can this raise an exception e.g. if there is insufficient memory? FullGC(taskData); } catch (...) { } // If an ML exception is raised taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Returns unit. } /******************************************************************************/ /* */ /* Error Messages */ /* */ /******************************************************************************/ // Return the handle to a string error message. This will return // something like "Unknown error" from strerror if it doesn't match // anything. Handle errorMsg(TaskData *taskData, int err) { #if (defined(_WIN32)) LPTSTR lpMsg = NULL; TCHAR *p; if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, (DWORD)err, 0, (LPTSTR)&lpMsg, 1, NULL) > 0) { /* The message is returned with CRLF at the end. Remove them. */ for (p = lpMsg; *p != '\0' && *p != '\n' && *p != '\r'; p++); *p = '\0'; Handle res = SAVE(C_string_to_Poly(taskData, lpMsg)); LocalFree(lpMsg); return res; } #endif // Unix and unknown Windows errors. return SAVE(C_string_to_Poly(taskData, strerror(err))); } #define DEREFEXNHANDLE(_x) ((poly_exn *)DEREFHANDLE(_x)) static Handle make_exn(TaskData *taskData, int id, Handle arg, const char *fileName, int lineNo) { const char *exName; switch (id) { case EXC_interrupt: exName = "Interrupt"; break; case EXC_syserr: exName = "SysErr"; break; case EXC_size: exName = "Size"; break; case EXC_overflow: exName = "Overflow"; break; case EXC_underflow: exName = "Underflow"; break; case EXC_divide: exName = "Div"; break; case EXC_conversion: exName = "Conversion"; break; case EXC_XWindows: exName = "XWindows"; break; case EXC_subscript: exName = "Subscript"; break; case EXC_foreign: exName = "Foreign"; break; case EXC_Fail: exName = "Fail"; break; case EXC_thread: exName = "Thread"; break; case EXC_extrace: exName = "ExTrace"; break; default: ASSERT(0); exName = "Unknown"; // Shouldn't happen. } Handle pushed_name = SAVE(C_string_to_Poly(taskData, exName)); Handle exnHandle = alloc_and_save(taskData, SIZEOF(poly_exn)); Handle location; // The location data in an exception packet is either "NoLocation" (tagged 0) // or the address of a record. if (fileName == 0) location = taskData->saveVec.push(TAGGED(0)); else { Handle file = taskData->saveVec.push(C_string_to_Poly(taskData, fileName)); Handle line = Make_fixed_precision(taskData, lineNo); location = alloc_and_save(taskData, 5); location->WordP()->Set(0, file->Word()); // file location->WordP()->Set(1, line->Word()); // startLine location->WordP()->Set(2, line->Word()); // endLine location->WordP()->Set(3, TAGGED(0)); // startPosition location->WordP()->Set(4, TAGGED(0)); // endPosition } DEREFEXNHANDLE(exnHandle)->ex_id = TAGGED(id); DEREFEXNHANDLE(exnHandle)->ex_name = pushed_name->Word(); DEREFEXNHANDLE(exnHandle)->arg = arg->Word(); DEREFEXNHANDLE(exnHandle)->ex_location = location->Word(); return exnHandle; } // Create an exception packet, e.g. Interrupt, for later use. This does not have a // location. poly_exn *makeExceptionPacket(TaskData *taskData, int id) { Handle exn = make_exn(taskData, id, taskData->saveVec.push(TAGGED(0)), 0, 0); return DEREFEXNHANDLE(exn); } static NORETURNFN(void raise_exception(TaskData *taskData, int id, Handle arg, const char *file, int line)); void raise_exception(TaskData *taskData, int id, Handle arg, const char *file, int line) /* Raise an exception with no arguments. */ { Handle exn = make_exn(taskData, id, arg, file, line); taskData->SetException(DEREFEXNHANDLE(exn)); throw IOException(); /* Return to Poly code immediately. */ /*NOTREACHED*/ } void raiseException0WithLocation(TaskData *taskData, int id, const char *file, int line) /* Raise an exception with no arguments. */ { raise_exception(taskData, id, SAVE(TAGGED(0)), file, line); /*NOTREACHED*/ } void raiseExceptionStringWithLocation(TaskData *taskData, int id, const char *str, const char *file, int line) /* Raise an exception with a C string as the argument. */ { raise_exception(taskData, id, SAVE(C_string_to_Poly(taskData, str)), file, line); /*NOTREACHED*/ } // This is called via a macro that puts in the file name and line number. void raiseSycallWithLocation(TaskData *taskData, const char *errmsg, int err, const char *file, int line) { if (err == 0) { Handle pushed_option = SAVE(NONE_VALUE); /* NONE */ Handle pushed_name = SAVE(C_string_to_Poly(taskData, errmsg)); Handle pair = alloc_and_save(taskData, 2); DEREFHANDLE(pair)->Set(0, pushed_name->Word()); DEREFHANDLE(pair)->Set(1, pushed_option->Word()); raise_exception(taskData, EXC_syserr, pair, file, line); } else { Handle errornum = Make_sysword(taskData, err); Handle pushed_option = alloc_and_save(taskData, 1); DEREFHANDLE(pushed_option)->Set(0, errornum->Word()); /* SOME err */ Handle pushed_name = errorMsg(taskData, err); // Generate the string. Handle pair = alloc_and_save(taskData, 2); DEREFHANDLE(pair)->Set(0, pushed_name->Word()); DEREFHANDLE(pair)->Set(1, pushed_option->Word()); raise_exception(taskData, EXC_syserr, pair, file, line); } } void raiseExceptionFailWithLocation(TaskData *taskData, const char *str, const char *file, int line) { raiseExceptionStringWithLocation(taskData, EXC_Fail, str, file, line); } /* "Polymorphic" function to generate a list. */ Handle makeList(TaskData *taskData, int count, char *p, int size, void *arg, Handle (mkEntry)(TaskData *, void*, char*)) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); /* Start from the end of the list. */ p += count*size; while (count > 0) { Handle value, next; p -= size; /* Back up to the last entry. */ value = mkEntry(taskData, arg, p); next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = value->Word(); DEREFLISTHANDLE(next)->t = list->Word(); taskData->saveVec.reset(saved); list = SAVE(next->Word()); count--; } return list; } void CheckAndGrowStack(TaskData *taskData, uintptr_t minSize) /* Expands the current stack if it has grown. We cannot shrink a stack segment when it grows smaller because the frame is checked only at the beginning of a function to ensure that there is enough space for the maximum that can be allocated. */ { /* Get current size of new stack segment. */ uintptr_t old_len = taskData->stack->spaceSize(); if (old_len >= minSize) return; /* Ok with present size. */ // If it is too small double its size. uintptr_t new_len; /* New size */ for (new_len = old_len; new_len < minSize; new_len *= 2); uintptr_t limitSize = getPolyUnsigned(taskData, taskData->threadObject->mlStackSize); // Do not grow the stack if its size is already too big. if ((limitSize != 0 && old_len >= limitSize) || ! gMem.GrowOrShrinkStack(taskData, new_len)) { /* Cannot expand the stack any further. */ extern FILE *polyStderr; fprintf(polyStderr, "Warning - Unable to increase stack - interrupting thread\n"); if (debugOptions & DEBUG_THREADS) Log("THREAD: Unable to grow stack for thread %p from %lu to %lu\n", taskData, old_len, new_len); // We really should do this only if the thread is handling interrupts // asynchronously. On the other hand what else do we do? taskData->SetException(processes->GetInterrupt()); } else { if (debugOptions & DEBUG_THREADS) Log("THREAD: Growing stack for thread %p from %lu to %lu\n", taskData, old_len, new_len); } } Handle Make_fixed_precision(TaskData *taskData, int val) { #if (SIZEOF_INT >= SIZEOF_POLYWORD) // This range check may produce a warning if int is 32 bits and PolyWord is 64-bits. if (val > MAXTAGGED || val < -MAXTAGGED-1) raise_exception0(taskData, EXC_overflow); #endif return taskData->saveVec.push(TAGGED(val)); } Handle Make_fixed_precision(TaskData *taskData, unsigned uval) { #if (SIZEOF_INT >= SIZEOF_POLYWORD) if (uval > MAXTAGGED) raise_exception0(taskData, EXC_overflow); #endif return taskData->saveVec.push(TAGGED(uval)); } Handle Make_fixed_precision(TaskData *taskData, long val) { if (val > MAXTAGGED || val < -MAXTAGGED-1) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED(val)); } Handle Make_fixed_precision(TaskData *taskData, unsigned long uval) { if (uval > MAXTAGGED) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED(uval)); } #ifdef HAVE_LONG_LONG Handle Make_fixed_precision(TaskData *taskData, long long val) { if (val > MAXTAGGED || val < -MAXTAGGED-1) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED((POLYSIGNED)val)); } Handle Make_fixed_precision(TaskData *taskData, unsigned long long uval) { if (uval > MAXTAGGED) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED((POLYUNSIGNED)uval)); } #endif Handle Make_sysword(TaskData *taskData, uintptr_t p) { Handle result = alloc_and_save(taskData, sizeof(uintptr_t)/sizeof(PolyWord), F_BYTE_OBJ); *(uintptr_t*)(result->Word().AsCodePtr()) = p; return result; } // A volatile ref is used for data that is not valid in a different session. // When loaded from a saved state it is cleared to zero. Handle MakeVolatileWord(TaskData *taskData, void *p) { Handle result = alloc_and_save(taskData, WORDS(SIZEOF_VOIDP), F_BYTE_OBJ | F_WEAK_BIT | F_MUTABLE_BIT | F_NO_OVERWRITE); *(void**)(result->Word().AsCodePtr()) = p; return result; } Handle MakeVolatileWord(TaskData *taskData, uintptr_t p) { return MakeVolatileWord(taskData, (void*)p); } // This is used to determine the endian-ness that Poly/ML is running under. // It's really only needed for the interpreter. In particular the pre-built // compiler may be running under either byte order and has to check at // run-time. POLYUNSIGNED PolyIsBigEndian() { #ifdef WORDS_BIGENDIAN return TAGGED(1).AsUnsigned(); #else return TAGGED(0).AsUnsigned(); #endif } struct _entrypts runTimeEPT[] = { { "PolyFullGC", (polyRTSFunction)&PolyFullGC}, { "PolyIsBigEndian", (polyRTSFunction)&PolyIsBigEndian}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/save_vec.h b/libpolyml/save_vec.h index e40c174d..59f6d4f8 100644 --- a/libpolyml/save_vec.h +++ b/libpolyml/save_vec.h @@ -1,88 +1,93 @@ /* Title: save_vec.h - The save vector holds temporary values that may move as the result of a garbage collection. Copyright (c) 2006, 2010 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 as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. 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 SAVE_VEC_H_DEFINED #define SAVE_VEC_H_DEFINED #include "globals.h" // For PolyWord /* A handle is the address of an element of save_vec */ /* This element points at an element of the Poly heap */ /* The element is currently represented as a (PolyWord *) */ class SaveVecEntry { public: SaveVecEntry(PolyWord w): m_Handle(w) {} SaveVecEntry(): m_Handle(PolyWord::FromUnsigned(0)) {} // Just used when initialising the vec PolyWord Word() { return m_Handle; } PolyObject *WordP() { return m_Handle.AsObjPtr(); } private: PolyWord m_Handle; friend class SaveVec; }; typedef SaveVecEntry *Handle; #define DEREFWORD(_x) ((_x)->Word()) #define DEREFHANDLE(_x) ((_x)->WordP()) #define DEREFWORDHANDLE(_x) ((_x)->WordP()) #define DEREFBYTEHANDLE(_x) ((byte *)DEREFHANDLE(_x)) #define DEREFLISTHANDLE(_x) ((ML_Cons_Cell *)DEREFHANDLE(_x)) class ScanAddress; class SaveVec { public: SaveVec(); ~SaveVec(); // Clear the save vec at the start of an RTS call void init(void) { save_vec_addr = save_vec; } // Add a word to the save vec Handle push(PolyWord valu); + // Overloading for common RTS case. + Handle push(POLYUNSIGNED valu) { + return push(PolyWord::FromUnsigned(valu)); + } + // Mark a position Handle mark(void) { return save_vec_addr; } // Reset to the mark void reset(Handle mark); bool isValidHandle(Handle h) { return h >= save_vec && h < save_vec_addr; } // Check it is in the range. // Called by the garbage collector to scan and then update the addresses in the // vector. void gcScan(ScanAddress *process); private: SaveVecEntry *save_vec; SaveVecEntry *save_vec_addr; }; #endif diff --git a/libpolyml/savestate.cpp b/libpolyml/savestate.cpp index 833e0411..089d1eaa 100644 --- a/libpolyml/savestate.cpp +++ b/libpolyml/savestate.cpp @@ -1,2264 +1,2264 @@ /* Title: savestate.cpp - Save and Load state Copyright (c) 2007, 2015, 2017-19, 2021 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 */ #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_WINDOWS_H #include // For MAX_PATH #endif #ifdef HAVE_SYS_PARAM_H #include // For MAX_PATH #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_TIME_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #if (defined(_WIN32)) #include #define ERRORNUMBER _doserrno #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #else typedef char TCHAR; #define _T(x) x #define _tfopen fopen #define _tcscpy strcpy #define _tcsdup strdup #define _tcslen strlen #define _fputtc fputc #define _fputts fputs #ifndef lstrcmpi #define lstrcmpi strcasecmp #endif #define ERRORNUMBER errno #define NOMEMORY ENOMEM #endif #include "globals.h" #include "savestate.h" #include "processes.h" #include "run_time.h" #include "polystring.h" #include "scanaddrs.h" #include "arb.h" #include "memmgr.h" #include "mpoly.h" // For exportTimeStamp #include "exporter.h" // For CopyScan #include "machine_dep.h" #include "osmem.h" #include "gc.h" // For FullGC. #include "timing.h" #include "rtsentry.h" #include "check_objects.h" #include "rtsentry.h" #include "../polyexports.h" // For InitHeaderFromExport #include "version.h" // For InitHeaderFromExport #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolySaveState(FirstArgument threadId, PolyWord fileName, PolyWord depth); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadState(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowHierarchy(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRenameParent(FirstArgument threadId, PolyWord childName, PolyWord parentName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowParent(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyStoreModule(FirstArgument threadId, PolyWord name, PolyWord contents); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadModule(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadHierarchy(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetModuleDirectory(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySaveState(POLYUNSIGNED threadId, POLYUNSIGNED fileName, POLYUNSIGNED depth); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadState(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowHierarchy(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRenameParent(POLYUNSIGNED threadId, POLYUNSIGNED childName, POLYUNSIGNED parentName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowParent(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyStoreModule(POLYUNSIGNED threadId, POLYUNSIGNED name, POLYUNSIGNED contents); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadModule(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadHierarchy(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetModuleDirectory(POLYUNSIGNED threadId); } // Helper class to close files on exit. class AutoClose { public: AutoClose(FILE *f = 0): m_file(f) {} ~AutoClose() { if (m_file) ::fclose(m_file); } operator FILE*() { return m_file; } FILE* operator = (FILE* p) { return (m_file = p); } private: FILE *m_file; }; // This is probably generally useful so may be moved into // a general header file. template class AutoFree { public: AutoFree(BASE p = 0): m_value(p) {} ~AutoFree() { free(m_value); } // Automatic conversions to the base type. operator BASE() { return m_value; } BASE operator = (BASE p) { return (m_value = p); } private: BASE m_value; }; #ifdef HAVE__FTELLI64 // fseek and ftell are only 32-bits in Windows. #define off_t __int64 #define fseek _fseeki64 #define ftell _ftelli64 #endif /* * Structure definitions for the saved state files. */ #define SAVEDSTATESIGNATURE "POLYSAVE" #define SAVEDSTATEVERSION 2 // File header for a saved state file. This appears as the first entry // in the file. typedef struct _savedStateHeader { // These entries are primarily to check that we have a valid // saved state file before we try to interpret anything else. char headerSignature[8]; // Should contain SAVEDSTATESIGNATURE unsigned headerVersion; // Should contain SAVEDSTATEVERSION unsigned headerLength; // Number of bytes in the header unsigned segmentDescrLength; // Number of bytes in a descriptor // These entries contain the real data. off_t segmentDescr; // Position of segment descriptor table unsigned segmentDescrCount; // Number of segment descriptors in the table off_t stringTable; // Pointer to the string table (zero if none) size_t stringTableSize; // Size of string table unsigned parentNameEntry; // Position of parent name in string table (0 if top) time_t timeStamp; // The time stamp for this file. time_t parentTimeStamp; // The time stamp for the parent. void *originalBaseAddr; // Original base address (32-in-64 only) } SavedStateHeader; // Entry for segment table. This describes the segments on the disc that // need to be loaded into memory. typedef struct _savedStateSegmentDescr { off_t segmentData; // Position of the segment data size_t segmentSize; // Size of the segment data off_t relocations; // Position of the relocation table unsigned relocationCount; // Number of entries in relocation table unsigned relocationSize; // Size of a relocation entry unsigned segmentFlags; // Segment flags (see SSF_ values) unsigned segmentIndex; // The index of this segment or the segment it overwrites void *originalAddress; // The base address when the segment was written. } SavedStateSegmentDescr; #define SSF_WRITABLE 1 // The segment contains mutable data #define SSF_OVERWRITE 2 // The segment overwrites the data (mutable) in a parent. #define SSF_NOOVERWRITE 4 // The segment must not be further overwritten #define SSF_BYTES 8 // The segment contains only byte data #define SSF_CODE 16 // The segment contains only code typedef struct _relocationEntry { // Each entry indicates a location that has to be set to an address. // The location to be set is determined by adding "relocAddress" to the base address of // this segment (the one to which these relocations apply) and the value to store // by adding "targetAddress" to the base address of the segment indicated by "targetSegment". POLYUNSIGNED relocAddress; // The (byte) offset in this segment that we will set POLYUNSIGNED targetAddress; // The value to add to the base of the destination segment unsigned targetSegment; // The base segment. 0 is IO segment. ScanRelocationKind relKind; // The kind of relocation (processor dependent). } RelocationEntry; #define SAVE(x) taskData->saveVec.push(x) /* * Hierarchy table: contains information about last loaded or saved state. */ // Pointer to list of files loaded in last load. // There's no need for a lock since the update is only made when all // the ML threads have stopped. class HierarchyTable { public: HierarchyTable(const TCHAR *file, time_t time): fileName(_tcsdup(file)), timeStamp(time) { } AutoFree fileName; time_t timeStamp; }; HierarchyTable **hierarchyTable; static unsigned hierarchyDepth; static bool AddHierarchyEntry(const TCHAR *fileName, time_t timeStamp) { // Add an entry to the hierarchy table for this file. HierarchyTable *newEntry = new HierarchyTable(fileName, timeStamp); if (newEntry == 0) return false; HierarchyTable **newTable = (HierarchyTable **)realloc(hierarchyTable, sizeof(HierarchyTable *)*(hierarchyDepth+1)); if (newTable == 0) return false; hierarchyTable = newTable; hierarchyTable[hierarchyDepth++] = newEntry; return true; } // Test whether we're overwriting a parent of ourself. #if (defined(_WIN32) || defined(__CYGWIN__)) static bool sameFile(const TCHAR *x, const TCHAR *y) { HANDLE hXFile = INVALID_HANDLE_VALUE, hYFile = INVALID_HANDLE_VALUE; bool result = false; hXFile = CreateFile(x, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hXFile == INVALID_HANDLE_VALUE) goto closeAndExit; hYFile = CreateFile(y, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hYFile == INVALID_HANDLE_VALUE) goto closeAndExit; BY_HANDLE_FILE_INFORMATION fileInfoX, fileInfoY; if (! GetFileInformationByHandle(hXFile, &fileInfoX)) goto closeAndExit; if (! GetFileInformationByHandle(hYFile, &fileInfoY)) goto closeAndExit; result = fileInfoX.dwVolumeSerialNumber == fileInfoY.dwVolumeSerialNumber && fileInfoX.nFileIndexLow == fileInfoY.nFileIndexLow && fileInfoX.nFileIndexHigh == fileInfoY.nFileIndexHigh; closeAndExit: if (hXFile != INVALID_HANDLE_VALUE) CloseHandle(hXFile); if (hYFile != INVALID_HANDLE_VALUE) CloseHandle(hYFile); return result; } #else static bool sameFile(const char *x, const char *y) { struct stat xStat, yStat; // If either file does not exist that's fine. if (stat(x, &xStat) != 0 || stat(y, &yStat) != 0) return false; return (xStat.st_dev == yStat.st_dev && xStat.st_ino == yStat.st_ino); } #endif /* * Saving state. */ // This class is used to create the relocations. It uses Exporter // for this but this may perhaps be too heavyweight. class SaveStateExport: public Exporter, public ScanAddress { public: SaveStateExport(unsigned int h=0): Exporter(h), relocationCount(0) {} public: virtual void exportStore(void) {} // Not used. private: // ScanAddress overrides virtual void ScanConstant(PolyObject *base, byte *addrOfConst, ScanRelocationKind code, intptr_t displacement); // At the moment we should only get calls to ScanConstant. virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; } protected: void setRelocationAddress(void *p, POLYUNSIGNED *reloc); PolyWord createRelocation(PolyWord p, void *relocAddr); unsigned relocationCount; friend class SaveRequest; }; // Generate the address relative to the start of the segment. void SaveStateExport::setRelocationAddress(void *p, POLYUNSIGNED *reloc) { unsigned area = findArea(p); POLYUNSIGNED offset = (POLYUNSIGNED)((char*)p - (char*)memTable[area].mtOriginalAddr); *reloc = offset; } // Create a relocation entry for an address at a given location. PolyWord SaveStateExport::createRelocation(PolyWord p, void *relocAddr) { RelocationEntry reloc; // Set the offset within the section we're scanning. setRelocationAddress(relocAddr, &reloc.relocAddress); void *addr = p.AsAddress(); unsigned addrArea = findArea(addr); reloc.targetAddress = (POLYUNSIGNED)((char*)addr - (char*)memTable[addrArea].mtOriginalAddr); reloc.targetSegment = (unsigned)memTable[addrArea].mtIndex; reloc.relKind = PROCESS_RELOC_DIRECT; fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; return p; // Don't change the contents } /* This is called for each constant within the code. Print a relocation entry for the word and return a value that means that the offset is saved in original word. */ void SaveStateExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code, intptr_t displacement) { PolyObject *p = GetConstantValue(addr, code, displacement); if (p == 0) return; void *a = p; unsigned aArea = findArea(a); // We don't need a relocation if this is relative to the current segment // since the relative address will already be right. if (code == PROCESS_RELOC_I386RELATIVE && aArea == findArea(addr)) return; // Set the value at the address to the offset relative to the symbol. RelocationEntry reloc; setRelocationAddress(addr, &reloc.relocAddress); reloc.targetAddress = (POLYUNSIGNED)((char*)a - (char*)memTable[aArea].mtOriginalAddr); reloc.targetSegment = (unsigned)memTable[aArea].mtIndex; reloc.relKind = code; fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; } // Request to the main thread to save data. class SaveRequest: public MainThreadRequest { public: SaveRequest(const TCHAR *name, unsigned h): MainThreadRequest(MTP_SAVESTATE), fileName(name), newHierarchy(h), errorMessage(0), errCode(0) {} virtual void Perform(); const TCHAR *fileName; unsigned newHierarchy; const char *errorMessage; int errCode; }; // This class is used to update references to objects that have moved. If // we have copied an object into the area to be exported we may still have references // to it from the stack or from RTS data structures. We have to ensure that these // are updated. // This is very similar to ProcessFixupAddress in sharedata.cpp class SaveFixupAddress: public ScanAddress { protected: virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt); virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { *pt = ScanObjectAddress(*pt); return 0; } virtual PolyObject *ScanObjectAddress(PolyObject *base); public: void ScanCodeSpace(CodeSpace *space); }; POLYUNSIGNED SaveFixupAddress::ScanAddressAt(PolyWord *pt) { PolyWord val = *pt; if (val.IsDataPtr() && val != PolyWord::FromUnsigned(0)) *pt = ScanObjectAddress(val.AsObjPtr()); return 0; } // Returns the new address if the argument is the address of an object that // has moved, otherwise returns the original. PolyObject *SaveFixupAddress::ScanObjectAddress(PolyObject *obj) { if (obj->ContainsForwardingPtr()) // tombstone is a pointer to a moved object { #ifdef POLYML32IN64 MemSpace *space = gMem.SpaceForAddress((PolyWord*)obj - 1); PolyObject *newp; if (space->isCode) newp = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else newp = obj->GetForwardingPtr(); #else PolyObject *newp = obj->GetForwardingPtr(); #endif ASSERT (newp->ContainsNormalLengthWord()); return newp; } ASSERT (obj->ContainsNormalLengthWord()); // object is not moved return obj; } // Fix up addresses in the code area. Unlike ScanAddressesInRegion this updates // cells that have been moved. We need to do that because we may still have // return addresses into those cells and we don't move return addresses. We // do want the code to see updated constant addresses. void SaveFixupAddress::ScanCodeSpace(CodeSpace *space) { for (PolyWord *pt = space->bottom; pt < space->top; ) { pt++; PolyObject *obj = (PolyObject*)pt; #ifdef POLYML32IN64 PolyObject *dest = obj; while (dest->ContainsForwardingPtr()) { MemSpace *space = gMem.SpaceForObjectAddress(dest); if (space->isCode) dest = (PolyObject*)(globalCodeBase + ((dest->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else dest = dest->GetForwardingPtr(); } #else PolyObject *dest = obj->FollowForwardingChain(); #endif POLYUNSIGNED length = dest->Length(); if (length != 0) ScanAddressesInObject(obj, dest->LengthWord()); pt += length; } } // Called by the root thread to actually save the state and write the file. void SaveRequest::Perform() { if (debugOptions & DEBUG_SAVING) Log("SAVE: Beginning saving state.\n"); // Check that we aren't overwriting our own parent. for (unsigned q = 0; q < newHierarchy-1; q++) { if (sameFile(hierarchyTable[q]->fileName, fileName)) { errorMessage = "File being saved is used as a parent of this file"; errCode = 0; if (debugOptions & DEBUG_SAVING) Log("SAVE: File being saved is used as a parent of this file.\n"); return; } } SaveStateExport exports; // Open the file. This could quite reasonably fail if the path is wrong. exports.exportFile = _tfopen(fileName, _T("wb")); if (exports.exportFile == NULL) { errorMessage = "Cannot open save file"; errCode = ERRORNUMBER; if (debugOptions & DEBUG_SAVING) Log("SAVE: Cannot open save file.\n"); return; } // Scan over the permanent mutable area copying all reachable data that is // not in a lower hierarchy into new permanent segments. CopyScan copyScan(newHierarchy); copyScan.initialise(false); bool success = true; try { for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->isMutable && !space->noOverwrite && !space->byteOnly) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Scanning permanent mutable area %p allocated at %p size %lu\n", space, space->bottom, space->spaceSize()); copyScan.ScanAddressesInRegion(space->bottom, space->top); } } } catch (MemoryException &) { success = false; if (debugOptions & DEBUG_SAVING) Log("SAVE: Scan of permanent mutable area raised memory exception.\n"); } // Copy the areas into the export object. Make sufficient space for // the largest possible number of entries. exports.memTable = new memoryTableEntry[gMem.eSpaces.size()+gMem.pSpaces.size()+1]; unsigned memTableCount = 0; // Permanent spaces at higher level. These have to have entries although // only the mutable entries will be written. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->hierarchy < newHierarchy) { memoryTableEntry *entry = &exports.memTable[memTableCount++]; entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom; entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord); entry->mtIndex = space->index; entry->mtFlags = 0; if (space->isMutable) { entry->mtFlags |= MTF_WRITEABLE; if (space->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE; if (space->byteOnly) entry->mtFlags |= MTF_BYTES; } if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; } } unsigned permanentEntries = memTableCount; // Remember where new entries start. // Newly created spaces. for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { memoryTableEntry *entry = &exports.memTable[memTableCount++]; PermanentMemSpace *space = *i; entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom; entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord); entry->mtIndex = space->index; entry->mtFlags = 0; if (space->isMutable) { entry->mtFlags |= MTF_WRITEABLE; if (space->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE; if (space->byteOnly) entry->mtFlags |= MTF_BYTES; } if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; } exports.memTableEntries = memTableCount; if (debugOptions & DEBUG_SAVING) Log("SAVE: Updating references to moved objects.\n"); // Update references to moved objects. SaveFixupAddress fixup; for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; fixup.ScanAddressesInRegion(space->bottom, space->lowerAllocPtr); fixup.ScanAddressesInRegion(space->upperAllocPtr, space->top); } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) fixup.ScanCodeSpace(*i); GCModules(&fixup); // Restore the length words in the code areas. // Although we've updated any pointers to the start of the code we could have return addresses // pointing to the original code. GCModules updates the stack but doesn't update return addresses. for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; for (PolyWord *pt = space->bottom; pt < space->top; ) { pt++; PolyObject *obj = (PolyObject*)pt; if (obj->ContainsForwardingPtr()) { #ifdef POLYML32IN64 PolyObject *forwardedTo = obj; while (forwardedTo->ContainsForwardingPtr()) forwardedTo = (PolyObject*)(globalCodeBase + ((forwardedTo->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); #else PolyObject *forwardedTo = obj->FollowForwardingChain(); #endif POLYUNSIGNED lengthWord = forwardedTo->LengthWord(); space->writeAble(obj)->SetLengthWord(lengthWord); } pt += obj->Length(); } } // Update the global memory space table. Old segments at the same level // or lower are removed. The new segments become permanent. // Try to promote the spaces even if we've had a failure because export // spaces are deleted in ~CopyScan and we may have already copied // some objects there. if (debugOptions & DEBUG_SAVING) Log("SAVE: Promoting export spaces to permanent spaces.\n"); if (! gMem.PromoteExportSpaces(newHierarchy) || ! success) { errorMessage = "Out of Memory"; errCode = NOMEMORY; if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to promote export spaces.\n"); return; } // Remove any deeper entries from the hierarchy table. while (hierarchyDepth > newHierarchy-1) { hierarchyDepth--; delete(hierarchyTable[hierarchyDepth]); hierarchyTable[hierarchyDepth] = 0; } if (debugOptions & DEBUG_SAVING) Log("SAVE: Writing out data.\n"); // Write out the file header. SavedStateHeader saveHeader; memset(&saveHeader, 0, sizeof(saveHeader)); saveHeader.headerLength = sizeof(saveHeader); memcpy(saveHeader.headerSignature, SAVEDSTATESIGNATURE, sizeof(saveHeader.headerSignature)); saveHeader.headerVersion = SAVEDSTATEVERSION; saveHeader.segmentDescrLength = sizeof(SavedStateSegmentDescr); if (newHierarchy == 1) saveHeader.parentTimeStamp = exportTimeStamp; else { saveHeader.parentTimeStamp = hierarchyTable[newHierarchy-2]->timeStamp; saveHeader.parentNameEntry = sizeof(TCHAR); // Always the first entry. } saveHeader.timeStamp = getBuildTime(); saveHeader.segmentDescrCount = exports.memTableEntries; // One segment for each space. #ifdef POLYML32IN64 saveHeader.originalBaseAddr = globalHeapBase; #endif // Write out the header. fwrite(&saveHeader, sizeof(saveHeader), 1, exports.exportFile); // We need a segment header for each permanent area whether it is // actually in this file or not. SavedStateSegmentDescr *descrs = new SavedStateSegmentDescr [exports.memTableEntries]; for (unsigned j = 0; j < exports.memTableEntries; j++) { memoryTableEntry *entry = &exports.memTable[j]; memset(&descrs[j], 0, sizeof(SavedStateSegmentDescr)); descrs[j].relocationSize = sizeof(RelocationEntry); descrs[j].segmentIndex = (unsigned)entry->mtIndex; descrs[j].segmentSize = entry->mtLength; // Set this even if we don't write it. descrs[j].originalAddress = entry->mtOriginalAddr; if (entry->mtFlags & MTF_WRITEABLE) { descrs[j].segmentFlags |= SSF_WRITABLE; if (entry->mtFlags & MTF_NO_OVERWRITE) descrs[j].segmentFlags |= SSF_NOOVERWRITE; if (j < permanentEntries && (entry->mtFlags & MTF_NO_OVERWRITE) == 0) descrs[j].segmentFlags |= SSF_OVERWRITE; if (entry->mtFlags & MTF_BYTES) descrs[j].segmentFlags |= SSF_BYTES; } if (entry->mtFlags & MTF_EXECUTABLE) descrs[j].segmentFlags |= SSF_CODE; } // Write out temporarily. Will be overwritten at the end. saveHeader.segmentDescr = ftell(exports.exportFile); fwrite(descrs, sizeof(SavedStateSegmentDescr), exports.memTableEntries, exports.exportFile); // Write out the relocations and the data. for (unsigned k = 1 /* Not IO area */; k < exports.memTableEntries; k++) { memoryTableEntry *entry = &exports.memTable[k]; // Write out the contents if this is new or if it is a normal, overwritable // mutable area. if (k >= permanentEntries || (entry->mtFlags & (MTF_WRITEABLE|MTF_NO_OVERWRITE)) == MTF_WRITEABLE) { descrs[k].relocations = ftell(exports.exportFile); // Have to write this out. exports.relocationCount = 0; // Create the relocation table. char *start = (char*)entry->mtOriginalAddr; char *end = start + entry->mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); // Most relocations can be computed when the saved state is // loaded so we only write out the difficult ones: those that // occur within compiled code. // exports.relocateObject(obj); if (length != 0 && obj->IsCodeObject()) machineDependent->ScanConstantsWithinCode(obj, &exports); p += length; } descrs[k].relocationCount = exports.relocationCount; // Write out the data. descrs[k].segmentData = ftell(exports.exportFile); fwrite(entry->mtOriginalAddr, entry->mtLength, 1, exports.exportFile); } } // If this is a child we need to write a string table containing the parent name. if (newHierarchy > 1) { saveHeader.stringTable = ftell(exports.exportFile); _fputtc(0, exports.exportFile); // First byte of string table is zero _fputts(hierarchyTable[newHierarchy-2]->fileName, exports.exportFile); _fputtc(0, exports.exportFile); // A terminating null. saveHeader.stringTableSize = (_tcslen(hierarchyTable[newHierarchy-2]->fileName) + 2)*sizeof(TCHAR); } // Rewrite the header and the segment tables now they're complete. fseek(exports.exportFile, 0, SEEK_SET); fwrite(&saveHeader, sizeof(saveHeader), 1, exports.exportFile); fwrite(descrs, sizeof(SavedStateSegmentDescr), exports.memTableEntries, exports.exportFile); if (debugOptions & DEBUG_SAVING) Log("SAVE: Writing complete.\n"); // Add an entry to the hierarchy table for this file. (void)AddHierarchyEntry(fileName, saveHeader.timeStamp); delete[](descrs); CheckMemory(); } // Write a saved state file. -POLYUNSIGNED PolySaveState(FirstArgument threadId, PolyWord fileName, PolyWord depth) +POLYUNSIGNED PolySaveState(POLYUNSIGNED threadId, POLYUNSIGNED fileName, POLYUNSIGNED depth) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - TempString fileNameBuff(Poly_string_to_T_alloc(fileName)); + TempString fileNameBuff(Poly_string_to_T_alloc(PolyWord::FromUnsigned(fileName))); // The value of depth is zero for top-level save so we need to add one for hierarchy. - unsigned newHierarchy = get_C_unsigned(taskData, depth) + 1; + unsigned newHierarchy = get_C_unsigned(taskData, PolyWord::FromUnsigned(depth)) + 1; if (newHierarchy > hierarchyDepth + 1) raise_fail(taskData, "Depth must be no more than the current hierarchy plus one"); // Request a full GC first. The main reason is to avoid running out of memory as a // result of repeated saves. Old export spaces are turned into local spaces and // the GC will delete them if they are completely empty FullGC(taskData); SaveRequest request(fileNameBuff, newHierarchy); processes->MakeRootRequest(taskData, &request); if (request.errorMessage) raise_syscall(taskData, request.errorMessage, request.errCode); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* * Loading saved state files. */ class StateLoader: public MainThreadRequest { public: StateLoader(bool isH, Handle files): MainThreadRequest(MTP_LOADSTATE), isHierarchy(isH), fileNameList(files), errorResult(0), errNumber(0) { } virtual void Perform(void); bool LoadFile(bool isInitial, time_t requiredStamp, PolyWord tail); bool isHierarchy; Handle fileNameList; const char *errorResult; // The fileName here is the last file loaded. As well as using it // to load the name can also be printed out at the end to identify the // particular file in the hierarchy that failed. AutoFree fileName; int errNumber; }; // Called by the main thread once all the ML threads have stopped. void StateLoader::Perform(void) { // Copy the first file name into the buffer. if (isHierarchy) { if (ML_Cons_Cell::IsNull(fileNameList->Word())) { errorResult = "Hierarchy list is empty"; return; } ML_Cons_Cell *p = DEREFLISTHANDLE(fileNameList); fileName = Poly_string_to_T_alloc(p->h); if (fileName == NULL) { errorResult = "Insufficient memory"; errNumber = NOMEMORY; return; } (void)LoadFile(true, 0, p->t); } else { fileName = Poly_string_to_T_alloc(fileNameList->Word()); if (fileName == NULL) { errorResult = "Insufficient memory"; errNumber = NOMEMORY; return; } (void)LoadFile(true, 0, TAGGED(0)); } } class ClearVolatile: public ScanAddress { public: ClearVolatile() {} virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; } virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord); }; // Set the values of external references and clear the values of other weak byte refs. void ClearVolatile::ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord) { if (OBJ_IS_MUTABLE_OBJECT(lengthWord) && OBJ_IS_NO_OVERWRITE(lengthWord)) { if (OBJ_IS_BYTE_OBJECT(lengthWord)) { if (OBJ_IS_WEAKREF_OBJECT(lengthWord)) { POLYUNSIGNED len = OBJ_OBJECT_LENGTH(lengthWord); if (len >= sizeof(uintptr_t) / sizeof(PolyWord)) *((uintptr_t*)base) = 0; setEntryPoint(base); } } else { // Clear volatile refs POLYUNSIGNED len = OBJ_OBJECT_LENGTH(lengthWord); for (POLYUNSIGNED i = 0; i < len; i++) base->Set(i, TAGGED(0)); } } } // This is copied from the B-tree in MemMgr. It probably should be // merged but will do for the moment. It's intended to reduce the // cost of finding the segment for relocation. class SpaceBTree { public: SpaceBTree(bool is, unsigned i = 0) : isLeaf(is), index(i) { } virtual ~SpaceBTree() {} bool isLeaf; unsigned index; // The index if this is a leaf }; // A non-leaf node in the B-tree class SpaceBTreeTree : public SpaceBTree { public: SpaceBTreeTree(); virtual ~SpaceBTreeTree(); SpaceBTree *tree[256]; }; SpaceBTreeTree::SpaceBTreeTree() : SpaceBTree(false) { for (unsigned i = 0; i < 256; i++) tree[i] = 0; } SpaceBTreeTree::~SpaceBTreeTree() { for (unsigned i = 0; i < 256; i++) delete(tree[i]); } // This class is used to relocate addresses in areas that have been loaded. class LoadRelocate: public ScanAddress { public: LoadRelocate(bool pcc = false): processCodeConstants(pcc), originalBaseAddr(0), descrs(0), targetAddresses(0), nDescrs(0), spaceTree(0) {} ~LoadRelocate(); void RelocateObject(PolyObject *p); virtual PolyObject *ScanObjectAddress(PolyObject *base) { ASSERT(0); return base; } // Not used virtual void ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code, intptr_t displacement); void RelocateAddressAt(PolyWord *pt); PolyObject *RelocateAddress(PolyObject *obj); void AddTreeRange(SpaceBTree **t, unsigned index, uintptr_t startS, uintptr_t endS); bool processCodeConstants; PolyWord *originalBaseAddr; SavedStateSegmentDescr *descrs; PolyWord **targetAddresses; unsigned nDescrs; SpaceBTree *spaceTree; intptr_t relativeOffset; }; LoadRelocate::~LoadRelocate() { if (descrs) delete[](descrs); if (targetAddresses) delete[](targetAddresses); delete(spaceTree); } // Add an entry to the space B-tree. void LoadRelocate::AddTreeRange(SpaceBTree **tt, unsigned index, uintptr_t startS, uintptr_t endS) { if (*tt == 0) *tt = new SpaceBTreeTree; ASSERT(!(*tt)->isLeaf); SpaceBTreeTree *t = (SpaceBTreeTree*)*tt; const unsigned shift = (sizeof(void*) - 1) * 8; // Takes the high-order byte uintptr_t r = startS >> shift; ASSERT(r < 256); const uintptr_t s = endS == 0 ? 256 : endS >> shift; ASSERT(s >= r && s <= 256); if (r == s) // Wholly within this entry AddTreeRange(&(t->tree[r]), index, startS << 8, endS << 8); else { // Deal with any remainder at the start. if ((r << shift) != startS) { AddTreeRange(&(t->tree[r]), index, startS << 8, 0 /*End of range*/); r++; } // Whole entries. while (r < s) { ASSERT(t->tree[r] == 0); t->tree[r] = new SpaceBTree(true, index); r++; } // Remainder at the end. if ((s << shift) != endS) AddTreeRange(&(t->tree[r]), index, 0, endS << 8); } } // Update the addresses in a group of words. void LoadRelocate::RelocateAddressAt(PolyWord *pt) { PolyWord val = *pt; if (! val.IsTagged()) *gMem.SpaceForAddress(pt)->writeAble(pt) = RelocateAddress(val.AsObjPtr(originalBaseAddr)); } PolyObject *LoadRelocate::RelocateAddress(PolyObject *obj) { // Which segment is this address in? // N.B. As with SpaceForAddress we need to subtract 1 to point to the length word. uintptr_t t = (uintptr_t)((PolyWord*)obj - 1); SpaceBTree *tr = spaceTree; // Each level of the tree is either a leaf or a vector of trees. unsigned j = sizeof(void *) * 8; for (;;) { if (tr == 0) break; if (tr->isLeaf) { // It's in this segment: relocate it to the current position. unsigned i = tr->index; SavedStateSegmentDescr *descr = &descrs[i]; PolyWord *newAddress = targetAddresses[descr->segmentIndex]; ASSERT((char*)obj > descr->originalAddress && (char*)obj <= (char*)descr->originalAddress + descr->segmentSize); ASSERT(newAddress != 0); byte *setAddress = (byte*)newAddress + ((char*)obj - (char*)descr->originalAddress); return (PolyObject*)setAddress; } j -= 8; tr = ((SpaceBTreeTree*)tr)->tree[(t >> j) & 0xff]; } // This should never happen. ASSERT(0); return 0; } // This is based on Exporter::relocateObject but does the reverse. // It attempts to adjust all the addresses in the object when it has // been read in. void LoadRelocate::RelocateObject(PolyObject *p) { if (p->IsByteObject()) { } else if (p->IsCodeObject()) { POLYUNSIGNED constCount; PolyWord *cp; ASSERT(! p->IsMutable() ); machineDependent->GetConstSegmentForCode(p, cp, constCount); /* Now the constant area. */ for (POLYUNSIGNED i = 0; i < constCount; i++) RelocateAddressAt(&(cp[i])); // Saved states and modules have relocation entries for constants in the code. // We can't use them when loading object files in 32-in-64 so have to process the // constants here. if (processCodeConstants) machineDependent->ScanConstantsWithinCode(p, this); // On 32-in-64 ARM we may have to update the global heap base in an FFI callback. machineDependent->UpdateGlobalHeapReference(p); } else if (p->IsClosureObject()) { // The first word is the address of the code. POLYUNSIGNED length = p->Length(); *(PolyObject**)p = RelocateAddress(*(PolyObject**)p); for (POLYUNSIGNED i = sizeof(PolyObject*)/sizeof(PolyWord); i < length; i++) RelocateAddressAt(p->Offset(i)); } else /* Ordinary objects, essentially tuples. */ { POLYUNSIGNED length = p->Length(); for (POLYUNSIGNED i = 0; i < length; i++) RelocateAddressAt(p->Offset(i)); } } // Update addresses as constants within the code. void LoadRelocate::ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code, intptr_t displacement) { PolyObject *p = GetConstantValue(addressOfConstant, code, displacement); if (p != 0) { // Relative addresses are computed by adding the CURRENT address. // We have to convert them into addresses in original space before we // can relocate them. if (code == PROCESS_RELOC_I386RELATIVE) p = (PolyObject*)((PolyWord*)p + relativeOffset); PolyObject *newValue = RelocateAddress(p); SetConstantValue(addressOfConstant, newValue, code); } } // Work around bug in Mac OS when reading into MAP_JIT memory. static size_t readData(void *ptr, size_t size, FILE *stream) { #ifndef MACOSX return fread(ptr, size, 1, stream); #else char buff[1024]; for (size_t s = 0; s < size; ) { size_t unit = sizeof(buff); if (size - s < unit) unit = size-s; if (fread(buff, unit, 1, stream) != 1) return 0; memcpy((char*)ptr+s, buff, unit); s += unit; } return 1; // Succeeded #endif } // Load a saved state file. Calls itself to handle parent files. bool StateLoader::LoadFile(bool isInitial, time_t requiredStamp, PolyWord tail) { LoadRelocate relocate; AutoFree thisFile(_tcsdup(fileName)); AutoClose loadFile(_tfopen(fileName, _T("rb"))); if ((FILE*)loadFile == NULL) { errorResult = "Cannot open load file"; errNumber = ERRORNUMBER; return false; } SavedStateHeader header; // Read the header and check the signature. if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1) { errorResult = "Unable to load header"; return false; } if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0) { errorResult = "File is not a saved state"; return false; } if (header.headerVersion != SAVEDSTATEVERSION || header.headerLength != sizeof(SavedStateHeader) || header.segmentDescrLength != sizeof(SavedStateSegmentDescr)) { errorResult = "Unsupported version of saved state file"; return false; } // Check that we have the required stamp before loading any children. // If a parent has been overwritten we could get a loop. if (! isInitial && header.timeStamp != requiredStamp) { // Time-stamps don't match. errorResult = "The parent for this saved state does not match or has been changed"; return false; } // Have verified that this is a reasonable saved state file. If it isn't a // top-level file we have to load the parents first. if (header.parentNameEntry != 0) { if (isHierarchy) { // Take the file name from the list if (ML_Cons_Cell::IsNull(tail)) { errorResult = "Missing parent name in argument list"; return false; } ML_Cons_Cell *p = (ML_Cons_Cell *)tail.AsObjPtr(); fileName = Poly_string_to_T_alloc(p->h); if (fileName == NULL) { errorResult = "Insufficient memory"; errNumber = NOMEMORY; return false; } if (! LoadFile(false, header.parentTimeStamp, p->t)) return false; } else { size_t toRead = header.stringTableSize-header.parentNameEntry; size_t elems = ((toRead + sizeof(TCHAR) - 1) / sizeof(TCHAR)); // Always allow space for null terminator size_t roundedBytes = (elems + 1) * sizeof(TCHAR); TCHAR *newFileName = (TCHAR *)realloc(fileName, roundedBytes); if (newFileName == NULL) { errorResult = "Insufficient memory"; errNumber = NOMEMORY; return false; } fileName = newFileName; if (header.parentNameEntry >= header.stringTableSize /* Bad entry */ || fseek(loadFile, header.stringTable + header.parentNameEntry, SEEK_SET) != 0 || fread(fileName, 1, toRead, loadFile) != toRead) { errorResult = "Unable to read parent file name"; return false; } fileName[elems] = 0; // Should already be null-terminated, but just in case. if (! LoadFile(false, header.parentTimeStamp, TAGGED(0))) return false; } ASSERT(hierarchyDepth > 0 && hierarchyTable[hierarchyDepth-1] != 0); } else // Top-level file { if (isHierarchy && ! ML_Cons_Cell::IsNull(tail)) { // There should be no further file names if this is really the top. errorResult = "Too many file names in the list"; return false; } if (header.parentTimeStamp != exportTimeStamp) { // Time-stamp does not match executable. errorResult = "Saved state was exported from a different executable or the executable has changed"; return false; } // Any existing spaces at this level or greater must be turned // into local spaces. We may have references from the stack to objects that // have previously been imported but otherwise these spaces are no longer // needed. gMem.DemoteImportSpaces(); // Clean out the hierarchy table. for (unsigned h = 0; h < hierarchyDepth; h++) { delete(hierarchyTable[h]); hierarchyTable[h] = 0; } hierarchyDepth = 0; } // Now have a valid, matching saved state. // Load the segment descriptors. relocate.nDescrs = header.segmentDescrCount; relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs]; relocate.originalBaseAddr = (PolyWord*)header.originalBaseAddr; if (fseek(loadFile, header.segmentDescr, SEEK_SET) != 0 || fread(relocate.descrs, sizeof(SavedStateSegmentDescr), relocate.nDescrs, loadFile) != relocate.nDescrs) { errorResult = "Unable to read segment descriptors"; return false; } { unsigned maxIndex = 0; for (unsigned i = 0; i < relocate.nDescrs; i++) { if (relocate.descrs[i].segmentIndex > maxIndex) maxIndex = relocate.descrs[i].segmentIndex; relocate.AddTreeRange(&relocate.spaceTree, i, (uintptr_t)relocate.descrs[i].originalAddress, (uintptr_t)((char*)relocate.descrs[i].originalAddress + relocate.descrs[i].segmentSize-1)); } relocate.targetAddresses = new PolyWord*[maxIndex+1]; for (unsigned i = 0; i <= maxIndex; i++) relocate.targetAddresses[i] = 0; } // Read in and create the new segments first. If we have problems, // in particular if we have run out of memory, then it's easier to recover. for (unsigned i = 0; i < relocate.nDescrs; i++) { SavedStateSegmentDescr *descr = &relocate.descrs[i]; MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); if (space != NULL) relocate.targetAddresses[descr->segmentIndex] = space->bottom; if (descr->segmentData == 0) { // No data - just an entry in the index. if (space == NULL/* || descr->segmentSize != (size_t)((char*)space->top - (char*)space->bottom)*/) { errorResult = "Mismatch for existing memory space"; return false; } } else if ((descr->segmentFlags & SSF_OVERWRITE) == 0) { // New segment. if (space != NULL) { errorResult = "Segment already exists"; return false; } // Allocate memory for the new segment. unsigned mFlags = (descr->segmentFlags & SSF_WRITABLE ? MTF_WRITEABLE : 0) | (descr->segmentFlags & SSF_NOOVERWRITE ? MTF_NO_OVERWRITE : 0) | (descr->segmentFlags & SSF_BYTES ? MTF_BYTES : 0) | (descr->segmentFlags & SSF_CODE ? MTF_EXECUTABLE : 0); PermanentMemSpace *newSpace = gMem.AllocateNewPermanentSpace(descr->segmentSize, mFlags, descr->segmentIndex, hierarchyDepth + 1); if (newSpace == 0) { errorResult = "Unable to allocate memory"; return false; } PolyWord *mem = newSpace->bottom; PolyWord* writeAble = newSpace->writeAble(mem); if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0) { errorResult = "Unable to seek segment"; return false; } if (readData(writeAble, descr->segmentSize, loadFile) != 1) { errorResult = "Unable to read segment"; return false; } // Fill unused space to the top of the area. gMem.FillUnusedSpace(writeAble +descr->segmentSize/sizeof(PolyWord), newSpace->spaceSize() - descr->segmentSize/sizeof(PolyWord)); // Leave it writable until we've done the relocations. relocate.targetAddresses[descr->segmentIndex] = mem; if (newSpace->noOverwrite) { ClearVolatile cwbr; cwbr.ScanAddressesInRegion(newSpace->bottom, newSpace->topPointer); } } } // Now read in the mutable overwrites and relocate. for (unsigned j = 0; j < relocate.nDescrs; j++) { SavedStateSegmentDescr *descr = &relocate.descrs[j]; MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); ASSERT(space != NULL); // We should have created it. if (descr->segmentFlags & SSF_OVERWRITE) { if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0 || fread(space->bottom, descr->segmentSize, 1, loadFile) != 1) { errorResult = "Unable to read segment"; return false; } } // Relocation. if (descr->segmentData != 0) { // Adjust the addresses in the loaded segment. for (PolyWord *p = space->bottom; p < space->top; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); relocate.RelocateObject(obj); p += length; } } // Process explicit relocations. // If we get errors just skip the error and continue rather than leave // everything in an unstable state. if (descr->relocations) { if (fseek(loadFile, descr->relocations, SEEK_SET) != 0) { errorResult = "Unable to read relocation segment"; return false; } for (unsigned k = 0; k < descr->relocationCount; k++) { RelocationEntry reloc; if (fread(&reloc, sizeof(reloc), 1, loadFile) != 1) { errorResult = "Unable to read relocation segment"; return false; } MemSpace *toSpace = gMem.SpaceForIndex(reloc.targetSegment); if (toSpace == NULL) { errorResult = "Unknown space reference in relocation"; continue; } byte *setAddress = (byte*)space->bottom + reloc.relocAddress; byte *targetAddress = (byte*)toSpace->bottom + reloc.targetAddress; if (setAddress >= (byte*)space->top || targetAddress >= (byte*)toSpace->top) { errorResult = "Bad relocation"; continue; } ScanAddress::SetConstantValue(setAddress, (PolyObject*)(targetAddress), reloc.relKind); } } } // Set the final permissions. for (unsigned j = 0; j < relocate.nDescrs; j++) { SavedStateSegmentDescr *descr = &relocate.descrs[j]; if (descr->segmentData != 0) { PermanentMemSpace* space = gMem.SpaceForIndex(descr->segmentIndex); gMem.CompletePermanentSpaceAllocation(space); } } // Add an entry to the hierarchy table for this file. if (! AddHierarchyEntry(thisFile, header.timeStamp)) return false; return true; // Succeeded } static void LoadState(TaskData *taskData, bool isHierarchy, Handle hFileList) // Load a saved state or a hierarchy. // hFileList is a list if this is a hierarchy and a single name if it is not. { StateLoader loader(isHierarchy, hFileList); // Request the main thread to do the load. This may set the error string if it failed. processes->MakeRootRequest(taskData, &loader); if (loader.errorResult != 0) { if (loader.errNumber == 0) raise_fail(taskData, loader.errorResult); else { AutoFree buff((char *)malloc(strlen(loader.errorResult) + 2 + _tcslen(loader.fileName) * sizeof(TCHAR) + 1)); #if (defined(_WIN32) && defined(UNICODE)) sprintf(buff, "%s: %S", loader.errorResult, (TCHAR *)loader.fileName); #else sprintf(buff, "%s: %s", loader.errorResult, (TCHAR *)loader.fileName); #endif raise_syscall(taskData, buff, loader.errNumber); } } } // Load a saved state file and any ancestors. -POLYUNSIGNED PolyLoadState(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyLoadState(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { LoadState(taskData, false, pushedArg); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Load hierarchy. This provides a complete list of children and parents. -POLYUNSIGNED PolyLoadHierarchy(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyLoadHierarchy(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { LoadState(taskData, true, pushedArg); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } /* * Additional functions to provide information or change saved-state files. */ // These functions do not affect the global state so can be executed by // the ML threads directly. static Handle ShowHierarchy(TaskData *taskData) // Return the list of files in the hierarchy. { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); // Process this in reverse order. for (unsigned i = hierarchyDepth; i > 0; i--) { Handle value = SAVE(C_string_to_Poly(taskData, hierarchyTable[i-1]->fileName)); Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell)/sizeof(PolyWord)); DEREFLISTHANDLE(next)->h = value->Word(); DEREFLISTHANDLE(next)->t = list->Word(); taskData->saveVec.reset(saved); list = SAVE(next->Word()); } return list; } // Show the hierarchy. -POLYUNSIGNED PolyShowHierarchy(FirstArgument threadId) +POLYUNSIGNED PolyShowHierarchy(POLYUNSIGNED threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = ShowHierarchy(taskData); } 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(); } static void RenameParent(TaskData *taskData, PolyWord childName, PolyWord parentName) // Change the name of the immediate parent stored in a child { // The name of the file to modify. AutoFree fileNameBuff(Poly_string_to_T_alloc(childName)); if (fileNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // The new parent name to insert. AutoFree parentNameBuff(Poly_string_to_T_alloc(parentName)); if (parentNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); AutoClose loadFile(_tfopen(fileNameBuff, _T("r+b"))); // Open for reading and writing if ((FILE*)loadFile == NULL) { AutoFree buff((char *)malloc(23 + _tcslen(fileNameBuff) * sizeof(TCHAR) + 1)); #if (defined(_WIN32) && defined(UNICODE)) sprintf(buff, "Cannot open load file: %S", (TCHAR *)fileNameBuff); #else sprintf(buff, "Cannot open load file: %s", (TCHAR *)fileNameBuff); #endif raise_syscall(taskData, buff, ERRORNUMBER); } SavedStateHeader header; // Read the header and check the signature. if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1) raise_fail(taskData, "Unable to load header"); if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0) raise_fail(taskData, "File is not a saved state"); if (header.headerVersion != SAVEDSTATEVERSION || header.headerLength != sizeof(SavedStateHeader) || header.segmentDescrLength != sizeof(SavedStateSegmentDescr)) { raise_fail(taskData, "Unsupported version of saved state file"); } // Does this actually have a parent? if (header.parentNameEntry == 0) raise_fail(taskData, "File does not have a parent"); // At the moment the only entry in the string table is the parent // name so we can simply write a new one on the end of the file. // This makes the file grow slightly each time but it shouldn't be // significant. fseek(loadFile, 0, SEEK_END); header.stringTable = ftell(loadFile); // Remember where this is _fputtc(0, loadFile); // First byte of string table is zero _fputts(parentNameBuff, loadFile); _fputtc(0, loadFile); // A terminating null. header.stringTableSize = (_tcslen(parentNameBuff) + 2)*sizeof(TCHAR); // Now rewind and write the header with the revised string table. fseek(loadFile, 0, SEEK_SET); fwrite(&header, sizeof(header), 1, loadFile); } -POLYUNSIGNED PolyRenameParent(FirstArgument threadId, PolyWord childName, PolyWord parentName) +POLYUNSIGNED PolyRenameParent(POLYUNSIGNED threadId, POLYUNSIGNED childName, POLYUNSIGNED parentName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - RenameParent(taskData, childName, parentName); + RenameParent(taskData, PolyWord::FromUnsigned(childName), PolyWord::FromUnsigned(parentName)); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } static Handle ShowParent(TaskData *taskData, Handle hFileName) // Return the name of the immediate parent stored in a child { AutoFree fileNameBuff(Poly_string_to_T_alloc(hFileName->Word())); if (fileNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); AutoClose loadFile(_tfopen(fileNameBuff, _T("rb"))); if ((FILE*)loadFile == NULL) { AutoFree buff((char *)malloc(23 + _tcslen(fileNameBuff) * sizeof(TCHAR) + 1)); if (buff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); #if (defined(_WIN32) && defined(UNICODE)) sprintf(buff, "Cannot open load file: %S", (TCHAR *)fileNameBuff); #else sprintf(buff, "Cannot open load file: %s", (TCHAR *)fileNameBuff); #endif raise_syscall(taskData, buff, ERRORNUMBER); } SavedStateHeader header; // Read the header and check the signature. if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1) raise_fail(taskData, "Unable to load header"); if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0) raise_fail(taskData, "File is not a saved state"); if (header.headerVersion != SAVEDSTATEVERSION || header.headerLength != sizeof(SavedStateHeader) || header.segmentDescrLength != sizeof(SavedStateSegmentDescr)) { raise_fail(taskData, "Unsupported version of saved state file"); } // Does this have a parent? if (header.parentNameEntry != 0) { size_t toRead = header.stringTableSize-header.parentNameEntry; size_t elems = ((toRead + sizeof(TCHAR) - 1) / sizeof(TCHAR)); // Always allow space for null terminator size_t roundedBytes = (elems + 1) * sizeof(TCHAR); AutoFree parentFileName((TCHAR *)malloc(roundedBytes)); if (parentFileName == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (header.parentNameEntry >= header.stringTableSize /* Bad entry */ || fseek(loadFile, header.stringTable + header.parentNameEntry, SEEK_SET) != 0 || fread(parentFileName, 1, toRead, loadFile) != toRead) { raise_fail(taskData, "Unable to read parent file name"); } parentFileName[elems] = 0; // Should already be null-terminated, but just in case. // Convert the name into a Poly string and then build a "Some" value. // It's possible, although silly, to have the empty string as a parent name. Handle resVal = SAVE(C_string_to_Poly(taskData, parentFileName)); Handle result = alloc_and_save(taskData, 1); DEREFHANDLE(result)->Set(0, resVal->Word()); return result; } else return SAVE(NONE_VALUE); } // Return the name of the immediate parent stored in a child -POLYUNSIGNED PolyShowParent(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyShowParent(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = ShowParent(taskData, pushedArg); } 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(); } // Module system #define MODULESIGNATURE "POLYMODU" #define MODULEVERSION 2 typedef struct _moduleHeader { // These entries are primarily to check that we have a valid // saved state file before we try to interpret anything else. char headerSignature[8]; // Should contain MODULESIGNATURE unsigned headerVersion; // Should contain MODULEVERSION unsigned headerLength; // Number of bytes in the header unsigned segmentDescrLength; // Number of bytes in a descriptor // These entries contain the real data. off_t segmentDescr; // Position of segment descriptor table unsigned segmentDescrCount; // Number of segment descriptors in the table time_t timeStamp; // The time stamp for this file. time_t executableTimeStamp; // The time stamp for the parent executable. // Root uintptr_t rootSegment; POLYUNSIGNED rootOffset; } ModuleHeader; // Store a module class ModuleStorer: public MainThreadRequest { public: ModuleStorer(const TCHAR *file, Handle r): MainThreadRequest(MTP_STOREMODULE), fileName(file), root(r), errorMessage(0), errCode(0) {} virtual void Perform(); const TCHAR *fileName; Handle root; const char *errorMessage; int errCode; }; class ModuleExport: public SaveStateExport { public: ModuleExport(): SaveStateExport(1/* Everything EXCEPT the executable. */) {} virtual void exportStore(void); // Write the data out. }; void ModuleStorer::Perform() { ModuleExport exporter; #if (defined(_WIN32) && defined(UNICODE)) exporter.exportFile = _wfopen(fileName, L"wb"); #else exporter.exportFile = fopen(fileName, "wb"); #endif if (exporter.exportFile == NULL) { errorMessage = "Cannot open export file"; errCode = ERRORNUMBER; return; } // RunExport copies everything reachable from the root, except data from // the executable because we've set the hierarchy to 1, using CopyScan. // It builds the tables in the export data structure then calls exportStore // to actually write the data. if (! root->Word().IsDataPtr()) { // If we have a completely empty module the list may be null. // This needs to be dealt with at a higher level. errorMessage = "Module root is not an address"; return; } exporter.RunExport(root->WordP()); errorMessage = exporter.errorMessage; // This will be null unless there's been an error. } void ModuleExport::exportStore(void) { // What we need to do here is implement the export in a similar way to e.g. PECOFFExport::exportStore // This is copied from SaveRequest::Perform and should be common code. ModuleHeader modHeader; memset(&modHeader, 0, sizeof(modHeader)); modHeader.headerLength = sizeof(modHeader); memcpy(modHeader.headerSignature, MODULESIGNATURE, sizeof(modHeader.headerSignature)); modHeader.headerVersion = MODULEVERSION; modHeader.segmentDescrLength = sizeof(SavedStateSegmentDescr); modHeader.executableTimeStamp = exportTimeStamp; { unsigned rootArea = findArea(this->rootFunction); struct _memTableEntry *mt = &memTable[rootArea]; modHeader.rootSegment = mt->mtIndex; modHeader.rootOffset = (POLYUNSIGNED)((char*)this->rootFunction - (char*)mt->mtOriginalAddr); } modHeader.timeStamp = getBuildTime(); modHeader.segmentDescrCount = this->memTableEntries; // One segment for each space. // Write out the header. fwrite(&modHeader, sizeof(modHeader), 1, this->exportFile); SavedStateSegmentDescr *descrs = new SavedStateSegmentDescr [this->memTableEntries]; // We need an entry in the descriptor tables for each segment in the executable because // we may have relocations that refer to addresses in it. for (unsigned j = 0; j < this->memTableEntries; j++) { SavedStateSegmentDescr *thisDescr = &descrs[j]; memoryTableEntry *entry = &this->memTable[j]; memset(thisDescr, 0, sizeof(SavedStateSegmentDescr)); thisDescr->relocationSize = sizeof(RelocationEntry); thisDescr->segmentIndex = (unsigned)entry->mtIndex; thisDescr->segmentSize = entry->mtLength; // Set this even if we don't write it. thisDescr->originalAddress = entry->mtOriginalAddr; if (entry->mtFlags & MTF_WRITEABLE) { thisDescr->segmentFlags |= SSF_WRITABLE; if (entry->mtFlags & MTF_NO_OVERWRITE) thisDescr->segmentFlags |= SSF_NOOVERWRITE; if ((entry->mtFlags & MTF_NO_OVERWRITE) == 0) thisDescr->segmentFlags |= SSF_OVERWRITE; if (entry->mtFlags & MTF_BYTES) thisDescr->segmentFlags |= SSF_BYTES; } if (entry->mtFlags & MTF_EXECUTABLE) thisDescr->segmentFlags |= SSF_CODE; } // Write out temporarily. Will be overwritten at the end. modHeader.segmentDescr = ftell(this->exportFile); fwrite(descrs, sizeof(SavedStateSegmentDescr), this->memTableEntries, this->exportFile); // Write out the relocations and the data. for (unsigned k = 0; k < this->memTableEntries; k++) { SavedStateSegmentDescr *thisDescr = &descrs[k]; memoryTableEntry *entry = &this->memTable[k]; if (k >= newAreas) // Not permanent areas { thisDescr->relocations = ftell(this->exportFile); // Have to write this out. this->relocationCount = 0; // Create the relocation table. char *start = (char*)entry->mtOriginalAddr; char *end = start + entry->mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); // For saved states we don't include explicit relocations except // in code but it's easier if we do for modules. if (length != 0 && obj->IsCodeObject()) machineDependent->ScanConstantsWithinCode(obj, this); relocateObject(obj); p += length; } thisDescr->relocationCount = this->relocationCount; // Write out the data. thisDescr->segmentData = ftell(exportFile); fwrite(entry->mtOriginalAddr, entry->mtLength, 1, exportFile); } } // Rewrite the header and the segment tables now they're complete. fseek(exportFile, 0, SEEK_SET); fwrite(&modHeader, sizeof(modHeader), 1, exportFile); fwrite(descrs, sizeof(SavedStateSegmentDescr), this->memTableEntries, exportFile); delete[](descrs); fclose(exportFile); exportFile = NULL; } // Store a module -POLYUNSIGNED PolyStoreModule(FirstArgument threadId, PolyWord name, PolyWord contents) +POLYUNSIGNED PolyStoreModule(POLYUNSIGNED threadId, POLYUNSIGNED name, POLYUNSIGNED contents) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedContents = taskData->saveVec.push(contents); try { - TempString fileName(name); + TempString fileName(PolyWord::FromUnsigned(name)); ModuleStorer storer(fileName, pushedContents); processes->MakeRootRequest(taskData, &storer); if (storer.errorMessage) raise_syscall(taskData, storer.errorMessage, storer.errCode); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } // Load a module. class ModuleLoader: public MainThreadRequest { public: ModuleLoader(TaskData *taskData, const TCHAR *file): MainThreadRequest(MTP_LOADMODULE), callerTaskData(taskData), fileName(file), errorResult(NULL), errNumber(0), rootHandle(0) {} virtual void Perform(); TaskData *callerTaskData; const TCHAR *fileName; const char *errorResult; int errNumber; Handle rootHandle; }; void ModuleLoader::Perform() { AutoClose loadFile(_tfopen(fileName, _T("rb"))); if ((FILE*)loadFile == NULL) { errorResult = "Cannot open load file"; errNumber = ERRORNUMBER; return; } ModuleHeader header; // Read the header and check the signature. if (fread(&header, sizeof(ModuleHeader), 1, loadFile) != 1) { errorResult = "Unable to load header"; return; } if (strncmp(header.headerSignature, MODULESIGNATURE, sizeof(header.headerSignature)) != 0) { errorResult = "File is not a Poly/ML module"; return; } if (header.headerVersion != MODULEVERSION || header.headerLength != sizeof(ModuleHeader) || header.segmentDescrLength != sizeof(SavedStateSegmentDescr)) { errorResult = "Unsupported version of module file"; return; } if (header.executableTimeStamp != exportTimeStamp) { // Time-stamp does not match executable. errorResult = "Module was exported from a different executable or the executable has changed"; return; } LoadRelocate relocate; relocate.nDescrs = header.segmentDescrCount; relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs]; if (fseek(loadFile, header.segmentDescr, SEEK_SET) != 0 || fread(relocate.descrs, sizeof(SavedStateSegmentDescr), relocate.nDescrs, loadFile) != relocate.nDescrs) { errorResult = "Unable to read segment descriptors"; return; } { unsigned maxIndex = 0; for (unsigned i = 0; i < relocate.nDescrs; i++) if (relocate.descrs[i].segmentIndex > maxIndex) maxIndex = relocate.descrs[i].segmentIndex; relocate.targetAddresses = new PolyWord*[maxIndex+1]; for (unsigned i = 0; i <= maxIndex; i++) relocate.targetAddresses[i] = 0; } // Read in and create the new segments first. If we have problems, // in particular if we have run out of memory, then it's easier to recover. for (unsigned i = 0; i < relocate.nDescrs; i++) { SavedStateSegmentDescr *descr = &relocate.descrs[i]; MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); if (descr->segmentData == 0) { // No data - just an entry in the index. if (space == NULL/* || descr->segmentSize != (size_t)((char*)space->top - (char*)space->bottom)*/) { errorResult = "Mismatch for existing memory space"; return; } else relocate.targetAddresses[descr->segmentIndex] = space->bottom; } else { // New segment. if (space != NULL) { errorResult = "Segment already exists"; return; } // Allocate memory for the new segment. size_t actualSize = descr->segmentSize; MemSpace *space; if (descr->segmentFlags & SSF_CODE) { CodeSpace *cSpace = gMem.NewCodeSpace(actualSize); if (cSpace == 0) { errorResult = "Unable to allocate memory"; return; } space = cSpace; cSpace->firstFree = (PolyWord*)((byte*)space->bottom + descr->segmentSize); if (cSpace->firstFree != cSpace->top) gMem.FillUnusedSpace(cSpace->firstFree, cSpace->top - cSpace->firstFree); } else { LocalMemSpace *lSpace = gMem.NewLocalSpace(actualSize, descr->segmentFlags & SSF_WRITABLE); if (lSpace == 0) { errorResult = "Unable to allocate memory"; return; } space = lSpace; lSpace->lowerAllocPtr = (PolyWord*)((byte*)lSpace->bottom + descr->segmentSize); } if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0) { errorResult = "Unable to seek to segment"; return; } if (readData(space->bottom, descr->segmentSize, loadFile) != 1) { errorResult = "Unable to read segment"; return; } relocate.targetAddresses[descr->segmentIndex] = space->bottom; if (space->isMutable && (descr->segmentFlags & SSF_BYTES) != 0) { ClearVolatile cwbr; cwbr.ScanAddressesInRegion(space->bottom, (PolyWord*)((byte*)space->bottom + descr->segmentSize)); } } } // Now deal with relocation. for (unsigned j = 0; j < relocate.nDescrs; j++) { SavedStateSegmentDescr *descr = &relocate.descrs[j]; PolyWord *baseAddr = relocate.targetAddresses[descr->segmentIndex]; ASSERT(baseAddr != NULL); // We should have created it. // Process explicit relocations. // If we get errors just skip the error and continue rather than leave // everything in an unstable state. if (descr->relocations) { if (fseek(loadFile, descr->relocations, SEEK_SET) != 0) errorResult = "Unable to read relocation segment"; for (unsigned k = 0; k < descr->relocationCount; k++) { RelocationEntry reloc; if (fread(&reloc, sizeof(reloc), 1, loadFile) != 1) errorResult = "Unable to read relocation segment"; byte *setAddress = (byte*)baseAddr + reloc.relocAddress; byte *targetAddress = (byte*)relocate.targetAddresses[reloc.targetSegment] + reloc.targetAddress; ScanAddress::SetConstantValue(setAddress, (PolyObject*)(targetAddress), reloc.relKind); } } } // Get the root address. Push this to the caller's save vec. If we put the // newly created areas into local memory we could get a GC as soon as we // complete this root request. { PolyWord *baseAddr = relocate.targetAddresses[header.rootSegment]; rootHandle = callerTaskData->saveVec.push((PolyObject*)((byte*)baseAddr + header.rootOffset)); } } static Handle LoadModule(TaskData *taskData, Handle args) { TempString fileName(args->Word()); ModuleLoader loader(taskData, fileName); processes->MakeRootRequest(taskData, &loader); if (loader.errorResult != 0) { if (loader.errNumber == 0) raise_fail(taskData, loader.errorResult); else { AutoFree buff((char *)malloc(strlen(loader.errorResult) + 2 + _tcslen(loader.fileName) * sizeof(TCHAR) + 1)); #if (defined(_WIN32) && defined(UNICODE)) sprintf(buff, "%s: %S", loader.errorResult, loader.fileName); #else sprintf(buff, "%s: %s", loader.errorResult, loader.fileName); #endif raise_syscall(taskData, buff, loader.errNumber); } } return loader.rootHandle; } // Load a module -POLYUNSIGNED PolyLoadModule(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyLoadModule(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = LoadModule(taskData, pushedArg); } 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(); } PolyObject *InitHeaderFromExport(struct _exportDescription *exports) { // Check the structure sizes stored in the export structure match the versions // used in this library. if (exports->structLength != sizeof(exportDescription) || exports->memTableSize != sizeof(memoryTableEntry) || exports->rtsVersion < FIRST_supported_version || exports->rtsVersion > LAST_supported_version) { #if (FIRST_supported_version == LAST_supported_version) Exit("The exported object file has version %0.2f but this library supports %0.2f", ((float)exports->rtsVersion) / 100.0, ((float)FIRST_supported_version) / 100.0); #else Exit("The exported object file has version %0.2f but this library supports %0.2f-%0.2f", ((float)exports->rtsVersion) / 100.0, ((float)FIRST_supported_version) / 100.0, ((float)LAST_supported_version) / 100.0); #endif } // We could also check the RTS version and the architecture. exportTimeStamp = exports->timeStamp; // Needed for load and save. memoryTableEntry *memTable = exports->memTable; #ifdef POLYML32IN64 // We need to copy this into the heap before beginning execution. // This is very like loading a saved state and the code should probably // be merged. LoadRelocate relocate(true); relocate.nDescrs = exports->memTableEntries; relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs]; relocate.targetAddresses = new PolyWord*[exports->memTableEntries]; relocate.originalBaseAddr = (PolyWord*)exports->originalBaseAddr; PolyObject *root = 0; for (unsigned i = 0; i < exports->memTableEntries; i++) { relocate.descrs[i].segmentIndex = memTable[i].mtIndex; relocate.descrs[i].originalAddress = memTable[i].mtOriginalAddr; relocate.descrs[i].segmentSize = memTable[i].mtLength; PermanentMemSpace *newSpace = gMem.AllocateNewPermanentSpace(memTable[i].mtLength, (unsigned)memTable[i].mtFlags, (unsigned)memTable[i].mtIndex); if (newSpace == 0) Exit("Unable to initialise a permanent memory space"); PolyWord *mem = newSpace->bottom; memcpy(newSpace->writeAble(mem), memTable[i].mtCurrentAddr, memTable[i].mtLength); PolyWord* unused = mem + memTable[i].mtLength / sizeof(PolyWord); gMem.FillUnusedSpace(newSpace->writeAble(unused), newSpace->spaceSize() - memTable[i].mtLength / sizeof(PolyWord)); if (newSpace == 0) Exit("Unable to initialise a permanent memory space"); relocate.targetAddresses[i] = mem; relocate.AddTreeRange(&relocate.spaceTree, i, (uintptr_t)relocate.descrs[i].originalAddress, (uintptr_t)((char*)relocate.descrs[i].originalAddress + relocate.descrs[i].segmentSize - 1)); // Relocate the root function. if (exports->rootFunction >= memTable[i].mtCurrentAddr && exports->rootFunction < (char*)memTable[i].mtCurrentAddr + memTable[i].mtLength) { root = (PolyObject*)((char*)mem + ((char*)exports->rootFunction - (char*)memTable[i].mtCurrentAddr)); } } // Now relocate the addresses for (unsigned j = 0; j < exports->memTableEntries; j++) { SavedStateSegmentDescr *descr = &relocate.descrs[j]; MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex); // Any relative addresses have to be corrected by adding this. relocate.relativeOffset = (PolyWord*)descr->originalAddress - space->bottom; for (PolyWord *p = space->bottom; p < space->top; ) { #ifdef POLYML32IN64 if ((((uintptr_t)p) & 4) == 0) { // Skip any padding. The length word should be on an odd-word boundary. p++; continue; } #endif p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); relocate.RelocateObject(obj); p += length; } } // Set the final permissions. for (unsigned j = 0; j < exports->memTableEntries; j++) { PermanentMemSpace *space = gMem.SpaceForIndex(memTable[j].mtIndex); gMem.CompletePermanentSpaceAllocation(space); } return root; #else for (unsigned i = 0; i < exports->memTableEntries; i++) { // Construct a new space for each of the entries. if (gMem.NewPermanentSpace( (PolyWord*)memTable[i].mtCurrentAddr, memTable[i].mtLength / sizeof(PolyWord), (unsigned)memTable[i].mtFlags, (unsigned)memTable[i].mtIndex) == 0) Exit("Unable to initialise a permanent memory space"); } return (PolyObject *)exports->rootFunction; #endif } // Return the system directory for modules. This is configured differently // in Unix and in Windows. -POLYUNSIGNED PolyGetModuleDirectory(FirstArgument threadId) +POLYUNSIGNED PolyGetModuleDirectory(POLYUNSIGNED threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(MODULEDIR)) result = SAVE(C_string_to_Poly(taskData, MODULEDIR)); #elif (defined(_WIN32)) { // This registry key is configured when Poly/ML is installed using the installer. // It gives the path to the Poly/ML installation directory. We return the // Modules subdirectory. HKEY hk; if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, _T("SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\PolyML.exe"), 0, KEY_QUERY_VALUE, &hk) == ERROR_SUCCESS) { DWORD valSize; if (RegQueryValueEx(hk, _T("Path"), 0, NULL, NULL, &valSize) == ERROR_SUCCESS) { #define MODULEDIR _T("Modules") TempString buff((TCHAR*)malloc(valSize + (_tcslen(MODULEDIR) + 1) * sizeof(TCHAR))); DWORD dwType; if (RegQueryValueEx(hk, _T("Path"), 0, &dwType, (LPBYTE)(LPTSTR)buff, &valSize) == ERROR_SUCCESS) { // The registry entry should end with a backslash. _tcscat(buff, MODULEDIR); result = SAVE(C_string_to_Poly(taskData, buff)); } } RegCloseKey(hk); } result = SAVE(C_string_to_Poly(taskData, "")); } #else result = SAVE(C_string_to_Poly(taskData, "")); #endif } 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(); } struct _entrypts savestateEPT[] = { { "PolySaveState", (polyRTSFunction)&PolySaveState }, { "PolyLoadState", (polyRTSFunction)&PolyLoadState }, { "PolyShowHierarchy", (polyRTSFunction)&PolyShowHierarchy }, { "PolyRenameParent", (polyRTSFunction)&PolyRenameParent }, { "PolyShowParent", (polyRTSFunction)&PolyShowParent }, { "PolyStoreModule", (polyRTSFunction)&PolyStoreModule }, { "PolyLoadModule", (polyRTSFunction)&PolyLoadModule }, { "PolyLoadHierarchy", (polyRTSFunction)&PolyLoadHierarchy }, { "PolyGetModuleDirectory", (polyRTSFunction)&PolyGetModuleDirectory }, { NULL, NULL } // End of list. }; diff --git a/libpolyml/sharedata.cpp b/libpolyml/sharedata.cpp index d6e51dea..5a35a278 100644 --- a/libpolyml/sharedata.cpp +++ b/libpolyml/sharedata.cpp @@ -1,1125 +1,1125 @@ /* Title: Share common immutable data Copyright (c) 2000 Cambridge University Technical Services Limited and David C. J. Matthews 2006, 2010-13, 2016-17, 2019 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_STDLIB_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STRING_H #include #endif #include #include "globals.h" #include "save_vec.h" #include "machine_dep.h" #include "scanaddrs.h" #include "run_time.h" #include "sys.h" #include "gc.h" #include "rtsentry.h" #include "memmgr.h" #include "processes.h" #include "gctaskfarm.h" #include "diagnostics.h" #include "sharedata.h" #include "gc_progress.h" /* This code was largely written by Simon Finn as a database improver for the memory-mapped persistent store version. The aim is that where two immutable objects (cells) contain the same data (i.e. where ML equality would say they were equal) they should be merged so that only a single object is retained. The basic algorithm works like this: 1. From the root, recursively process all objects and calculate a "depth" for each object. Mutable data and code segments have depth 0 and cannot be merged. Byte segments (e.g. strings and long-format arbitrary precision values) have depth 1. Other cells have depths of 1 or greater, the depth being the maximum recursion depth until a byte segment or an object with depth 0 is reached. Cycles of immutable data don't arise normally in ML but could be produced as a result of locking mutable objects. To avoid infinite recursion cycles are broken by setting the depth of an object to zero before processing it. The depth of each object is stored in the length word of the object. This ensures each object is processed once only. 2. Vectors are created containing objects of the same depth, from 1 to the maximum depth found. 3. We begin a loop starting at depth 1. 4. The length words are restored, replacing the depth count in the header. 5. The objects are sorted by their contents so bringing together objects with the same contents. The contents are considered simply as uninterpreted bits. 6. The sorted vector is processed to find those objects that are actually bitwise equal. One object is selected to be retained and other objects have their length words turned into tombstones pointing at the retained object. 7. Objects at the next depth are first processed to find pointers to objects that moved in the previous step (or that step with a lower depth). The addresses are updated to point to the retained object. The effect of this step is to ensure that now two objects that are equal in ML terms have identical contents. e.g. If we have val a = ("abc", "def") and b = ("abc", "def") then we will have merged the two occurrences of "abc" and "def" in the previous pass of level 1 objects. This step ensures that the two cells containing the pairs both hold pointers to the same objects and so are bitwise equal. 8. Repeat with 4, 5 and 6 until all the levels have been processed. Each object is processed once and at the end most of the objects have been updated with the shared addresses. We have to scan all the mutable and code objects to update the addresses but also have to scan the immutables because of the possibility of missing an update as a result of breaking a loop (see SPF's comment below). DCJM 3/8/06 This has been substantially updated while retaining the basic algorithm. Sorting is now done in parallel by the GC task farm and the stack is now in dynamic memory. That avoids a possible segfault if the normal C stack overflows. A further problem is that the vectors can get very large and this can cause problems if there is insufficient contiguous space. The code has been modified to reduce the size of the vectors at the cost of increasing the total memory requirement. */ extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyShareCommonData(FirstArgument threadId, PolyWord root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyShareCommonData(POLYUNSIGNED threadId, POLYUNSIGNED root); } // The depth is stored in the length field. If the Weak bit is set but the Mutable bit // is clear the value in the length word is a depth rather than a real length. // The tombstone bit is zero. // Previously "depth" values were encoded with the tombstone bit set but that isn't // possible in 32-in-64 because we need 31 bits in a forwarding pointer. inline bool OBJ_IS_DEPTH(POLYUNSIGNED L) { return (L & (_OBJ_WEAK_BIT| _OBJ_MUTABLE_BIT)) == _OBJ_WEAK_BIT; } inline POLYUNSIGNED OBJ_GET_DEPTH(POLYUNSIGNED L) { return OBJ_OBJECT_LENGTH(L); } inline POLYUNSIGNED OBJ_SET_DEPTH(POLYUNSIGNED n) { return n | _OBJ_WEAK_BIT; } // The DepthVector type contains all the items of a particular depth. // This is the abstract class. There are variants for the case where all // the cells have the same size and where they may vary. class DepthVector { public: DepthVector() : nitems(0), vsize(0), ptrVector(0) {} virtual ~DepthVector() { free(ptrVector); } virtual POLYUNSIGNED MergeSameItems(void); virtual void Sort(void); virtual POLYUNSIGNED ItemCount(void) { return nitems; } virtual void AddToVector(POLYUNSIGNED L, PolyObject *pt) = 0; void FixLengthAndAddresses(ScanAddress *scan); virtual void RestoreForwardingPointers() = 0; protected: POLYUNSIGNED nitems; POLYUNSIGNED vsize; PolyObject **ptrVector; // This must only be called BEFORE sorting. The pointer vector will be // modified by sorting but the length vector is not. virtual void RestoreLengthWords(void) = 0; static void SortRange(PolyObject * *first, PolyObject * *last); static int CompareItems(const PolyObject * const *a, const PolyObject * const *b); static int qsCompare(const void *a, const void *b) { return CompareItems((const PolyObject * const*)a, (const PolyObject *const *)b); } static void sortTask(GCTaskId*, void *s, void *l) { SortRange((PolyObject **)s, (PolyObject **)l); } }; // DepthVector where the size needs to be held for each item. class DepthVectorWithVariableLength: public DepthVector { public: DepthVectorWithVariableLength() : lengthVector(0) {} virtual ~DepthVectorWithVariableLength() { free(lengthVector); } virtual void RestoreLengthWords(void); virtual void AddToVector(POLYUNSIGNED L, PolyObject *pt); virtual void RestoreForwardingPointers(); protected: POLYUNSIGNED *lengthVector; // Same size as the ptrVector }; class DepthVectorWithFixedLength : public DepthVector { public: DepthVectorWithFixedLength(POLYUNSIGNED l) : length(l) {} virtual void RestoreLengthWords(void); virtual void AddToVector(POLYUNSIGNED L, PolyObject *pt); // It's safe to run this again for the fixed length vectors. virtual void RestoreForwardingPointers() { RestoreLengthWords(); } protected: POLYUNSIGNED length; }; // We have special vectors for the sizes from 1 to FIXEDLENGTHSIZE-1. // Zero-sized and large objects go in depthVectorArray[0]. #define FIXEDLENGTHSIZE 10 class ShareDataClass { public: ShareDataClass(); ~ShareDataClass(); bool RunShareData(PolyObject *root); void AddToVector(POLYUNSIGNED depth, POLYUNSIGNED length, PolyObject *pt); private: std::vector depthVectorArray[FIXEDLENGTHSIZE]; POLYUNSIGNED maxVectorSize; }; ShareDataClass::ShareDataClass() { maxVectorSize = 0; } ShareDataClass::~ShareDataClass() { // Free the bitmaps associated with the permanent spaces. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) (*i)->shareBitmap.Destroy(); // Free the depth vectors. for (unsigned i = 0; i < FIXEDLENGTHSIZE; i++) { for (std::vector ::iterator j = depthVectorArray[i].begin(); j < depthVectorArray[i].end(); j++) delete(*j); } } // Grow the appropriate depth vector if necessary and add the item to it. void ShareDataClass::AddToVector(POLYUNSIGNED depth, POLYUNSIGNED length, PolyObject *pt) { // Select the appropriate vector. Element zero is the variable length vector and is // also used for the, rare, zero length objects. std::vector *vectorToUse = &(depthVectorArray[length < FIXEDLENGTHSIZE ? length : 0]); if (depth >= maxVectorSize) maxVectorSize = depth+1; while (vectorToUse->size() <= depth) { try { if (length != 0 && length < FIXEDLENGTHSIZE) vectorToUse->push_back(new DepthVectorWithFixedLength(length)); else vectorToUse->push_back(new DepthVectorWithVariableLength); } catch (std::bad_alloc&) { throw MemoryException(); } } (*vectorToUse)[depth]->AddToVector(length, pt); } // Add an object to a depth vector void DepthVectorWithVariableLength::AddToVector(POLYUNSIGNED L, PolyObject *pt) { ASSERT (this->nitems <= this->vsize); if (this->nitems == this->vsize) { // The vector is full or has not yet been allocated. Grow it by 50%. POLYUNSIGNED new_vsize = this->vsize + this->vsize / 2 + 1; if (new_vsize < 15) new_vsize = 15; // First the length vector. POLYUNSIGNED *newLength = (POLYUNSIGNED *)realloc(this->lengthVector, new_vsize * sizeof(POLYUNSIGNED)); if (newLength == 0) { // The vectors can get large and we may not be able to grow them // particularly if the address space is limited in 32-bit mode. // Try again with just a small increase. new_vsize = this->vsize + 15; newLength = (POLYUNSIGNED *)realloc(this->lengthVector, new_vsize * sizeof(POLYUNSIGNED)); // If that failed give up. if (newLength == 0) throw MemoryException(); } PolyObject **newPtrVector = (PolyObject * *)realloc (this->ptrVector, new_vsize*sizeof(PolyObject *)); if (newPtrVector == 0) { new_vsize = this->vsize + 15; newPtrVector = (PolyObject **)realloc (this->ptrVector, new_vsize*sizeof(PolyObject *)); // If that failed give up. if (newPtrVector == 0) throw MemoryException(); } this->lengthVector = newLength; this->ptrVector = newPtrVector; this->vsize = new_vsize; } ASSERT (this->nitems < this->vsize); this->lengthVector[this->nitems] = L; this->ptrVector[this->nitems] = pt; this->nitems++; ASSERT (this->nitems <= this->vsize); } // Add an object to a depth vector void DepthVectorWithFixedLength::AddToVector(POLYUNSIGNED L, PolyObject *pt) { ASSERT(this->nitems <= this->vsize); ASSERT(L == length); if (this->nitems == this->vsize) { // The vector is full or has not yet been allocated. Grow it by 50%. POLYUNSIGNED new_vsize = this->vsize + this->vsize / 2 + 1; if (new_vsize < 15) new_vsize = 15; PolyObject **newPtrVector = (PolyObject * *)realloc(this->ptrVector, new_vsize * sizeof(PolyObject *)); if (newPtrVector == 0) { new_vsize = this->vsize + 15; newPtrVector = (PolyObject **)realloc(this->ptrVector, new_vsize * sizeof(PolyObject *)); // If that failed give up. if (newPtrVector == 0) throw MemoryException(); } this->ptrVector = newPtrVector; this->vsize = new_vsize; } ASSERT(this->nitems < this->vsize); this->ptrVector[this->nitems] = pt; this->nitems++; ASSERT(this->nitems <= this->vsize); } // Comparison function used for sorting and also to test whether // two cells can be merged. int DepthVector::CompareItems(const PolyObject *const *a, const PolyObject *const *b) { const PolyObject *x = *a; const PolyObject *y = *b; POLYUNSIGNED lX = x->LengthWord(); POLYUNSIGNED lY = y->LengthWord(); // ASSERT (OBJ_IS_LENGTH(lX)); // ASSERT (OBJ_IS_LENGTH(lY)); if (lX > lY) return 1; // These tests include the flag bits if (lX < lY) return -1; // Return simple bitwise equality. return memcmp(x, y, OBJ_OBJECT_LENGTH(lX)*sizeof(PolyWord)); } // Merge cells with the same contents. POLYUNSIGNED DepthVector::MergeSameItems() { POLYUNSIGNED N = this->nitems; POLYUNSIGNED n = 0; POLYUNSIGNED i = 0; while (i < N) { PolyObject *bestShare = 0; // Candidate to share. MemSpace *bestSpace = 0; POLYUNSIGNED j; for (j = i; j < N; j++) { ASSERT (OBJ_IS_LENGTH(ptrVector[i]->LengthWord())); // Search for identical objects. Don't bother to compare it with itself. if (i != j && CompareItems (&ptrVector[i], &ptrVector[j]) != 0) break; // The order of sharing is significant. // Choose an object in the permanent memory if that is available. // This is necessary to retain the invariant that no object in // the permanent memory points to an object in the temporary heap. // (There may well be pointers to this object elsewhere in the permanent // heap). // Choose the lowest hierarchy value for preference since that // may reduce the size of saved state when resaving already saved // data. // If we can't find a permanent space choose a space that isn't // an allocation space. Otherwise we could break the invariant // that immutable areas never point into the allocation area. MemSpace *space = gMem.SpaceForObjectAddress(ptrVector[j]); if (bestSpace == 0) { bestShare = ptrVector[j]; bestSpace = space; } else if (bestSpace->spaceType == ST_PERMANENT) { // Only update if the current space is also permanent and a lower hierarchy if (space->spaceType == ST_PERMANENT && ((PermanentMemSpace *)space)->hierarchy < ((PermanentMemSpace *)bestSpace)->hierarchy) { bestShare = ptrVector[j]; bestSpace = space; } } else if (bestSpace->spaceType == ST_LOCAL) { // Update if the current space is not an allocation space if (space->spaceType != ST_LOCAL || ! ((LocalMemSpace*)space)->allocationSpace) { bestShare = ptrVector[j]; bestSpace = space; } } } POLYUNSIGNED k = j; // Remember the first object that didn't match. // For each identical object set all but the one we want to point to // the shared object. for (j = i; j < k; j++) { ASSERT (OBJ_IS_LENGTH(ptrVector[j]->LengthWord())); if (ptrVector[j] != bestShare) { ptrVector[j]->SetForwardingPtr(bestShare); /* an indirection */ n++; } } i = k; } return n; } // Sort this vector void DepthVector::Sort() { if (nitems > 1) { SortRange(ptrVector, ptrVector + (nitems - 1)); gpTaskFarm->WaitForCompletion(); } // Check // for (POLYUNSIGNED i = 0; i < nitems-1; i++) // ASSERT(CompareItems(vector+i, vector+i+1) <= 0); } inline void swapItems(PolyObject * *i, PolyObject * *j) { PolyObject * t = *i; *i = *j; *j = t; } // Simple parallel quick-sort. "first" and "last" are the first // and last items (inclusive) in the vector. void DepthVector::SortRange(PolyObject * *first, PolyObject * *last) { while (first < last) { if (last-first <= 100) { // Use the standard library function for small ranges. qsort(first, last-first+1, sizeof(PolyObject *), qsCompare); return; } // Select the best pivot from the first, last and middle item // by sorting these three items. We use the middle item as // the pivot and since the first and last items are sorted // by this we can skip them when we start the partitioning. PolyObject * *middle = first + (last-first)/2; if (CompareItems(first, middle) > 0) swapItems(first, middle); if (CompareItems(middle, last) > 0) { swapItems(middle, last); if (CompareItems(first, middle) > 0) swapItems(first, middle); } // Partition the data about the pivot. This divides the // vector into two partitions with all items <= pivot to // the left and all items >= pivot to the right. // Note: items equal to the pivot could be in either partition. PolyObject * *f = first+1; PolyObject * *l = last-1; do { // Find an item we have to move. These loops will always // terminate because testing the middle with itself // will return == 0. while (CompareItems(f, middle/* pivot*/) < 0) f++; while (CompareItems(middle/* pivot*/, l) < 0) l--; // If we haven't finished we need to swap the items. if (f < l) { swapItems(f, l); // If one of these was the pivot item it will have moved to // the other position. if (middle == f) middle = l; else if (middle == l) middle = f; f++; l--; } else if (f == l) { f++; l--; break; } } while (f <= l); // Process the larger partition as a separate task or // by recursion and do the smaller partition by tail // recursion. if (l-first > last-f) { // Lower part is larger gpTaskFarm->AddWorkOrRunNow(sortTask, first, l); first = f; } else { // Upper part is larger gpTaskFarm->AddWorkOrRunNow(sortTask, f, last); last = l; } } } // Set the genuine length word. This overwrites both depth words and forwarding pointers. void DepthVectorWithVariableLength::RestoreLengthWords() { for (POLYUNSIGNED i = 0; i < this->nitems; i++) { PolyObject* obj = ptrVector[i]; obj = gMem.SpaceForObjectAddress(obj)->writeAble(obj); // This could be code. obj->SetLengthWord(lengthVector[i]); // restore genuine length word } } void DepthVectorWithFixedLength::RestoreLengthWords() { for (POLYUNSIGNED i = 0; i < this->nitems; i++) ptrVector[i]->SetLengthWord(length); // restore genuine length word } // Fix up the length word. Then update all addresses to their new location if // we have shared the original destination of the address with something else. void DepthVector::FixLengthAndAddresses(ScanAddress *scan) { RestoreLengthWords(); for (POLYUNSIGNED i = 0; i < this->nitems; i++) { // Fix up all addresses. scan->ScanAddressesInObject(ptrVector[i]); } } // Restore the original length words on forwarding pointers. // After sorting the pointer vector and length vector are no longer // matched so we have to follow the pointers. void DepthVectorWithVariableLength::RestoreForwardingPointers() { for (POLYUNSIGNED i = 0; i < this->nitems; i++) { PolyObject *obj = ptrVector[i]; if (obj->ContainsForwardingPtr()) obj->SetLengthWord(obj->GetForwardingPtr()->LengthWord()); } } // This class is used in two places and is called to ensure that all // object length words have been restored. // Before we actually try to share the immutable objects at a particular depth it // is called to update addresses in those objects to take account of // sharing at lower depths. // When all sharing is complete it is called to update the addresses in // level zero objects, i.e. mutables and code. class ProcessFixupAddress: public ScanAddress { protected: virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt); virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt); virtual PolyObject *ScanObjectAddress(PolyObject *base) { return GetNewAddress(base).AsObjPtr(); } PolyWord GetNewAddress(PolyWord old); }; POLYUNSIGNED ProcessFixupAddress::ScanAddressAt(PolyWord *pt) { *pt = GetNewAddress(*pt); return 0; } // Don't have to do anything for code since it isn't moved. POLYUNSIGNED ProcessFixupAddress::ScanCodeAddressAt(PolyObject **pt) { return 0; } // Returns the new address if the argument is the address of an object that // has moved, otherwise returns the original. PolyWord ProcessFixupAddress::GetNewAddress(PolyWord old) { if (old.IsTagged() || old == PolyWord::FromUnsigned(0)) return old; // Nothing to do. ASSERT(old.IsDataPtr()); PolyObject *obj = old.AsObjPtr(); POLYUNSIGNED L = obj->LengthWord(); if (obj->ContainsForwardingPtr()) // tombstone is a pointer to a shared object { PolyObject *newp = obj->GetForwardingPtr(); // ASSERT (newp->ContainsNormalLengthWord()); return newp; } // Generally each address will point to an object processed at a lower depth. // The exception is if we have a cycle and have assigned the rest of the // structure to a higher depth. // N.B. We return the original address here but this could actually share // with something else and not be retained. if (OBJ_IS_DEPTH(L)) return old; ASSERT (obj->ContainsNormalLengthWord()); // object is not shared return old; } // This class is used to set up the depth vectors for sorting. It subclasses ScanAddress // in order to be able to use that for code objects since they are complicated but it // handles all the other object types itself. It scans them depth-first using an explicit stack. class ProcessAddToVector: public ScanAddress { public: ProcessAddToVector(ShareDataClass *p): m_parent(p), addStack(0), stackSize(0), asp(0) {} ~ProcessAddToVector(); // These are used when scanning code areas. They return either // a length or a possibly updated address. virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt) { (void)AddPolyWordToDepthVectors(*pt); return 0; } virtual PolyObject *ScanObjectAddress(PolyObject *base) { (void)AddObjectToDepthVector(base); return base; } virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject** pt) { *pt = ScanObjectAddress(*pt); return 0; } void ProcessRoot(PolyObject *root); protected: // Process an address and return the "depth". POLYUNSIGNED AddPolyWordToDepthVectors(PolyWord old); POLYUNSIGNED AddObjectToDepthVector(PolyObject *obj); void PushToStack(PolyObject *obj); ShareDataClass *m_parent; PolyObject **addStack; unsigned stackSize; unsigned asp; }; ProcessAddToVector::~ProcessAddToVector() { // Normally the stack will be empty. However if we have run out of // memory and thrown an exception we may well have items left. // We have to remove the mark bits otherwise it will mess up any // subsequent GC. for (unsigned i = 0; i < asp; i++) { PolyObject *obj = addStack[i]; if (obj->LengthWord() & _OBJ_GC_MARK) obj->SetLengthWord(obj->LengthWord() & (~_OBJ_GC_MARK)); } free(addStack); // Now free the stack } POLYUNSIGNED ProcessAddToVector::AddPolyWordToDepthVectors(PolyWord old) { // If this is a tagged integer or an IO pointer that's simply a constant. if (old.IsTagged() || old == PolyWord::FromUnsigned(0)) return 0; return AddObjectToDepthVector(old.AsObjPtr()); } // Either adds an object to the stack or, if its depth is known, adds it // to the depth vector and returns the depth. // We use _OBJ_GC_MARK to detect when we have visited a cell but not yet // computed the depth. We have to be careful that this bit is removed // before we finish in the case that we run out of memory and throw an // exception. PushToStack may throw the exception if the stack needs to // grow. POLYUNSIGNED ProcessAddToVector::AddObjectToDepthVector(PolyObject *obj) { MemSpace *space = gMem.SpaceForObjectAddress(obj); if (space == 0) return 0; POLYUNSIGNED L = obj->LengthWord(); if (OBJ_IS_DEPTH(L)) // tombstone contains genuine depth or 0. return OBJ_GET_DEPTH(L); if (obj->LengthWord() & _OBJ_GC_MARK) return 0; // Marked but not yet scanned. Circular structure. ASSERT (OBJ_IS_LENGTH(L)); if (obj->IsMutable()) { // Mutable data in the local or permanent areas. Ignore byte objects or // word objects containing only ints. if (obj->IsWordObject()) { bool containsAddress = false; for (POLYUNSIGNED j = 0; j < OBJ_OBJECT_LENGTH(L) && !containsAddress; j++) containsAddress = ! obj->Get(j).IsTagged(); if (containsAddress) { // Add it to the vector so we will update any addresses it contains. m_parent->AddToVector(0, L, obj); // and follow any addresses to try to merge those. PushToStack(obj); obj->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan } // If we don't add it to the vector we mustn't set _OBJ_GC_MARK. } return 0; // Level is zero } if (space->spaceType == ST_PERMANENT && ((PermanentMemSpace*)space)->hierarchy == 0) { // Immutable data in the permanent area can't be merged // because it's read only. We need to follow the addresses // because they may point to mutable areas containing data // that can be. A typical case is the root function pointing // at the global name table containing new declarations. Bitmap *bm = &((PermanentMemSpace*)space)->shareBitmap; if (! bm->TestBit((PolyWord*)obj - space->bottom)) { bm->SetBit((PolyWord*)obj - space->bottom); if (! obj->IsByteObject()) PushToStack(obj); } return 0; } /* There's a problem sharing code objects if they have relative calls/jumps in them to other code. The code of two functions may be identical (e.g. they both call functions 100 bytes ahead) and so they will appear the same but if the functions they jump to are different they are actually different. For that reason we don't share code segments. DCJM 4/1/01 */ if (obj->IsCodeObject()) { // We want to update addresses in the code segment. m_parent->AddToVector(0, L, obj); PushToStack(obj); gMem.SpaceForObjectAddress(obj)->writeAble(obj)->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan return 0; } // Byte objects always have depth 1 and can't contain addresses. if (obj->IsByteObject()) { m_parent->AddToVector (1, L, obj);// add to vector at correct depth obj->SetLengthWord(OBJ_SET_DEPTH(1)); return 1; } ASSERT(OBJ_IS_WORD_OBJECT(L) || OBJ_IS_CLOSURE_OBJECT(L)); // That leaves immutable data objects. PushToStack(obj); obj->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan return 0; } // Adds an object to the stack. void ProcessAddToVector::PushToStack(PolyObject *obj) { if (asp == stackSize) { if (addStack == 0) { addStack = (PolyObject**)malloc(sizeof(PolyObject*) * 100); if (addStack == 0) throw MemoryException(); stackSize = 100; } else { unsigned newSize = stackSize+100; PolyObject** newStack = (PolyObject**)realloc(addStack, sizeof(PolyObject*) * newSize); if (newStack == 0) throw MemoryException(); stackSize = newSize; addStack = newStack; } } ASSERT(asp < stackSize); addStack[asp++] = obj; } // Processes the root and anything reachable from it. Addresses are added to the // explicit stack if an object has not yet been processed. Most of this function // is about processing the stack. void ProcessAddToVector::ProcessRoot(PolyObject *root) { // Mark the initial object AddObjectToDepthVector(root); // Process the stack until it's empty. while (asp != 0) { // Pop it from the stack. PolyObject *obj = addStack[asp-1]; if (obj->IsCodeObject()) { // Code cells are now only found in the code area. /* There's a problem sharing code objects if they have relative calls/jumps in them to other code. The code of two functions may be identical (e.g. they both call functions 100 bytes ahead) and so they will appear the same but if the functions they jump to are different they are actually different. For that reason we don't share code segments. DCJM 4/1/01 */ asp--; // Pop it because we'll process it completely ScanAddressesInObject(obj); // If it's local set the depth with the value zero. It has already been // added to the zero depth vector. if (obj->LengthWord() & _OBJ_GC_MARK) gMem.SpaceForObjectAddress(obj)->writeAble(obj)->SetLengthWord(OBJ_SET_DEPTH(0)); // Now scanned } else { POLYUNSIGNED length = obj->Length(); PolyWord *pt = (PolyWord*)obj; unsigned osp = asp; if (obj->IsClosureObject()) { // The first word of a closure is a code pointer. We don't share code but // we do want to share anything reachable from the constants. AddObjectToDepthVector(*(PolyObject**)pt); pt += sizeof(PolyObject*) / sizeof(PolyWord); length -= sizeof(PolyObject*) / sizeof(PolyWord); } if (((obj->LengthWord() & _OBJ_GC_MARK) && !obj->IsMutable())) { // Immutable local objects. These can be shared. We need to compute the // depth by computing the maximum of the depth of all the addresses in it. POLYUNSIGNED depth = 0; while (length != 0 && osp == asp) { POLYUNSIGNED d = AddPolyWordToDepthVectors(*pt); if (d > depth) depth = d; pt++; length--; } if (osp == asp) { // We've finished it asp--; // Pop this item. depth++; // One more for this object obj->SetLengthWord(obj->LengthWord() & (~_OBJ_GC_MARK)); m_parent->AddToVector(depth, obj->LengthWord() & (~_OBJ_GC_MARK), obj); obj->SetLengthWord(OBJ_SET_DEPTH(depth)); } } else { // Mutable or non-local objects. These have depth zero. Local objects have // _OBJ_GC_MARK in their header. Immutable permanent objects cannot be // modified so we don't set the depth. Mutable objects are added to the // depth vectors even though they aren't shared so that they will be // updated if they point to immutables that have been shared. while (length != 0) { if (!(*pt).IsTagged()) { // If we've already pushed an address break now if (osp != asp) break; // Process the address and possibly push it AddPolyWordToDepthVectors(*pt); } pt++; length--; } if (length == 0) { // We've finished it if (osp != asp) { ASSERT(osp == asp - 1); addStack[osp - 1] = addStack[osp]; } asp--; // Pop this item. if (obj->LengthWord() & _OBJ_GC_MARK) obj->SetLengthWord(OBJ_SET_DEPTH(0)); } } } } } // This is called by the root thread to do the work. bool ShareDataClass::RunShareData(PolyObject *root) { // We use a bitmap to indicate when we've visited an object to avoid // infinite recursion in cycles in the data. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (!space->isMutable && space->hierarchy == 0) { if (! space->shareBitmap.Create(space->spaceSize())) return false; } } POLYUNSIGNED totalObjects = 0; POLYUNSIGNED totalShared = 0; // Build the vectors from the immutable objects. bool success = true; try { ProcessAddToVector addToVector(this); addToVector.ProcessRoot(root); } catch (MemoryException &) { // If we ran out of memory we may still be able to process what we have. // That will also do any clean-up. success = false; } ProcessFixupAddress fixup; for (POLYUNSIGNED depth = 1; depth < maxVectorSize; depth++) { for (unsigned j = 0; j < FIXEDLENGTHSIZE; j++) { if (depth < depthVectorArray[j].size()) { DepthVector *vec = depthVectorArray[j][depth]; // Set the length word and update all addresses. vec->FixLengthAndAddresses(&fixup); vec->Sort(); POLYUNSIGNED n = vec->MergeSameItems(); if ((debugOptions & DEBUG_SHARING) && n > 0) Log("Sharing: Level %4" POLYUFMT ", size %3u, Objects %6" POLYUFMT ", Shared %6" POLYUFMT " (%1.0f%%)\n", depth, j, vec->ItemCount(), n, (float)n / (float)vec->ItemCount() * 100.0); totalObjects += vec->ItemCount(); totalShared += n; } } } if (debugOptions & DEBUG_SHARING) Log("Sharing: Maximum level %4" POLYUFMT ",\n", maxVectorSize); /* At this stage, we have fixed up most but not all of the forwarding pointers. The ones that we haven't fixed up arise from situations such as the following: X -> Y <-> Z i.e. Y and Z form a loop, and X is isomorphic to Z. When we assigned the depths, we have to arbitrarily break the loop between Y and Z. Suppose Y is assigned to level 1, and Z is assigned to level 2. When we process level 1 and fixup Y, there's nothing to do, since Z is still an ordinary object. However when we process level 2, we find that X and Z are isomorphic so we arbitrarily choose one of them and turn it into a "tombstone" pointing at the other. If we change Z into the tombstone, then Y now contains a pointer that needs fixing up. That's why we need the second fixup pass. Note also that if we had broken the loop the other way, we would have assigned Z to level 1, Y to level 2 and X to level 3, so we would have missed the chance to share Z and X. Perhaps that's why running the program repeatedly sometimes finds extra things to share? SPF 26/1/95 */ /* We have updated the addresses in objects with non-zero level so they point to the single occurrence but we need to do the same with level 0 objects (mutables and code). */ for (unsigned j = 0; j < FIXEDLENGTHSIZE; j++) { if (! depthVectorArray[j].empty()) { DepthVector *v = depthVectorArray[j][0]; // Log this because it could be very large. if (debugOptions & DEBUG_SHARING) Log("Sharing: Level %4" POLYUFMT ", size %3u, Objects %6" POLYUFMT "\n", 0ul, j, v->ItemCount()); v->FixLengthAndAddresses(&fixup); } } /* Previously we made a complete scan over the memory updating any addresses so that if we have shared two substructures within our root we would also share any external pointers. This has been removed but we have to reinstate the length words we've overwritten with forwarding pointers because there may be references to unshared objects from outside. */ for (POLYUNSIGNED d = 1; d < maxVectorSize; d++) { for (unsigned j = 0; j < FIXEDLENGTHSIZE; j++) { if (d < depthVectorArray[j].size()) { DepthVector *v = depthVectorArray[j][d]; v->RestoreForwardingPointers(); } } } if (debugOptions & DEBUG_SHARING) Log ("Sharing: Total Objects %6" POLYUFMT ", Total Shared %6" POLYUFMT " (%1.0f%%)\n", totalObjects, totalShared, (float)totalShared / (float)totalObjects * 100.0); return success; // Succeeded. } class ShareRequest: public MainThreadRequest { public: ShareRequest(Handle root): MainThreadRequest(MTP_SHARING), shareRoot(root), result(false) {} virtual void Perform() { ShareDataClass s; // Do a full GC. If we have a large heap the allocation of the vectors // can cause paging. Doing this now reduces the heap and discards the // allocation spaces. It may be overkill if we are applying the sharing // to a small root but generally it seems to be applied to the whole heap. FullGCForShareCommonData(); gcProgressBeginOtherGC(); // Set the phase to "other" now the GC is complete. // Now do the sharing. result = s.RunShareData(shareRoot->WordP()); } Handle shareRoot; bool result; }; // ShareData. This is the main entry point. // Because this can recurse deeply it needs to be run by the main thread. // Also it manipulates the heap in ways that could mess up other threads // so we need to stop them before executing this. void ShareData(TaskData *taskData, Handle root) { if (! root->Word().IsDataPtr()) return; // Nothing to do. We could do handle a code pointer but it shouldn't occur. // Request the main thread to do the sharing. ShareRequest request(root); processes->MakeRootRequest(taskData, &request); // Raise an exception if it failed. if (! request.result) raise_exception_string(taskData, EXC_Fail, "Insufficient memory"); } // RTS call entry. -POLYUNSIGNED PolyShareCommonData(FirstArgument threadId, PolyWord root) +POLYUNSIGNED PolyShareCommonData(POLYUNSIGNED threadId, POLYUNSIGNED root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - if (! root.IsDataPtr()) + if (!PolyWord::FromUnsigned(root).IsDataPtr()) return TAGGED(0).AsUnsigned(); // Nothing to do. // Request the main thread to do the sharing. ShareRequest request(taskData->saveVec.push(root)); processes->MakeRootRequest(taskData, &request); // Raise an exception if it failed. if (! request.result) raise_exception_string(taskData, EXC_Fail, "Insufficient memory"); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } struct _entrypts shareDataEPT[] = { { "PolyShareCommonData", (polyRTSFunction)&PolyShareCommonData}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/sighandler.cpp b/libpolyml/sighandler.cpp index cdd22262..fd6f6e3e 100644 --- a/libpolyml/sighandler.cpp +++ b/libpolyml/sighandler.cpp @@ -1,579 +1,579 @@ /* Title: Signal handling Author: David C.J. Matthews Copyright (c) 2000-8, 2016, 2019 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 */ #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_SYS_TYPES_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_ERRNO_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_IO_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_STDLIB_H #include // For malloc #endif #if (defined(HAVE_SEMAPHORE_H) && !defined(_WIN32)) // Don't include semaphore.h on Mingw. It's provided but doesn't compile. #include #endif #if (defined(_WIN32)) #define INVALIDSIGNAL ERROR_INVALID_PARAMETER #else #define INVALIDSIGNAL EINVAL #endif /* Signal handling is complicated in a multi-threaded environment. The pthread mutex and condition variables are not safe to use in a signal handler so we need to use POSIX semaphores since sem_post is safe. */ #if (defined(HAVE_STACK_T) && defined(HAVE_SIGALTSTACK)) extern "C" { // This is missing in older versions of Mac OS X int sigaltstack(const stack_t *, stack_t *); } #endif #include "globals.h" #include "arb.h" #include "run_time.h" #include "sighandler.h" #include "processes.h" #include "machine_dep.h" #include "sys.h" #include "save_vec.h" #include "rts_module.h" #include "gc.h" // For convertedWeak #include "scanaddrs.h" #include "locking.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolySetSignalHandler(FirstArgument threadId, PolyWord signalNo, PolyWord action); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWaitForSignal(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySetSignalHandler(POLYUNSIGNED threadId, POLYUNSIGNED signalNo, POLYUNSIGNED action); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWaitForSignal(POLYUNSIGNED threadId); } #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(word)) #define DEFAULT_SIG 0 #define IGNORE_SIG 1 #define HANDLE_SIG 2 // This is only used in SignalRequest static struct _sigData { bool nonMaskable; // True if this sig is used within the RTS. Must not be ignored or replaced PolyWord handler; // User-installed handler, TAGGED(DEFAULT_SIG) or TAGGED(IGNORE_SIG) int signalCount; } sigData[NSIG]; unsigned receivedSignalCount = 0; // Incremented each time we get a signal // sigLock protects access to the signalCount values in sigData but // not the "handler" field. static PLock sigLock; #if (!defined(_WIN32)) static PSemaphore *waitSema; static int lastSignals[NSIG]; static bool terminate = false; #endif // This must not be called from an asynchronous signal handler. static void signalArrived(int sig) { sigLock.Lock(); receivedSignalCount++; sigData[sig].signalCount++; sigLock.Unlock(); // To avoid deadlock we must release sigLock first. processes->SignalArrived(); } // Called whenever a signal handler is installed other than in this // module. Because modules are initialised in an unspecified order // we may have already masked off this signal. void markSignalInuse(int sig) { sigData[sig].nonMaskable = true; #if (!defined(_WIN32)) // Enable this signal. sigset_t sigset; sigemptyset(&sigset); sigaddset(&sigset, sig); pthread_sigmask(SIG_UNBLOCK, &sigset, NULL); #endif } /* Find the existing handler for this signal. */ static PolyWord findHandler(int sig) { if ((unsigned)sig >= NSIG) // Check it's in range. return TAGGED(DEFAULT_SIG); /* Not there - default action. */ else return sigData[sig].handler; } #if (defined(_WIN32) && ! defined(__CYGWIN__)) // This is called to simulate a SIGINT in Windows. void RequestConsoleInterrupt(void) { // The default action for SIGINT is to exit. if (findHandler(SIGINT) == TAGGED(DEFAULT_SIG)) processes->RequestProcessExit(2); // Exit with the signal value. else signalArrived(SIGINT); } #endif #if (!defined(_WIN32)) // Request the main thread to change the blocking state of a signal. class SignalRequest: public MainThreadRequest { public: SignalRequest(int s, int r): MainThreadRequest(MTP_SIGHANDLER), signl(s), state(r) {} virtual void Perform(); int signl, state; }; // Called whenever a signal is received. static void handle_signal(SIG_HANDLER_ARGS(s, c)) { if (waitSema != 0) { lastSignals[s]++; // Assume this is atomic with respect to reading. // Wake the signal detection thread. waitSema->Signal(); } } void SignalRequest::Perform() { struct sigaction action; memset(&action, 0, sizeof(action)); switch (state) { case DEFAULT_SIG: action.sa_handler = SIG_DFL; sigaction(signl, &action, 0); break; case IGNORE_SIG: action.sa_handler = SIG_IGN; sigaction(signl, &action, 0); break; case HANDLE_SIG: setSignalHandler(signl, handle_signal); break; } } #endif static Handle waitForSignal(TaskData *taskData) { while (true) { processes->ProcessAsynchRequests(taskData); // Check for kill. sigLock.Lock(); // Any pending signals? for (int sig = 0; sig < NSIG; sig++) { if (sigData[sig].signalCount > 0) { sigData[sig].signalCount--; if (!IS_INT(findHandler(sig))) /* If it's not DEFAULT or IGNORE. */ { // Create a pair of the handler and signal and pass // them back to be run. Handle pair = alloc_and_save(taskData, 2); // Have to call findHandler again here because that // allocation could have garbage collected. DEREFHANDLE(pair)->Set(0, findHandler(sig)); DEREFHANDLE(pair)->Set(1, TAGGED(sig)); sigLock.Unlock(); return pair; } } } if (convertedWeak) { // Last GC converted a weak SOME into NONE. This isn't // anything to do with signals but the signal thread can // deal with this. sigLock.Unlock(); convertedWeak = false; return SAVE(TAGGED(0)); } // No pending signal. Wait until we're woken up. // This releases sigLock after acquiring schedLock. if (! processes->WaitForSignal(taskData, &sigLock)) raise_exception_string(taskData, EXC_Fail, "Only one thread may wait for signals"); } } -POLYUNSIGNED PolySetSignalHandler(FirstArgument threadId, PolyWord signalNo, PolyWord action) +POLYUNSIGNED PolySetSignalHandler(POLYUNSIGNED threadId, POLYUNSIGNED signalNo, POLYUNSIGNED action) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedAction = taskData->saveVec.push(action); Handle oldaction = 0; try { { int sign; int action; { // Lock while we look at the signal vector but release // it before making a root request. PLocker locker(&sigLock); // We have to pass this to the main thread to // set up the signal handler. - sign = get_C_int(taskData, signalNo); + sign = get_C_int(taskData, PolyWord::FromUnsigned(signalNo)); /* Decode the action if it is Ignore or Default. */ if (pushedAction->Word().IsTagged()) action = (int)pushedAction->Word().UnTagged(); else action = HANDLE_SIG; /* Set the handler. */ if (sign <= 0 || sign >= NSIG) raise_syscall(taskData, "Invalid signal value", INVALIDSIGNAL); /* Get the old action before updating the vector. */ oldaction = SAVE(findHandler(sign)); // Now update it. sigData[sign].handler = pushedAction->Word(); } // Request a change in the masking by the root thread. // This doesn't do anything in Windows so the only "signal" // we affect is SIGINT and that is handled by RequestConsoleInterrupt. if (! sigData[sign].nonMaskable) { #if (!defined(_WIN32)) SignalRequest request(sign, action); processes->MakeRootRequest(taskData, &request); #endif } } } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (oldaction == 0) return TAGGED(0).AsUnsigned(); else return oldaction->Word().AsUnsigned(); } // Called by the signal handler thread. Blocks until a signal is available. -POLYUNSIGNED PolyWaitForSignal(FirstArgument threadId) +POLYUNSIGNED PolyWaitForSignal(POLYUNSIGNED threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = waitForSignal(taskData); } catch (KillException &) { processes->ThreadExit(taskData); // May test for kill } 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(); } // Set up per-thread signal data: basically signal stack. // This is really only needed for profiling timer signals. void initThreadSignals(TaskData *taskData) { #if (!(defined(_WIN32)||defined(MACOSX))) // On the i386, at least, we need to set up a signal stack for // each thread if it might receive a signal. ML code checks for // stack overflow but a signal could result in C code being // executed on the ML stack. The signal stack avoids this. // On some architectures the C stack pointer is left unused // when executing ML code so this isn't a problem. // In Linux each thread can receive a SIGVTALRM signal when // profiling. // This is currently disabled in Mac OS X. In 10.4 and before // setting a signal stack in a thread seemed to set it for the // whole process and crash with an illegal instruction on the // second signal. This isn't currently a problem since only the // main thread receives signals in Mac OS X. #if (defined(SA_ONSTACK) && defined(HAVE_SIGALTSTACK)) taskData->signalStack = malloc(SIGSTKSZ); #ifdef HAVE_STACK_T stack_t ex_stack; #else // This used to be used in FreeBSD and Mac OS X struct sigaltstack ex_stack; #endif memset(&ex_stack, 0, sizeof(ex_stack)); // Cast to char* because ss_sp is char* in FreeBSD. // Linux simply casts it back to void*. ex_stack.ss_sp = (char*)taskData->signalStack; ex_stack.ss_size = SIGSTKSZ; ex_stack.ss_flags = 0; /* not SS_DISABLE */ int sigaltstack_result = sigaltstack(&ex_stack, NULL); ASSERT(sigaltstack_result == 0); #endif #endif /* not the PC */ #if (!defined(_WIN32)) // Block all signals except those marked as in use by the RTS so // that they will only be picked up by the signal detection thread. // Since the signal mask is inherited we really don't need to do // this for every thread, just the initial one. sigset_t sigset; sigfillset(&sigset); for (int i = 0; i < NSIG; i++) { if (sigData[i].nonMaskable) sigdelset(&sigset, i); } pthread_sigmask(SIG_SETMASK, &sigset, NULL); #endif } /* General purpose function to set up a signal handler. */ #if (!defined(_WIN32)) bool setSignalHandler(int sig, signal_handler_type func) { struct sigaction sigcatch; memset(&sigcatch, 0, sizeof(sigcatch)); sigcatch.sa_sigaction = func; /* Both Linux and FreeBSD now use SA_SIGINFO in a similar way. If SA_SIGINFO is set the handler is supposed to be in sa_sigaction rather than sa_handler (actually this is a union so they're in the same place). */ init_asyncmask(&sigcatch.sa_mask); sigcatch.sa_flags = 0; #if defined(SA_ONSTACK) && defined(HAVE_SIGALTSTACK) sigcatch.sa_flags |= SA_ONSTACK; #endif #ifdef SA_RESTART sigcatch.sa_flags |= SA_RESTART; #endif #ifdef SA_SIGINFO sigcatch.sa_flags |= SA_SIGINFO; #endif #ifdef SV_SAVE_REGS sigcatch.sa_flags |= SV_SAVE_REGS; #endif return sigaction(sig, &sigcatch,NULL) >= 0; } // Signals to mask off when handling a signal. The signal being handled // is always masked off. This really only applied when emulation traps // and requests to GC involved signals. That no longer applies except // on the Sparc. void init_asyncmask(sigset_t *mask) { /* disable asynchronous interrupts while servicing interrupt */ sigemptyset(mask); sigaddset(mask,SIGVTALRM); sigaddset(mask,SIGINT); sigaddset(mask,SIGUSR2); sigaddset(mask,SIGWINCH); // This next used to be needed when emulation traps resulted in // signals. This no longer applies except on the Sparc. #ifdef SPARC sigaddset(mask,SIGILL); sigaddset(mask,SIGFPE); /* Mask off SIGSEGV. This is definitely needed when we are installing a handler for SIGINT under Linux and may also be needed in other cases as well e.g. SIGVTALRM. Without it typing control-C to a program which is taking lots of emulation traps can cause a crash because the signals are delivered in the "wrong" order and the pc value given to catchSEGV can point at the handler for SIGINT. DCJM 7/2/01. */ sigaddset(mask,SIGSEGV); /* And, just to be sure, include SIGBUS. DCJM 22/5/02. */ sigaddset(mask,SIGBUS); #endif } #endif struct _entrypts sigHandlerEPT[] = { { "PolySetSignalHandler", (polyRTSFunction)&PolySetSignalHandler}, { "PolyWaitForSignal", (polyRTSFunction)&PolyWaitForSignal}, { NULL, NULL} // End of list. }; class SigHandler: public RtsModule { public: virtual void Init(void); virtual void Stop(void); virtual void GarbageCollect(ScanAddress * /*process*/); #if (!defined(_WIN32)) SigHandler() { threadRunning = false; } pthread_t detectionThreadId; bool threadRunning; #endif }; // Declare this. It will be automatically added to the table. static SigHandler sighandlerModule; #if (!defined(_WIN32)) // This thread is really only to convert between POSIX semaphores and // pthread condition variables. It waits for a semphore to be released by the // signal handler running on the main thread and then wakes up the ML handler // thread. The ML thread must not wait directly on a POSIX semaphore because it // may also be woken by other events, particularly a kill request when the program // exits. static void *SignalDetectionThread(void *) { // Block all signals so they will be delivered to the main thread. sigset_t active_signals; sigfillset(&active_signals); pthread_sigmask(SIG_SETMASK, &active_signals, NULL); int readSignals[NSIG] = {0}; while (true) { if (waitSema == 0) return 0; // Wait until we are woken up by an arriving signal. // waitSema will be incremented for each signal so we should // not block until we have processed them all. if (! waitSema->Wait() || terminate) return 0; for (int j = 1; j < NSIG; j++) { if (readSignals[j] < lastSignals[j]) { readSignals[j]++; signalArrived(j); } } } } #endif void SigHandler::Init(void) { // Mark certain signals as non-maskable since they really // indicate a fatal error. #ifdef SIGSEGV sigData[SIGSEGV].nonMaskable = true; #endif #ifdef SIGBUS sigData[SIGBUS].nonMaskable = true; #endif #ifdef SIGILL sigData[SIGILL].nonMaskable = true; #endif #if (!defined(_WIN32)) static PSemaphore waitSemaphore; // Initialise the "wait" semaphore so that it blocks immediately. if (! waitSemaphore.Init(0, NSIG)) return; waitSema = &waitSemaphore; // Create a new thread to handle signals synchronously. // for it to finish. pthread_attr_t attrs; pthread_attr_init(&attrs); #ifdef PTHREAD_STACK_MIN #if (PTHREAD_STACK_MIN < 4096) pthread_attr_setstacksize(&attrs, 4096); // But not too small: FreeBSD makes it 2k #else pthread_attr_setstacksize(&attrs, PTHREAD_STACK_MIN); // Only small stack. #endif #endif threadRunning = pthread_create(&detectionThreadId, &attrs, SignalDetectionThread, 0) == 0; pthread_attr_destroy(&attrs); #endif } // Wait for the signal thread to finish before the semaphore is deleted in the // final clean-up. Failing to do this causes a hang in Mac OS X. void SigHandler::Stop(void) { #if (!defined(_WIN32)) terminate = true; waitSema->Signal(); pthread_join(detectionThreadId, NULL); #endif } void SigHandler::GarbageCollect(ScanAddress *process) { for (unsigned i = 0; i < NSIG; i++) { if (sigData[i].handler != PolyWord::FromUnsigned(0)) process->ScanRuntimeWord(&sigData[i].handler); } } diff --git a/libpolyml/statistics.cpp b/libpolyml/statistics.cpp index 027d9c79..b103803d 100644 --- a/libpolyml/statistics.cpp +++ b/libpolyml/statistics.cpp @@ -1,885 +1,885 @@ /* Title: statistics.cpp - Profiling statistics Copyright (c) 2011, 2013, 2015, 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_WINDOWS_H #include #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_MMAN_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_TIME_H #include #endif #ifdef HAVE_SYS_TIMES_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SYS_RESOURCE_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #if defined(HAVE_MMAP) // How do we get the page size? #ifndef HAVE_GETPAGESIZE #ifdef _SC_PAGESIZE #define getpagesize() sysconf(_SC_PAGESIZE) #else // If this fails we're stuck #define getpagesize() PAGESIZE #endif #endif #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #if (defined(_WIN32)) #include #else #define _T(x) x #endif #include #ifdef max #undef max #endif #include "run_time.h" #include "sys.h" #include "save_vec.h" #include "rts_module.h" #include "timing.h" #include "polystring.h" #include "processes.h" #include "statistics.h" #include "../polystatistics.h" #include "rtsentry.h" #include "arb.h" #include "diagnostics.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetUserStatsCount(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolySetUserStat(FirstArgument threadId, PolyWord index, PolyWord value); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLocalStats(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetRemoteStats(FirstArgument threadId, PolyWord procId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySetUserStat(POLYUNSIGNED threadId, POLYUNSIGNED index, POLYUNSIGNED value); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLocalStats(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetRemoteStats(POLYUNSIGNED threadId, POLYUNSIGNED procId); } #define STATS_SPACE 4096 // Enough for all the statistics #define ASN1_U_BOOL 1 #define ASN1_U_INT 2 #define ASN1_U_STRING 4 #define ASN1_U_NULL 5 #define ASN1_U_ENUM 10 #define ASN1_U_SEQUENCE 16 // For the moment we don't bother to interlock access to the statistics memory. // Other processes only read the memory and at worst they may get a glitch in // the values. Statistics::Statistics(): accessLock("Statistics") { statMemory = 0; memSize = 0; newPtr = 0; for (unsigned i = 0; i < N_PS_INTS; i++) counterAddrs[i] = 0; for (unsigned j = 0; j < N_PS_TIMES; j++) timeAddrs[j].secAddr = timeAddrs[j].usecAddr = 0; for (unsigned k = 0; k < N_PS_USER; k++) userAddrs[k] = 0; memset(&gcUserTime, 0, sizeof(gcUserTime)); memset(&gcSystemTime, 0, sizeof(gcSystemTime)); memset(&gcRealTime, 0, sizeof(gcRealTime)); #ifdef _WIN32 // File mapping handle hFileMap = NULL; exportStats = true; // Actually unused #else mapFd = -1; mapFileName = 0; exportStats = false; // Don't export by default #endif memSize = 0; statMemory = 0; newPtr = 0; } #ifdef _WIN32 // In Windows we always create shared memory for the statistics. // If this fails just create local stats. bool Statistics::createWindowsSharedStats() { // Get the process ID to use in the shared memory name DWORD pid = ::GetCurrentProcessId(); TCHAR shmName[MAX_PATH]; wsprintf(shmName, _T(POLY_STATS_NAME) _T("%lu"), pid); // Create a piece of shared memory hFileMap = CreateFileMapping(INVALID_HANDLE_VALUE, NULL, PAGE_READWRITE, 0, STATS_SPACE, shmName); if (hFileMap == NULL) return false; // If it already exists it's the wrong one. if (GetLastError() == ERROR_ALREADY_EXISTS) { CloseHandle(hFileMap); hFileMap = NULL; return false; } statMemory = (unsigned char*)MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, STATS_SPACE); if (statMemory == NULL) { CloseHandle(hFileMap); hFileMap = NULL; return false; } memSize = STATS_SPACE; return true; } #endif void Statistics::Init() { #ifdef _WIN32 // Record an initial time of day to use as the basis of real timing GetSystemTimeAsFileTime(&startTime); createWindowsSharedStats(); #else // Record an initial time of day to use as the basis of real timing gettimeofday(&startTime, NULL); // On Unix we need to specify --exportstats but if we do and have a problem we exit. if (exportStats) { // Create the shared memory in the user's .polyml directory int pageSize = getpagesize(); memSize = (STATS_SPACE + pageSize-1) & ~(pageSize-1); char* polyStatsDir = getenv("POLYSTATSDIR"); if (!polyStatsDir || !createSharedStats(polyStatsDir, "")) { char* homeDir = getenv("HOME"); if (homeDir == NULL) Exit("Unable to create shared statistics - HOME is not defined"); if (!createSharedStats(homeDir, "/.polyml")) Exit("Unable to create shared statistics"); } } #endif if (statMemory == 0) { // If we just want the statistics locally. statMemory = (unsigned char*)calloc(STATS_SPACE, sizeof(unsigned char)); if (statMemory == 0) return; memSize = STATS_SPACE; } // Set up the ASN1 structure in the statistics area. newPtr = statMemory; *newPtr++ = POLY_STATS_C_STATISTICS; // Context tag for statistics *newPtr++ = 0x82; // Extended length, 2 bytes *newPtr++ = 0x00; // Length is initially zero *newPtr++ = 0x00; addCounter(PSC_THREADS, POLY_STATS_ID_THREADS, "ThreadCount"); addCounter(PSC_THREADS_IN_ML, POLY_STATS_ID_THREADS_IN_ML, "ThreadsInML"); addCounter(PSC_THREADS_WAIT_IO, POLY_STATS_ID_THREADS_WAIT_IO, "ThreadsInIOWait"); addCounter(PSC_THREADS_WAIT_MUTEX, POLY_STATS_ID_THREADS_WAIT_MUTEX, "ThreadsInMutexWait"); addCounter(PSC_THREADS_WAIT_CONDVAR, POLY_STATS_ID_THREADS_WAIT_CONDVAR, "ThreadsInCondVarWait"); addCounter(PSC_THREADS_WAIT_SIGNAL, POLY_STATS_ID_THREADS_WAIT_SIGNAL, "ThreadsInSignalWait"); addCounter(PSC_GC_FULLGC, POLY_STATS_ID_GC_FULLGC, "FullGCCount"); addCounter(PSC_GC_PARTIALGC, POLY_STATS_ID_GC_PARTIALGC, "PartialGCCount"); addCounter(PSC_GC_SHARING, POLY_STATS_ID_GC_SHARING, "GCSharingCount"); addCounter(PSC_GC_STATE, POLY_STATS_ID_GC_STATE, "GCState"); addCounter(PSC_GC_PERCENT, POLY_STATS_ID_GC_PERCENT, "GCPercent"); addSize(PSS_TOTAL_HEAP, POLY_STATS_ID_TOTAL_HEAP, "TotalHeap"); addSize(PSS_AFTER_LAST_GC, POLY_STATS_ID_AFTER_LAST_GC, "HeapAfterLastGC"); addSize(PSS_AFTER_LAST_FULLGC, POLY_STATS_ID_AFTER_LAST_FULLGC, "HeapAfterLastFullGC"); addSize(PSS_ALLOCATION, POLY_STATS_ID_ALLOCATION, "AllocationSpace"); addSize(PSS_ALLOCATION_FREE, POLY_STATS_ID_ALLOCATION_FREE, "AllocationSpaceFree"); addSize(PSS_CODE_SPACE, POLY_STATS_ID_CODE_SPACE, "CodeSpace"); addSize(PSS_STACK_SPACE, POLY_STATS_ID_STACK_SPACE, "StackSpace"); addTime(PST_NONGC_UTIME, POLY_STATS_ID_NONGC_UTIME, "NonGCUserTime"); addTime(PST_NONGC_STIME, POLY_STATS_ID_NONGC_STIME, "NonGCSystemTime"); addTime(PST_GC_UTIME, POLY_STATS_ID_GC_UTIME, "GCUserTime"); addTime(PST_GC_STIME, POLY_STATS_ID_GC_STIME, "GCSystemTime"); addTime(PST_NONGC_RTIME, POLY_STATS_ID_NONGC_RTIME, "NonGCRealTime"); addTime(PST_GC_RTIME, POLY_STATS_ID_GC_RTIME, "GCRealTime"); addUser(0, POLY_STATS_ID_USER0, "UserCounter0"); addUser(1, POLY_STATS_ID_USER1, "UserCounter1"); addUser(2, POLY_STATS_ID_USER2, "UserCounter2"); addUser(3, POLY_STATS_ID_USER3, "UserCounter3"); addUser(4, POLY_STATS_ID_USER4, "UserCounter4"); addUser(5, POLY_STATS_ID_USER5, "UserCounter5"); addUser(6, POLY_STATS_ID_USER6, "UserCounter6"); addUser(7, POLY_STATS_ID_USER7, "UserCounter7"); } #ifndef _WIN32 // Try to create a shared memory file in the appropriate directory. bool Statistics::createSharedStats(const char* baseName, const char* subDirName) { size_t tMapSize = strlen(baseName) + strlen(subDirName) + strlen(POLY_STATS_NAME) + 100; TempCString tMapFileName((char*)malloc(tMapSize)); // First construct the directory name because it may not exist. if (subDirName[0] != 0) { int cx = snprintf(tMapFileName, tMapSize, "%s%s", baseName, subDirName); if (cx < 0 || (size_t)cx >= tMapSize) return -1; mkdir(tMapFileName, 0777); } int cx = snprintf(tMapFileName, tMapSize, "%s%s/%s%d", baseName, subDirName, POLY_STATS_NAME, getpid()); if (cx < 0 || (size_t)cx >= tMapSize) return -1; // Remove any existing file. We're creating with 0444 so if there's an old one // left over from a previous crash we won't be able to reopen it. unlink(tMapFileName); // Open the file. mapFd = open(tMapFileName, O_RDWR | O_CREAT, 0444); if (mapFd == -1) return false; if (ftruncate(mapFd, memSize) == -1) return false; statMemory = (unsigned char*)mmap(0, memSize, PROT_READ | PROT_WRITE, MAP_SHARED, mapFd, 0); if (statMemory == MAP_FAILED) return false; memset(statMemory, 0, memSize); // Set the file name to this. mapFileName = tMapFileName; tMapFileName = 0; return true; } #endif void Statistics::addCounter(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_COUNTERSTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the counter itself. // This, along with the other counters, is technically incorrect // for an ASN1 integer because it should not contain more than // one zero byte. *newPtr++ = POLY_STATS_C_COUNTER_VALUE; *newPtr++ = sizeof(POLYUNSIGNED); counterAddrs[cEnum] = newPtr; // This is the address for (unsigned j = 0; j < sizeof(POLYUNSIGNED); j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addSize(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_SIZESTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the size value itself. We have to allow one // byte extra to ensure that the value we encode is unsigned. unsigned bytes = sizeof(size_t) + 1; *newPtr++ = POLY_STATS_C_BYTE_COUNT; *newPtr++ = bytes; counterAddrs[cEnum] = newPtr; // This is the address for (unsigned j = 0; j < bytes; j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addTime(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_TIMESTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the time. Two four byte values. *newPtr++ = POLY_STATS_C_TIME; *newPtr++ = 12; *newPtr++ = POLY_STATS_C_SECONDS; *newPtr++ = 4; timeAddrs[cEnum].secAddr = newPtr; // This is the address for (unsigned j = 0; j < 4; j++) *newPtr++ = 0; *newPtr++ = POLY_STATS_C_MICROSECS; *newPtr++ = 4; timeAddrs[cEnum].usecAddr = newPtr; // This is the address for (unsigned k = 0; k < 4; k++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addUser(int n, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_USERSTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the counter itself. For a user counter the value is a POLYSIGNED. *newPtr++ = POLY_STATS_C_COUNTER_VALUE; *newPtr++ = sizeof(POLYSIGNED); userAddrs[n] = newPtr; // This is the address for (unsigned j = 0; j < sizeof(POLYSIGNED); j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } Statistics::~Statistics() { #ifdef _WIN32 if (hFileMap != NULL) { if (statMemory != NULL) ::UnmapViewOfFile(statMemory); ::CloseHandle(hFileMap); statMemory = NULL; } #else if (mapFileName != 0) { if (statMemory != 0 && statMemory != MAP_FAILED) munmap(statMemory, memSize); if (mapFd != -1) close(mapFd); if (mapFileName != 0) unlink(mapFileName); free(mapFileName); statMemory = NULL; } #endif if (statMemory) free(statMemory); } // Counters. These are used for thread state so need interlocks void Statistics::incCount(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); unsigned length = counterAddrs[which][-1]; while (length--) { if ((++counterAddrs[which][length]) != 0) break; } } } void Statistics::decCount(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); unsigned length = counterAddrs[which][-1]; while (length--) { if ((counterAddrs[which][length]--) != 0) break; } } } // This is only used for the GC progress which could really fit in a single byte. void Statistics::setCount(int which, POLYUNSIGNED count) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); unsigned length = counterAddrs[which][-1]; while (length--) { counterAddrs[which][length] = (unsigned char)(count & 0xff); count = count >> 8; } } } // Sizes. Some of these are only set during GC so may not need interlocks size_t Statistics::getSizeWithLock(int which) { unsigned length = counterAddrs[which][-1]; size_t result = 0; for (unsigned i = 0; i < length; i++) result = (result << 8) | counterAddrs[which][i]; return result; } void Statistics::setSizeWithLock(int which, size_t s) { unsigned length = counterAddrs[which][-1]; while (length--) { counterAddrs[which][length] = (unsigned char)(s & 0xff); s = s >> 8; } } void Statistics::setSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, s); } } void Statistics::incSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, getSizeWithLock(which) + s); } } void Statistics::decSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, getSizeWithLock(which) - s); } } size_t Statistics::getSize(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); return getSizeWithLock(which); } else return 0; } void Statistics::setTimeValue(int which, unsigned long secs, unsigned long usecs) { if (statMemory && timeAddrs[which].secAddr && timeAddrs[which].usecAddr) { PLocker lock(&accessLock); // Necessary ??? unsigned sLength = timeAddrs[which].secAddr[-1]; while (sLength--) { timeAddrs[which].secAddr[sLength] = (unsigned char)(secs & 0xff); secs = secs >> 8; } unsigned usLength = timeAddrs[which].usecAddr[-1]; while (usLength--) { timeAddrs[which].usecAddr[usLength] = (unsigned char)(usecs & 0xff); usecs = usecs >> 8; } } } #if (defined(_WIN32)) // Native Windows void Statistics::copyGCTimes(const FILETIME &gcUtime, const FILETIME &gcStime, const FILETIME &gcRtime) { gcUserTime = gcUtime; gcSystemTime = gcStime; ULARGE_INTEGER li; li.LowPart = gcUtime.dwLowDateTime; li.HighPart = gcUtime.dwHighDateTime; setTimeValue(PST_GC_UTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = gcStime.dwLowDateTime; li.HighPart = gcStime.dwHighDateTime; setTimeValue(PST_GC_STIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = gcRtime.dwLowDateTime; li.HighPart = gcRtime.dwHighDateTime; setTimeValue(PST_GC_RTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); } #else // Unix void Statistics::copyGCTimes(const struct timeval &gcUtime, const struct timeval &gcStime, const struct timeval &gcRtime) { gcUserTime = gcUtime; gcSystemTime = gcStime; setTimeValue(PST_GC_UTIME, gcUtime.tv_sec, gcUtime.tv_usec); setTimeValue(PST_GC_STIME, gcStime.tv_sec, gcStime.tv_usec); setTimeValue(PST_GC_RTIME, gcRtime.tv_sec, gcRtime.tv_usec); } #endif // Update the statistics that are not otherwise copied. Called from the // root thread every second. void Statistics::updatePeriodicStats(size_t freeWords, unsigned threadsInML) { setSize(PSS_ALLOCATION_FREE, freeWords*sizeof(PolyWord)); #if (defined(_WIN32)) FILETIME ct, et, st, ut, rt; GetProcessTimes(GetCurrentProcess(), &ct, &et, &st, &ut); GetSystemTimeAsFileTime(&rt); subFiletimes(&st, &gcSystemTime); subFiletimes(&ut, &gcUserTime); subFiletimes(&rt, &startTime); subFiletimes(&rt, &gcRealTime); ULARGE_INTEGER li; li.LowPart = ut.dwLowDateTime; li.HighPart = ut.dwHighDateTime; setTimeValue(PST_NONGC_UTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = st.dwLowDateTime; li.HighPart = st.dwHighDateTime; setTimeValue(PST_NONGC_STIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = rt.dwLowDateTime; li.HighPart = rt.dwHighDateTime; setTimeValue(PST_NONGC_RTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); #else struct rusage usage; struct timeval tv; getrusage(RUSAGE_SELF, &usage); gettimeofday(&tv, NULL); subTimevals(&usage.ru_stime, &gcSystemTime); subTimevals(&usage.ru_utime, &gcUserTime); subTimevals(&tv, &startTime); subTimevals(&tv, &gcRealTime); setTimeValue(PST_NONGC_UTIME, usage.ru_utime.tv_sec, usage.ru_utime.tv_usec); setTimeValue(PST_NONGC_STIME, usage.ru_stime.tv_sec, usage.ru_stime.tv_usec); setTimeValue(PST_NONGC_RTIME, tv.tv_sec, tv.tv_usec); #endif if (statMemory && counterAddrs[PSC_THREADS_IN_ML]) { PLocker lock(&accessLock); unsigned length = counterAddrs[PSC_THREADS_IN_ML][-1]; while (length--) { counterAddrs[PSC_THREADS_IN_ML][length] = (unsigned char)(threadsInML & 0xff); threadsInML = threadsInML >> 8; } } } void Statistics::setUserCounter(unsigned which, POLYSIGNED value) { if (statMemory && userAddrs[which]) { PLocker lock(&accessLock); // Not really needed // The ASN1 int is big-endian unsigned length = userAddrs[which][-1]; while (length--) { userAddrs[which][length] = (unsigned char)value; value = value >> 8; } } } Handle Statistics::returnStatistics(TaskData *taskData, const unsigned char *stats, size_t size) { // Just return the memory as a string i.e. Word8Vector.vector. return taskData->saveVec.push(C_string_to_Poly(taskData, (const char*)stats, size)); } // Copy the local statistics into the buffer Handle Statistics::getLocalStatistics(TaskData *taskData) { if (statMemory == 0) raise_exception_string(taskData, EXC_Fail, "No statistics available"); return returnStatistics(taskData, statMemory, memSize); } // Get statistics for a remote instance. We don't do any locking Handle Statistics::getRemoteStatistics(TaskData *taskData, POLYUNSIGNED pid) { #ifdef _WIN32 TCHAR shmName[MAX_PATH]; wsprintf(shmName, _T(POLY_STATS_NAME) _T("%lu"), pid); HANDLE hRemMemory = OpenFileMapping(FILE_MAP_READ, FALSE, shmName); if (hRemMemory == NULL) raise_exception_string(taskData, EXC_Fail, "No statistics available"); unsigned char *sMem = (unsigned char *)MapViewOfFile(hRemMemory, FILE_MAP_READ, 0, 0, 0); if (sMem == NULL) { CloseHandle(hRemMemory); raise_exception_string(taskData, EXC_Fail, "No statistics available"); } // The size may not be the size of the statistics for this process // because we may be using a different version of Poly/ML. It should // still be properly formatted ASN1. MEMORY_BASIC_INFORMATION memInfo; SIZE_T buffSize = VirtualQuery(sMem, &memInfo, sizeof(memInfo)); if (buffSize == 0) { UnmapViewOfFile(sMem); CloseHandle(hRemMemory); raise_exception_string(taskData, EXC_Fail, "Unable to get statistics"); } Handle result = returnStatistics(taskData, sMem, memInfo.RegionSize); UnmapViewOfFile(sMem); CloseHandle(hRemMemory); return result; #else int remMapFd = -1; char* polyStatsDir = getenv("POLYSTATSDIR"); if (polyStatsDir) remMapFd = openSharedStats(polyStatsDir, "", pid); if (remMapFd == -1) { char* homeDir = getenv("HOME"); if (homeDir) remMapFd = openSharedStats(homeDir, "/.polyml", pid); } if (remMapFd == -1) raise_exception_string(taskData, EXC_Fail, "No statistics available"); struct stat statBuf; if (fstat(remMapFd, &statBuf) == -1) { close(remMapFd); raise_exception_string(taskData, EXC_Fail, "No statistics available"); } TempCString statData((char*)malloc(statBuf.st_size)); if (statData == NULL) { close(remMapFd); raise_exception_string(taskData, EXC_Fail, "No statistics available"); } ssize_t haveRead = read(remMapFd, statData, statBuf.st_size); close(remMapFd); if (haveRead < 0) raise_exception_string(taskData, EXC_Fail, "No statistics available"); return returnStatistics(taskData, (const unsigned char*)(const char *)statData, statBuf.st_size); #endif } #ifndef _WIN32 // Try to open a shared statistics file int Statistics::openSharedStats(const char* baseName, const char* subDirName, int pid) { size_t remMapSize = strlen(baseName) + strlen(subDirName) + strlen(POLY_STATS_NAME) + 100; TempCString remMapFileName((char*)malloc(remMapSize)); int cx = snprintf(remMapFileName, remMapSize, "%s%s/%s%d", baseName, subDirName, POLY_STATS_NAME, pid); if (cx < 0 || (size_t)cx >= remMapSize) return -1; // Open the file. return open(remMapFileName, O_RDONLY); } #endif // Create the global statistics object. Statistics globalStats; POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetUserStatsCount() { return TAGGED(N_PS_USER).AsUnsigned(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolySetUserStat(FirstArgument threadId, PolyWord indexVal, PolyWord valueVal) +POLYEXTERNALSYMBOL POLYUNSIGNED PolySetUserStat(POLYUNSIGNED threadId, POLYUNSIGNED indexVal, POLYUNSIGNED valueVal) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - unsigned index = get_C_unsigned(taskData, indexVal); + unsigned index = get_C_unsigned(taskData, PolyWord::FromUnsigned(indexVal)); if (index >= N_PS_USER) raise_exception0(taskData, EXC_subscript); - POLYSIGNED value = getPolySigned(taskData, valueVal); + POLYSIGNED value = getPolySigned(taskData, PolyWord::FromUnsigned(valueVal)); globalStats.setUserCounter(index, value); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLocalStats(FirstArgument threadId) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLocalStats(POLYUNSIGNED threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = globalStats.getLocalStatistics(taskData); } 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(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetRemoteStats(FirstArgument threadId, PolyWord procId) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetRemoteStats(POLYUNSIGNED threadId, POLYUNSIGNED procId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - result = globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, procId)); + result = globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, PolyWord::FromUnsigned(procId))); } 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(); } struct _entrypts statisticsEPT[] = { { "PolyGetUserStatsCount", (polyRTSFunction)&PolyGetUserStatsCount }, { "PolySetUserStat", (polyRTSFunction)&PolySetUserStat }, { "PolyGetLocalStats", (polyRTSFunction)&PolyGetLocalStats }, { "PolyGetRemoteStats", (polyRTSFunction)&PolyGetRemoteStats }, { NULL, NULL } // End of list. }; diff --git a/libpolyml/timing.cpp b/libpolyml/timing.cpp index 72b2bf3b..f42a4670 100644 --- a/libpolyml/timing.cpp +++ b/libpolyml/timing.cpp @@ -1,803 +1,803 @@ /* Title: Time functions. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 Cambridge University Technical Services Limited Further development copyright David C.J. Matthews 2011,12,16,19-20 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_STDLIB_H #include #endif #ifdef HAVE_LOCALE_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_TIME_H #include #endif #ifdef HAVE_SYS_TIMES_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SYS_RESOURCE_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_WINDOWS_H #include #endif #include // Windows headers define min/max macros, which messes up trying to use std::numeric_limits::min/max() #ifdef min #undef min #endif #ifdef max #undef max #endif #include "locking.h" #include "globals.h" #include "arb.h" #include "run_time.h" #include "sys.h" #include "timing.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "processes.h" #include "heapsizing.h" #include "rtsentry.h" #include "mpoly.h" // For polyStderr extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingTicksPerMicroSec(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetNow(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingBaseYear(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingYearOffset(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingLocalOffset(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingSummerApplies(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingConvertDateStuct(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetUser(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetSystem(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetGCUser(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetReal(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetChildUser(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetChildSystem(FirstArgument threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetGCSystem(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingTicksPerMicroSec(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetNow(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingBaseYear(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingYearOffset(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingLocalOffset(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingSummerApplies(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingConvertDateStuct(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetUser(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetSystem(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetGCUser(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetReal(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetChildUser(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetChildSystem(POLYUNSIGNED threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetGCSystem(POLYUNSIGNED threadId); } #if (defined(_WIN32)) /* Windows file times are 64-bit numbers representing times in tenths of a microsecond. */ #define TICKS_PER_MICROSECOND 10 #ifdef __GNUC__ #define SECSSINCE1601 11644473600LL #else #define SECSSINCE1601 11644473600 #endif #else /* For Unix return times in microseconds. */ #define TICKS_PER_MICROSECOND 1 #endif /* The original Poly timing functions used a variety of timing bases (e.g. seconds, tenths of a second). The old functions have been retained but the intention is to phase them out in favour of new functions. Most of these are handled through the timing_dispatch function. The intention behind the timing functions is to make use of the arbitrary precision arithmetic to allow for a wider range of dates than the usual mktime range of 1970 to 2036. We also want to handle more accurate timing than per second or per microsecond where the operating system provides it. */ #if (defined(_WIN32)) static FILETIME startTime; #define StrToLL _strtoi64 #else static struct timeval startTime; #define StrToLL strtoll #endif #if(!(defined(HAVE_GMTIME_R) && defined(HAVE_LOCALTIME_R))) // gmtime and localtime are not re-entrant so if we don't have the // re-entrant versions we need to use a lock. static PLock timeLock("Timing"); #endif #define XSTR(X) STR(X) #define STR(X) #X // Get ticks per microsecond. -POLYUNSIGNED PolyTimingTicksPerMicroSec(FirstArgument threadId) +POLYUNSIGNED PolyTimingTicksPerMicroSec(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = Make_arbitrary_precision(taskData, TICKS_PER_MICROSECOND); } 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(); } /* Return time since the time base. */ -POLYUNSIGNED PolyTimingGetNow(FirstArgument threadId) +POLYUNSIGNED PolyTimingGetNow(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32)) FILETIME ft; GetSystemTimeAsFileTime(&ft); result = Make_arb_from_Filetime(taskData, ft); #else struct timeval tv; if (gettimeofday(&tv, NULL) != 0) raise_syscall(taskData, "gettimeofday failed", errno); result = Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #endif } 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(); } /* Return the base year. This is the year which corresponds to zero in the timing sequence. */ -POLYUNSIGNED PolyTimingBaseYear(FirstArgument threadId) +POLYUNSIGNED PolyTimingBaseYear(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32)) result = Make_arbitrary_precision(taskData, 1601); #else result = Make_arbitrary_precision(taskData, 1970); #endif } 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(); } /* In both Windows and Unix the time base is 1st of January in the base year. This function is provided just in case we are running on a system with a different base. It returns the number of seconds after 1st January of the base year that corresponds to zero of the time base. */ -POLYUNSIGNED PolyTimingYearOffset(FirstArgument threadId) +POLYUNSIGNED PolyTimingYearOffset(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = Make_arbitrary_precision(taskData, 0); } 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(); } /* Return the time offset which applied/will apply at the specified time (in seconds). */ -POLYUNSIGNED PolyTimingLocalOffset(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyTimingLocalOffset(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { int localoff = 0; time_t theTime; int day = 0; #if (defined(HAVE_GMTIME_R) || defined(HAVE_LOCALTIME_R)) struct tm resultTime; #endif #if (defined(_WIN32)) /* Although the offset is in seconds it is since 1601. */ FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. getFileTimeFromArb(taskData, pushedArg, &ftSeconds); /* May raise exception. */ ULARGE_INTEGER liTime; liTime.HighPart = ftSeconds.dwHighDateTime; liTime.LowPart = ftSeconds.dwLowDateTime; theTime = (long)(liTime.QuadPart - SECSSINCE1601); #else theTime = get_C_long(taskData, DEREFWORD(pushedArg)); /* May raise exception. */ #endif { #ifdef HAVE_GMTIME_R struct tm* loctime = gmtime_r(&theTime, &resultTime); #else PLocker lock(&timeLock); struct tm* loctime = gmtime(&theTime); #endif if (loctime == NULL) raise_exception0(taskData, EXC_size); localoff = (loctime->tm_hour * 60 + loctime->tm_min) * 60 + loctime->tm_sec; day = loctime->tm_yday; } { #ifdef HAVE_LOCALTIME_R struct tm* loctime = localtime_r(&theTime, &resultTime); #else PLocker lock(&timeLock); struct tm* loctime = localtime(&theTime); #endif if (loctime == NULL) raise_exception0(taskData, EXC_size); localoff -= (loctime->tm_hour * 60 + loctime->tm_min) * 60 + loctime->tm_sec; if (loctime->tm_yday != day) { // Different day - have to correct it. We can assume that there // is at most one day to correct. if (day == loctime->tm_yday + 1 || (day == 0 && loctime->tm_yday >= 364)) localoff += 24 * 60 * 60; else localoff -= 24 * 60 * 60; } } result = Make_arbitrary_precision(taskData, localoff); } 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(); } /* Find out if Summer Time (daylight saving) was/will be in effect. */ -POLYUNSIGNED PolyTimingSummerApplies(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyTimingSummerApplies(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { time_t theTime; #if (defined(_WIN32)) FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. getFileTimeFromArb(taskData, pushedArg, &ftSeconds); /* May raise exception. */ ULARGE_INTEGER liTime; liTime.HighPart = ftSeconds.dwHighDateTime; liTime.LowPart = ftSeconds.dwLowDateTime; theTime = (long)(liTime.QuadPart - SECSSINCE1601); #else theTime = get_C_long(taskData, DEREFWORD(pushedArg)); /* May raise exception. */ #endif int isDst = 0; #ifdef HAVE_LOCALTIME_R struct tm resultTime; struct tm* loctime = localtime_r(&theTime, &resultTime); isDst = loctime->tm_isdst; #else { PLocker lock(&timeLock); struct tm* loctime = localtime(&theTime); if (loctime == NULL) raise_exception0(taskData, EXC_size); isDst = loctime->tm_isdst; } #endif result = Make_arbitrary_precision(taskData, isDst); } 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 strftime. It would be possible to do much of this in ML except that it requires the current locale. */ -POLYUNSIGNED PolyTimingConvertDateStuct(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyTimingConvertDateStuct(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { struct tm time; char* format, buff[2048]; Handle resString; /* Get the format string. */ format = Poly_string_to_C_alloc(DEREFHANDLE(pushedArg)->Get(0)); /* Copy the time information. */ time.tm_year = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(1)) - 1900; time.tm_mon = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(2)); time.tm_mday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(3)); time.tm_hour = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(4)); time.tm_min = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(5)); time.tm_sec = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(6)); time.tm_wday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(7)); time.tm_yday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(8)); time.tm_isdst = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(9)); #if (defined(_WIN32)) _tzset(); /* Make sure we set the current locale. */ #else setlocale(LC_TIME, ""); #endif /* It would be better to dynamically allocate the string rather than use a fixed size but Unix unlike Windows does not distinguish between an error in the input and the buffer being too small. */ if (strftime(buff, sizeof(buff), format, &time) <= 0) { /* Error */ free(format); raise_exception0(taskData, EXC_size); } resString = taskData->saveVec.push(C_string_to_Poly(taskData, buff)); free(format); result = resString; } 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(); } /* Return User CPU time since the start. */ -POLYUNSIGNED PolyTimingGetUser(FirstArgument threadId) +POLYUNSIGNED PolyTimingGetUser(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32)) FILETIME ut, ct, et, kt; if (!GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); result = Make_arb_from_Filetime(taskData, ut); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); result = Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, rusage.ru_utime.tv_usec, 1000000); #endif } 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(); } /* Return System CPU time since the start. */ -POLYUNSIGNED PolyTimingGetSystem(FirstArgument threadId) +POLYUNSIGNED PolyTimingGetSystem(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32)) FILETIME ct, et, kt, ut; if (!GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); result = Make_arb_from_Filetime(taskData, kt); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); result = Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, rusage.ru_stime.tv_usec, 1000000); #endif } 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(); } /* Return GC time since the start. */ -POLYUNSIGNED PolyTimingGetGCUser(FirstArgument threadId) +POLYUNSIGNED PolyTimingGetGCUser(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = gHeapSizeParameters.getGCUtime(taskData); } 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(); } /* Return real time since the start. */ -POLYUNSIGNED PolyTimingGetReal(FirstArgument threadId) +POLYUNSIGNED PolyTimingGetReal(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32)) FILETIME ft; GetSystemTimeAsFileTime(&ft); subFiletimes(&ft, &startTime); result = Make_arb_from_Filetime(taskData, ft); #else struct timeval tv; if (gettimeofday(&tv, NULL) != 0) raise_syscall(taskData, "gettimeofday failed", errno); subTimevals(&tv, &startTime); result = Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #endif } 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(); } /* Return User CPU time used by child processes. (Posix only) */ -POLYUNSIGNED PolyTimingGetChildUser(FirstArgument threadId) +POLYUNSIGNED PolyTimingGetChildUser(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32)) result = Make_arbitrary_precision(taskData, 0); #else struct rusage rusage; if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); result = Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, rusage.ru_utime.tv_usec, 1000000); #endif } 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(); } /* Return System CPU time used by child processes. (Posix only) */ -POLYUNSIGNED PolyTimingGetChildSystem(FirstArgument threadId) +POLYUNSIGNED PolyTimingGetChildSystem(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { #if (defined(_WIN32)) result = Make_arbitrary_precision(taskData, 0); #else struct rusage rusage; if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); result = Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, rusage.ru_stime.tv_usec, 1000000); #endif } 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(); } /* Return GC system time since the start. */ -POLYUNSIGNED PolyTimingGetGCSystem(FirstArgument threadId) +POLYUNSIGNED PolyTimingGetGCSystem(POLYUNSIGNED threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = gHeapSizeParameters.getGCStime(taskData); } 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(); } #ifdef _WIN32 void addFiletimes(FILETIME *result, const FILETIME *x) { ULARGE_INTEGER liA, liB; liA.LowPart = result->dwLowDateTime; liA.HighPart = result->dwHighDateTime; liB.LowPart = x->dwLowDateTime; liB.HighPart = x->dwHighDateTime; liA.QuadPart += liB.QuadPart; result->dwLowDateTime = liA.LowPart; result->dwHighDateTime = liA.HighPart; } void subFiletimes(FILETIME *result, const FILETIME *x) { ULARGE_INTEGER liA, liB; liA.LowPart = result->dwLowDateTime; liA.HighPart = result->dwHighDateTime; liB.LowPart = x->dwLowDateTime; liB.HighPart = x->dwHighDateTime; liA.QuadPart -= liB.QuadPart; result->dwLowDateTime = liA.LowPart; result->dwHighDateTime = liA.HighPart; } float filetimeToSeconds(const FILETIME *x) { ULARGE_INTEGER ul; ul.LowPart = x->dwLowDateTime; ul.HighPart = x->dwHighDateTime; return (float)ul.QuadPart / (float)1.0E7; } void FileTimeTime::fromSeconds(unsigned u) { ULARGE_INTEGER li; li.QuadPart = (ULONGLONG)u * TICKS_PER_MICROSECOND * 1000000; t.dwLowDateTime = li.LowPart; t.dwHighDateTime = li.HighPart; } void FileTimeTime::add(const FileTimeTime &f) { addFiletimes(&t, &f.t); } void FileTimeTime::sub(const FileTimeTime &f) { subFiletimes(&t, &f.t); } float FileTimeTime::toSeconds(void) { return filetimeToSeconds(&t); } #endif #ifdef HAVE_SYS_TIME_H void addTimevals(struct timeval *result, const struct timeval *x) { long uSecs = result->tv_usec + x->tv_usec; result->tv_sec += x->tv_sec; if (uSecs >= 1000000) { result->tv_sec++; uSecs -= 1000000; } result->tv_usec = uSecs; } void subTimevals(struct timeval *result, const struct timeval *x) { long uSecs = result->tv_usec - x->tv_usec; result->tv_sec -= x->tv_sec; if (uSecs < 0) { result->tv_sec--; uSecs += 1000000; } result->tv_usec = uSecs; } float timevalToSeconds(const struct timeval *x) { return (float)x->tv_sec + (float)x->tv_usec / 1.0E6; } void TimeValTime::add(const TimeValTime &f) { addTimevals(&t, &f.t); } void TimeValTime::sub(const TimeValTime &f) { subTimevals(&t, &f.t); } #endif struct _entrypts timingEPT[] = { { "PolyTimingTicksPerMicroSec", (polyRTSFunction)&PolyTimingTicksPerMicroSec}, { "PolyTimingGetNow", (polyRTSFunction)&PolyTimingGetNow}, { "PolyTimingBaseYear", (polyRTSFunction)&PolyTimingBaseYear}, { "PolyTimingYearOffset", (polyRTSFunction)&PolyTimingYearOffset}, { "PolyTimingLocalOffset", (polyRTSFunction)&PolyTimingLocalOffset}, { "PolyTimingSummerApplies", (polyRTSFunction)&PolyTimingSummerApplies}, { "PolyTimingConvertDateStuct", (polyRTSFunction)&PolyTimingConvertDateStuct}, { "PolyTimingGetUser", (polyRTSFunction)&PolyTimingGetUser}, { "PolyTimingGetSystem", (polyRTSFunction)&PolyTimingGetSystem}, { "PolyTimingGetGCUser", (polyRTSFunction)&PolyTimingGetGCUser}, { "PolyTimingGetReal", (polyRTSFunction)&PolyTimingGetReal}, { "PolyTimingGetChildUser", (polyRTSFunction)&PolyTimingGetChildUser}, { "PolyTimingGetChildSystem", (polyRTSFunction)&PolyTimingGetChildSystem}, { "PolyTimingGetGCSystem", (polyRTSFunction)&PolyTimingGetGCSystem}, { NULL, NULL} // End of list. }; class Timing: public RtsModule { public: virtual void Init(void); }; // Declare this. It will be automatically added to the table. static Timing timingModule; void Timing::Init(void) { #if (defined(_WIN32)) // Record an initial time of day to use as the basis of real timing GetSystemTimeAsFileTime(&startTime); #else gettimeofday(&startTime, NULL); #endif } time_t getBuildTime(void) { char *source_date_epoch = getenv("SOURCE_DATE_EPOCH"); if (source_date_epoch) { errno = 0; char *endptr; long long epoch = StrToLL(source_date_epoch, &endptr, 10); if ((errno == ERANGE && (epoch == LLONG_MIN || epoch == LLONG_MAX)) || (errno != 0 && epoch == 0)) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: " XSTR(StrToLL) ": %s\n", strerror(errno)); goto err; } if (endptr == source_date_epoch) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: No digits were found: %s\n", endptr); goto err; } if (*endptr != '\0') { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: Trailing garbage: %s\n", endptr); goto err; } if (epoch < (long long)std::numeric_limits::min()) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: value must be greater than or equal to: %lld but was found to be: %lld\n", (long long)std::numeric_limits::min(), epoch); goto err; } if (epoch > (long long)std::numeric_limits::max()) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: value must be smaller than or equal to: %lld but was found to be: %lld\n", (long long)std::numeric_limits::max(), epoch); goto err; } return (time_t) epoch; } err: return time(NULL); } diff --git a/libpolyml/unix_specific.cpp b/libpolyml/unix_specific.cpp index 684c4d53..318383c3 100644 --- a/libpolyml/unix_specific.cpp +++ b/libpolyml/unix_specific.cpp @@ -1,2097 +1,2097 @@ /* Title: Operating Specific functions: Unix version. Copyright (c) 2000-8, 2016-17, 2019, 2020, 2021 David C. J. Matthews Portions of this code are derived from the original stream io package copyright CUTS 1983-2000. 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_UNISTD_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_PWD_H #include #endif #ifdef HAVE_GRP_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_WAIT_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_TERMIOS_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_SYS_UTSNAME_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #include "globals.h" #include "arb.h" #include "run_time.h" #include "io_internal.h" #include "sys.h" #include "diagnostics.h" #include "machine_dep.h" #include "os_specific.h" #include "gc.h" #include "processes.h" #include "mpoly.h" #include "sighandler.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetOSType(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixSleep(FirstArgument threadId, PolyWord maxTime, PolyWord sigCount); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyUnixExecute(FirstArgument threadId, PolyWord cmd, PolyWord args, PolyWord env); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixSleep(POLYUNSIGNED threadId, POLYUNSIGNED maxTime, POLYUNSIGNED sigCount); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyUnixExecute(POLYUNSIGNED threadId, POLYUNSIGNED cmd, POLYUNSIGNED args, POLYUNSIGNED env); } #define SAVE(x) taskData->saveVec.push(x) #define ALLOC(n) alloc_and_save(taskData, n) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) /* Table of constants returned by call 4. */ // This is currently unsigned because that's necessary on the PowerPC for // NOFLUSH. Perhaps there should be separate tables for different kinds // of constants. static unsigned unixConstVec[] = { /* Error codes. */ E2BIG, /* 0 */ EACCES, EAGAIN, EBADF, #ifdef EBADMSG /* This is not defined in FreeBSD. */ EBADMSG, #else 0, #endif EBUSY, #ifdef ECANCELED /* This is not defined in Linux. Perhaps someone knows how to spell "cancelled". */ ECANCELED, #else 0, /* Perhaps some other value. */ #endif ECHILD, EDEADLK, EDOM, EEXIST, EFAULT, EFBIG, EINPROGRESS, EINTR, EINVAL, EIO, EISDIR, ELOOP, EMFILE, EMLINK, /* 20 */ EMSGSIZE, ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC, ENOSYS, ENOTDIR, ENOTEMPTY, #ifdef ENOTSUP /* Not defined in Linux. */ ENOTSUP, #else 0, #endif ENOTTY, ENXIO, EPERM, EPIPE, ERANGE, EROFS, ESPIPE, ESRCH, EXDEV, /* 42 */ /* Signals. */ SIGABRT, /* 43 */ SIGALRM, SIGBUS, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE, SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, /* 62 */ /* Open flags. */ O_RDONLY, /* 63 */ O_WRONLY, O_RDWR, O_APPEND, O_EXCL, O_NOCTTY, O_NONBLOCK, #ifdef O_SYNC O_SYNC, /* Not defined in FreeBSD. */ #else 0, #endif O_TRUNC, /* 71 */ /* TTY: Special characters. */ VEOF, /* 72 */ VEOL, VERASE, VINTR, VKILL, VMIN, VQUIT, VSUSP, VTIME, VSTART, VSTOP, NCCS, /* 83 */ /* TTY: Input mode. */ BRKINT, /* 84 */ ICRNL, IGNBRK, IGNCR, IGNPAR, INLCR, INPCK, ISTRIP, IXOFF, IXON, PARMRK, /* 94 */ /* TTY: Output mode. */ OPOST, /* 95 */ /* TTY: Control modes. */ CLOCAL, /* 96 */ CREAD, CS5, CS6, CS7, CS8, CSIZE, CSTOPB, HUPCL, PARENB, PARODD, /* 106 */ /* TTY: Local modes. */ ECHO, /* 107 */ ECHOE, ECHOK, ECHONL, ICANON, IEXTEN, ISIG, (unsigned)NOFLSH, TOSTOP, /* 115 */ /* TTY: Speeds. */ B0, /* 116 */ B50, B75, B110, B134, B150, B200, B300, B600, B1200, B1800, B2400, B4800, B9600, B19200, B38400, /* 131 */ /* FD flags. */ FD_CLOEXEC, /* 132 */ /* Wait flags. */ WUNTRACED, /* 133 */ WNOHANG, /* 134 */ /* tcsetattr flags. */ TCSANOW, /* 135 */ TCSADRAIN, TCSAFLUSH, /* tcflow flags. */ TCOOFF, /* 138 */ TCOON, TCIOFF, TCION, /* tcflush flags. */ TCIFLUSH, /* 142 */ TCOFLUSH, TCIOFLUSH, /* File permissions. */ S_IRUSR, /* 145 */ S_IWUSR, S_IXUSR, S_IRGRP, S_IWGRP, S_IXGRP, S_IROTH, S_IWOTH, S_IXOTH, S_ISUID, S_ISGID, /* 155 */ /* Bits for access function. */ R_OK, /* 156 */ W_OK, X_OK, F_OK, /* 159 */ /* Values for lseek. */ SEEK_SET, /* 160 */ SEEK_CUR, SEEK_END, /* 162 */ /* Values for lock types. */ F_RDLCK, /* 163 */ F_WRLCK, F_UNLCK, /* 165 */ /* Mask for file access. */ O_ACCMODE, /* 166 */ }; /* Auxiliary functions which implement the more complex cases. */ static Handle waitForProcess(TaskData *taskData, Handle args); static Handle makePasswordEntry(TaskData *taskData, struct passwd *pw); static Handle makeGroupEntry(TaskData *taskData, struct group *grp); static Handle getUname(TaskData *taskData); static Handle getSysConf(TaskData *taskData, Handle args); static Handle getTTYattrs(TaskData *taskData, Handle args); static Handle setTTYattrs(TaskData *taskData, Handle args); static Handle getStatInfo(TaskData *taskData, struct stat *buf); static Handle lockCommand(TaskData *taskData, int cmd, Handle args); static int findPathVar(TaskData *taskData, PolyWord ps); // Unmask all signals just before exec. static void restoreSignals(void) { sigset_t sigset; sigemptyset(&sigset); sigprocmask(SIG_SETMASK, &sigset, NULL); } Handle OS_spec_dispatch_c(TaskData *taskData, Handle args, Handle code) { int c = get_C_long(taskData, code->Word()); switch (c) { case 0: /* Return our OS type. Not in any structure. */ return Make_fixed_precision(taskData, 0); /* 0 for Unix. */ case 4: /* Return a constant. */ { unsigned i = get_C_unsigned(taskData, args->Word()); if (i >= sizeof(unixConstVec)/sizeof(unixConstVec[0])) raise_syscall(taskData, "Invalid index", 0); return Make_sysword(taskData, unixConstVec[i]); } case 5: /* fork. */ { pid_t pid = fork(); if (pid < 0) raise_syscall(taskData, "fork failed", errno); // Have to clean up the RTS in the child. It's single threaded among other things. if (pid == 0) ForkChildModules(); return Make_fixed_precision(taskData, pid); } case 6: /* kill */ { int pid = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int sig = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (kill(pid, sig) < 0) raise_syscall(taskData, "kill failed", errno); return Make_fixed_precision(taskData, 0); } case 7: /* get process id */ { pid_t pid = getpid(); if (pid < 0) raise_syscall(taskData, "getpid failed", errno); return Make_fixed_precision(taskData, pid); } case 8: /* get process id of parent */ { pid_t pid = getppid(); if (pid < 0) raise_syscall(taskData, "getppid failed", errno); return Make_fixed_precision(taskData, pid); } case 9: /* get real user id */ { uid_t uid = getuid(); // This is defined always to succeed return Make_fixed_precision(taskData, uid); } case 10: /* get effective user id */ { uid_t uid = geteuid(); // This is defined always to succeed return Make_fixed_precision(taskData, uid); } case 11: /* get real group id */ { gid_t gid = getgid(); // This is defined always to succeed return Make_fixed_precision(taskData, gid); } case 12: /* get effective group id */ { gid_t gid = getegid(); // This is defined always to succeed return Make_fixed_precision(taskData, gid); } case 13: /* Return process group */ { pid_t pid = getpgrp(); if (pid < 0) raise_syscall(taskData, "getpgrp failed", errno); return Make_fixed_precision(taskData, pid); } case 14: /* Wait for child process to terminate. */ return waitForProcess(taskData, args); case 15: /* Unpack a process result. */ { int resType, resVal; Handle result, typeHandle, resHandle; int status = get_C_long(taskData, args->Word()); if (WIFEXITED(status)) { resType = 1; resVal = WEXITSTATUS(status); } else if (WIFSIGNALED(status)) { resType = 2; resVal = WTERMSIG(status); } else if (WIFSTOPPED(status)) { resType = 3; resVal = WSTOPSIG(status); } else { /* ?? */ resType = 0; resVal = 0; } typeHandle = Make_fixed_precision(taskData, resType); resHandle = Make_fixed_precision(taskData, resVal); result = ALLOC(2); DEREFHANDLE(result)->Set(0, typeHandle->Word()); DEREFHANDLE(result)->Set(1, resHandle->Word()); return result; } case 16: /* Pack up a process result. The inverse of the previous call. */ { int resType = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int resVal = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int result = 0; switch (resType) { case 1: /* Exited */ result = resVal << 8; break; case 2: /* Signalled */ result = resVal; break; case 3: /* Stopped */ result = (resVal << 8) | 0177; } return Make_fixed_precision(taskData, result); } case 17: /* Run a new executable. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); int err; restoreSignals(); execv(path, argl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); raise_syscall(taskData, "execv failed", err); } case 18: /* Run a new executable with given environment. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); char **envl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(2))); int err; restoreSignals(); execve(path, argl, envl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); freeStringVector(envl); raise_syscall(taskData, "execve failed", err); } case 19: /* Run a new executable using PATH environment variable. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); int err; restoreSignals(); execvp(path, argl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); raise_syscall(taskData, "execvp failed", err); } case 20: /* Sets an alarm and returns the current alarm time. A value of zero for the time cancels the timer. */ { /* We have a value in microseconds. We need to split it into seconds and microseconds. */ Handle hTime = args; Handle hMillion = Make_arbitrary_precision(taskData, 1000000); struct itimerval newTimer, oldTimer; newTimer.it_interval.tv_sec = 0; newTimer.it_interval.tv_usec = 0; newTimer.it_value.tv_sec = get_C_long(taskData, div_longc(taskData, hMillion, hTime)->Word()); newTimer.it_value.tv_usec = get_C_long(taskData, rem_longc(taskData, hMillion, hTime)->Word()); if (setitimer(ITIMER_REAL, &newTimer, &oldTimer) != 0) raise_syscall(taskData, "setitimer failed", errno); Handle result = /* Return the previous setting. */ Make_arb_from_pair_scaled(taskData, oldTimer.it_value.tv_sec, oldTimer.it_value.tv_usec, 1000000); return result; } case 23: /* Set uid. */ { uid_t uid = get_C_long(taskData, args->Word()); if (setuid(uid) != 0) raise_syscall(taskData, "setuid failed", errno); return Make_fixed_precision(taskData, 0); } case 24: /* Set gid. */ { gid_t gid = get_C_long(taskData, args->Word()); if (setgid(gid) != 0) raise_syscall(taskData, "setgid failed", errno); return Make_fixed_precision(taskData, 0); } case 25: /* Get group list. */ { // This previously allocated gid_t[NGROUPS_MAX] on the stack but this // requires quite a bit of stack space. gid_t gid[1]; int ngroups = getgroups(0, gid); // Just get the number. if (ngroups < 0) raise_syscall(taskData, "getgroups failed", errno); if (ngroups == 0) return SAVE(ListNull); gid_t *groups = (gid_t*)calloc(sizeof(gid_t), ngroups); if (groups == 0) raise_syscall(taskData, "Unable to allocate memory", errno); if (getgroups(ngroups, groups) < 0) { int lasterr = errno; free(groups); raise_syscall(taskData, "getgroups failed", lasterr); } Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); /* It's simplest to process the integers in reverse order */ while (--ngroups >= 0) { Handle value = Make_fixed_precision(taskData, groups[ngroups]); Handle next = ALLOC(SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = value->Word(); DEREFLISTHANDLE(next)->t = list->Word(); taskData->saveVec.reset(saved); list = SAVE(next->Word()); } free(groups); return list; } case 26: /* Get login name. */ { char *login = getlogin(); if (login == 0) raise_syscall(taskData, "getlogin failed", errno); return SAVE(C_string_to_Poly(taskData, login)); } case 27: /* Set sid */ { pid_t pid = setsid(); if (pid < 0) raise_syscall(taskData, "setsid failed", errno); return Make_fixed_precision(taskData, pid); } case 28: /* Set process group. */ { pid_t pid = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); pid_t pgid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (setpgid(pid, pgid) < 0 ) raise_syscall(taskData, "setpgid failed", errno); return Make_fixed_precision(taskData, 0); } case 29: /* uname */ return getUname(taskData); case 30: /* Get controlling terminal. */ #ifdef HAVE_CTERMID { char *term = ctermid(0); /* Can this generate an error? */ if (term == 0) raise_syscall(taskData, "ctermid failed", errno); return SAVE(C_string_to_Poly(taskData, term)); } #else raise_syscall(taskData, "ctermid is not implemented", 0); #endif case 31: /* Get terminal name for file descriptor. */ { char *term = ttyname(getStreamFileDescriptor(taskData, args->Word())); if (term == 0) raise_syscall(taskData, "ttyname failed", errno); return SAVE(C_string_to_Poly(taskData, term)); } case 32: /* Test if file descriptor is a terminal. Returns false if the stream is closed. */ { int descr = getStreamFileDescriptorWithoutCheck(args->Word()); if (descr != -1 && isatty(descr)) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } case 33: /* sysconf. */ return getSysConf(taskData, args); /* Filesys entries. */ case 50: /* Set the file creation mask and return the old one. */ { mode_t mode = get_C_ulong(taskData, args->Word()); return Make_fixed_precision(taskData, umask(mode)); } case 51: /* Create a hard link. */ { char *old = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char *newp = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(1)); int err, res; res = link(old, newp); err = errno; /* Save the error result in case free changes it. */ free(old); free(newp); if (res < 0) raise_syscall(taskData, "link failed", err); return Make_fixed_precision(taskData, 0); } case 52: /* Create a directory. There is an OS-independent version in basicio which uses a default creation mode. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = mkdir(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "mkdir failed", err); return Make_fixed_precision(taskData, 0); } case 53: /* Create a fifo. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = mkfifo(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "mkfifo failed", err); return Make_fixed_precision(taskData, 0); } case 54: /* Create a symbolic link. */ { char *old = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char *newp = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(1)); int err, res; res = symlink(old, newp); err = errno; /* Save the error result in case free changes it. */ free(old); free(newp); if (res < 0) raise_syscall(taskData, "link failed", err); return Make_fixed_precision(taskData, 0); } case 55: /* Get information about a file. */ { struct stat buf; int res, err; char *name = Poly_string_to_C_alloc(DEREFWORD(args)); res = stat(name, &buf); err = errno; free(name); if (res < 0) raise_syscall(taskData, "stat failed", err); return getStatInfo(taskData, &buf); } case 56: /* Get information about a symbolic link. */ { struct stat buf; int res, err; char *name = Poly_string_to_C_alloc(DEREFWORD(args)); res = lstat(name, &buf); err = errno; free(name); if (res < 0) raise_syscall(taskData, "lstat failed", err); return getStatInfo(taskData, &buf); } case 57: /* Get information about an open file. */ { struct stat buf; if (fstat(getStreamFileDescriptor(taskData, args->Word()), &buf) < 0) raise_syscall(taskData, "fstat failed", errno); return getStatInfo(taskData, &buf); } case 58: /* Test access rights to a file. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); int amode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int res; res = access(name, amode); free(name); /* Return false if error, true if not. It's not clear that this is correct since there are several reasons why we might get -1 as the result. */ return Make_fixed_precision(taskData, res < 0 ? 0 : 1); } case 59: /* Change access rights. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = chmod(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "chmod failed", err); return Make_fixed_precision(taskData, 0); } case 60: /* Change access rights on open file. */ { mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fchmod(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), mode) < 0) raise_syscall(taskData, "fchmod failed", errno); return Make_fixed_precision(taskData, 0); } case 61: /* Change owner and group. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); uid_t uid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); gid_t gid = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); int err, res; res = chown(name, uid, gid); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "chown failed", err); return Make_fixed_precision(taskData, 0); } case 62: /* Change owner and group on open file. */ { uid_t uid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); gid_t gid = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); if (fchown(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), uid, gid) < 0) raise_syscall(taskData, "fchown failed", errno); return Make_fixed_precision(taskData, 0); } case 63: /* Set access and modification times. We use utimes rather than utime since it allows us to be more accurate. There's a similar function in basicio which sets both the access and modification times to the same time. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); Handle hAccess = SAVE(DEREFHANDLE(args)->Get(1)); Handle hMod = SAVE(DEREFHANDLE(args)->Get(2)); struct timeval times[2]; /* We have a value in microseconds. We need to split it into seconds and microseconds. N.B. The arguments to div_longc and rem_longc are in reverse order. */ Handle hMillion = Make_arbitrary_precision(taskData, 1000000); unsigned secsAccess = get_C_ulong(taskData, div_longc(taskData, hMillion, hAccess)->Word()); unsigned usecsAccess = get_C_ulong(taskData, rem_longc(taskData, hMillion, hAccess)->Word()); unsigned secsMod = get_C_ulong(taskData, div_longc(taskData, hMillion, hMod)->Word()); unsigned usecsMod = get_C_ulong(taskData, rem_longc(taskData, hMillion, hMod)->Word()); int err, res; times[0].tv_sec = secsAccess; times[0].tv_usec = usecsAccess; times[1].tv_sec = secsMod; times[1].tv_usec = usecsMod; res = utimes(name, times); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "utimes failed", err); return Make_fixed_precision(taskData, 0); } case 64: /* Set access and modification times to the current time. This could be defined in terms of the previous call and Time.now but it could result in an error due to rounding. This is probably safer. */ { char *name = Poly_string_to_C_alloc(DEREFWORD(args)); int err, res; res = utimes(name, 0); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "utimes failed", err); return Make_fixed_precision(taskData, 0); } case 65: /* Truncate an open file. */ { int size = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (ftruncate(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), size) < 0) raise_syscall(taskData, "ftruncate failed", errno); return Make_fixed_precision(taskData, 0); } case 66: /* Get the configured limits for a file. */ { /* Look up the variable. May raise an exception. */ int nvar = findPathVar(taskData, DEREFHANDLE(args)->Get(1)); char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); int err, res; /* Set errno to zero. If there is no limit pathconf returns -1 but does not change errno. */ errno = 0; res = pathconf(name, nvar); err = errno; /* Save the error result in case free changes it. */ free(name); /* We return -1 as a valid result indicating no limit. */ if (res < 0 && err != 0) raise_syscall(taskData, "pathconf failed", err); return Make_fixed_precision(taskData, res); } case 67: /* Get the configured limits for an open file. */ { /* Look up the variable. May raise an exception. */ int nvar = findPathVar(taskData, DEREFHANDLE(args)->Get(1)); errno = 0; /* Unchanged if there is no limit. */ int res = fpathconf(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), nvar); if (res < 0 && errno != 0) raise_syscall(taskData, "fpathconf failed", errno); return Make_fixed_precision(taskData, res); } /* Password and group entries. */ case 100: /* Get Password entry by name. */ { char pwName[200]; int length; struct passwd *pw; length = Poly_string_to_C(DEREFWORD(args), pwName, 200); if (length > 200) raise_syscall(taskData, "Password name too long", ENAMETOOLONG); pw = getpwnam(pwName); if (pw == NULL) raise_syscall(taskData, "Password entry not found", ENOENT); return makePasswordEntry(taskData, pw); } case 101: /* Get password entry by uid. */ { int uid = get_C_long(taskData, DEREFWORD(args)); struct passwd *pw = getpwuid(uid); if (pw == NULL) raise_syscall(taskData, "Password entry not found", ENOENT); return makePasswordEntry(taskData, pw); } case 102: /* Get group entry by name. */ { struct group *grp; char grpName[200]; int length; length = Poly_string_to_C(DEREFWORD(args), grpName, 200); if (length > 200) raise_syscall(taskData, "Group name too long", ENAMETOOLONG); grp = getgrnam(grpName); if (grp == NULL) raise_syscall(taskData, "Group entry not found", ENOENT); return makeGroupEntry(taskData, grp); } case 103: /* Get group entry by gid. */ { int gid = get_C_long(taskData, DEREFWORD(args)); struct group *grp = getgrgid(gid); if (grp == NULL) raise_syscall(taskData, "Group entry not found", ENOENT); return makeGroupEntry(taskData, grp); } /* IO Entries. */ case 110: /* Create a pipe. */ { int filedes[2]; if (pipe(filedes) < 0) raise_syscall(taskData, "pipe failed", errno); Handle strRead = wrapFileDescriptor(taskData, filedes[0]); Handle strWrite = wrapFileDescriptor(taskData, filedes[1]); Handle result = ALLOC(2); DEREFHANDLE(result)->Set(0, strRead->Word()); DEREFHANDLE(result)->Set(1, strWrite->Word()); return result; } case 111: /* Duplicate a file descriptor. */ { int srcFd = getStreamFileDescriptor(taskData, args->WordP()); int fd = dup(srcFd); if (fd < 0) raise_syscall(taskData, "dup failed", errno); return wrapFileDescriptor(taskData, fd); } case 112: /* Duplicate a file descriptor to a given entry. */ { int oldFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int newFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(1)); if (dup2(oldFd, newFd) < 0) raise_syscall(taskData, "dup2 failed", errno); return Make_fixed_precision(taskData, 0); } case 113: /* Duplicate a file descriptor to an entry equal to or greater than the given value. */ { int oldFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int baseFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(1)); int newFd = fcntl(oldFd, F_DUPFD, baseFd); return wrapFileDescriptor(taskData, newFd); } case 114: /* Get the file descriptor flags. */ { int res = fcntl(getStreamFileDescriptor(taskData, args->Word()), F_GETFD); if (res < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, res); } case 115: /* Set the file descriptor flags. */ { int flags = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fcntl(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), F_SETFD, flags) < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, 0); } case 116: /* Get the file status and access flags. */ { int res = fcntl(getStreamFileDescriptor(taskData, args->Word()), F_GETFL); if (res < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, res); } case 117: /* Set the file status and access flags. */ { int flags = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fcntl(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), F_SETFL, flags) < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, 0); } case 118: /* Seek to a position on the stream. */ { long position = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int whence = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); long newpos = lseek(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), position, whence); if (newpos < 0) raise_syscall(taskData, "lseek failed", errno); return Make_arbitrary_precision(taskData, (POLYSIGNED)newpos); // Position.int } case 119: /* Synchronise file contents. */ { if (fsync(getStreamFileDescriptor(taskData, args->Word())) < 0) raise_syscall(taskData, "fsync failed", errno); return Make_fixed_precision(taskData, 0); } case 120: /* get lock */ return lockCommand(taskData, F_GETLK, args); case 121: /* set lock */ return lockCommand(taskData, F_SETLK, args); case 122: /* wait for lock */ /* TODO: This may well block the whole process. We should look at the result and retry if need be. */ return lockCommand(taskData, F_SETLKW, args); /* TTY entries. */ case 150: /* Get attributes. */ return getTTYattrs(taskData, args); case 151: /* Set attributes. */ return setTTYattrs(taskData, args); case 152: /* Send a break. */ { int duration = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcsendbreak(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), duration) < 0) raise_syscall(taskData, "tcsendbreak failed", errno); return Make_fixed_precision(taskData, 0); } case 153: /* Wait for output to drain. */ { /* TODO: This will block the process. It really needs to check whether the stream has drained and run another process until it has. */ #ifdef HAVE_TCDRAIN if (tcdrain(getStreamFileDescriptor(taskData, args->Word())) < 0) raise_syscall(taskData, "tcdrain failed", errno); #else raise_syscall(taskData, "tcdrain is not implemented", 0); #endif return Make_fixed_precision(taskData, 0); } case 154: /* Flush terminal stream. */ { int qs = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcflush(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), qs) < 0) raise_syscall(taskData, "tcflush failed", errno); return Make_fixed_precision(taskData, 0); } case 155: /* Flow control. */ { int action = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcflow(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), action) < 0) raise_syscall(taskData, "tcflow failed", errno); return Make_fixed_precision(taskData, 0); } case 156: /* Get process group. */ { pid_t pid = tcgetpgrp(getStreamFileDescriptor(taskData, args->Word())); if (pid < 0) raise_syscall(taskData, "tcgetpgrp failed", errno); return Make_fixed_precision(taskData, pid); } case 157: /* Set process group. */ { pid_t pid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcsetpgrp(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), pid) < 0) raise_syscall(taskData, "tcsetpgrp failed", errno); return Make_fixed_precision(taskData, 0); } default: { char msg[100]; sprintf(msg, "Unknown unix-specific function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); } } } // General interface to Unix OS-specific. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyOSSpecificGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = OS_spec_dispatch_c(taskData, pushedArg, pushedCode); } 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 PolyGetOSType() { return TAGGED(0).AsUnsigned(); // Return 0 for Unix } // Wait for the shorter of the times. // TODO: This should really wait for some event from the signal thread. class WaitUpto : public Waiter { public: WaitUpto(unsigned mSecs) : maxTime(mSecs), result(0), errcode(0) {} virtual void Wait(unsigned maxMillisecs) { useconds_t usec; if (maxTime < maxMillisecs) usec = maxTime * 1000; else usec = maxMillisecs * 1000; result = usleep(usec); if (result != 0) errcode = errno; } unsigned maxTime; int result; int errcode; }; // This waits for a period of up to a second. The actual time calculations are // done in ML. Takes the signal count as an argument and returns the last signal // count. This ensures that it does not miss any signals that arrive while in ML. -POLYUNSIGNED PolyPosixSleep(FirstArgument threadId, PolyWord maxMillisecs, PolyWord sigCount) +POLYUNSIGNED PolyPosixSleep(POLYUNSIGNED threadId, POLYUNSIGNED maxMillisecs, POLYUNSIGNED sigCount) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned(); try { if (UNTAGGED_UNSIGNED(sigCount) == receivedSignalCount) { WaitUpto waiter(maxMilliseconds); processes->ThreadPauseForIO(taskData, &waiter); if (waiter.result != 0) { if (waiter.errcode != EINTR) raise_syscall(taskData, "sleep failed", waiter.errcode); } } } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return TAGGED(receivedSignalCount).AsUnsigned(); } Handle waitForProcess(TaskData *taskData, Handle args) /* Get result status of a child process. */ { TryAgain: // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); int kind = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int pid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int callFlags = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); int flags = callFlags | WNOHANG; // Add in WNOHANG so we never block. pid_t pres = 0; int status = 0; switch (kind) { case 0: /* Wait for any child. */ pres = waitpid(-1, &status, flags); break; case 1: /* Wait for specific process. */ pres = waitpid(pid, &status, flags); break; case 2: /* Wait for any in current process group. */ pres = waitpid(0, &status, flags); break; case 3: /* Wait for child in given process group */ pres = waitpid(-pid, &status, flags); break; } if (pres < 0) { if (errno == EINTR) goto TryAgain; else raise_syscall(taskData, "wait failed", errno); } /* If the caller did not specify WNOHANG but there wasn't a child process waiting we have to block and come back here later. */ if (pres == 0 && !(callFlags & WNOHANG)) { processes->ThreadPause(taskData); goto TryAgain; } /* Construct the result tuple. */ { Handle result, pidHandle, resHandle; pidHandle = Make_fixed_precision(taskData, pres); // If the pid is zero status may not be a valid value and may overflow. resHandle = Make_fixed_precision(taskData, pres == 0 ? 0: status); result = ALLOC(2); DEREFHANDLE(result)->Set(0, DEREFWORD(pidHandle)); DEREFHANDLE(result)->Set(1, DEREFWORD(resHandle)); return result; } } static Handle makePasswordEntry(TaskData *taskData, struct passwd *pw) /* Return a password entry. */ { Handle nameHandle, uidHandle, gidHandle, homeHandle, shellHandle, result; nameHandle = SAVE(C_string_to_Poly(taskData, pw->pw_name)); uidHandle = Make_fixed_precision(taskData, pw->pw_uid); gidHandle = Make_fixed_precision(taskData, pw->pw_gid); homeHandle = SAVE(C_string_to_Poly(taskData, pw->pw_dir)); shellHandle = SAVE(C_string_to_Poly(taskData, pw->pw_shell)); result = ALLOC(5); DEREFHANDLE(result)->Set(0, nameHandle->Word()); DEREFHANDLE(result)->Set(1, uidHandle->Word()); DEREFHANDLE(result)->Set(2, gidHandle->Word()); DEREFHANDLE(result)->Set(3, homeHandle->Word()); DEREFHANDLE(result)->Set(4, shellHandle->Word()); return result; } static Handle makeGroupEntry(TaskData *taskData, struct group *grp) { Handle nameHandle, gidHandle, membersHandle, result; int i; char **p; nameHandle = SAVE(C_string_to_Poly(taskData, grp->gr_name)); gidHandle = Make_fixed_precision(taskData, grp->gr_gid); /* Group members. */ for (i=0, p = grp->gr_mem; *p != NULL; p++, i++); membersHandle = convert_string_list(taskData, i, grp->gr_mem); result = ALLOC(3); DEREFHANDLE(result)->Set(0, nameHandle->Word()); DEREFHANDLE(result)->Set(1, gidHandle->Word()); DEREFHANDLE(result)->Set(2, membersHandle->Word()); return result; } /* Make a cons cell for a pair of strings. */ // Doesn't currently reset the save vec so it's only safe for a small number // of cells. static void makeStringPairList(TaskData *taskData, Handle &list, const char *s1, const char *s2) { Handle nameHandle, valueHandle, pairHandle, next; /* This has to be done carefully to ensure we don't throw anything away if we garbage-collect and also to ensure that each object is fully initialised before the next object is created. */ /* Make the strings. */ nameHandle = SAVE(C_string_to_Poly(taskData, s1)); valueHandle = SAVE(C_string_to_Poly(taskData, s2)); /* Make the pair. */ pairHandle = ALLOC(2); DEREFHANDLE(pairHandle)->Set(0, nameHandle->Word()); DEREFHANDLE(pairHandle)->Set(1, valueHandle->Word()); /* Make the cons cell. */ next = ALLOC(SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = pairHandle->Word(); DEREFLISTHANDLE(next)->t = list->Word(); list = SAVE(next->Word()); } /* Return the uname information. */ static Handle getUname(TaskData *taskData) { #ifdef HAVE_SYS_UTSNAME_H struct utsname name; Handle list = SAVE(ListNull); if (uname(&name) < 0) raise_syscall(taskData, "uname failed", errno); makeStringPairList(taskData, list, "sysname", name.sysname); makeStringPairList(taskData, list, "nodename", name.nodename); makeStringPairList(taskData, list, "release", name.release); makeStringPairList(taskData, list, "version", name.version); makeStringPairList(taskData, list, "machine", name.machine); return list; #else raise_syscall(taskData, "uname not available on this machine", errno); #endif } /* Return the contents of a stat buffer. */ static Handle getStatInfo(TaskData *taskData, struct stat *buf) { int kind; /* Get the protection mode, masking off the file type info. */ Handle modeHandle = Make_fixed_precision(taskData, buf->st_mode & (S_IRWXU|S_IRWXG|S_IRWXO|S_ISUID|S_ISGID)); if (S_ISDIR(buf->st_mode)) kind = 1; else if (S_ISCHR(buf->st_mode)) kind = 2; else if (S_ISBLK(buf->st_mode)) kind = 3; else if (S_ISFIFO(buf->st_mode)) kind = 4; else if ((buf->st_mode & S_IFMT) == S_IFLNK) kind = 5; else if ((buf->st_mode & S_IFMT) == S_IFSOCK) kind = 6; else /* Regular. */ kind = 0; Handle kindHandle = Make_fixed_precision(taskData, kind); Handle inoHandle = Make_arbitrary_precision(taskData, buf->st_ino); Handle devHandle = Make_arbitrary_precision(taskData, buf->st_dev); Handle linkHandle = Make_fixed_precision(taskData, buf->st_nlink); Handle uidHandle = Make_fixed_precision(taskData, buf->st_uid); Handle gidHandle = Make_fixed_precision(taskData, buf->st_gid); Handle sizeHandle = Make_arbitrary_precision(taskData, buf->st_size); // Position.int Handle atimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,a), STAT_USECS(buf,a), 1000000); Handle mtimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,m), STAT_USECS(buf,m), 1000000); Handle ctimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,c), STAT_USECS(buf,c), 1000000); Handle result = ALLOC(11); DEREFHANDLE(result)->Set(0, modeHandle->Word()); DEREFHANDLE(result)->Set(1, kindHandle->Word()); DEREFHANDLE(result)->Set(2, inoHandle->Word()); DEREFHANDLE(result)->Set(3, devHandle->Word()); DEREFHANDLE(result)->Set(4, linkHandle->Word()); DEREFHANDLE(result)->Set(5, uidHandle->Word()); DEREFHANDLE(result)->Set(6, gidHandle->Word()); DEREFHANDLE(result)->Set(7, sizeHandle->Word()); DEREFHANDLE(result)->Set(8, atimeHandle->Word()); DEREFHANDLE(result)->Set(9, mtimeHandle->Word()); DEREFHANDLE(result)->Set(10, ctimeHandle->Word()); return result; } static Handle getTTYattrs(TaskData *taskData, Handle args) { int fd = getStreamFileDescriptor(taskData, args->Word()); struct termios tios; speed_t ispeed, ospeed; Handle ifHandle, ofHandle, cfHandle, lfHandle, ccHandle; Handle isHandle, osHandle, result; if (tcgetattr(fd, &tios) < 0) raise_syscall(taskData, "tcgetattr failed", errno); /* Extract the speed entries. */ ospeed = cfgetospeed(&tios); ispeed = cfgetispeed(&tios); /* Set the speed entries to zero. In Solaris, at least, the speed is encoded in the flags and we don't want any confusion. The order of these functions is significant. */ cfsetospeed(&tios, B0); cfsetispeed(&tios, B0); /* Convert the values to ML representation. */ ifHandle = Make_fixed_precision(taskData, tios.c_iflag); ofHandle = Make_fixed_precision(taskData, tios.c_oflag); cfHandle = Make_fixed_precision(taskData, tios.c_cflag); lfHandle = Make_fixed_precision(taskData, tios.c_lflag); /* The cc vector is treated as a string. */ ccHandle = SAVE(C_string_to_Poly(taskData, (const char *)tios.c_cc, NCCS)); isHandle = Make_fixed_precision(taskData, ispeed); osHandle = Make_fixed_precision(taskData, ospeed); /* We can now create the result tuple. */ result = ALLOC(7); DEREFHANDLE(result)->Set(0, ifHandle->Word()); DEREFHANDLE(result)->Set(1, ofHandle->Word()); DEREFHANDLE(result)->Set(2, cfHandle->Word()); DEREFHANDLE(result)->Set(3, lfHandle->Word()); DEREFHANDLE(result)->Set(4, ccHandle->Word()); DEREFHANDLE(result)->Set(5, isHandle->Word()); DEREFHANDLE(result)->Set(6, osHandle->Word()); return result; } /* Assemble the tios structure from the arguments and set the TTY attributes. */ static Handle setTTYattrs(TaskData *taskData, Handle args) { int fd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int actions = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); struct termios tios; speed_t ispeed, ospeed; /* Make sure anything unset is zero. It might be better to call tcgetattr instead. */ memset(&tios, 0, sizeof(tios)); tios.c_iflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(2)); tios.c_oflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(3)); tios.c_cflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(4)); tios.c_lflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(5)); /* The cc vector should be a string of exactly NCCS characters. It may well contain nulls so we can't use Poly_string_to_C to copy it. */ PolyWord ccv = DEREFHANDLE(args)->Get(6); if (ccv.IsTagged()) // Just to check. raise_syscall(taskData, "Incorrect cc vector", EINVAL); PolyStringObject * ccvs = (PolyStringObject *)ccv.AsObjPtr(); if (ccvs->length != NCCS) // Just to check. */ raise_syscall(taskData, "Incorrect cc vector", EINVAL); memcpy(tios.c_cc, ccvs->chars, NCCS); ispeed = get_C_ulong(taskData, DEREFHANDLE(args)->Get(7)); ospeed = get_C_ulong(taskData, DEREFHANDLE(args)->Get(8)); if (cfsetispeed(&tios, ispeed) < 0) raise_syscall(taskData, "cfsetispeed failed", errno); if (cfsetospeed(&tios, ospeed) < 0) raise_syscall(taskData, "cfsetospeed failed", errno); /* Now it's all set we can call tcsetattr to do the work. */ if (tcsetattr(fd, actions, &tios) < 0) raise_syscall(taskData, "tcsetattr failed", errno); return Make_fixed_precision(taskData, 0); } /* Lock/unlock/test file locks. Returns the, possibly modified, argument structure. */ static Handle lockCommand(TaskData *taskData, int cmd, Handle args) { int fd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); struct flock lock; memset(&lock, 0, sizeof(lock)); /* Make sure unused fields are zero. */ lock.l_type = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); lock.l_whence = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); lock.l_start = get_C_long(taskData, DEREFHANDLE(args)->Get(3)); lock.l_len = get_C_long(taskData, DEREFHANDLE(args)->Get(4)); lock.l_pid = get_C_long(taskData, DEREFHANDLE(args)->Get(5)); if (fcntl(fd, cmd, &lock) < 0) raise_syscall(taskData, "fcntl failed", errno); /* Construct the result. */ Handle typeHandle = Make_fixed_precision(taskData, lock.l_type); Handle whenceHandle = Make_fixed_precision(taskData, lock.l_whence); Handle startHandle = Make_arbitrary_precision(taskData, (POLYUNSIGNED)lock.l_start); // Position.int Handle lenHandle = Make_arbitrary_precision(taskData, (POLYUNSIGNED)lock.l_len); // Position.int Handle pidHandle = Make_fixed_precision(taskData, lock.l_pid); Handle result = ALLOC(5); DEREFHANDLE(result)->Set(0, typeHandle->Word()); DEREFHANDLE(result)->Set(1, whenceHandle->Word()); DEREFHANDLE(result)->Set(2, startHandle->Word()); DEREFHANDLE(result)->Set(3, lenHandle->Word()); DEREFHANDLE(result)->Set(4, pidHandle->Word()); return result; } /* This table maps string arguments for sysconf into the corresponding constants. */ /* These are highly OS dependent. It has been configured on Solaris 2.8, Linux Redhat 5.2 and FreeBSD 3.4. */ static struct { const char *saName; int saVal; } sysArgTable[] = { { "_SC_ARG_MAX", _SC_ARG_MAX }, { "_SC_CHILD_MAX", _SC_CHILD_MAX }, { "_SC_CLK_TCK", _SC_CLK_TCK }, { "_SC_NGROUPS_MAX", _SC_NGROUPS_MAX }, { "_SC_OPEN_MAX", _SC_OPEN_MAX }, { "_SC_JOB_CONTROL", _SC_JOB_CONTROL }, { "_SC_SAVED_IDS", _SC_SAVED_IDS }, { "_SC_VERSION", _SC_VERSION }, #ifdef _SC_PASS_MAX { "_SC_PASS_MAX", _SC_PASS_MAX }, #endif #ifdef _SC_LOGNAME_MAX { "_SC_LOGNAME_MAX", _SC_LOGNAME_MAX }, #endif #ifdef _SC_PAGESIZE { "_SC_PAGESIZE", _SC_PAGESIZE }, #endif #ifdef _SC_XOPEN_VERSION { "_SC_XOPEN_VERSION", _SC_XOPEN_VERSION }, #endif #ifdef _SC_NPROCESSORS_CONF { "_SC_NPROCESSORS_CONF", _SC_NPROCESSORS_CONF }, #endif #ifdef _SC_NPROCESSORS_ONLN { "_SC_NPROCESSORS_ONLN", _SC_NPROCESSORS_ONLN }, #endif #ifdef _SC_STREAM_MAX { "_SC_STREAM_MAX", _SC_STREAM_MAX }, #endif #ifdef _SC_TZNAME_MAX { "_SC_TZNAME_MAX", _SC_TZNAME_MAX }, #endif #ifdef _SC_AIO_LISTIO_MAX { "_SC_AIO_LISTIO_MAX", _SC_AIO_LISTIO_MAX }, #endif #ifdef _SC_AIO_MAX { "_SC_AIO_MAX", _SC_AIO_MAX }, #endif #ifdef _SC_AIO_PRIO_DELTA_MAX { "_SC_AIO_PRIO_DELTA_MAX", _SC_AIO_PRIO_DELTA_MAX }, #endif #ifdef _SC_ASYNCHRONOUS_IO { "_SC_ASYNCHRONOUS_IO", _SC_ASYNCHRONOUS_IO }, #endif #ifdef _SC_DELAYTIMER_MAX { "_SC_DELAYTIMER_MAX", _SC_DELAYTIMER_MAX }, #endif #ifdef _SC_FSYNC { "_SC_FSYNC", _SC_FSYNC }, #endif #ifdef _SC_MAPPED_FILES { "_SC_MAPPED_FILES", _SC_MAPPED_FILES }, #endif #ifdef _SC_MEMLOCK { "_SC_MEMLOCK", _SC_MEMLOCK }, #endif #ifdef _SC_MEMLOCK_RANGE { "_SC_MEMLOCK_RANGE", _SC_MEMLOCK_RANGE }, #endif #ifdef _SC_MEMORY_PROTECTION { "_SC_MEMORY_PROTECTION", _SC_MEMORY_PROTECTION }, #endif #ifdef _SC_MESSAGE_PASSING { "_SC_MESSAGE_PASSING", _SC_MESSAGE_PASSING }, #endif #ifdef _SC_MQ_OPEN_MAX { "_SC_MQ_OPEN_MAX", _SC_MQ_OPEN_MAX }, #endif #ifdef _SC_MQ_PRIO_MAX { "_SC_MQ_PRIO_MAX", _SC_MQ_PRIO_MAX }, #endif #ifdef _SC_PRIORITIZED_IO { "_SC_PRIORITIZED_IO", _SC_PRIORITIZED_IO }, #endif #ifdef _SC_PRIORITY_SCHEDULING { "_SC_PRIORITY_SCHEDULING", _SC_PRIORITY_SCHEDULING }, #endif #ifdef _SC_REALTIME_SIGNALS { "_SC_REALTIME_SIGNALS", _SC_REALTIME_SIGNALS }, #endif #ifdef _SC_RTSIG_MAX { "_SC_RTSIG_MAX", _SC_RTSIG_MAX }, #endif #ifdef _SC_SEMAPHORES { "_SC_SEMAPHORES", _SC_SEMAPHORES }, #endif #ifdef _SC_SEM_NSEMS_MAX { "_SC_SEM_NSEMS_MAX", _SC_SEM_NSEMS_MAX }, #endif #ifdef _SC_SEM_VALUE_MAX { "_SC_SEM_VALUE_MAX", _SC_SEM_VALUE_MAX }, #endif #ifdef _SC_SHARED_MEMORY_OBJECTS { "_SC_SHARED_MEMORY_OBJECTS", _SC_SHARED_MEMORY_OBJECTS }, #endif #ifdef _SC_SIGQUEUE_MAX { "_SC_SIGQUEUE_MAX", _SC_SIGQUEUE_MAX }, #endif #ifdef _SC_SIGRT_MIN { "_SC_SIGRT_MIN", _SC_SIGRT_MIN }, #endif #ifdef _SC_SIGRT_MAX { "_SC_SIGRT_MAX", _SC_SIGRT_MAX }, #endif #ifdef _SC_SYNCHRONIZED_IO { "_SC_SYNCHRONIZED_IO", _SC_SYNCHRONIZED_IO }, #endif #ifdef _SC_TIMERS { "_SC_TIMERS", _SC_TIMERS }, #endif #ifdef _SC_TIMER_MAX { "_SC_TIMER_MAX", _SC_TIMER_MAX }, #endif #ifdef _SC_2_C_BIND { "_SC_2_C_BIND", _SC_2_C_BIND }, #endif #ifdef _SC_2_C_DEV { "_SC_2_C_DEV", _SC_2_C_DEV }, #endif #ifdef _SC_2_C_VERSION { "_SC_2_C_VERSION", _SC_2_C_VERSION }, #endif #ifdef _SC_2_FORT_DEV { "_SC_2_FORT_DEV", _SC_2_FORT_DEV }, #endif #ifdef _SC_2_FORT_RUN { "_SC_2_FORT_RUN", _SC_2_FORT_RUN }, #endif #ifdef _SC_2_LOCALEDEF { "_SC_2_LOCALEDEF", _SC_2_LOCALEDEF }, #endif #ifdef _SC_2_SW_DEV { "_SC_2_SW_DEV", _SC_2_SW_DEV }, #endif #ifdef _SC_2_UPE { "_SC_2_UPE", _SC_2_UPE }, #endif #ifdef _SC_2_VERSION { "_SC_2_VERSION", _SC_2_VERSION }, #endif #ifdef _SC_BC_BASE_MAX { "_SC_BC_BASE_MAX", _SC_BC_BASE_MAX }, #endif #ifdef _SC_BC_DIM_MAX { "_SC_BC_DIM_MAX", _SC_BC_DIM_MAX }, #endif #ifdef _SC_BC_SCALE_MAX { "_SC_BC_SCALE_MAX", _SC_BC_SCALE_MAX }, #endif #ifdef _SC_BC_STRING_MAX { "_SC_BC_STRING_MAX", _SC_BC_STRING_MAX }, #endif #ifdef _SC_COLL_WEIGHTS_MAX { "_SC_COLL_WEIGHTS_MAX", _SC_COLL_WEIGHTS_MAX }, #endif #ifdef _SC_EXPR_NEST_MAX { "_SC_EXPR_NEST_MAX", _SC_EXPR_NEST_MAX }, #endif #ifdef _SC_LINE_MAX { "_SC_LINE_MAX", _SC_LINE_MAX }, #endif #ifdef _SC_RE_DUP_MAX { "_SC_RE_DUP_MAX", _SC_RE_DUP_MAX }, #endif #ifdef _SC_XOPEN_CRYPT { "_SC_XOPEN_CRYPT", _SC_XOPEN_CRYPT }, #endif #ifdef _SC_XOPEN_ENH_I18N { "_SC_XOPEN_ENH_I18N", _SC_XOPEN_ENH_I18N }, #endif #ifdef _SC_XOPEN_SHM { "_SC_XOPEN_SHM", _SC_XOPEN_SHM }, #endif #ifdef _SC_2_CHAR_TERM { "_SC_2_CHAR_TERM", _SC_2_CHAR_TERM }, #endif #ifdef _SC_XOPEN_XCU_VERSION { "_SC_XOPEN_XCU_VERSION", _SC_XOPEN_XCU_VERSION }, #endif #ifdef _SC_ATEXIT_MAX { "_SC_ATEXIT_MAX", _SC_ATEXIT_MAX }, #endif #ifdef _SC_IOV_MAX { "_SC_IOV_MAX", _SC_IOV_MAX }, #endif #ifdef _SC_XOPEN_UNIX { "_SC_XOPEN_UNIX", _SC_XOPEN_UNIX }, #endif #ifdef _SC_PAGE_SIZE { "_SC_PAGE_SIZE", _SC_PAGE_SIZE }, #endif #ifdef _SC_T_IOV_MAX { "_SC_T_IOV_MAX", _SC_T_IOV_MAX }, #endif #ifdef _SC_PHYS_PAGES { "_SC_PHYS_PAGES", _SC_PHYS_PAGES }, #endif #ifdef _SC_AVPHYS_PAGES { "_SC_AVPHYS_PAGES", _SC_AVPHYS_PAGES }, #endif #ifdef _SC_COHER_BLKSZ { "_SC_COHER_BLKSZ", _SC_COHER_BLKSZ }, #endif #ifdef _SC_SPLIT_CACHE { "_SC_SPLIT_CACHE", _SC_SPLIT_CACHE }, #endif #ifdef _SC_ICACHE_SZ { "_SC_ICACHE_SZ", _SC_ICACHE_SZ }, #endif #ifdef _SC_DCACHE_SZ { "_SC_DCACHE_SZ", _SC_DCACHE_SZ }, #endif #ifdef _SC_ICACHE_LINESZ { "_SC_ICACHE_LINESZ", _SC_ICACHE_LINESZ }, #endif #ifdef _SC_DCACHE_LINESZ { "_SC_DCACHE_LINESZ", _SC_DCACHE_LINESZ }, #endif #ifdef _SC_ICACHE_BLKSZ { "_SC_ICACHE_BLKSZ", _SC_ICACHE_BLKSZ }, #endif #ifdef _SC_DCACHE_BLKSZ { "_SC_DCACHE_BLKSZ", _SC_DCACHE_BLKSZ }, #endif #ifdef _SC_DCACHE_TBLKSZ { "_SC_DCACHE_TBLKSZ", _SC_DCACHE_TBLKSZ }, #endif #ifdef _SC_ICACHE_ASSOC { "_SC_ICACHE_ASSOC", _SC_ICACHE_ASSOC }, #endif #ifdef _SC_DCACHE_ASSOC { "_SC_DCACHE_ASSOC", _SC_DCACHE_ASSOC }, #endif #ifdef _SC_MAXPID { "_SC_MAXPID", _SC_MAXPID }, #endif #ifdef _SC_STACK_PROT { "_SC_STACK_PROT", _SC_STACK_PROT }, #endif #ifdef _SC_THREAD_DESTRUCTOR_ITERATIONS { "_SC_THREAD_DESTRUCTOR_ITERATIONS", _SC_THREAD_DESTRUCTOR_ITERATIONS }, #endif #ifdef _SC_GETGR_R_SIZE_MAX { "_SC_GETGR_R_SIZE_MAX", _SC_GETGR_R_SIZE_MAX }, #endif #ifdef _SC_GETPW_R_SIZE_MAX { "_SC_GETPW_R_SIZE_MAX", _SC_GETPW_R_SIZE_MAX }, #endif #ifdef _SC_LOGIN_NAME_MAX { "_SC_LOGIN_NAME_MAX", _SC_LOGIN_NAME_MAX }, #endif #ifdef _SC_THREAD_KEYS_MAX { "_SC_THREAD_KEYS_MAX", _SC_THREAD_KEYS_MAX }, #endif #ifdef _SC_THREAD_STACK_MI { "_SC_THREAD_STACK_MIN", _SC_THREAD_STACK_MIN }, #endif #ifdef _SC_THREAD_THREADS_MAX { "_SC_THREAD_THREADS_MAX", _SC_THREAD_THREADS_MAX }, #endif #ifdef _SC_THREAD_ATTR_STACKADDR { "_SC_THREAD_ATTR_STACKADDR", _SC_THREAD_ATTR_STACKADDR }, #endif #ifdef _SC_THREAD_ATTR_STACKSIZE { "_SC_THREAD_ATTR_STACKSIZE", _SC_THREAD_ATTR_STACKSIZE }, #endif #ifdef _SC_THREAD_PRIORITY_SCHEDULING { "_SC_THREAD_PRIORITY_SCHEDULING", _SC_THREAD_PRIORITY_SCHEDULING }, #endif #ifdef _SC_THREAD_PRIO_INHERIT { "_SC_THREAD_PRIO_INHERIT", _SC_THREAD_PRIO_INHERIT }, #endif #ifdef _SC_THREAD_PRIO_PROTECT { "_SC_THREAD_PRIO_PROTECT", _SC_THREAD_PRIO_PROTECT }, #endif #ifdef _SC_THREAD_PROCESS_SHARED { "_SC_THREAD_PROCESS_SHARED", _SC_THREAD_PROCESS_SHARED }, #endif #ifdef _SC_XOPEN_LEGACY { "_SC_XOPEN_LEGACY", _SC_XOPEN_LEGACY }, #endif #ifdef _SC_XOPEN_REALTIME { "_SC_XOPEN_REALTIME", _SC_XOPEN_REALTIME }, #endif #ifdef _SC_XOPEN_REALTIME_THREADS { "_SC_XOPEN_REALTIME_THREADS", _SC_XOPEN_REALTIME_THREADS }, #endif #ifdef _SC_XBS5_ILP32_OFF32 { "_SC_XBS5_ILP32_OFF32", _SC_XBS5_ILP32_OFF32 }, #endif #ifdef _SC_XBS5_ILP32_OFFBIG { "_SC_XBS5_ILP32_OFFBIG", _SC_XBS5_ILP32_OFFBIG }, #endif #ifdef _SC_XBS5_LP64_OFF64 { "_SC_XBS5_LP64_OFF64", _SC_XBS5_LP64_OFF64 }, #endif #ifdef _SC_XBS5_LPBIG_OFFBIG { "_SC_XBS5_LPBIG_OFFBIG", _SC_XBS5_LPBIG_OFFBIG }, #endif #ifdef _SC_EQUIV_CLASS_MAX { "_SC_EQUIV_CLASS_MAX", _SC_EQUIV_CLASS_MAX }, #endif #ifdef _SC_CHARCLASS_NAME_MAX { "_SC_CHARCLASS_NAME_MAX", _SC_CHARCLASS_NAME_MAX }, #endif #ifdef _SC_PII { "_SC_PII", _SC_PII }, #endif #ifdef _SC_PII_XTI { "_SC_PII_XTI", _SC_PII_XTI }, #endif #ifdef _SC_PII_SOCKET { "_SC_PII_SOCKET", _SC_PII_SOCKET }, #endif #ifdef _SC_PII_INTERNET { "_SC_PII_INTERNET", _SC_PII_INTERNET }, #endif #ifdef _SC_PII_OSI { "_SC_PII_OSI", _SC_PII_OSI }, #endif #ifdef _SC_POLL { "_SC_POLL", _SC_POLL }, #endif #ifdef _SC_SELECT { "_SC_SELECT", _SC_SELECT }, #endif #ifdef _SC_UIO_MAXIOV { "_SC_UIO_MAXIOV", _SC_UIO_MAXIOV }, #endif #ifdef _SC_PII_INTERNET_STREAM { "_SC_PII_INTERNET_STREAM", _SC_PII_INTERNET_STREAM }, #endif #ifdef _SC_PII_INTERNET_DGRAM { "_SC_PII_INTERNET_DGRAM", _SC_PII_INTERNET_DGRAM }, #endif #ifdef _SC_PII_OSI_COTS { "_SC_PII_OSI_COTS", _SC_PII_OSI_COTS }, #endif #ifdef _SC_PII_OSI_CLTS { "_SC_PII_OSI_CLTS", _SC_PII_OSI_CLTS }, #endif #ifdef _SC_PII_OSI_M { "_SC_PII_OSI_M", _SC_PII_OSI_M }, #endif #ifdef _SC_T_IOV_MAX { "_SC_T_IOV_MAX", _SC_T_IOV_MAX }, #endif #ifdef _SC_THREADS { "_SC_THREADS", _SC_THREADS }, #endif #ifdef _SC_THREAD_SAFE_FUNCTIONS { "_SC_THREAD_SAFE_FUNCTIONS", _SC_THREAD_SAFE_FUNCTIONS }, #endif #ifdef _SC_TTY_NAME_MAX { "_SC_TTY_NAME_MAX", _SC_TTY_NAME_MAX }, #endif #ifdef _SC_XOPEN_XPG2 { "_SC_XOPEN_XPG2", _SC_XOPEN_XPG2 }, #endif #ifdef _SC_XOPEN_XPG3 { "_SC_XOPEN_XPG3", _SC_XOPEN_XPG3 }, #endif #ifdef _SC_XOPEN_XPG4 { "_SC_XOPEN_XPG4", _SC_XOPEN_XPG4 }, #endif #ifdef _SC_CHAR_BIT { "_SC_CHAR_BIT", _SC_CHAR_BIT }, #endif #ifdef _SC_CHAR_MAX { "_SC_CHAR_MAX", _SC_CHAR_MAX }, #endif #ifdef _SC_CHAR_MIN { "_SC_CHAR_MIN", _SC_CHAR_MIN }, #endif #ifdef _SC_INT_MAX { "_SC_INT_MAX", _SC_INT_MAX }, #endif #ifdef _SC_INT_MIN { "_SC_INT_MIN", _SC_INT_MIN }, #endif #ifdef _SC_LONG_BIT { "_SC_LONG_BIT", _SC_LONG_BIT }, #endif #ifdef _SC_WORD_BIT { "_SC_WORD_BIT", _SC_WORD_BIT }, #endif #ifdef _SC_MB_LEN_MAX { "_SC_MB_LEN_MAX", _SC_MB_LEN_MAX }, #endif #ifdef _SC_NZERO { "_SC_NZERO", _SC_NZERO }, #endif #ifdef _SC_SSIZE_MAX { "_SC_SSIZE_MAX", _SC_SSIZE_MAX }, #endif #ifdef _SC_SCHAR_MAX { "_SC_SCHAR_MAX", _SC_SCHAR_MAX }, #endif #ifdef _SC_SCHAR_MIN { "_SC_SCHAR_MIN", _SC_SCHAR_MIN }, #endif #ifdef _SC_SHRT_MAX { "_SC_SHRT_MAX", _SC_SHRT_MAX }, #endif #ifdef _SC_SHRT_MIN { "_SC_SHRT_MIN", _SC_SHRT_MIN }, #endif #ifdef _SC_UCHAR_MAX { "_SC_UCHAR_MAX", _SC_UCHAR_MAX }, #endif #ifdef _SC_UINT_MAX { "_SC_UINT_MAX", _SC_UINT_MAX }, #endif #ifdef _SC_ULONG_MAX { "_SC_ULONG_MAX", _SC_ULONG_MAX }, #endif #ifdef _SC_USHRT_MAX { "_SC_USHRT_MAX", _SC_USHRT_MAX }, #endif #ifdef _SC_NL_ARGMAX { "_SC_NL_ARGMAX", _SC_NL_ARGMAX }, #endif #ifdef _SC_NL_LANGMAX { "_SC_NL_LANGMAX", _SC_NL_LANGMAX }, #endif #ifdef _SC_NL_MSGMAX { "_SC_NL_MSGMAX", _SC_NL_MSGMAX }, #endif #ifdef _SC_NL_NMAX { "_SC_NL_NMAX", _SC_NL_NMAX }, #endif #ifdef _SC_NL_SETMAX { "_SC_NL_SETMAX", _SC_NL_SETMAX }, #endif }; static Handle getSysConf(TaskData *taskData, Handle args) { char argName[200]; int length; unsigned i; long res; length = Poly_string_to_C(DEREFWORD(args), argName, 200); if (length > 200) raise_syscall(taskData, "Argument name too long", ENAMETOOLONG); for (i = 0; i < sizeof(sysArgTable)/sizeof(sysArgTable[0]); i++) { if (strcmp(argName, sysArgTable[i].saName) == 0) break; /* See if it matches without the _SC_ at the beginning. */ if (strcmp(argName, sysArgTable[i].saName+4) == 0) break; } if (i == sizeof(sysArgTable)/sizeof(sysArgTable[0])) raise_syscall(taskData, "sysconf argument not found", EINVAL); errno = 0; /* Sysconf may return -1 without updating errno. */ res = sysconf(sysArgTable[i].saVal); if (res < 0) raise_syscall(taskData, "sysconf failed", errno); return Make_fixed_precision(taskData, (POLYUNSIGNED)res); } static struct { const char *pcName; int pcVal; } pathConfTable[] = { { "_PC_LINK_MAX", _PC_LINK_MAX }, { "_PC_MAX_CANON", _PC_MAX_CANON }, { "_PC_MAX_INPUT", _PC_MAX_INPUT }, { "_PC_NAME_MAX", _PC_NAME_MAX }, { "_PC_PATH_MAX", _PC_PATH_MAX }, { "_PC_PIPE_BUF", _PC_PIPE_BUF }, { "_PC_NO_TRUNC", _PC_NO_TRUNC }, { "_PC_VDISABLE", _PC_VDISABLE }, { "_PC_CHOWN_RESTRICTED", _PC_CHOWN_RESTRICTED }, #ifdef _PC_ASYNC_IO { "_PC_ASYNC_IO", _PC_ASYNC_IO }, #endif #ifdef _PC_PRIO_IO { "_PC_PRIO_IO", _PC_PRIO_IO }, #endif #ifdef _PC_SYNC_IO { "_PC_SYNC_IO", _PC_SYNC_IO }, #endif #ifdef _PC_FILESIZEBITS { "_PC_FILESIZEBITS", _PC_FILESIZEBITS }, #endif #ifdef _PC_SOCK_MAXBUF { "_PC_SOCK_MAXBUF", _PC_SOCK_MAXBUF }, #endif }; /* Look up a path variable in the table. */ static int findPathVar(TaskData *taskData, PolyWord ps) { char argName[200]; int length; unsigned i; length = Poly_string_to_C(ps, argName, 200); if (length > 200) raise_syscall(taskData, "Argument name too long", ENAMETOOLONG); for (i = 0; i < sizeof(pathConfTable)/sizeof(pathConfTable[0]); i++) { if (strcmp(argName, pathConfTable[i].pcName) == 0) return pathConfTable[i].pcVal; /* See if it matches without the _PC_ at the beginning. */ if (strcmp(argName, pathConfTable[i].pcName+4) == 0) return pathConfTable[i].pcVal; } raise_syscall(taskData, "pathconf argument not found", EINVAL); } // Unix.executeInEnv. This was previously implemented in ML but // there were problems, possibly associated with garbage collection. // Generally, the state after fork is problematic for the rest of the // run-time system so it is generally better to avoid Posix.Process.fork, -POLYUNSIGNED PolyUnixExecute(FirstArgument threadId, PolyWord cmd, PolyWord args, PolyWord env) +POLYUNSIGNED PolyUnixExecute(POLYUNSIGNED threadId, POLYUNSIGNED cmd, POLYUNSIGNED args, POLYUNSIGNED env) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCmd = taskData->saveVec.push(cmd); Handle pushedArgs = taskData->saveVec.push(args); Handle pushedEnv = taskData->saveVec.push(env); char* path = Poly_string_to_C_alloc(pushedCmd->WordP()); char** argl = stringListToVector(pushedArgs); char** envl = stringListToVector(pushedEnv); Handle result = 0; int toChild[2] = { -1, -1 }, fromChild[2] = { -1, -1 }; try { // Create input and output pipes if (pipe(toChild) < 0) raise_syscall(taskData, "pipe failed", errno); if (pipe(fromChild) < 0) raise_syscall(taskData, "pipe failed", errno); pid_t pid = fork(); if (pid < 0) raise_syscall(taskData, "fork failed", errno); if (pid == 0) { // In the child close(toChild[1]); // Write side to child - this is used in parent close(fromChild[0]); // Read side from child - this is used in parent dup2(toChild[0], 0); // Read side becomes stdin dup2(fromChild[1], 1); // Write side becomes stdout close(toChild[0]); close(fromChild[1]); execve(path, argl, envl); // If we get here the exec must have failed and we must stop with 126. _exit(126); } // In the parent close(toChild[0]); // These are used in the child close(fromChild[1]); Handle childPid = Make_fixed_precision(taskData, pid); Handle writeStr = wrapFileDescriptor(taskData, toChild[1]); Handle readStr = wrapFileDescriptor(taskData, fromChild[0]); result = ALLOC(3); DEREFHANDLE(result)->Set(0, childPid->Word()); DEREFHANDLE(result)->Set(1, writeStr->Word()); DEREFHANDLE(result)->Set(2, readStr->Word()); } catch (...) { // If an ML exception is raised if (toChild[0] != -1) close(toChild[0]); if (toChild[1] != -1) close(toChild[1]); if (fromChild[0] != -1) close(fromChild[0]); if (fromChild[1] != -1) close(fromChild[1]); } free(path); freeStringVector(argl); freeStringVector(envl); 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 osSpecificEPT[] = { { "PolyGetOSType", (polyRTSFunction)&PolyGetOSType}, { "PolyOSSpecificGeneral", (polyRTSFunction)&PolyOSSpecificGeneral}, { "PolyPosixSleep", (polyRTSFunction)&PolyPosixSleep}, { "PolyUnixExecute", (polyRTSFunction)&PolyUnixExecute}, { NULL, NULL} // End of list. }; class UnixSpecific: public RtsModule { public: virtual void Init(void); }; // Declare this. It will be automatically added to the table. static UnixSpecific unixModule; void UnixSpecific::Init(void) { struct sigaction sigcatch; /* Ignore SIGPIPE - return any errors as failure to write. */ memset(&sigcatch, 0, sizeof(sigcatch)); sigcatch.sa_handler = SIG_IGN; sigaction(SIGPIPE, &sigcatch, NULL); } diff --git a/libpolyml/winbasicio.cpp b/libpolyml/winbasicio.cpp index d3617fd9..f3c7904c 100644 --- a/libpolyml/winbasicio.cpp +++ b/libpolyml/winbasicio.cpp @@ -1,1439 +1,1439 @@ /* Title: Basic IO for Windows. Copyright (c) 2000, 2015-2019 David C. J. Matthews This was split from the common code for Unix and Windows. Portions of this code are derived from the original stream io package copyright CUTS 1983-2000. 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_FCNTL_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_POLL_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_SYS_SELECT_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_DIRECT_H #include #endif #ifdef HAVE_STDIO_H #include #endif #include #include #include #ifndef INFTIM #define INFTIM (-1) #endif #include #include "globals.h" #include "basicio.h" #include "sys.h" #include "gc.h" #include "run_time.h" #include "machine_dep.h" #include "arb.h" #include "processes.h" #include "diagnostics.h" #include "io_internal.h" #include "scanaddrs.h" #include "polystring.h" #include "mpoly.h" #include "save_vec.h" #include "rts_module.h" #include "locking.h" #include "rtsentry.h" #include "timing.h" #include "winstartup.h" #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #define STREAMCLOSED ERROR_INVALID_HANDLE #define FILEDOESNOTEXIST ERROR_FILE_NOT_FOUND #define ERRORNUMBER _doserrno #ifndef O_ACCMODE #define O_ACCMODE (O_RDONLY|O_RDWR|O_WRONLY) #endif #define SAVE(x) taskData->saveVec.push(x) #ifdef _MSC_VER // Don't tell me about ISO C++ changes. #pragma warning(disable:4996) #endif extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVec, PolyWord bitVec, PolyWord maxMillisecs); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForInput(FirstArgument threadId, PolyWord strm, PolyWord waitMillisecs); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForOutput(FirstArgument threadId, PolyWord strm, PolyWord waitMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED strm, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(POLYUNSIGNED threadId, POLYUNSIGNED streamVec, POLYUNSIGNED bitVec, POLYUNSIGNED maxMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForInput(POLYUNSIGNED threadId, POLYUNSIGNED strm, POLYUNSIGNED waitMillisecs); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForOutput(POLYUNSIGNED threadId, POLYUNSIGNED strm, POLYUNSIGNED waitMillisecs); } // References to the standard streams. They are only needed if we are compiling // the basis library and make a second call to get the standard streams. static PolyObject *standardInputValue, *standardOutputValue, *standardErrorValue; // Creates a new unique pipename in the appropriate format. // Utility function provided for winguiconsole and windows_specific void newPipeName(TCHAR *pipeName) { static LONG pipenum = 0; wsprintf(pipeName, _T("\\\\.\\Pipe\\PolyPipe.%08x.%08x"), GetCurrentProcessId(), InterlockedIncrement(&pipenum)); } int WinStream::fileTypeOfHandle(HANDLE hStream) { switch (GetFileType(hStream)) { case FILE_TYPE_PIPE: return FILEKIND_PIPE; case FILE_TYPE_CHAR: return FILEKIND_TTY;// Or a device? case FILE_TYPE_DISK: return FILEKIND_FILE; default: if (GetLastError() == 0) return FILEKIND_UNKNOWN; // Error or unknown. else return FILEKIND_ERROR; } } void WinStream::unimplemented(TaskData *taskData) { // Called on the random access functions raise_syscall(taskData, "Position error", ERROR_NOT_SUPPORTED); } // Backwards compatibility. This should now be done in ML. void WinStream::waitUntilAvailable(TaskData *taskData) { while (!testForInput(taskData, 1000)) { } } void WinStream::waitUntilOutputPossible(TaskData *taskData) { while (!testForOutput(taskData, 1000)) { } } WinInOutStream::WinInOutStream() { hStream = hEvent = INVALID_HANDLE_VALUE; buffer = 0; currentInBuffer = currentPtr = 0; endOfStream = false; buffSize = 4096; // Seems like a good number ZeroMemory(&overlap, sizeof(overlap)); isText = false; isRead = true; } WinInOutStream::~WinInOutStream() { free(buffer); } void WinInOutStream::openFile(TaskData * taskData, TCHAR *name, openMode mode, bool isT) { isRead = mode == OPENREAD; isText = isT; ASSERT(hStream == INVALID_HANDLE_VALUE); // We should never reuse an object. buffer = (byte*)malloc(buffSize); if (buffer == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // Create a manual reset event with state=signalled. This means // that no operation is in progress. hEvent = CreateEvent(NULL, TRUE, TRUE, NULL); overlap.hEvent = hEvent; switch (mode) { case OPENREAD: hStream = CreateFile(name, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, NULL); break; case OPENWRITE: hStream = CreateFile(name, GENERIC_WRITE, FILE_SHARE_READ, NULL, CREATE_ALWAYS, FILE_FLAG_OVERLAPPED, NULL); break; case OPENAPPEND: hStream = CreateFile(name, GENERIC_WRITE, FILE_SHARE_READ, NULL, OPEN_ALWAYS, FILE_FLAG_OVERLAPPED, NULL); break; } if (hStream == INVALID_HANDLE_VALUE) raise_syscall(taskData, "CreateFile failed", GetLastError()); // Start a read immediately so that there is something in the buffer. switch (mode) { case OPENREAD: if(!beginReading()) raise_syscall(taskData, "Read failure", GetLastError()); break; case OPENWRITE: break; case OPENAPPEND: { // We could use the special 0xfff... value in the overlapped structure for this // but that would mess up getPos/endPos. LARGE_INTEGER fileSize; if (!GetFileSizeEx(hStream, &fileSize)) raise_syscall(taskData, "Stream is not a file", GetLastError()); setOverlappedPos(fileSize.QuadPart); } break; } } // This is only used to set up standard output. // Now also used for Windows.execute. bool WinInOutStream::openHandle(HANDLE hndl, openMode mode, bool isT) { // Need to check the handle. It seems DuplicateHandle actually allows an invalid handle if (hndl == INVALID_HANDLE_VALUE) { SetLastError(ERROR_INVALID_HANDLE); return false; } isRead = mode == OPENREAD; isText = isT; ASSERT(hStream == INVALID_HANDLE_VALUE); // We should never reuse an object. buffer = (byte*)malloc(buffSize); if (buffer == 0) { SetLastError(NOMEMORY); return false; } hEvent = CreateEvent(NULL, TRUE, TRUE, NULL); overlap.hEvent = hEvent; // Duplicate the handle so we can safely close it. if (!DuplicateHandle(GetCurrentProcess(), hndl, GetCurrentProcess(), &hStream, 0, FALSE, DUPLICATE_SAME_ACCESS)) return false; if (isRead) return beginReading(); return true; } // Start reading. This may complete immediately. bool WinInOutStream::beginReading() { if (!ReadFile(hStream, buffer, buffSize, NULL, &overlap)) { switch (GetLastError()) { case ERROR_HANDLE_EOF: // We get ERROR_BROKEN_PIPE as EOF on a pipe. case ERROR_BROKEN_PIPE: endOfStream = true; case ERROR_IO_PENDING: return true; default: return false; } } return true; } void WinInOutStream::closeEntry(TaskData *taskData) { if (isRead) { if (WaitForSingleObject(hEvent, 0) == WAIT_TIMEOUT) // Something is in progress. CancelIoEx(hStream, &overlap); } else flushOut(taskData); PLocker locker(&lock); if (!CloseHandle(hStream)) raise_syscall(taskData, "CloseHandle failed", GetLastError()); hStream = INVALID_HANDLE_VALUE; CloseHandle(hEvent); hEvent = INVALID_HANDLE_VALUE; } // Make sure that everything has been written. void WinInOutStream::flushOut(TaskData *taskData) { while (currentInBuffer != 0) { // If currentInBuffer is not zero we have an operation in progress. waitUntilOutputPossible(taskData); // canOutput will test the result and may update currentInBuffer. // We may not have written everything so check and repeat if necessary. if (currentInBuffer != 0) writeStream(taskData, NULL, 0); } } size_t WinInOutStream::readStream(TaskData *taskData, byte *base, size_t length) { PLocker locker(&lock); if (endOfStream) return 0; size_t copied = 0; // Copy as much as we can from the buffer. while (currentPtr < currentInBuffer && copied < length) { byte b = buffer[currentPtr++]; // In text mode we want to return NL for CRNL. Assume that this is // properly formatted and simply skip CRs. It's not clear what to return // if it isn't properly formatted and the user can always open it as binary // and do the conversion. if (!isText || b != '\r') base[copied++] = b; } // If we have exhausted the buffer we start a new read. while (isText && currentPtr < currentInBuffer && buffer[currentPtr] == '\r') currentPtr++; if (currentInBuffer == currentPtr) { // We need to start a new read currentInBuffer = currentPtr = 0; if (!beginReading()) raise_syscall(taskData, "Read failure", GetLastError()); } return copied; } // This actually does most of the work. In particular for text streams we may have a // block that consists only of CRs. bool WinInOutStream::isAvailable(TaskData *taskData) { while (1) { { PLocker locker(&lock); // It is available if we have something in the buffer or we're at EOF if (currentInBuffer < currentPtr || endOfStream) return true; // We should have had a read in progress. DWORD bytesRead = 0; if (!GetOverlappedResult(hStream, &overlap, &bytesRead, FALSE)) { DWORD err = GetLastError(); switch (err) { case ERROR_HANDLE_EOF: case ERROR_BROKEN_PIPE: // We've had EOF - That result is available endOfStream = true; return true; case ERROR_IO_INCOMPLETE: // It's still in progress. return false; default: raise_syscall(taskData, "GetOverlappedResult failed", err); } } // The next read must be after this. setOverlappedPos(getOverlappedPos() + bytesRead); currentInBuffer = bytesRead; // If this is a text stream skip CRs. while (isText && currentPtr < currentInBuffer && buffer[currentPtr] == '\r') currentPtr++; // If we have some real data it can be read now if (currentPtr < currentInBuffer) return true; } // Try again. if (!beginReading()) // And loop raise_syscall(taskData, "Read failure", GetLastError()); } } bool WinInOutStream::testForInput(TaskData *taskData, unsigned waitMilliSecs) { if (isAvailable(taskData)) return true; if (waitMilliSecs != 0) { WaitHandle waiter(hEvent, waitMilliSecs); processes->ThreadPauseForIO(taskData, &waiter); } return false; } int WinInOutStream::poll(TaskData *taskData, int test) { if (test & POLL_BIT_IN) { if (testForInput(taskData, 0)) return POLL_BIT_IN; } if (test & POLL_BIT_OUT) { if (testForOutput(taskData, 0)) return POLL_BIT_OUT; } return 0; } // Random access functions uint64_t WinInOutStream::getPos(TaskData *taskData) { if (GetFileType(hStream) != FILE_TYPE_DISK) raise_syscall(taskData, "Stream is not a file", ERROR_SEEK_ON_DEVICE); PLocker locker(&lock); if (isRead) return getOverlappedPos() - currentInBuffer + currentPtr; else return getOverlappedPos() + currentInBuffer; } void WinInOutStream::setPos(TaskData *taskData, uint64_t pos) { if (GetFileType(hStream) != FILE_TYPE_DISK) raise_syscall(taskData, "Stream is not a file", ERROR_SEEK_ON_DEVICE); // Need to wait until any pending operation is complete. If this is a write // we need to flush anything before changing the position. if (isRead) { while (WaitForSingleObject(hEvent, 0) == WAIT_TIMEOUT) { WaitHandle waiter(hEvent, 1000); processes->ThreadPauseForIO(taskData, &waiter); } } else flushOut(taskData); PLocker locker(&lock); setOverlappedPos(pos); // Discard any unread data and start reading at the new position. currentInBuffer = currentPtr = 0; endOfStream = false; if (isRead && !beginReading()) raise_syscall(taskData, "Read failure", GetLastError()); } uint64_t WinInOutStream::fileSize(TaskData *taskData) { LARGE_INTEGER fileSize; if (!GetFileSizeEx(hStream, &fileSize)) raise_syscall(taskData, "Stream is not a file", GetLastError()); return fileSize.QuadPart; } bool WinInOutStream::canOutput(TaskData *taskData) { if (isRead) unimplemented(taskData); PLocker locker(&lock); // If the buffer is empty we're fine. if (currentInBuffer == 0) return true; // Otherwise there is an operation in progress. Has it finished? DWORD bytesWritten = 0; if (!GetOverlappedResult(hStream, &overlap, &bytesWritten, FALSE)) { DWORD err = GetLastError(); if (err == ERROR_IO_INCOMPLETE) return false; else raise_syscall(taskData, "GetOverlappedResult failed", err); } setOverlappedPos(getOverlappedPos() + bytesWritten); // If we haven't written everything copy down what we have left. if (bytesWritten < currentInBuffer) memmove(buffer, buffer + bytesWritten, currentInBuffer - bytesWritten); currentInBuffer -= bytesWritten; // This will then be written before anything else. return true; } bool WinInOutStream::testForOutput(TaskData *taskData, unsigned waitMilliSecs) { if (canOutput(taskData)) return true; if (waitMilliSecs != 0) { WaitHandle waiter(hEvent, waitMilliSecs); processes->ThreadPauseForIO(taskData, &waiter); } return false; } // Write data. N.B. This is also used with zero data from closeEntry. size_t WinInOutStream::writeStream(TaskData *taskData, byte *base, size_t length) { if (isRead) unimplemented(taskData); PLocker locker(&lock); // Copy as much as we can into the buffer. size_t copied = 0; while (currentInBuffer < buffSize && copied < length) { if (isText && base[copied] == '\n') { // Put in a CR but make sure we've space for both. if (currentInBuffer == buffSize - 1) break; // Exit the loop with what we've done. buffer[currentInBuffer++] = '\r'; } buffer[currentInBuffer++] = base[copied++]; } // Write what's in the buffer. if (!WriteFile(hStream, buffer, currentInBuffer, NULL, &overlap)) { DWORD dwErr = GetLastError(); if (dwErr != ERROR_IO_PENDING) raise_syscall(taskData, "WriteFile failed", dwErr); } // Even if it actually succeeded we still pick up the result in canOutput. return copied; // Return what we copied. } /* Open a file in the required mode. */ static Handle openWinFile(TaskData *taskData, Handle filename, openMode mode, bool isAppend, bool isBinary) { TempString cFileName(filename->Word()); // Get file name if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); try { WinInOutStream *stream = new WinInOutStream(); stream->openFile(taskData, cFileName, mode, !isBinary); return MakeVolatileWord(taskData, stream); } catch (std::bad_alloc&) { raise_syscall(taskData, "Insufficient memory", NOMEMORY); } } /* Read into an array. */ // We can't combine readArray and readString because we mustn't compute the // destination of the data in readArray until after any GC. static Handle readArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { WinStream *strm = *(WinStream**)(stream->WordP()); if (strm == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); /* The isText argument is ignored in both Unix and Windows but is provided for future use. Windows remembers the mode used when the file was opened to determine whether to translate CRLF into LF. */ // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); // First test to see if we have input available. // These tests may result in a GC if another thread is running. strm->waitUntilAvailable(taskData); // We can now try to read without blocking. // Actually there's a race here in the unlikely situation that there // are multiple threads sharing the same low-level reader. They could // both detect that input is available but only one may succeed in // reading without blocking. This doesn't apply where the threads use // the higher-level IO interfaces in ML which have their own mutexes. byte *base = DEREFHANDLE(args)->Get(0).AsObjPtr()->AsBytePtr(); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); size_t haveRead = strm->readStream(taskData, base + offset, length); return Make_fixed_precision(taskData, haveRead); // Success. } /* Return input as a string. We don't actually need both readArray and readString but it's useful to have both to reduce unnecessary garbage. The IO library will construct one from the other but the higher levels choose the appropriate function depending on need. */ static Handle readString(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { size_t length = getPolyUnsigned(taskData, DEREFWORD(args)); WinStream *strm = *(WinStream**)(stream->WordP()); if (strm == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); // First test to see if we have input available. // These tests may result in a GC if another thread is running. strm->waitUntilAvailable(taskData); // We can now try to read without blocking. // We previously allocated the buffer on the stack but that caused // problems with multi-threading at least on Mac OS X because of // stack exhaustion. We limit the space to 100k. */ if (length > 102400) length = 102400; byte *buff = (byte*)malloc(length); if (buff == 0) raise_syscall(taskData, "Unable to allocate buffer", NOMEMORY); try { size_t haveRead = strm->readStream(taskData, buff, length); Handle result = SAVE(C_string_to_Poly(taskData, (char*)buff, haveRead)); free(buff); return result; } catch (...) { free(buff); throw; } } static Handle writeArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/) { // The isText argument is ignored in both Unix and Windows but // is provided for future use. Windows remembers the mode used // when the file was opened to determine whether to translate // LF into CRLF. WinStream *strm = *(WinStream**)(stream->WordP()); if (strm == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); strm->waitUntilOutputPossible(taskData); PolyWord base = DEREFWORDHANDLE(args)->Get(0); POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); /* We don't actually handle cases of blocking on output. */ byte *toWrite = base.AsObjPtr()->AsBytePtr(); size_t haveWritten = strm->writeStream(taskData, toWrite + offset, length); return Make_fixed_precision(taskData, haveWritten); } Handle pollTest(TaskData *taskData, Handle stream) { WinStream *strm = *(WinStream**)(stream->WordP()); return Make_fixed_precision(taskData, strm->pollTest()); } // Poll file descriptors. Also used with empty descriptors as OS.Process.sleep. // Takes a vector of io descriptors, a vector of bits to test // and a time to wait and returns a vector of results. // Windows: This is messy because "select" only works on sockets. // Do the best we can. -POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVector, PolyWord bitVector, PolyWord maxMillisecs) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(POLYUNSIGNED threadId, POLYUNSIGNED streamVector, POLYUNSIGNED bitVector, POLYUNSIGNED maxMillisecs) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); - unsigned maxMilliseconds = (unsigned)maxMillisecs.UnTaggedUnsigned(); + unsigned maxMilliseconds = (unsigned)PolyWord::FromUnsigned(maxMillisecs).UnTaggedUnsigned(); Handle result = 0; try { - PolyObject *strmVec = streamVector.AsObjPtr(); - PolyObject *bitVec = bitVector.AsObjPtr(); + PolyObject *strmVec = PolyWord::FromUnsigned(streamVector).AsObjPtr(); + PolyObject *bitVec = PolyWord::FromUnsigned(bitVector).AsObjPtr(); POLYUNSIGNED nDesc = strmVec->Length(); ASSERT(nDesc == bitVec->Length()); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); /* Simply do a non-blocking poll. */ /* Record the results in this vector. */ char *results = 0; bool haveResult = false; if (nDesc > 0) { results = (char*)alloca(nDesc); memset(results, 0, nDesc); } for (POLYUNSIGNED i = 0; i < nDesc; i++) { WinStream *strm = *(WinStream**)(strmVec->Get(i).AsObjPtr()); if (strm == NULL) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); int bits = get_C_int(taskData, bitVec->Get(i)); results[i] = strm->poll(taskData, bits); if (results[i] != 0) haveResult = true; } if (haveResult == 0 && maxMilliseconds != 0) { /* Poll failed - treat as time out. */ WaitHandle waiter(NULL, maxMilliseconds); processes->ThreadPauseForIO(taskData, &waiter); } /* Copy the results to a result vector. */ result = alloc_and_save(taskData, nDesc); for (POLYUNSIGNED j = 0; j < nDesc; j++) (DEREFWORDHANDLE(result))->Set(j, TAGGED(results[j])); } catch (KillException &) { processes->ThreadExit(taskData); // TestAnyEvents may test for kill } 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(); } // Directory functions. class WinDirData { public: HANDLE hFind; /* FindFirstFile handle */ WIN32_FIND_DATA lastFind; int fFindSucceeded; }; static Handle openDirectory(TaskData *taskData, Handle dirname) { // Get the directory name but add on two characters for the \* plus one for the NULL. POLYUNSIGNED length = PolyStringLength(dirname->Word()); TempString dirName((TCHAR*)malloc((length + 3) * sizeof(TCHAR))); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); Poly_string_to_C(dirname->Word(), dirName, length + 2); // Tack on \* to the end so that we find all files in the directory. lstrcat(dirName, _T("\\*")); WinDirData *pData = new WinDirData; // TODO: Handle failue HANDLE hFind = FindFirstFile(dirName, &pData->lastFind); if (hFind == INVALID_HANDLE_VALUE) raise_syscall(taskData, "FindFirstFile failed", GetLastError()); pData->hFind = hFind; /* There must be at least one file which matched. */ pData->fFindSucceeded = 1; return MakeVolatileWord(taskData, pData); } /* Return the next entry from the directory, ignoring current and parent arcs ("." and ".." in Windows and Unix) */ Handle readDirectory(TaskData *taskData, Handle stream) { WinDirData *pData = *(WinDirData**)(stream->WordP()); // In a Volatile if (pData == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); Handle result = NULL; // The next entry to read is already in the buffer. FindFirstFile // both opens the directory and returns the first entry. If // fFindSucceeded is false we have already reached the end. if (!pData->fFindSucceeded) return SAVE(EmptyString(taskData)); while (result == NULL) { WIN32_FIND_DATA *pFind = &(pData->lastFind); if (!((pFind->dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) && (lstrcmp(pFind->cFileName, _T(".")) == 0 || lstrcmp(pFind->cFileName, _T("..")) == 0))) { result = SAVE(C_string_to_Poly(taskData, pFind->cFileName)); } /* Get the next entry. */ if (!FindNextFile(pData->hFind, pFind)) { DWORD dwErr = GetLastError(); if (dwErr == ERROR_NO_MORE_FILES) { pData->fFindSucceeded = 0; if (result == NULL) return SAVE(EmptyString(taskData)); } } } return result; } Handle rewindDirectory(TaskData *taskData, Handle stream, Handle dirname) { WinDirData *pData = *(WinDirData**)(stream->WordP()); // In a SysWord if (pData == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // There's no rewind - close and reopen. FindClose(pData->hFind); POLYUNSIGNED length = PolyStringLength(dirname->Word()); TempString dirName((TCHAR*)malloc((length + 3) * sizeof(TCHAR))); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); Poly_string_to_C(dirname->Word(), dirName, length + 2); // Tack on \* to the end so that we find all files in the directory. lstrcat(dirName, _T("\\*")); HANDLE hFind = FindFirstFile(dirName, &(pData->lastFind)); if (hFind == INVALID_HANDLE_VALUE) raise_syscall(taskData, "FindFirstFile failed", GetLastError()); pData->hFind = hFind; /* There must be at least one file which matched. */ pData->fFindSucceeded = 1; return Make_fixed_precision(taskData, 0); } static Handle closeDirectory(TaskData *taskData, Handle stream) { WinDirData *pData = *(WinDirData**)(stream->WordP()); // In a SysWord if (pData != 0) { FindClose(pData->hFind); delete(pData); *((WinDirData**)stream->WordP()) = 0; // Clear this - no longer valid } return Make_fixed_precision(taskData, 0); } /* change_dirc - this is called directly and not via the dispatch function. */ static Handle change_dirc(TaskData *taskData, Handle name) /* Change working directory. */ { TempString cDirName(name->Word()); if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (SetCurrentDirectory(cDirName) == FALSE) raise_syscall(taskData, "SetCurrentDirectory failed", GetLastError()); return SAVE(TAGGED(0)); } // External call -POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyChDir(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); try { (void)change_dirc(taskData, pushedArg); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Result is unit } /* Test for a directory. */ Handle isDir(TaskData *taskData, Handle name) { TempString cDirName(name->Word()); if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); DWORD dwRes = GetFileAttributes(cDirName); if (dwRes == 0xFFFFFFFF) raise_syscall(taskData, "GetFileAttributes failed", GetLastError()); if (dwRes & FILE_ATTRIBUTE_DIRECTORY) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } /* Get absolute canonical path name. */ Handle fullPath(TaskData *taskData, Handle filename) { TempString cFileName; /* Special case of an empty string. */ if (PolyStringLength(filename->Word()) == 0) cFileName = _tcsdup(_T(".")); else cFileName = Poly_string_to_T_alloc(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // Get the length DWORD dwRes = GetFullPathName(cFileName, 0, NULL, NULL); if (dwRes == 0) raise_syscall(taskData, "GetFullPathName failed", GetLastError()); TempString resBuf((TCHAR*)malloc(dwRes * sizeof(TCHAR))); if (resBuf == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // When the length is enough the result is the length excluding the null DWORD dwRes1 = GetFullPathName(cFileName, dwRes, resBuf, NULL); if (dwRes1 == 0 || dwRes1 >= dwRes) raise_syscall(taskData, "GetFullPathName failed", GetLastError()); /* Check that the file exists. GetFullPathName doesn't do that. */ dwRes = GetFileAttributes(resBuf); if (dwRes == 0xffffffff) raise_syscall(taskData, "File does not exist", FILEDOESNOTEXIST); return(SAVE(C_string_to_Poly(taskData, resBuf))); } /* Get file modification time. This returns the value in the time units and from the base date used by timing.c. c.f. filedatec */ Handle modTime(TaskData *taskData, Handle filename) { TempString cFileName(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); /* There are two ways to get this information. We can either use GetFileTime if we are able to open the file for reading but if it is locked we won't be able to. FindFirstFile is the other alternative. We have to check that the file name does not contain '*' or '?' otherwise it will try to "glob" this, which isn't what we want here. */ WIN32_FIND_DATA wFind; HANDLE hFind; const TCHAR *p; for(p = cFileName; *p; p++) if (*p == '*' || *p == '?') raise_syscall(taskData, "Invalid filename", STREAMCLOSED); hFind = FindFirstFile(cFileName, &wFind); if (hFind == INVALID_HANDLE_VALUE) raise_syscall(taskData, "FindFirstFile failed", GetLastError()); FindClose(hFind); return Make_arb_from_Filetime(taskData, wFind.ftLastWriteTime); } /* Get file size. */ Handle fileSize(TaskData *taskData, Handle filename) { TempString cFileName(filename->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); /* Similar to modTime*/ WIN32_FIND_DATA wFind; HANDLE hFind; const TCHAR *p; for(p = cFileName; *p; p++) if (*p == '*' || *p == '?') raise_syscall(taskData, "Invalid filename", STREAMCLOSED); hFind = FindFirstFile(cFileName, &wFind); if (hFind == INVALID_HANDLE_VALUE) raise_syscall(taskData, "FindFirstFile failed", GetLastError()); FindClose(hFind); return Make_arb_from_32bit_pair(taskData, wFind.nFileSizeHigh, wFind.nFileSizeLow); } /* Set file modification and access times. */ Handle setTime(TaskData *taskData, Handle fileName, Handle fileTime) { TempString cFileName(fileName->Word()); if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); // The only way to set the time is to open the file and use SetFileTime. FILETIME ft; /* Get the file time. */ getFileTimeFromArb(taskData, fileTime, &ft); /* Open an existing file with write access. We need that for SetFileTime. */ HANDLE hFile = CreateFile(cFileName, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hFile == INVALID_HANDLE_VALUE) raise_syscall(taskData, "CreateFile failed", GetLastError()); /* Set the file time. */ if (!SetFileTime(hFile, NULL, &ft, &ft)) { int nErr = GetLastError(); CloseHandle(hFile); raise_syscall(taskData, "SetFileTime failed", nErr); } CloseHandle(hFile); return Make_fixed_precision(taskData, 0); } /* Rename a file. */ Handle renameFile(TaskData *taskData, Handle oldFileName, Handle newFileName) { TempString oldName(oldFileName->Word()), newName(newFileName->Word()); if (oldName == 0 || newName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (! MoveFileEx(oldName, newName, MOVEFILE_REPLACE_EXISTING)) raise_syscall(taskData, "MoveFileEx failed", GetLastError()); return Make_fixed_precision(taskData, 0); } /* Access right requests passed in from ML. */ #define FILE_ACCESS_READ 1 #define FILE_ACCESS_WRITE 2 #define FILE_ACCESS_EXECUTE 4 /* Get access rights to a file. */ Handle fileAccess(TaskData *taskData, Handle name, Handle rights) { TempString fileName(name->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int rts = get_C_int(taskData, DEREFWORD(rights)); /* Test whether the file is read-only. This is, of course, not what was asked but getting anything more is really quite complicated. I don't see how we can find out if a file is executable (maybe check if the extension is .exe, .com or .bat?). It would be possible, in NT, to examine the access structures but that seems far too complicated. Leave it for the moment. */ DWORD dwRes = GetFileAttributes(fileName); if (dwRes == 0xffffffff) return Make_fixed_precision(taskData, 0); /* If we asked for write access but it is read-only we return false. */ if ((dwRes & FILE_ATTRIBUTE_READONLY) && (rts & FILE_ACCESS_WRITE)) return Make_fixed_precision(taskData, 0); else return Make_fixed_precision(taskData, 1); } /* IO_dispatchc. Called from assembly code module. */ static Handle IO_dispatch_c(TaskData *taskData, Handle args, Handle strm, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 0: // Return standard input. // This and the next two are normally only called once during start-up. // The exception is when we build the basis library during bootstrap. // We need to maintain the invariant that each WinStream object is referenced // by precisely one volatile word in order to be able to delete it when we close it. { if (standardInputValue != 0) return taskData->saveVec.push(standardInputValue); Handle stdStrm = MakeVolatileWord(taskData, standardInput); standardInputValue = stdStrm->WordP(); return stdStrm; } case 1: // Return standard output { if (standardOutputValue != 0) return taskData->saveVec.push(standardOutputValue); Handle stdStrm = MakeVolatileWord(taskData, standardOutput); standardOutputValue = stdStrm->WordP(); return stdStrm; } case 2: // Return standard error { if (standardErrorValue != 0) return taskData->saveVec.push(standardErrorValue); Handle stdStrm = MakeVolatileWord(taskData, standardError); standardErrorValue = stdStrm->WordP(); return stdStrm; } case 3: /* Open file for text input. */ return openWinFile(taskData, args, OPENREAD, false, false); case 4: /* Open file for binary input. */ return openWinFile(taskData, args, OPENREAD, false, true); case 5: /* Open file for text output. */ return openWinFile(taskData, args, OPENWRITE, false, false); case 6: /* Open file for binary output. */ return openWinFile(taskData, args, OPENWRITE, false, true); case 13: /* Open text file for appending. */ /* The IO library definition leaves it open whether this should use "append mode" or not. */ return openWinFile(taskData, args, OPENWRITE, true, false); case 14: /* Open binary file for appending. */ return openWinFile(taskData, args, OPENWRITE, true, true); case 7: /* Close file */ { // During the bootstrap we will have old format references. if (strm->Word().IsTagged()) return Make_fixed_precision(taskData, 0); WinStream *stream = *(WinStream **)(strm->WordP()); // May already have been closed. if (stream != 0) { try { stream->closeEntry(taskData); delete(stream); *(WinStream **)(strm->WordP()) = 0; } catch (...) { // If there was an error and we've raised an exception. delete(stream); *(WinStream **)(strm->WordP()) = 0; throw; } } return Make_fixed_precision(taskData, 0); } case 8: /* Read text into an array. */ return readArray(taskData, strm, args, true); case 9: /* Read binary into an array. */ return readArray(taskData, strm, args, false); case 10: /* Get text as a string. */ return readString(taskData, strm, args, true); case 11: /* Write from memory into a text file. */ return writeArray(taskData, strm, args, true); case 12: /* Write from memory into a binary file. */ return writeArray(taskData, strm, args, false); case 15: /* Return recommended buffer size. */ // This is a guess but 4k seems reasonable. return Make_fixed_precision(taskData, 4096); case 16: /* See if we can get some input. */ { WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return Make_fixed_precision(taskData, stream->testForInput(taskData, 0) ? 1 : 0); } case 17: // Return the number of bytes available. PrimIO.avail. { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); uint64_t endOfStream = stream->fileSize(taskData); // May raise an exception if this isn't a file. uint64_t current = stream->getPos(taskData); return Make_fixed_precision(taskData, endOfStream - current); } case 18: // Get position on stream. PrimIO.getPos { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // Get the current position in the stream. This is used to test // for the availability of random access so it should raise an // exception if setFilePos or endFilePos would fail. return Make_arbitrary_precision(taskData, stream->getPos(taskData)); } case 19: // Seek to position on stream. PrimIO.setPos { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // TODO: This doesn't necessarily return a 64-bit value. uint64_t position = (uint64_t)getPolyUnsigned(taskData, DEREFWORD(args)); stream->setPos(taskData, position); return Make_arbitrary_precision(taskData, 0); } case 20: // Return position at end of stream. PrimIO.endPos. { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return Make_arbitrary_precision(taskData, stream->fileSize(taskData)); } case 21: /* Get the kind of device underlying the stream. */ { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return Make_fixed_precision(taskData, stream->fileKind()); } case 22: /* Return the polling options allowed on this descriptor. */ return pollTest(taskData, strm); // case 23: /* Poll the descriptor, waiting forever. */ // return pollDescriptors(taskData, args, 1); // case 24: /* Poll the descriptor, waiting for the time requested. */ // return pollDescriptors(taskData, args, 0); // case 25: /* Poll the descriptor, returning immediately.*/ // return pollDescriptors(taskData, args, 2); case 26: /* Get binary as a vector. */ return readString(taskData, strm, args, false); case 27: /* Block until input is available. */ { WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); stream->waitUntilAvailable(taskData); return Make_fixed_precision(taskData, 0); } case 28: /* Test whether output is possible. */ { WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return Make_fixed_precision(taskData, stream->testForOutput(taskData, 0) ? 1 : 0); } case 29: /* Block until output is possible. */ { WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); stream->waitUntilOutputPossible(taskData); return Make_fixed_precision(taskData, 0); } /* Directory functions. */ case 50: /* Open a directory. */ return openDirectory(taskData, args); case 51: /* Read a directory entry. */ return readDirectory(taskData, strm); case 52: /* Close the directory */ return closeDirectory(taskData, strm); case 53: /* Rewind the directory. */ return rewindDirectory(taskData, strm, args); case 54: /* Get current working directory. */ { DWORD space = GetCurrentDirectory(0, NULL); if (space == 0) raise_syscall(taskData, "GetCurrentDirectory failed", GetLastError()); TempString buff((TCHAR*)malloc(space * sizeof(TCHAR))); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (GetCurrentDirectory(space, buff) == 0) raise_syscall(taskData, "GetCurrentDirectory failed", GetLastError()); return SAVE(C_string_to_Poly(taskData, buff)); } case 55: /* Create a new directory. */ { TempString dirName(args->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (!CreateDirectory(dirName, NULL)) raise_syscall(taskData, "CreateDirectory failed", GetLastError()); return Make_fixed_precision(taskData, 0); } case 56: /* Delete a directory. */ { TempString dirName(args->Word()); if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (!RemoveDirectory(dirName)) raise_syscall(taskData, "RemoveDirectory failed", GetLastError()); return Make_fixed_precision(taskData, 0); } case 57: /* Test for directory. */ return isDir(taskData, args); case 58: /* Test for symbolic link. */ { TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); DWORD dwRes = GetFileAttributes(fileName); if (dwRes == 0xFFFFFFFF) raise_syscall(taskData, "GetFileAttributes failed", GetLastError()); return Make_fixed_precision(taskData, (dwRes & FILE_ATTRIBUTE_REPARSE_POINT) ? 1 : 0); } case 59: /* Read a symbolic link. */ { // Windows has added symbolic links but reading the target is far from // straightforward. It's probably not worth trying to implement this. raise_syscall(taskData, "Symbolic links are not implemented", 0); return taskData->saveVec.push(TAGGED(0)); /* To keep compiler happy. */ } case 60: /* Return the full absolute path name. */ return fullPath(taskData, args); case 61: /* Modification time. */ return modTime(taskData, args); case 62: /* File size. */ return fileSize(taskData, args); case 63: /* Set file time. */ return setTime(taskData, strm, args); case 64: /* Delete a file. */ { TempString fileName(args->Word()); if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (!DeleteFile(fileName)) raise_syscall(taskData, "DeleteFile failed", GetLastError()); return Make_fixed_precision(taskData, 0); } case 65: /* rename a file. */ return renameFile(taskData, strm, args); case 66: /* Get access rights. */ return fileAccess(taskData, strm, args); case 67: /* Return a temporary file name. */ { DWORD dwSpace = GetTempPath(0, NULL); if (dwSpace == 0) raise_syscall(taskData, "GetTempPath failed", GetLastError()); TempString buff((TCHAR*)malloc((dwSpace + 12) * sizeof(TCHAR))); if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY); if (GetTempPath(dwSpace, buff) == 0) raise_syscall(taskData, "GetTempPath failed", GetLastError()); lstrcat(buff, _T("MLTEMPXXXXXX")); #if (defined(HAVE_MKSTEMP) && ! defined(UNICODE)) // mkstemp is present in the Mingw64 headers but only as ANSI not Unicode. // Set the umask to mask out access by anyone else. // mkstemp generally does this anyway. mode_t oldMask = umask(0077); int fd = mkstemp(buff); int wasError = ERRORNUMBER; (void)umask(oldMask); if (fd != -1) close(fd); else raise_syscall(taskData, "mkstemp failed", wasError); #else if (_tmktemp(buff) == 0) raise_syscall(taskData, "mktemp failed", ERRORNUMBER); int fd = _topen(buff, O_RDWR | O_CREAT | O_EXCL, 00600); if (fd != -1) close(fd); else raise_syscall(taskData, "Temporary file creation failed", ERRORNUMBER); #endif Handle res = SAVE(C_string_to_Poly(taskData, buff)); return res; } case 68: /* Get the file id. */ { /* This concept does not exist in Windows. */ /* Return a negative number. This is interpreted as "not implemented". */ return Make_fixed_precision(taskData, -1); } case 69: { // Return an index for a token. It is used in OS.IO.hash. // This is supposed to be well distributed for any 2^n but simply return // the low order part of the object address. WinStream *stream = *(WinStream **)(strm->WordP()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); return Make_fixed_precision(taskData, (POLYUNSIGNED)((uintptr_t)(stream)) & 0xfffffff); } default: { char msg[100]; sprintf(msg, "Unknown io function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to IO. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg) +POLYUNSIGNED PolyBasicIOGeneral(POLYUNSIGNED threadId, POLYUNSIGNED code, POLYUNSIGNED strm, POLYUNSIGNED arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedStrm = taskData->saveVec.push(strm); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = IO_dispatch_c(taskData, pushedArg, pushedStrm, pushedCode); } catch (KillException &) { processes->ThreadExit(taskData); // TestAnyEvents may test for kill } 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(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForInput(FirstArgument threadId, PolyWord strm, PolyWord waitMillisecs) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForInput(POLYUNSIGNED threadId, POLYUNSIGNED strm, POLYUNSIGNED waitMillisecs) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); bool result = false; try { - WinStream *stream = *(WinStream **)(strm.AsObjPtr()); + WinStream *stream = *(WinStream **)(PolyWord::FromUnsigned(strm).AsObjPtr()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); - result = stream->testForInput(taskData, (unsigned)waitMillisecs.UnTaggedUnsigned()); + result = stream->testForInput(taskData, (unsigned)PolyWord::FromUnsigned(waitMillisecs).UnTaggedUnsigned()); } catch (KillException &) { processes->ThreadExit(taskData); // TestAnyEvents may test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(result? 1: 0).AsUnsigned(); } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForOutput(FirstArgument threadId, PolyWord strm, PolyWord waitMillisecs) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTestForOutput(POLYUNSIGNED threadId, POLYUNSIGNED strm, POLYUNSIGNED waitMillisecs) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); bool result = false; try { - WinStream *stream = *(WinStream **)(strm.AsObjPtr()); + WinStream *stream = *(WinStream **)(PolyWord::FromUnsigned(strm).AsObjPtr()); if (stream == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED); - result = stream->testForOutput(taskData, (unsigned)waitMillisecs.UnTaggedUnsigned()); + result = stream->testForOutput(taskData, (unsigned)PolyWord::FromUnsigned(waitMillisecs).UnTaggedUnsigned()); } catch (KillException &) { processes->ThreadExit(taskData); // TestAnyEvents may test for kill } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(result ? 1 : 0).AsUnsigned(); } struct _entrypts basicIOEPT[] = { { "PolyChDir", (polyRTSFunction)&PolyChDir }, { "PolyBasicIOGeneral", (polyRTSFunction)&PolyBasicIOGeneral }, { "PolyPollIODescriptors", (polyRTSFunction)&PolyPollIODescriptors }, { "PolyTestForInput", (polyRTSFunction)&PolyTestForInput }, { "PolyTestForOutput", (polyRTSFunction)&PolyTestForOutput }, { NULL, NULL } // End of list. }; class WinBasicIO : public RtsModule { public: virtual void Start(void); virtual void GarbageCollect(ScanAddress * /*process*/); }; // Declare this. It will be automatically added to the table. static WinBasicIO basicIOModule; void WinBasicIO::Start(void) { } void WinBasicIO::GarbageCollect(ScanAddress *process) { if (standardInputValue != 0) process->ScanRuntimeAddress(&standardInputValue, ScanAddress::STRENGTH_STRONG); if (standardOutputValue != 0) process->ScanRuntimeAddress(&standardOutputValue, ScanAddress::STRENGTH_STRONG); if (standardErrorValue != 0) process->ScanRuntimeAddress(&standardErrorValue, ScanAddress::STRENGTH_STRONG); } \ No newline at end of file diff --git a/libpolyml/windows_specific.cpp b/libpolyml/windows_specific.cpp index 9bf6e2fa..3e53c2ee 100644 --- a/libpolyml/windows_specific.cpp +++ b/libpolyml/windows_specific.cpp @@ -1,538 +1,539 @@ /* Title: Operating Specific functions: Windows version. Copyright (c) 2000, 2015, 2018, 2019 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #include #include #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_TCHAR_H #include #endif #ifdef HAVE_IO_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #include #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include #include "globals.h" #include "arb.h" #include "gc.h" #include "run_time.h" #include "io_internal.h" #include "os_specific.h" #include "sys.h" #include "processes.h" #include "winguiconsole.h" #include "mpoly.h" #include "diagnostics.h" #include "scanaddrs.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "machine_dep.h" #include "rtsentry.h" #include "winstartup.h" #define SAVE(x) taskData->saveVec.push(x) #define SIZEOF(x) (sizeof(x)/sizeof(word)) extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsExecute(FirstArgument threadId, PolyWord command, PolyWord argument); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsOpenProcessHandle(FirstArgument threadId, PolyWord arg, PolyWord isRead, PolyWord isText); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsGetProcessResult(FirstArgument threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsSimpleExecute(FirstArgument threadId, PolyWord command, PolyWord argument); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEStartDialogue(FirstArgument threadId, PolyWord service, PolyWord topic); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEExecute(FirstArgument threadId, PolyWord info, PolyWord commd); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEClose(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsExecute(POLYUNSIGNED threadId, POLYUNSIGNED command, POLYUNSIGNED argument); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsOpenProcessHandle(POLYUNSIGNED threadId, POLYUNSIGNED arg, POLYUNSIGNED isRead, POLYUNSIGNED isText); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsGetProcessResult(POLYUNSIGNED threadId, POLYUNSIGNED arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsSimpleExecute(POLYUNSIGNED threadId, POLYUNSIGNED command, POLYUNSIGNED argument); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEStartDialogue(POLYUNSIGNED threadId, POLYUNSIGNED service, POLYUNSIGNED topic); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEExecute(POLYUNSIGNED threadId, POLYUNSIGNED info, POLYUNSIGNED commd); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsDDEClose(POLYUNSIGNED threadId, POLYUNSIGNED arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetOSType(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyWindowsGetCodePage(); } typedef struct { HANDLE hProcess, hInput, hOutput; } PROCESSDATA; // Start DDE dialogue. -POLYUNSIGNED PolyWindowsDDEStartDialogue(FirstArgument threadId, PolyWord service, PolyWord topic) +POLYUNSIGNED PolyWindowsDDEStartDialogue(POLYUNSIGNED threadId, POLYUNSIGNED service, POLYUNSIGNED topic) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - TCHAR* serviceName = Poly_string_to_T_alloc(service); - TCHAR* topicName = Poly_string_to_T_alloc(topic); + TCHAR* serviceName = Poly_string_to_T_alloc(PolyWord::FromUnsigned(service)); + TCHAR* topicName = Poly_string_to_T_alloc(PolyWord::FromUnsigned(topic)); /* Send a request to the main thread to do the work. */ HCONV hcDDEConv = StartDDEConversation(serviceName, topicName); free(serviceName); free(topicName); if (hcDDEConv == 0) raise_syscall(taskData, "DdeConnect failed", 0); // Create an entry to return the conversation. result = MakeVolatileWord(taskData, hcDDEConv); } catch (KillException&) { processes->ThreadExit(taskData); // Call 1005 may test for kill } 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(); } // Send DDE execute request. -POLYUNSIGNED PolyWindowsDDEExecute(FirstArgument threadId, PolyWord info, PolyWord commd) +POLYUNSIGNED PolyWindowsDDEExecute(POLYUNSIGNED threadId, POLYUNSIGNED info, POLYUNSIGNED commd) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); LRESULT res = 0; try { - HCONV hcDDEConv = *(HCONV*)(info.AsObjPtr()); + HCONV hcDDEConv = *(HCONV*)(PolyWord::FromUnsigned(info).AsObjPtr()); if (hcDDEConv == 0) raise_syscall(taskData, "DDE Conversation is closed", 0); - char* command = Poly_string_to_C_alloc(commd); + char* command = Poly_string_to_C_alloc(PolyWord::FromUnsigned(commd)); // Send a request to the main thread to do the work. // The result is -1 if an error, 0 if busy, 1 if success res = ExecuteDDE(command, hcDDEConv); free(command); if (res == -1) raise_syscall(taskData, "DdeClientTransaction failed", 0); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return TAGGED(res == 1 ? 1 : 0).AsUnsigned(); } -POLYUNSIGNED PolyWindowsDDEClose(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyWindowsDDEClose(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { - HCONV hcDDEConv = *(HCONV*)(arg.AsObjPtr()); + HCONV hcDDEConv = *(HCONV*)(PolyWord::FromUnsigned(arg).AsObjPtr()); if (hcDDEConv != 0) { CloseDDEConversation(hcDDEConv); - *(void**)(arg.AsObjPtr()) = 0; + *(void**)(PolyWord::FromUnsigned(arg).AsObjPtr()) = 0; } } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } POLYUNSIGNED PolyGetOSType() { return TAGGED(1).AsUnsigned(); // Return 1 for Windows } // Return the current code page set by the --codepage argument. // This allows Unicode conversions to use same conversions as everything else. POLYUNSIGNED PolyWindowsGetCodePage() { #if defined(UNICODE) return TAGGED(codePage).AsUnsigned(); #else return TAGGED(CP_ACP).AsUnsigned(); #endif } /* The Windows version of this is more complicated than the Unix version because we can't manipulate the pipe handles in the child process. Everything has to be set up in the parent. As with Unix we create two pipes and pass one end of each pipe to the child. The end we pass to the child is "inheritable" (i.e. duplicated in the child as with Unix file descriptors) while the ends we keep in the parent are non-inheritable (i.e. not duplicated in the child). DCJM: December 1999. This now uses overlapped IO for the streams. */ static Handle execute(TaskData *taskData, PolyWord command, PolyWord argument) { LPCSTR lpszError = ""; HANDLE hWriteToChild = INVALID_HANDLE_VALUE, hReadFromParent = INVALID_HANDLE_VALUE, hWriteToParent = INVALID_HANDLE_VALUE, hReadFromChild = INVALID_HANDLE_VALUE; STARTUPINFO startupInfo; PROCESS_INFORMATION processInfo; PROCESSDATA *pProcData = 0; LPTSTR commandName = Poly_string_to_T_alloc(command); LPTSTR arguments = Poly_string_to_T_alloc(argument); TCHAR toChildPipeName[MAX_PATH], fromChildPipeName[MAX_PATH]; newPipeName(toChildPipeName); newPipeName(fromChildPipeName); // Create the pipes as inheritable handles. These will be passed to the child. SECURITY_ATTRIBUTES secure; secure.nLength = sizeof(SECURITY_ATTRIBUTES); secure.lpSecurityDescriptor = NULL; secure.bInheritHandle = TRUE; hReadFromParent = CreateNamedPipe(toChildPipeName, PIPE_ACCESS_INBOUND | FILE_FLAG_FIRST_PIPE_INSTANCE, PIPE_READMODE_BYTE | PIPE_WAIT | PIPE_REJECT_REMOTE_CLIENTS, 1, 4096, 4096, 0, &secure); if (hReadFromParent == INVALID_HANDLE_VALUE) { lpszError = "CreateNamedPipe failed"; goto error; } hWriteToChild = CreateFile(toChildPipeName, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED, NULL); if (hWriteToChild == INVALID_HANDLE_VALUE) { lpszError = "CreateFile failed"; goto error; } hWriteToParent = CreateNamedPipe(fromChildPipeName, PIPE_ACCESS_OUTBOUND | FILE_FLAG_FIRST_PIPE_INSTANCE, PIPE_READMODE_BYTE | PIPE_WAIT | PIPE_REJECT_REMOTE_CLIENTS, 1, 4096, 4096, 0, &secure); if (hWriteToParent == INVALID_HANDLE_VALUE) { lpszError = "CreateNamedPipe failed"; goto error; } hReadFromChild = CreateFile(fromChildPipeName, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED, NULL); if (hReadFromChild == INVALID_HANDLE_VALUE) { lpszError = "CreateFile failed"; goto error; } // Create a STARTUPINFO structure in which to pass the pipes as stdin // and stdout to the new process. memset(&startupInfo, 0, sizeof(startupInfo)); startupInfo.cb = sizeof(startupInfo); startupInfo.dwFlags = STARTF_USESTDHANDLES; startupInfo.hStdInput = hReadFromParent; startupInfo.hStdOutput = hWriteToParent; // What should we do about the stderr? For the moment, inherit the original. startupInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); // Treat the empty string as NULL. This is non-standard. if (!CreateProcess(commandName[0] == 0 ? NULL: commandName, arguments[0] == 0 ? NULL: arguments, // Command line NULL, NULL, TRUE, // Security attributes. Inherit handles CREATE_NO_WINDOW, // creation flags NULL, NULL, // Inherit our environment and directory &startupInfo, &processInfo)) { lpszError = "Could not create process"; goto error; } pProcData = (PROCESSDATA *)malloc(sizeof(PROCESSDATA)); if (pProcData == 0) { lpszError = "Insufficient memory"; SetLastError(ERROR_NOT_ENOUGH_MEMORY); goto error; } pProcData->hProcess = processInfo.hProcess; pProcData->hInput = hReadFromChild; pProcData->hOutput = hWriteToChild; // Everything has gone well - remove what we don't want free(commandName); free(arguments); /* Close thread handle since we don't need it. */ CloseHandle(processInfo.hThread); /* Close the sides of the pipes we don't use in the parent. */ CloseHandle(hReadFromParent); CloseHandle(hWriteToParent); return(MakeVolatileWord(taskData, pProcData)); error: { int err = GetLastError(); free(commandName); free(arguments); free(pProcData); // Close all the pipe handles. if (hWriteToChild != INVALID_HANDLE_VALUE) CloseHandle(hWriteToChild); if (hReadFromParent != INVALID_HANDLE_VALUE) CloseHandle(hReadFromParent); if (hWriteToParent != INVALID_HANDLE_VALUE) CloseHandle(hWriteToParent); if (hReadFromChild != INVALID_HANDLE_VALUE) CloseHandle(hReadFromChild); raise_syscall(taskData, lpszError, err); return NULL; // Never reached. } } // Execute a command. -POLYUNSIGNED PolyWindowsExecute(FirstArgument threadId, PolyWord command, PolyWord argument) +POLYUNSIGNED PolyWindowsExecute(POLYUNSIGNED threadId, POLYUNSIGNED command, POLYUNSIGNED argument) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - result = execute(taskData, command, argument); + result = execute(taskData, PolyWord::FromUnsigned(command), PolyWord::FromUnsigned(argument)); } catch (KillException&) { processes->ThreadExit(taskData); // Call 1005 may test for kill } 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(); } static Handle simpleExecute(TaskData *taskData, PolyWord command, PolyWord argument) { HANDLE hNull = INVALID_HANDLE_VALUE; PROCESS_INFORMATION processInfo; TCHAR *commandName = Poly_string_to_T_alloc(command); TCHAR *arguments = Poly_string_to_T_alloc(argument); STARTUPINFO startupInfo; // Open a handle to NUL for input and output. hNull = CreateFile(_T("NUL"), GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); // Create a STARTUPINFO structure in which to pass hNULL as stdin // and stdout to the new process. // TODO: The handles should really be open on "NUL". memset(&startupInfo, 0, sizeof(startupInfo)); startupInfo.cb = sizeof(startupInfo); startupInfo.dwFlags = STARTF_USESTDHANDLES; startupInfo.hStdInput = hNull; startupInfo.hStdOutput = hNull; startupInfo.hStdError = hNull; STARTUPINFO *start = &startupInfo; // Treat the empty string as NULL. This is non-standard. if (!CreateProcess(commandName[0] == 0 ? NULL : commandName, arguments[0] == 0 ? NULL : arguments, // Command line NULL, NULL, // Security attributes TRUE, CREATE_NO_WINDOW, // Inherit handles, creation flags NULL, NULL, // Inherit our environment and directory start, &processInfo)) { int nErr = GetLastError(); // Clean up free(commandName); free(arguments); CloseHandle(hNull); raise_syscall(taskData, "CreateProcess failed", nErr); } free(commandName); free(arguments); /* Close thread handle since we don't need it. */ CloseHandle(processInfo.hThread); #ifndef _WIN32_WCE CloseHandle(hNull); // We no longer need this #endif PROCESSDATA *pProcData = (PROCESSDATA *)malloc(sizeof(PROCESSDATA)); if (pProcData == 0) raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); pProcData->hProcess = processInfo.hProcess; // We only use the process handle entry. pProcData->hInput = INVALID_HANDLE_VALUE; pProcData->hOutput = INVALID_HANDLE_VALUE; return(MakeVolatileWord(taskData, pProcData)); } -POLYUNSIGNED PolyWindowsSimpleExecute(FirstArgument threadId, PolyWord command, PolyWord argument) +POLYUNSIGNED PolyWindowsSimpleExecute(POLYUNSIGNED threadId, POLYUNSIGNED command, POLYUNSIGNED argument) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { - result = simpleExecute(taskData, command, argument); + result = simpleExecute(taskData, PolyWord::FromUnsigned(command), PolyWord::FromUnsigned(argument)); } 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(); } /* Return a stream, either text or binary, connected to an open process. */ -POLYUNSIGNED PolyWindowsOpenProcessHandle(FirstArgument threadId, PolyWord arg, PolyWord isRead, PolyWord isText) +POLYUNSIGNED PolyWindowsOpenProcessHandle(POLYUNSIGNED threadId, POLYUNSIGNED arg, POLYUNSIGNED isRead, POLYUNSIGNED isText) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(TAGGED(1001)); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { - PROCESSDATA* hnd = *(PROCESSDATA * *)(arg.AsObjPtr()); + PROCESSDATA* hnd = *(PROCESSDATA * *)(PolyWord::FromUnsigned(arg).AsObjPtr()); if (hnd == 0) raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); // We allow multiple streams on the handles. Since they are duplicated by openHandle that's safe. // A consequence is that closing the stream does not close the pipe as far as the child is // concerned. That only happens when we close the final handle in reap. try { WinInOutStream* stream = new WinInOutStream; bool fResult; - if (isRead.UnTagged()) fResult = stream->openHandle(hnd->hInput, OPENREAD, isText.UnTagged()); - else fResult = stream->openHandle(hnd->hOutput, OPENWRITE, isText.UnTagged()); + if (PolyWord::FromUnsigned(isRead).UnTagged()) + fResult = stream->openHandle(hnd->hInput, OPENREAD, PolyWord::FromUnsigned(isText).UnTagged()); + else fResult = stream->openHandle(hnd->hOutput, OPENWRITE, PolyWord::FromUnsigned(isText).UnTagged()); if (!fResult) { delete(stream); raise_syscall(taskData, "openHandle failed", GetLastError()); } result = MakeVolatileWord(taskData, stream); } catch (std::bad_alloc&) { raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); } } catch (KillException&) { processes->ThreadExit(taskData); // Call 1005 may test for kill } 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(); } /* Get result of process. */ -POLYUNSIGNED PolyWindowsGetProcessResult(FirstArgument threadId, PolyWord arg) +POLYUNSIGNED PolyWindowsGetProcessResult(POLYUNSIGNED threadId, POLYUNSIGNED arg) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(TAGGED(1005)); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { - PROCESSDATA* hnd = *(PROCESSDATA * *)(arg.AsObjPtr()); - *(PROCESSDATA * *)(arg.AsObjPtr()) = 0; // Mark as inaccessible. + PROCESSDATA* hnd = *(PROCESSDATA * *)(PolyWord::FromUnsigned(arg).AsObjPtr()); + *(PROCESSDATA * *)(PolyWord::FromUnsigned(arg).AsObjPtr()) = 0; // Mark as inaccessible. if (hnd == 0) raise_syscall(taskData, "Process is closed", ERROR_INVALID_HANDLE); // Close the streams. Either of them may have been // passed to the stream package. if (hnd->hInput != INVALID_HANDLE_VALUE) CloseHandle(hnd->hInput); hnd->hInput = INVALID_HANDLE_VALUE; if (hnd->hOutput != INVALID_HANDLE_VALUE) CloseHandle(hnd->hOutput); hnd->hOutput = INVALID_HANDLE_VALUE; // See if it's finished. while (true) { DWORD dwResult; if (GetExitCodeProcess(hnd->hProcess, &dwResult) == 0) raise_syscall(taskData, "GetExitCodeProcess failed", GetLastError()); if (dwResult != STILL_ACTIVE) { // Finished - return the result. // Remove the process object. The result is cached in ML. free(hnd); result = Make_fixed_precision(taskData, dwResult); break; } // Block and try again. WaitHandle waiter(hnd->hProcess, 1000); processes->ThreadPauseForIO(taskData, &waiter); } } catch (KillException&) { processes->ThreadExit(taskData); // May test for kill } 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 osSpecificEPT[] = { { "PolyGetOSType", (polyRTSFunction)&PolyGetOSType}, { "PolyWindowsExecute", (polyRTSFunction)& PolyWindowsExecute}, { "PolyWindowsOpenProcessHandle", (polyRTSFunction)& PolyWindowsOpenProcessHandle}, { "PolyWindowsGetProcessResult", (polyRTSFunction)& PolyWindowsGetProcessResult}, { "PolyWindowsSimpleExecute", (polyRTSFunction)& PolyWindowsSimpleExecute}, { "PolyWindowsDDEStartDialogue", (polyRTSFunction)& PolyWindowsDDEStartDialogue}, { "PolyWindowsDDEExecute", (polyRTSFunction)& PolyWindowsDDEExecute}, { "PolyWindowsDDEClose", (polyRTSFunction)& PolyWindowsDDEClose}, { "PolyWindowsGetCodePage", (polyRTSFunction)& PolyWindowsGetCodePage}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/x86_dep.cpp b/libpolyml/x86_dep.cpp index 6f2667ae..1dbac370 100644 --- a/libpolyml/x86_dep.cpp +++ b/libpolyml/x86_dep.cpp @@ -1,1544 +1,1544 @@ /* Title: Machine dependent code for i386 and X64 under Windows and Unix Copyright (c) 2000-7 Cambridge University Technical Services Limited Further work copyright David C. J. Matthews 2011-21 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_STDLIB_H #include #endif #include #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #if (defined(_WIN32)) #include #include #endif #include "globals.h" #include "run_time.h" #include "diagnostics.h" #include "processes.h" #include "profiling.h" #include "machine_dep.h" #include "scanaddrs.h" #include "memmgr.h" #include "rtsentry.h" #include "bytecode.h" #include "sys.h" // Temporary /********************************************************************** * * Register usage: * * %Reax: First argument to function. Result of function call. * %Rebx: Second argument to function. * %Recx: General register * %Redx: Closure pointer in call. * %Rebp: Points to memory used for extra registers * %Resi: General register. * %Redi: General register. * %Resp: Stack pointer. * The following apply only on the X64 * %R8: Third argument to function * %R9: Fourth argument to function * %R10: Fifth argument to function * %R11: General register * %R12: General register * %R13: General register * %R14: General register * %R15: Memory allocation pointer * **********************************************************************/ #ifdef HOSTARCHITECTURE_X86_64 struct fpSaveArea { double fpregister[7]; // Save area for xmm0-6 }; #else // Structure of floating point save area. // This is dictated by the hardware. typedef byte fpregister[10]; struct fpSaveArea { unsigned short cw; unsigned short _unused0; unsigned short sw; unsigned short _unused1; unsigned short tw; unsigned short _unused2; unsigned fip; unsigned short fcs0; unsigned short _unused3; unsigned foo; unsigned short fcs1; unsigned short _unused4; fpregister registers[8]; }; #endif /* the amount of ML stack space to reserve for registers, C exception handling etc. The compiler requires us to reserve 2 stack-frames worth (2 * 20 words). We actually reserve slightly more than this. */ #if (!defined(_WIN32) && !defined(HAVE_SIGALTSTACK)) // If we can't handle signals on a separate stack make sure there's space // on the Poly stack. #define OVERFLOW_STACK_SIZE (50+1024) #else #define OVERFLOW_STACK_SIZE 50 #endif class X86TaskData; // This is passed as the argument vector to X86AsmSwitchToPoly. // The offsets are built into the assembly code and the code-generator. // localMpointer and stackPtr are updated before control returns to C. typedef struct _AssemblyArgs { public: PolyWord *localMpointer; // Allocation ptr + 1 word stackItem *handlerRegister; // Current exception handler PolyWord *localMbottom; // Base of memory + 1 word stackItem *stackLimit; // Lower limit of stack stackItem exceptionPacket; // Set if there is an exception byte unusedRequestCode; // No longer used. byte unusedFlag; // No longer used byte returnReason; // Reason for returning from ML. byte unusedRestore; // No longer used. uintptr_t saveCStack; // Saved C stack frame. PolyWord threadId; // My thread id. Saves having to call into RTS for it. stackItem *stackPtr; // Current stack pointer byte *enterInterpreter; // These are filled in with the functions. byte *heapOverFlowCall; byte *stackOverFlowCall; byte *stackOverFlowCallEx; byte *trapHandlerEntry; // Saved registers, where applicable. stackItem p_rax; stackItem p_rbx; stackItem p_rcx; stackItem p_rdx; stackItem p_rsi; stackItem p_rdi; #ifdef HOSTARCHITECTURE_X86_64 stackItem p_r8; stackItem p_r9; stackItem p_r10; stackItem p_r11; stackItem p_r12; stackItem p_r13; stackItem p_r14; #endif struct fpSaveArea p_fp; } AssemblyArgs; // These next few are temporarily added for the interpreter // 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)) class X86TaskData: public TaskData, ByteCodeInterpreter { public: X86TaskData(); unsigned allocReg; // The register to take the allocated space. POLYUNSIGNED allocWords; // The words to allocate. AssemblyArgs assemblyInterface; int saveRegisterMask; // Registers that need to be updated by a GC. virtual void GarbageCollect(ScanAddress *process); void ScanStackAddress(ScanAddress *process, stackItem &val, StackSpace *stack); virtual void EnterPolyCode(); // Start running ML virtual void InterruptCode(); virtual bool AddTimeProfileCount(SIGNALCONTEXT *context); virtual void InitStackFrame(TaskData *parentTask, Handle proc); virtual void SetException(poly_exn *exc); // Atomically release a mutex using hardware interlock. virtual bool AtomicallyReleaseMutex(PolyObject* mutexp); // Return the minimum space occupied by the stack. Used when setting a limit. // N.B. This is PolyWords not native words. virtual uintptr_t currentStackSpace(void) const { return (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE*sizeof(uintptr_t)/sizeof(PolyWord); } // Increment the profile count for an allocation. Also now used for mutex contention. virtual void addProfileCount(POLYUNSIGNED words) { addSynchronousCount(assemblyInterface.stackPtr[0].codeAddr, words); } // PreRTSCall: After calling from ML to the RTS we need to save the current heap pointer virtual void PreRTSCall(void) { TaskData::PreRTSCall(); SaveMemRegisters(); } // PostRTSCall: Before returning we need to restore the heap pointer. // If there has been a GC in the RTS call we need to create a new heap area. virtual void PostRTSCall(void) { SetMemRegisters(); TaskData::PostRTSCall(); } virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length); void HeapOverflowTrap(byte *pcPtr); void StackOverflowTrap(uintptr_t space); void SetMemRegisters(); void SaveMemRegisters(); void SetRegisterMask(); void HandleTrap(); // ByteCode overrides. The interpreter and native code states need to be in sync. // The interpreter is only used during the initial bootstrap. virtual void ClearExceptionPacket() { assemblyInterface.exceptionPacket = TAGGED(0); } virtual PolyWord GetExceptionPacket() { return assemblyInterface.exceptionPacket; } virtual stackItem* GetHandlerRegister() { return assemblyInterface.handlerRegister; } virtual void SetHandlerRegister(stackItem* hr) { assemblyInterface.handlerRegister = hr; } // Check and grow the stack if necessary. Process any interupts. virtual void HandleStackOverflow(uintptr_t space) { StackOverflowTrap(space); } void Interpret(); void EndBootStrap() { mixedCode = true; } PLock interruptLock; stackItem *get_reg(int n); stackItem *®SP() { return assemblyInterface.stackPtr; } stackItem ®AX() { return assemblyInterface.p_rax; } stackItem ®BX() { return assemblyInterface.p_rbx; } stackItem ®CX() { return assemblyInterface.p_rcx; } stackItem ®DX() { return assemblyInterface.p_rdx; } stackItem ®SI() { return assemblyInterface.p_rsi; } stackItem ®DI() { return assemblyInterface.p_rdi; } #ifdef HOSTARCHITECTURE_X86_64 stackItem ®8() { return assemblyInterface.p_r8; } stackItem ®9() { return assemblyInterface.p_r9; } stackItem ®10() { return assemblyInterface.p_r10; } stackItem ®11() { return assemblyInterface.p_r11; } stackItem ®12() { return assemblyInterface.p_r12; } stackItem ®13() { return assemblyInterface.p_r13; } stackItem ®14() { return assemblyInterface.p_r14; } #endif }; class X86Dependent: public MachineDependent { public: X86Dependent(): mustInterpret(false) {} // Create a task data object. virtual TaskData *CreateTaskData(void) { return new X86TaskData(); } // Initial size of stack in PolyWords virtual unsigned InitialStackSize(void) { return (128+OVERFLOW_STACK_SIZE) * sizeof(uintptr_t) / sizeof(PolyWord); } virtual void ScanConstantsWithinCode(PolyObject *addr, PolyObject *oldAddr, POLYUNSIGNED length, PolyWord* newConstAddr, PolyWord* oldConstAddr, POLYUNSIGNED numConsts, ScanAddress *process); virtual void SetBootArchitecture(char arch, unsigned wordLength); virtual Architectures MachineArchitecture(void); // During the first bootstrap phase this is interpreted. bool mustInterpret; // Override for X86-64 because of the need for position-independent code. #if (defined(HOSTARCHITECTURE_X86_64) && !defined(POLYML32IN64)) // Find the start of the constant section for a piece of code. virtual void GetConstSegmentForCode(PolyObject* obj, POLYUNSIGNED obj_length, PolyWord*& cp, POLYUNSIGNED& count) const { PolyWord* last_word = obj->Offset(obj_length - 1); // Last word in the code // Only the low order 32-bits are valid since this may be // set by a 32-bit relative relocation. int32_t offset = (int32_t)last_word->AsSigned(); cp = last_word + 1 + offset / sizeof(PolyWord); count = cp[-1].AsUnsigned(); } // Set the address of the constant area. The default is a relative byte offset. virtual void SetAddressOfConstants(PolyObject* objAddr, PolyObject* writable, POLYUNSIGNED length, PolyWord* constAddr) { int64_t offset = (byte*)constAddr - (byte*)objAddr - length * sizeof(PolyWord); ASSERT(offset >= -(int64_t)0x80000000 && offset <= (int64_t)0x7fffffff); ASSERT(offset < ((int64_t)1) << 32 && offset >((int64_t)(-1)) << 32); writable->Set(length - 1, PolyWord::FromSigned(offset & 0xffffffff)); } #endif }; static X86Dependent x86Dependent; MachineDependent* machineDependent = &x86Dependent; Architectures X86Dependent::MachineArchitecture(void) { if (mustInterpret) return MA_Interpreted; #ifndef HOSTARCHITECTURE_X86_64 return MA_I386; #elif defined(POLYML32IN64) return MA_X86_64_32; #else return MA_X86_64; #endif } void X86Dependent::SetBootArchitecture(char arch, unsigned wordLength) { if (arch == 'I') mustInterpret = true; else if (arch != 'X') Crash("Boot file has unexpected architecture code: %c", arch); } // Values for the returnReason byte enum RETURN_REASON { RETURN_HEAP_OVERFLOW = 1, RETURN_STACK_OVERFLOW = 2, RETURN_STACK_OVERFLOWEX = 3, RETURN_ENTER_INTERPRETER = 4 }; extern "C" { // These are declared in the assembly code segment. void X86AsmSwitchToPoly(void *); int X86AsmCallExtraRETURN_ENTER_INTERPRETER(void); int X86AsmCallExtraRETURN_HEAP_OVERFLOW(void); int X86AsmCallExtraRETURN_STACK_OVERFLOW(void); int X86AsmCallExtraRETURN_STACK_OVERFLOWEX(void); void X86TrapHandler(PolyWord threadId); }; X86TaskData::X86TaskData(): ByteCodeInterpreter(&assemblyInterface.stackPtr, &assemblyInterface.stackLimit), allocReg(0), allocWords(0), saveRegisterMask(0) { assemblyInterface.enterInterpreter = (byte*)X86AsmCallExtraRETURN_ENTER_INTERPRETER; assemblyInterface.heapOverFlowCall = (byte*)X86AsmCallExtraRETURN_HEAP_OVERFLOW; assemblyInterface.stackOverFlowCall = (byte*)X86AsmCallExtraRETURN_STACK_OVERFLOW; assemblyInterface.stackOverFlowCallEx = (byte*)X86AsmCallExtraRETURN_STACK_OVERFLOWEX; assemblyInterface.trapHandlerEntry = (byte*)X86TrapHandler; interpreterPc = 0; mixedCode = !x86Dependent.mustInterpret; } void X86TaskData::GarbageCollect(ScanAddress *process) { TaskData::GarbageCollect(process); // Process the parent first ByteCodeInterpreter::GarbageCollect(process); assemblyInterface.threadId = threadObject; if (stack != 0) { ASSERT(assemblyInterface.stackPtr >= (stackItem*)stack->bottom && assemblyInterface.stackPtr <= (stackItem*)stack->top); // Now the values on the stack. for (stackItem *q = assemblyInterface.stackPtr; q < (stackItem*)stack->top; q++) ScanStackAddress(process, *q, stack); } // Register mask for (int i = 0; i < 16; i++) { if (saveRegisterMask & (1 << i)) ScanStackAddress(process, *get_reg(i), stack); } } // Process a value within the stack. void X86TaskData::ScanStackAddress(ScanAddress *process, stackItem &stackItem, StackSpace *stack) { // We may have return addresses on the stack which could look like // tagged values. Check whether the value is in the code area before // checking whether it is untagged. #ifdef POLYML32IN64 // In 32-in-64 return addresses always have the top 32 bits non-zero. if (stackItem.argValue < ((uintptr_t)1 << 32)) { // It's either a tagged integer or an object pointer. if (stackItem.w().IsDataPtr()) { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } } else { // Could be a code address or a stack address. MemSpace *space = gMem.SpaceForAddress(stackItem.codeAddr - 1); if (space == 0 || space->spaceType != ST_CODE) return; PolyObject *obj = gMem.FindCodeObject(stackItem.codeAddr); ASSERT(obj != 0); // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } #else // The -1 here is because we may have a zero-sized cell in the last // word of a space. MemSpace *space = gMem.SpaceForAddress(stackItem.codeAddr-1); if (space == 0) return; // In particular we may have one of the assembly code addresses. if (space->spaceType == ST_CODE) { PolyObject *obj = gMem.FindCodeObject(stackItem.codeAddr); // If it is actually an integer it might be outside a valid code object. if (obj == 0) { ASSERT(stackItem.w().IsTagged()); // It must be an integer } else // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } else if (space->spaceType == ST_LOCAL && stackItem.w().IsDataPtr()) // Local values must be word addresses. { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } #endif } // Copy a stack void X86TaskData::CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) { /* Moves a stack, updating all references within the stack */ #ifdef POLYML32IN64 old_length = old_length / 2; new_length = new_length / 2; #endif stackItem *old_base = (stackItem *)old_stack; stackItem *new_base = (stackItem*)new_stack; stackItem *old_top = old_base + old_length; /* Calculate the offset of the new stack from the old. If the frame is being extended objects in the new frame will be further up the stack than in the old one. */ uintptr_t offset = new_base - old_base + new_length - old_length; stackItem *oldStackPtr = assemblyInterface.stackPtr; // Adjust the stack pointer and handler pointer since these point into the stack. assemblyInterface.stackPtr = assemblyInterface.stackPtr + offset; assemblyInterface.handlerRegister = assemblyInterface.handlerRegister + offset; // We need to adjust any values on the stack that are pointers within the stack. // Skip the unused part of the stack. size_t i = oldStackPtr - old_base; ASSERT (i <= old_length); i = old_length - i; stackItem *old = oldStackPtr; stackItem *newp = assemblyInterface.stackPtr; while (i--) { stackItem old_word = *old++; if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) old_word.stackAddr = old_word.stackAddr + offset; else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) { stackItem *addr = (stackItem*)old_word.w().AsStackAddr(); if (addr >= old_base && addr <= old_top) { addr += offset; old_word = PolyWord::FromStackAddr((PolyWord*)addr); } } *newp++ = old_word; } ASSERT(old == ((stackItem*)old_stack)+old_length); ASSERT(newp == ((stackItem*)new_stack)+new_length); // And change any registers that pointed into the old stack for (int j = 0; j < 16; j++) { if (saveRegisterMask & (1 << j)) { stackItem *regAddr = get_reg(j); stackItem old_word = *regAddr; if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) old_word.stackAddr = old_word.stackAddr + offset; else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) { stackItem *addr = (stackItem*)old_word.w().AsStackAddr(); if (addr >= old_base && addr <= old_top) { addr += offset; old_word = PolyWord::FromStackAddr((PolyWord*)addr); } } *regAddr = old_word; } } } void X86TaskData::EnterPolyCode() /* Called from "main" to enter the code. */ { if (x86Dependent.mustInterpret) { PolyWord closure = assemblyInterface.p_rdx; *(--assemblyInterface.stackPtr) = closure; /* Closure address */ interpreterPc = *(POLYCODEPTR*)closure.AsObjPtr(); Interpret(); ASSERT(0); // Should never return } SetMemRegisters(); // Enter the ML code. X86AsmSwitchToPoly(&this->assemblyInterface); // This should never return ASSERT(0); } void X86TaskData::Interpret() { while (true) { switch (RunInterpreter(this)) { case ReturnCall: // After the call there will be an enter-int instruction so that when this // returns we will re-enter the interpreter. The number of arguments for // this call is after that. ASSERT(interpreterPc[0] == 0xff); numTailArguments = interpreterPc[3]; case ReturnTailCall: { ClearExceptionPacket(); // Pop the closure. PolyWord closureWord = *assemblyInterface.stackPtr++; PolyObject* closure = closureWord.AsObjPtr(); interpreterPc = *(POLYCODEPTR*)closure; if (interpreterPc[0] == 0xff && interpreterPc[1] == 0x55 && (interpreterPc[2] == 0x48 || interpreterPc[2] == 0x24)) { // If the code we're going to is interpreted push back the closure and // continue. assemblyInterface.stackPtr--; continue; } assemblyInterface.p_rdx = closureWord; // Put closure in the closure reg. // Pop the return address. POLYCODEPTR originalReturn = (assemblyInterface.stackPtr++)->codeAddr; // Because of the way the build process works we only ever call functions with a single argument. ASSERT(numTailArguments == 1); assemblyInterface.p_rax = *(assemblyInterface.stackPtr++); (*(--assemblyInterface.stackPtr)).codeAddr = originalReturn; // Push return address to caller (*(--assemblyInterface.stackPtr)).codeAddr = *(POLYCODEPTR*)closure; // Entry point to callee interpreterPc = 0; // No longer in the interpreter (See SaveMemRegs) return; } case ReturnReturn: { ClearExceptionPacket(); if (interpreterPc[0] == 0xff && interpreterPc[1] == 0x55 && (interpreterPc[2] == 0x48 || interpreterPc[2] == 0x24)) continue; // Get the return value from the stack and replace it by the // address we're going to. assemblyInterface.p_rax = assemblyInterface.stackPtr[0]; assemblyInterface.stackPtr[0].codeAddr = interpreterPc; interpreterPc = 0; // No longer in the interpreter (See SaveMemRegs) return; } } } } // Called from the assembly code as a result of a trap i.e. a request for // a GC or to extend the stack. void X86TrapHandler(PolyWord threadId) { X86TaskData* taskData = (X86TaskData*)TaskData::FindTaskForId(threadId); taskData->HandleTrap(); } void X86TaskData::HandleTrap() { SaveMemRegisters(); // Update globals from the memory registers. switch (this->assemblyInterface.returnReason) { case RETURN_HEAP_OVERFLOW: // The heap has overflowed. SetRegisterMask(); this->HeapOverflowTrap(assemblyInterface.stackPtr[0].codeAddr); // Computes a value for allocWords only break; case RETURN_STACK_OVERFLOW: case RETURN_STACK_OVERFLOWEX: { SetRegisterMask(); uintptr_t min_size; // Size in PolyWords if (assemblyInterface.returnReason == RETURN_STACK_OVERFLOW) { min_size = (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } else { // Stack limit overflow. If the required stack space is larger than // the fixed overflow size the code will calculate the limit in %EDI. stackItem* stackP = regDI().stackAddr; min_size = (this->stack->top - (PolyWord*)stackP) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } StackOverflowTrap(min_size); break; } case RETURN_ENTER_INTERPRETER: { interpreterPc = assemblyInterface.stackPtr[0].codeAddr; assemblyInterface.stackPtr++; // Pop return address. byte reasonCode = *interpreterPc++; // Sort out arguments. assemblyInterface.exceptionPacket = TAGGED(0); if (reasonCode == 0xff) { // Exception handler. ASSERT(0); // Not used assemblyInterface.exceptionPacket = assemblyInterface.p_rax; // Get the exception packet // We're already in the exception handler but we still have to // adjust the stack pointer and pop the current exception handler. assemblyInterface.stackPtr = assemblyInterface.handlerRegister; assemblyInterface.stackPtr++; assemblyInterface.handlerRegister = (assemblyInterface.stackPtr++)[0].stackAddr; } else if (reasonCode >= 128) { // Start of function. unsigned numArgs = reasonCode - 128; // We need the stack to contain: // The closure, the return address, the arguments. // First pop the original return address. POLYCODEPTR returnAddr = (assemblyInterface.stackPtr++)[0].codeAddr; // Push the register args. ASSERT(numArgs == 1); // We only ever call functions with one argument. #ifdef HOSTARCHITECTURE_X86_64 ASSERT(numArgs <= 5); if (numArgs >= 1) *(--assemblyInterface.stackPtr) = assemblyInterface.p_rax; #ifdef POLYML32IN64 if (numArgs >= 2) *(--assemblyInterface.stackPtr) = assemblyInterface.p_rsi; #else if (numArgs >= 2) *(--assemblyInterface.stackPtr) = assemblyInterface.p_rbx; #endif if (numArgs >= 3) *(--assemblyInterface.stackPtr) = assemblyInterface.p_r8; if (numArgs >= 4) *(--assemblyInterface.stackPtr) = assemblyInterface.p_r9; if (numArgs >= 5) *(--assemblyInterface.stackPtr) = assemblyInterface.p_r10; #else ASSERT(numArgs <= 2); if (numArgs >= 1) *(--assemblyInterface.stackPtr) = assemblyInterface.p_rax; if (numArgs >= 2) *(--assemblyInterface.stackPtr) = assemblyInterface.p_rbx; #endif (--assemblyInterface.stackPtr)[0].codeAddr = returnAddr; *(--assemblyInterface.stackPtr) = assemblyInterface.p_rdx; // Closure } else { // Return from call. Push RAX *(--assemblyInterface.stackPtr) = assemblyInterface.p_rax; } Interpret(); break; } default: Crash("Unknown return reason code %u", this->assemblyInterface.returnReason); } SetMemRegisters(); } void X86TaskData::StackOverflowTrap(uintptr_t space) { uintptr_t min_size = (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE + space; try { // The stack check has failed. This may either be because we really have // overflowed the stack or because the stack limit value has been adjusted // to result in a call here. CheckAndGrowStack(this, min_size); } catch (IOException&) { // We may get an exception while handling this if we run out of store } { PLocker l(&interruptLock); // Set the stack limit. This clears any interrupt and also sets the // correct value if we've grown the stack. assemblyInterface.stackLimit = (stackItem*)this->stack->bottom + OVERFLOW_STACK_SIZE; } try { processes->ProcessAsynchRequests(this); // Release and re-acquire use of the ML memory to allow another thread // to GC. processes->ThreadReleaseMLMemory(this); processes->ThreadUseMLMemory(this); } catch (IOException&) { } } void X86TaskData::InitStackFrame(TaskData *parentTaskData, Handle proc) /* Initialise stack frame. */ { StackSpace *space = this->stack; StackObject * newStack = space->stack(); uintptr_t stack_size = space->spaceSize() * sizeof(PolyWord) / sizeof(stackItem); // Set the top of the stack inside the stack rather than at the end. This wastes // a word but if sp is actually at the end OpenBSD segfaults because it isn't in // a MAP_STACK area. uintptr_t topStack = stack_size - 1; stackItem* stackTop = (stackItem*)newStack + topStack; *stackTop = TAGGED(0); // Set it to non-zero. assemblyInterface.stackPtr = stackTop; assemblyInterface.stackLimit = (stackItem*)space->bottom + OVERFLOW_STACK_SIZE; assemblyInterface.handlerRegister = stackTop; // Floating point save area. memset(&assemblyInterface.p_fp, 0, sizeof(struct fpSaveArea)); #ifndef HOSTARCHITECTURE_X86_64 // Set the control word for 64-bit precision otherwise we get inconsistent results. assemblyInterface.p_fp.cw = 0x027f ; // Control word assemblyInterface.p_fp.tw = 0xffff; // Tag registers - all unused #endif // Store the argument and the closure. assemblyInterface.p_rdx = proc->Word(); // Closure assemblyInterface.p_rax = TAGGED(0); // Argument // Have to set the register mask in case we get a GC before the thread starts. saveRegisterMask = (1 << 2) | 1; // Rdx and rax #ifdef POLYML32IN64 // In 32-in-64 RBX always contains the heap base address. assemblyInterface.p_rbx.stackAddr = (stackItem*)globalHeapBase; #endif } // In Solaris-x86 the registers are named EIP and ESP. #if (!defined(REG_EIP) && defined(EIP)) #define REG_EIP EIP #endif #if (!defined(REG_ESP) && defined(ESP)) #define REG_ESP ESP #endif // Get the PC and SP(stack) from a signal context. This is needed for profiling. // This version gets the actual sp and pc if we are in ML. // N.B. This must not call malloc since we're in a signal handler. bool X86TaskData::AddTimeProfileCount(SIGNALCONTEXT *context) { stackItem * sp = 0; POLYCODEPTR pc = 0; if (context != 0) { // The tests for HAVE_UCONTEXT_T, HAVE_STRUCT_SIGCONTEXT and HAVE_WINDOWS_H need // to follow the tests in processes.h. #if defined(HAVE_WINDOWS_H) #ifdef _WIN64 sp = (stackItem *)context->Rsp; pc = (POLYCODEPTR)context->Rip; #else // Windows 32 including cygwin. sp = (stackItem *)context->Esp; pc = (POLYCODEPTR)context->Eip; #endif #elif defined(HAVE_UCONTEXT_T) #ifdef HAVE_MCONTEXT_T_GREGS // Linux #ifndef HOSTARCHITECTURE_X86_64 pc = (byte*)context->uc_mcontext.gregs[REG_EIP]; sp = (stackItem*)context->uc_mcontext.gregs[REG_ESP]; #else /* HOSTARCHITECTURE_X86_64 */ pc = (byte*)context->uc_mcontext.gregs[REG_RIP]; sp = (stackItem*)context->uc_mcontext.gregs[REG_RSP]; #endif /* HOSTARCHITECTURE_X86_64 */ #elif defined(HAVE_MCONTEXT_T_MC_ESP) // FreeBSD #ifndef HOSTARCHITECTURE_X86_64 pc = (byte*)context->uc_mcontext.mc_eip; sp = (stackItem*)context->uc_mcontext.mc_esp; #else /* HOSTARCHITECTURE_X86_64 */ pc = (byte*)context->uc_mcontext.mc_rip; sp = (stackItem*)context->uc_mcontext.mc_rsp; #endif /* HOSTARCHITECTURE_X86_64 */ #else // Mac OS X #ifndef HOSTARCHITECTURE_X86_64 #if(defined(HAVE_STRUCT_MCONTEXT_SS)||defined(HAVE_STRUCT___DARWIN_MCONTEXT32_SS)) pc = (byte*)context->uc_mcontext->ss.eip; sp = (stackItem*)context->uc_mcontext->ss.esp; #elif(defined(HAVE_STRUCT___DARWIN_MCONTEXT32___SS)) pc = (byte*)context->uc_mcontext->__ss.__eip; sp = (stackItem*)context->uc_mcontext->__ss.__esp; #endif #else /* HOSTARCHITECTURE_X86_64 */ #if(defined(HAVE_STRUCT_MCONTEXT_SS)||defined(HAVE_STRUCT___DARWIN_MCONTEXT64_SS)) pc = (byte*)context->uc_mcontext->ss.rip; sp = (stackItem*)context->uc_mcontext->ss.rsp; #elif(defined(HAVE_STRUCT___DARWIN_MCONTEXT64___SS)) pc = (byte*)context->uc_mcontext->__ss.__rip; sp = (stackItem*)context->uc_mcontext->__ss.__rsp; #endif #endif /* HOSTARCHITECTURE_X86_64 */ #endif #elif defined(HAVE_STRUCT_SIGCONTEXT) #if defined(HOSTARCHITECTURE_X86_64) && defined(__OpenBSD__) // CPP defines missing in amd64/signal.h in OpenBSD pc = (byte*)context->sc_rip; sp = (stackItem*)context->sc_rsp; #else // !HOSTARCHITEXTURE_X86_64 || !defined(__OpenBSD__) pc = (byte*)context->sc_pc; sp = (stackItem*)context->sc_sp; #endif #endif } if (pc != 0) { // See if the PC we've got is an ML code address. MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { incrementCountAsynch(pc); return true; } } // See if the sp value is in the current stack. if (sp >= (stackItem*)this->stack->bottom && sp < (stackItem*)this->stack->top) { // We may be in the assembly code. The top of the stack will be a return address. pc = sp[0].w().AsCodePtr(); MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { incrementCountAsynch(pc); return true; } } // See if the value of regSP is a valid stack pointer. // This works if we happen to be in an RTS call using a "Full" call. // It doesn't work if we've used a "Fast" call because that doesn't save the SP. sp = assemblyInterface.stackPtr; if (sp >= (stackItem*)this->stack->bottom && sp < (stackItem*)this->stack->top) { // We may be in the run-time system. pc = sp[0].w().AsCodePtr(); MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { incrementCountAsynch(pc); return true; } } // None of those worked return false; } // This is called from a different thread so we have to be careful. void X86TaskData::InterruptCode() { PLocker l(&interruptLock); // Set the stack limit pointer to the top of the stack to cause // a trap when we next check for stack overflow. // We use a lock here to ensure that we always use the current value of the // stack. The thread we're interrupting could be growing the stack at this point. if (this->stack != 0) this->assemblyInterface.stackLimit = (stackItem*)(this->stack->top-1); } // This is called from SwitchToPoly before we enter the ML code. void X86TaskData::SetMemRegisters() { // Copy the current store limits into variables before we go into the assembly code. // If we haven't yet set the allocation area or we don't have enough we need // to create one (or a new one). if (this->allocPointer <= this->allocLimit + this->allocWords) { if (this->allocPointer < this->allocLimit) Crash ("Bad length in heap overflow trap"); // Find some space to allocate in. Updates taskData->allocPointer and // returns a pointer to the newly allocated space (if allocWords != 0) PolyWord *space = processes->FindAllocationSpace(this, this->allocWords, true); if (space == 0) { // We will now raise an exception instead of returning. // Set allocWords to zero so we don't set the allocation register // since that could be holding the exception packet. this->allocWords = 0; } // Undo the allocation just now. this->allocPointer += this->allocWords; } if (this->allocWords != 0) { // If we have had a heap trap we actually do the allocation here. // We will have already garbage collected and recovered sufficient space. // This also happens if we have just trapped because of store profiling. this->allocPointer -= this->allocWords; // Now allocate // Set the allocation register to this area. N.B. This is an absolute address. if (this->allocReg < 15) get_reg(this->allocReg)[0].codeAddr = (POLYCODEPTR)(this->allocPointer + 1); /* remember: it's off-by-one */ this->allocWords = 0; } // If we have run out of store, either just above or while allocating in the RTS, // allocPointer and allocLimit will have been set to zero as part of the GC. We will // now be raising an exception which may free some store but we need to come back here // before we allocate anything. The compiled code uses unsigned arithmetic to check for // heap overflow but only after subtracting the space required. We need to make sure // that the values are still non-negative after substracting any object size. if (this->allocPointer == 0) this->allocPointer += MAX_OBJECT_SIZE; if (this->allocLimit == 0) this->allocLimit += MAX_OBJECT_SIZE; this->assemblyInterface.localMbottom = this->allocLimit + 1; this->assemblyInterface.localMpointer = this->allocPointer + 1; // If we are profiling store allocation we set mem_hl so that a trap // will be generated. if (profileMode == kProfileStoreAllocation) this->assemblyInterface.localMbottom = this->assemblyInterface.localMpointer; this->assemblyInterface.threadId = this->threadObject; } // This is called whenever we have returned from ML to C. void X86TaskData::SaveMemRegisters() { if (interpreterPc == 0) // Not if we're already in the interpreter this->allocPointer = this->assemblyInterface.localMpointer - 1; this->allocWords = 0; this->assemblyInterface.exceptionPacket = TAGGED(0); this->saveRegisterMask = 0; } // Called on a GC or stack overflow trap. The register mask // is in the bytes after the trap call. void X86TaskData::SetRegisterMask() { byte *pc = assemblyInterface.stackPtr[0].codeAddr; if (*pc == 0xcd) // CD - INT n is used for a single byte { pc++; saveRegisterMask = *pc++; } else if (*pc == 0xca) // CA - FAR RETURN is used for a two byte mask { pc++; saveRegisterMask = pc[0] | (pc[1] << 8); pc += 2; } assemblyInterface.stackPtr[0].codeAddr = pc; } stackItem *X86TaskData::get_reg(int n) /* Returns a pointer to the register given by n. */ { switch (n) { case 0: return &assemblyInterface.p_rax; case 1: return &assemblyInterface.p_rcx; case 2: return &assemblyInterface.p_rdx; case 3: return &assemblyInterface.p_rbx; // Should not have rsp or rbp. case 6: return &assemblyInterface.p_rsi; case 7: return &assemblyInterface.p_rdi; #ifdef HOSTARCHITECTURE_X86_64 case 8: return &assemblyInterface.p_r8; case 9: return &assemblyInterface.p_r9; case 10: return &assemblyInterface.p_r10; case 11: return &assemblyInterface.p_r11; case 12: return &assemblyInterface.p_r12; case 13: return &assemblyInterface.p_r13; case 14: return &assemblyInterface.p_r14; // R15 is the heap pointer so shouldn't occur here. #endif /* HOSTARCHITECTURE_X86_64 */ default: Crash("Unknown register %d\n", n); } } // Called as a result of a heap overflow trap void X86TaskData::HeapOverflowTrap(byte *pcPtr) { X86TaskData *mdTask = this; POLYUNSIGNED wordsNeeded = 0; // The next instruction, after any branches round forwarding pointers or pop // instructions, will be a store of register containing the adjusted heap pointer. // We need to find that register and the value in it in order to find out how big // the area we actually wanted is. N.B. The code-generator and assembly code // must generate the correct instruction sequence. // byte *pcPtr = assemblyInterface.programCtr; while (true) { if (pcPtr[0] == 0xeb) { // Forwarding pointer if (pcPtr[1] >= 128) pcPtr += 256 - pcPtr[1] + 2; else pcPtr += pcPtr[1] + 2; } else if ((pcPtr[0] & 0xf8) == 0x58) // Pop instruction. pcPtr++; else if (pcPtr[0] == 0x41 && ((pcPtr[1] & 0xf8) == 0x58)) // Pop with Rex prefix pcPtr += 2; else break; } #ifndef HOSTARCHITECTURE_X86_64 // This should be movl REG,0[%ebp]. ASSERT(pcPtr[0] == 0x89); mdTask->allocReg = (pcPtr[1] >> 3) & 7; // Remember this until we allocate the memory stackItem *reg = get_reg(mdTask->allocReg); stackItem reg_val = *reg; // The space we need is the difference between this register // and the current value of newptr. // The +1 here is because assemblyInterface.localMpointer is A.M.pointer +1. The reason // is that after the allocation we have the register pointing at the address we will // actually use. wordsNeeded = (this->allocPointer - (PolyWord*)reg_val.stackAddr) + 1; *reg = TAGGED(0); // Clear this - it's not a valid address. /* length in words, including length word */ ASSERT (wordsNeeded <= (1<<24)); /* Max object size including length/flag word is 2^24 words. */ #else /* HOSTARCHITECTURE_X86_64 */ ASSERT(pcPtr[1] == 0x89 || pcPtr[1] == 0x8b); if (pcPtr[1] == 0x89) { // New (5.4) format. This should be movq REG,%r15 ASSERT(pcPtr[0] == 0x49 || pcPtr[0] == 0x4d); mdTask->allocReg = (pcPtr[2] >> 3) & 7; // Remember this until we allocate the memory if (pcPtr[0] & 0x4) mdTask->allocReg += 8; } else { // Alternative form of movq REG,%r15 ASSERT(pcPtr[0] == 0x4c || pcPtr[0] == 0x4d); mdTask->allocReg = pcPtr[2] & 7; // Remember this until we allocate the memory if (pcPtr[0] & 0x1) mdTask->allocReg += 8; } stackItem *reg = get_reg(this->allocReg); stackItem reg_val = *reg; wordsNeeded = (POLYUNSIGNED)((this->allocPointer - (PolyWord*)reg_val.stackAddr) + 1); *reg = TAGGED(0); // Clear this - it's not a valid address. #endif /* HOSTARCHITECTURE_X86_64 */ if (profileMode == kProfileStoreAllocation) addProfileCount(wordsNeeded); mdTask->allocWords = wordsNeeded; // The actual allocation is done in SetMemRegisters. } void X86TaskData::SetException(poly_exn *exc) // The RTS wants to raise an exception packet. Normally this is as the // result of an RTS call in which case the caller will check this. It can // also happen in a trap. { assemblyInterface.exceptionPacket = (PolyWord)exc; // Set for direct calls. } // Decode and process an effective address. There may // be a constant address in here but in any case we need // to decode it to work out where the next instruction starts. // If this is an lea instruction any addresses are just constants // so must not be treated as addresses. static void skipea(PolyObject *base, byte *&pt, ScanAddress *process, bool lea, PolyWord* oldConstAddr, POLYUNSIGNED numCodeWords, POLYSIGNED constAdjustment) { unsigned int modrm = *(pt++); unsigned int md = modrm >> 6; unsigned int rm = modrm & 7; if (md == 3) { } /* Register. */ else if (rm == 4) { /* s-i-b present. */ unsigned int sib = *(pt++); if (md == 0) { if ((sib & 7) == 5) { // Absolute address on X86, PC-relative on X64 if (! lea) { #ifdef HOSTARCHITECTURE_X86_64 if (constAdjustment != 0) { POLYSIGNED disp = (pt[3] & 0x80) ? -1 : 0; // Set the sign just in case. for (unsigned i = 4; i > 0; i--) disp = (disp << 8) | pt[i - 1]; if (pt + disp > (byte*)base + numCodeWords * sizeof(PolyWord)) { disp += constAdjustment; byte* wr = gMem.SpaceForAddress(pt)->writeAble(pt); for (unsigned i = 0; i < 4; i++) { wr[i] = (byte)(disp & 0xff); disp >>= 8; } ASSERT(disp == 0 || disp == -1); } } process->RelocateOnly(base, pt, PROCESS_RELOC_I386RELATIVE); #else process->ScanConstant(base, pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ } pt += 4; } } else if (md == 1) pt++; else if (md == 2) pt += 4; } else if (md == 0 && rm == 5) { // Absolute address on X86, PC-relative on X64 if (!lea) { #ifdef HOSTARCHITECTURE_X86_64 if (constAdjustment != 0) { POLYSIGNED disp = (pt[3] & 0x80) ? -1 : 0; // Set the sign just in case. for (unsigned i = 4; i > 0; i--) disp = (disp << 8) | pt[i - 1]; if (pt + disp > (byte*)base + numCodeWords * sizeof(PolyWord)) { disp += constAdjustment; byte* wr = gMem.SpaceForAddress(pt)->writeAble(pt); for (unsigned i = 0; i < 4; i++) { wr[i] = (byte)(disp & 0xff); disp >>= 8; } ASSERT(disp == 0 || disp == -1); } } process->RelocateOnly(base, pt, PROCESS_RELOC_I386RELATIVE); #else process->ScanConstant(base, pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ } pt += 4; } else { if (md == 1) pt += 1; else if (md == 2) pt += 4; } } /* Added to deal with constants within the code rather than in the constant area. The constant area is still needed for the function name. DCJM 2/1/2001 */ void X86Dependent::ScanConstantsWithinCode(PolyObject *addr, PolyObject *old, POLYUNSIGNED length, PolyWord* newConstAddr, PolyWord* oldConstAddr, POLYUNSIGNED numConsts, ScanAddress *process) { byte *pt = (byte*)addr; PolyWord *end = addr->Offset(length - 1); // If we have constants and code in separate areas then we will have to // adjust the offsets of constants in the constant area. // There are also offsets to non-address constants and these must // not be altered. POLYUNSIGNED numCodeWords = length - 1; if (oldConstAddr > (PolyWord*)old && oldConstAddr < ((PolyWord*)old) + length) numCodeWords -= numConsts; POLYSIGNED constAdjustment = (byte*)newConstAddr - (byte*)addr - ((byte*)oldConstAddr - (byte*)old); #ifdef HOSTARCHITECTURE_X86_64 // Put in a relocation for the offset itself if necessary. process->RelocateOnly(addr, (byte*)end, PROCESS_RELOC_I386RELATIVE); // There's a problem if the code and constant areas are allocated too // far apart that the offsets exceeed 32-bits. For testing just // include this assertion. ASSERT(constAdjustment >= -(POLYSIGNED)0x80000000 && constAdjustment <= 0x7fffffff); #endif // If this begins with enter-int it's interpreted code - ignore if (pt[0] == 0xff && pt[1] == 0x55 && (pt[2] == 0x48 || pt[2] == 0x24)) return; while (true) { // Escape prefixes come before any Rex byte if (*pt == 0xf2 || *pt == 0xf3 || *pt == 0x66) pt++; #ifdef HOSTARCHITECTURE_X86_64 // REX prefixes. Set this first. byte lastRex; if (*pt >= 0x40 && *pt <= 0x4f) lastRex = *pt++; else lastRex = 0; //printf("pt=%p *pt=%x\n", pt, *pt); #endif /* HOSTARCHITECTURE_X86_64 */ switch (*pt) { case 0x00: return; // This is actually the first byte of the old "marker" word. case 0xf4: return; // Halt - now used as a marker. case 0x50: case 0x51: case 0x52: case 0x53: case 0x54: case 0x55: case 0x56: case 0x57: /* Push */ case 0x58: case 0x59: case 0x5a: case 0x5b: case 0x5c: case 0x5d: case 0x5e: case 0x5f: /* Pop */ case 0x90: /* nop */ case 0xc3: /* ret */ case 0xf9: /* stc */ case 0xce: /* into */ case 0xf0: /* lock. */ case 0xf3: /* rep/repe */ case 0xa4: case 0xa5: case 0xaa: case 0xab: /* movs/stos */ case 0xa6: /* cmpsb */ case 0x9e: /* sahf */ case 0x99: /* cqo/cdq */ pt++; break; case 0x70: case 0x71: case 0x72: case 0x73: case 0x74: case 0x75: case 0x76: case 0x77: case 0x78: case 0x79: case 0x7a: case 0x7b: case 0x7c: case 0x7d: case 0x7e: case 0x7f: case 0xeb: /* short jumps. */ case 0xcd: /* INT - now used for a register mask */ case 0xa8: /* TEST_ACC8 */ case 0x6a: /* PUSH_8 */ pt += 2; break; case 0xc2: /* RET_16 */ case 0xca: /* FAR RET 16 - used for a register mask */ pt += 3; break; case 0x8d: /* leal. */ pt++; skipea(addr, pt, process, true, oldConstAddr, numCodeWords, constAdjustment); break; case 0x03: case 0x0b: case 0x13: case 0x1b: case 0x23: case 0x2b: case 0x33: case 0x3b: /* Add r,ea etc. */ case 0x88: /* MOVB_R_A */ case 0x89: /* MOVL_R_A */ case 0x8b: /* MOVL_A_R */ case 0x62: /* BOUNDL */ case 0xff: /* Group5 */ case 0xd1: /* Group2_1_A */ case 0x8f: /* POP_A */ case 0xd3: /* Group2_CL_A */ case 0x87: // XCHNG case 0x63: // MOVSXD pt++; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); break; case 0xf6: /* Group3_a */ { int isTest = 0; pt++; /* The test instruction has an immediate operand. */ if ((*pt & 0x38) == 0) isTest = 1; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); if (isTest) pt++; break; } case 0xf7: /* Group3_A */ { int isTest = 0; pt++; /* The test instruction has an immediate operand. */ if ((*pt & 0x38) == 0) isTest = 1; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); if (isTest) pt += 4; break; } case 0xc1: /* Group2_8_A */ case 0xc6: /* MOVB_8_A */ case 0x83: /* Group1_8_A */ case 0x80: /* Group1_8_a */ case 0x6b: // IMUL Ev,Ib pt++; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); pt++; break; case 0x69: // IMUL Ev,Iv pt++; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); pt += 4; break; case 0x81: /* Group1_32_A */ { pt ++; #ifndef HOSTARCHITECTURE_X86_64 unsigned opCode = *pt; #endif skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); // Only check the 32 bit constant if this is a comparison. // For other operations this may be untagged and shouldn't be an address. #ifndef HOSTARCHITECTURE_X86_64 if ((opCode & 0x38) == 0x38) process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif pt += 4; break; } case 0xe8: case 0xe9: // Long jump and call. These are used to call constant (known) functions // and also long jumps within the function. { pt++; POLYSIGNED disp = (pt[3] & 0x80) ? -1 : 0; // Set the sign just in case. for(unsigned i = 4; i > 0; i--) disp = (disp << 8) | pt[i-1]; byte *absAddr = pt + disp + 4; // The address is relative to AFTER the constant // If the new address is within the current piece of code we don't do anything if (absAddr >= (byte*)addr && absAddr < (byte*)end) {} else process->ScanConstant(addr, pt, PROCESS_RELOC_I386RELATIVE, (byte*)old- (byte*)addr); pt += 4; break; } case 0xc7:/* MOVL_32_A */ { pt++; if ((*pt & 0xc0) == 0x40 /* Byte offset or sib present */ && ((*pt & 7) != 4) /* But not sib present */ && pt[1] == 256-sizeof(PolyWord)) { /* We may use a move instruction to set the length word on a new segment. We mustn't try to treat this as a constant. */ pt += 6; /* Skip the modrm byte, the offset and the constant. */ } else { skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); #ifndef HOSTARCHITECTURE_X86_64 // This isn't used for addresses even in 32-in-64 process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ pt += 4; } break; } case 0xb8: case 0xb9: case 0xba: case 0xbb: case 0xbc: case 0xbd: case 0xbe: case 0xbf: /* MOVL_32_64_R */ pt ++; #ifdef HOSTARCHITECTURE_X86_64 if ((lastRex & 8) == 0) pt += 4; // 32-bit mode on 64-bits else #endif /* HOSTARCHITECTURE_X86_64 */ { // This is used in native 32-bit for constants and in // 32-in-64 for the special case of an absolute address. process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); pt += sizeof(uintptr_t); } break; case 0x68: /* PUSH_32 */ pt ++; #if (!defined(HOSTARCHITECTURE_X86_64)) process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif pt += 4; break; case 0x0f: /* ESCAPE */ { pt++; switch (*pt) { case 0xb1: // cmpxchg case 0xb6: /* movzl */ case 0xb7: // movzw case 0xbe: // movsx case 0xbf: // movsx case 0xc1: /* xaddl */ case 0xae: // ldmxcsr/stmxcsr case 0xaf: // imul case 0x40: case 0x41: case 0x42: case 0x43: case 0x44: case 0x45: case 0x46: case 0x47: case 0x48: case 0x49: case 0x4a: case 0x4b: case 0x4c: case 0x4d: case 0x4e: case 0x4f: // cmov pt++; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); break; case 0x80: case 0x81: case 0x82: case 0x83: case 0x84: case 0x85: case 0x86: case 0x87: case 0x88: case 0x89: case 0x8a: case 0x8b: case 0x8c: case 0x8d: case 0x8e: case 0x8f: /* Conditional branches with 32-bit displacement. */ pt += 5; break; case 0x90: case 0x91: case 0x92: case 0x93: case 0x94: case 0x95: case 0x96: case 0x97: case 0x98: case 0x99: case 0x9a: case 0x9b: case 0x9c: case 0x9d: case 0x9e: case 0x9f: /* SetCC. */ pt++; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); break; // These are SSE2 instructions case 0x10: case 0x11: case 0x58: case 0x5c: case 0x59: case 0x5e: case 0x2e: case 0x2a: case 0x54: case 0x57: case 0x5a: case 0x6e: case 0x7e: case 0x2c: case 0x2d: pt++; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); break; case 0x73: // PSRLDQ - EA,imm pt++; skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); pt++; break; default: Crash("Unknown opcode %d at %p\n", *pt, pt); } break; } case 0xd8: case 0xd9: case 0xda: case 0xdb: case 0xdc: case 0xdd: case 0xde: case 0xdf: // Floating point escape instructions { pt++; if ((*pt & 0xe0) == 0xe0) pt++; else skipea(addr, pt, process, false, oldConstAddr, numCodeWords, constAdjustment); break; } default: Crash("Unknown opcode %d at %p\n", *pt, pt); } } } #if defined(_MSC_VER) // This saves having to define it in the MASM assembly code. static uintptr_t X86AsmAtomicExchange(PolyObject* mutexp, uintptr_t value) { # if (SIZEOF_POLYWORD == 8) return InterlockedExchange64((LONG64*)mutexp, value); # else return InterlockedExchange((LONG*)mutexp, value); # endif } #else extern "C" { // This is only defined in the GAS assembly code uintptr_t X86AsmAtomicExchange(PolyObject*, uintptr_t); } #endif // Set the mutex to zero (released) and return true if no other thread is waiting. bool X86TaskData::AtomicallyReleaseMutex(PolyObject* mutexp) { uintptr_t oldValue = X86AsmAtomicExchange(mutexp, 0); return oldValue == 1; } extern "C" { POLYEXTERNALSYMBOL void *PolyX86GetThreadData(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedEnterIntMode(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyEndBootstrapMode(FirstArgument threadId, PolyWord function); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyEndBootstrapMode(POLYUNSIGNED threadId, POLYUNSIGNED function); POLYEXTERNALSYMBOL POLYUNSIGNED PolyX86IsLocalCode(PolyObject* destination); } // Return the address of assembly data for the current thread. This is normally in // RBP except if we are in a callback. void *PolyX86GetThreadData() { // We should get the task data for the thread that is running this code. // If this thread has been created by the foreign code we will have to // create a new one here. TaskData* taskData = processes->GetTaskDataForThread(); if (taskData == 0) { try { taskData = processes->CreateNewTaskData(); } catch (std::bad_alloc&) { ::Exit("Unable to create thread data - insufficient memory"); } catch (MemoryException&) { ::Exit("Unable to create thread data - insufficient memory"); } } return &((X86TaskData*)taskData)->assemblyInterface; } // Do we require EnterInt instructions and if so for which architecture? // 0 = > None; 1 => X86_32, 2 => X86_64. 3 => X86_32_in_64. POLYUNSIGNED PolyInterpretedEnterIntMode() { #ifdef POLYML32IN64 return TAGGED(3).AsUnsigned(); #elif defined(HOSTARCHITECTURE_X86_64) return TAGGED(2).AsUnsigned(); #else return TAGGED(1).AsUnsigned(); #endif } // End bootstrap mode and run a new function. -POLYUNSIGNED PolyEndBootstrapMode(FirstArgument threadId, PolyWord function) +POLYUNSIGNED PolyEndBootstrapMode(POLYUNSIGNED threadId, POLYUNSIGNED function) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle pushedFunction = taskData->saveVec.push(function); x86Dependent.mustInterpret = false; ((X86TaskData*)taskData)->EndBootStrap(); taskData->InitStackFrame(taskData, pushedFunction); taskData->EnterPolyCode(); // Should never return. ASSERT(0); return TAGGED(0).AsUnsigned(); } // Test whether the target is within the local code area. This is only used on // native 64-bits. A call/jump to local code can use a 32-bit displacement // whereas a call/jump to a function in the executable will need to use an // indirect reference through the code area. POLYUNSIGNED PolyX86IsLocalCode(PolyObject* destination) { MemSpace* space = gMem.SpaceForObjectAddress(destination); if (space->spaceType == ST_CODE) return TAGGED(1).AsUnsigned(); else return TAGGED(0).AsUnsigned(); } struct _entrypts machineSpecificEPT[] = { { "PolyX86GetThreadData", (polyRTSFunction)&PolyX86GetThreadData }, { "PolyInterpretedEnterIntMode", (polyRTSFunction)&PolyInterpretedEnterIntMode }, { "PolyEndBootstrapMode", (polyRTSFunction)&PolyEndBootstrapMode }, { "PolyX86IsLocalCode", (polyRTSFunction)&PolyX86IsLocalCode }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/xwindows.cpp b/libpolyml/xwindows.cpp index 692caf96..41f85469 100644 --- a/libpolyml/xwindows.cpp +++ b/libpolyml/xwindows.cpp @@ -1,9608 +1,9608 @@ /* Title: X-Windows/Motif Interface. 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 as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. 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 #if (defined(WITH_XWINDOWS)) // X-Windows is required. /* xwindows.c */ /* Removed indirection from get_C_* functions SPF 31/10/93 */ /* Added Handle type 2/11/93 */ /* Fixed "GetString can only be used once" bug 17/11/93 */ /* Dealing with gcc warning messages SPF 6/1/94 */ /* Retrofit to old Sun cc SPF 7/1/94 */ /* 25/1/94 SPF Fixed bug in EmptyVisual (core-dump when v==NULL) */ /* Comment added 4/11/93 SPF Global Invariants: (1) Get functions promise not to allocate on the Poly/ML heap (2) The Poly/ML heap contains pointers into the C heap! As these are only valid for one session, the run-time system records which Poly/ML objects have been created in the current session. Only these objects contain valid C pointers, and so may be dereferenced. The "bad" Poly/ML objects are: Flags Object Bad Field Access Function ----- ------ --------- --------------- M X_GC_Object GC *gc GetGC X_Font_Object Font *font GetFont ditto XFontStruct **fs GetFS X_Cursor_Object Cursor *cursor GetCursor BM X_Window_Object Drawable *drawable GetDrawable, GetPixmap X_Pixmap_Object Pixmap *pixmap GetDrawable, GetPixmap X_Colormap_Object Colormap *cmap GetColormap X_Visual_Object Visual **visual GetVisual (* FISHY *) B X_Display_Object Display *display (?) GetDisplay (?) ditto XtAppContext app_context NONE(?) M X_Widget_Object Widget *widget GetWidget, GetNWidget B X_Trans_Object XtTranslations table GetTrans B X_Acc_Object XtAccelerators acc GetAcc WARNING: the above list of unsafe fields was created by SPF and may be incomplete. The function CheckExists should be called on these objects before it is safe to use any of the above fields. That's because the object may have been created in a previous ML session, so the pointers that it contains may no longer be valid. Using the appropriate access function listed above guarantees that CheckExists is called. Exception: the fields can safely be tested against C's zero (None, Null) even if CheckExists hasn't been called. Note that this is only database-safe because this value is used for uninitialised fields, so it doesn't confuse the garbage-collector. For all the above fields EXCEPT display, app_context, table, acc the run-time system creates an indirection object in the Poly heap. These fields don't need an indirection object because the object which contains them is itself a BYTE object. This indirection is a byte-object. The indirection is necessary because the garbage collector would object to finding a C pointer in a standard ML labelled record. The alternative would be to store the C pointer as an ML integer, but then we would have to convert back to a C pointer befor we could dereference it. For similar reasons, eventMask is also stored as a boxed PolyWord. abstype Colormap = Colormap with end; (* X_Colormap_Object *) abstype Cursor = Cursor with end; (* X_Cursor_Object *) abstype Drawable = Drawable with end; (* X_Window_Object, XPixmap_Object *) abstype Font = Font with end; (* X_Font_Object *) abstype GC = GC with end; (* X_GC_Object *) abstype Visual = Visual with end; (* X_Visual_Object *) abstype Display = Display with end; (* X_Display_Object *) abstype Widget = Widget of int with end; abstype XtAccelerators = XtAccelerators of int with end; abstype XtTranslations = XtTranslations of int with end; */ /* MLXPoint, MLXRectangle, MLXArc, MLPair, MLTriple added 31/10/93 SPF */ #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_CTYPE_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_ASSERT_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_ERRNO_H #include #endif /* what goes wrong? ... gid, fd, private15 inaccessible */ /* THIS NEEDS TO BE FIXED!!!! */ #define XLIB_ILLEGAL_ACCESS 1 /* We need access to some opaque structures */ /* use prototypes, but make sure we get Booleans, not ints */ #define NeedWidePrototypes 0 #include #include /* IsCursorKey, IsFunctionKey, et cetera */ #include /* needed for protocol names such as X_CreateWindow */ #include /* XA_ATOM, et cetera */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include /* Motif 1.2 */ #include /* for XmIsDesktopObject */ #include /* for XmIsExtObject */ #include /* for XmIsShellExt */ #include /* for XmIsVendorShellExt */ #include #if(0) /* for XmIsWorldObject */ /* This is not supported in FreeBSD or Solaris 8. */ #include #endif #include "globals.h" #include "sys.h" #include "xwindows.h" #include "run_time.h" #include "arb.h" #include "mpoly.h" #include "gc.h" #include "xcall_numbers.h" #include "diagnostics.h" #include "processes.h" #include "save_vec.h" #include "polystring.h" #include "scanaddrs.h" #include "memmgr.h" #include "machine_dep.h" #include "processes.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(POLYUNSIGNED threadId, POLYUNSIGNED params); } /* The following are only forward so we can declare attributes */ static void RaiseXWindows(TaskData *taskData, const char *s) __attribute__((noreturn)); #define ButtonClickMask (((unsigned)1 << 29)) #define XMASK(m) ((m) &~ButtonClickMask) #undef SIZEOF #define debug1(fmt,p1) { /*EMPTY*/ } #undef debug1 #define debug1(fmt,p1) {if (debugOptions & DEBUG_X) printf(fmt,p1);} #define debug3(fmt,p1,p2,p3) {if (debugOptions & DEBUG_X) printf(fmt,p1,p2,p3);} #define debugCreate(type,value) debug1("%lx " #type " created\n",(unsigned long)(value)) #define debugReclaim(type,value) debug1("%lx " #type " reclaimed\n",(unsigned long)(value)) #define debugReclaimRef(type,value) debug1("%lx " #type " reference reclaimed\n",(unsigned long)(value)) #define debugRefer(type,value) debug1("%lx " #type " referenced\n",(unsigned long)(value)) #define debugCreateCallback(MLValue,CValue,CListCell) debug3("%p Widget callback reference created (%p,%p)\n",CValue,CListCell,MLValue) #define debugReclaimCallback(MLValue,CValue,CListCell) debug3("%p Widget callback reference removed (%p,%p)\n",CValue,CListCell,MLValue) /* forward declarations */ static Atom WM_DELETE_WINDOW(Display *d); /* was int SPF 6/1/94 */ #define DEREFDISPLAYHANDLE(h) ((X_Display_Object *)DEREFHANDLE(h)) #define DEREFWINDOWHANDLE(h) ((X_Window_Object *)DEREFHANDLE(h)) #define DEREFXOBJECTHANDLE(h) ((X_Object *)DEREFHANDLE(h)) #define SAVE(x) taskData->saveVec.push(x) #define Make_int(x) Make_arbitrary_precision(taskData, x) #define Make_string(s) SAVE(C_string_to_Poly(taskData, s)) #define Make_bool(b) Make_arbitrary_precision(taskData, (b) != 0) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) #define min(a,b) (a < b ? a : b) #define max(a,b) (a > b ? a : b) #define ISNIL(p) (ML_Cons_Cell::IsNull(p)) #define NONNIL(p) (!ISNIL(p)) typedef Handle EventHandle; /********************************************************************************/ /* Objects are created MUTABLE and are FINISHED when all their fields have been */ /* filled in (assuming they are immutable objects). This is so that we can */ /* consider the possibility of storing immutable objects in read-only memory */ /* segments (not currently implemented). SPF 7/12/93 */ /********************************************************************************/ static Handle FINISHED(TaskData *taskData, Handle P) { PolyObject *pt = DEREFHANDLE(P); assert(taskData->saveVec.isValidHandle(P)); assert(pt->IsMutable()); POLYUNSIGNED lengthW = pt->LengthWord(); pt->SetLengthWord(lengthW & ~_OBJ_MUTABLE_BIT); return P; } static void RaiseXWindows(TaskData *taskData, const char *s) { if (mainThreadPhase == MTP_USER_CODE) { raise_exception_string(taskData, EXC_XWindows,s); } else { /* Crash added 7/7/94 SPF */ Crash("Tried to raise exception (XWindows \"%s\") during garbage collection\n",s); } /*NOTREACHED*/ } /* bugfixed 6/12/94 SPF */ #define RaiseXWindows2(varmessage,constmessage) \ { \ const char message[] = constmessage; \ int n1 = strlen(varmessage); \ int n2 = strlen(message); \ char *mess = (char *)alloca(n1 + n2 + 1); \ strcat(strncpy(mess,varmessage,n1),message); \ RaiseXWindows(taskData, mess); \ /*NOTREACHED*/ \ } static void RaiseRange(TaskData *taskData) { raise_exception0(taskData, EXC_size); } typedef unsigned char uchar; static uchar get_C_uchar(TaskData *taskData, PolyWord a) { unsigned u = get_C_ushort(taskData, a); if (u >= 256) RaiseRange(taskData); return u; } /******************************************************************************/ /* */ /* String */ /* */ /******************************************************************************/ //#define String PolyStringObject //#define GetString(s) _GetString((PolyWord *)(s)) /* can only be called TABLESIZE times per X opcode */ static PolyStringObject *GetString(PolyWord s) { #define TABLESIZE 5 static PolyStringObject string[TABLESIZE]; static int index = 0; if (! s.IsTagged()) return (PolyStringObject *) s.AsObjPtr(); index = (index + 1) % TABLESIZE; string[index].length = 1; string[index].chars[0] = UNTAGGED(s); return &string[index]; #undef TABLESIZE } /******************************************************************************/ /* */ /* XObjects (Type definitions) */ /* */ /******************************************************************************/ /* We keep a list of all objects created by calls to X. */ /* When an object is created we add an entry to the list and */ /* return the entry. If the entry becomes inaccessible */ /* by the garbage collector then we free the object. */ /* The list is created by malloc so that it is not in the heap. */ // Types of objects. These are tagged when they are stored // in objects because some objects are not byte objects. typedef enum { X_GC = 111, X_Font = 222, X_Cursor = 333, X_Window = 444, X_Pixmap = 555, X_Colormap = 666, X_Visual = 777, X_Display = 888, X_Widget = 999, X_Trans = 1111, X_Acc = 2222 } X_types; class X_Object: public PolyObject { public: X_Object(): type(TAGGED(1)) {} // Just to keep gcc happy PolyWord type; }; class X_Trans_Object: public X_Object /* BYTE object */ { public: XtTranslations table; /* C value */ }; class X_Acc_Object: public X_Object /* BYTE object */ { public: XtAccelerators acc; /* C value */ }; class X_Display_Object: public X_Object /* BYTE object */ { public: Display *display; /* C value */ unsigned screen; /* C value */ XtAppContext app_context; /* C value */ } ; class X_Font_Object: public X_Object { public: Font *font; /* Token for C value */ XFontStruct **fs; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Cursor_Object: public X_Object { public: Cursor *cursor; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Pixmap_Object: public X_Object { public: Pixmap *pixmap; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Colormap_Object: public X_Object { public: Colormap *cmap; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_Widget_Object: public X_Object /* MUTABLE */ { public: Widget *widget; /* Token for C value */ PolyWord callbackList; /* mutable */ PolyWord state; /* mutable */ X_Display_Object *ds; /* Token */ } ; class X_Visual_Object: public X_Object { public: Visual **visual; /* Token for C value */ X_Display_Object *ds; /* Token */ } ; class X_GC_Object: public X_Object /* MUTABLE */ { public: GC *gc; /* Token for C value */ X_Font_Object *font_object; /* mutable; may be 0 */ X_Pixmap_Object *tile; /* mutable; may be 0 */ X_Pixmap_Object *stipple; /* mutable; may be 0 */ X_Pixmap_Object *clipMask; /* mutable; may be 0 */ X_Display_Object *ds; /* Token */ } ; class X_Window_Struct: public X_Object /* MUTABLE */ { public: Drawable *drawable; /* Token for C value */ PolyWord handler; /* mutable? */ PolyWord state; /* mutable? */ PolyObject *eventMask; /* Token for C value; token itself is mutable */ X_Colormap_Object *colormap_object; /* mutable; may be 0 */ X_Cursor_Object *cursor_object; /* mutable; may be 0 */ X_Pixmap_Object *backgroundPixmap; /* mutable; may be 0 */ X_Pixmap_Object *borderPixmap; /* mutable; may be 0 */ X_Window_Struct *parent; /* may be 0 */ X_Display_Object *ds; /* Token */ }; typedef X_Window_Struct X_Window_Object; /******************************************************************************/ /* */ /* Forward declarations */ /* */ /******************************************************************************/ static Font GetFont(TaskData *taskData, X_Object *P); static Cursor GetCursor(TaskData *taskData,X_Object *P); static Colormap GetColormap(TaskData *taskData,X_Object *P); static Visual *GetVisual(TaskData *taskData,X_Object *P); static XtTranslations GetTrans(TaskData *taskData,X_Object *P); static XtAccelerators GetAcc(TaskData *taskData,X_Object *P); static Pixmap GetPixmap(TaskData *, X_Object *P); static Widget GetNWidget(TaskData *, X_Object *P); static Window GetWindow(TaskData *, X_Object *P); static Display *GetDisplay(TaskData *, X_Object *P); static void DestroyWindow(X_Object *W); static void DestroySubwindows(X_Object *W); static X_GC_Object *GCObject(X_Object *P); static X_Pixmap_Object *PixmapObject(X_Object *P); static X_Widget_Object *WidgetObject(TaskData *, X_Object *P); static X_Window_Object *WindowObject(X_Object *P); /******************************************************************************/ /* */ /* C lists (Type definitions) */ /* */ /******************************************************************************/ typedef struct X_List_struct X_List; struct X_List_struct { X_List *next; /* pointer into C heap */ X_Object *object; /* pointer into Poly heap; weak */ }; typedef struct timeval TimeVal; /* In C heap */ typedef struct T_List_struct T_List; struct T_List_struct { T_List *next; /* pointer into C heap */ TimeVal timeout; /* here */ X_Window_Object *window_object; /* pointer into Poly heap, or 0; weak */ X_Widget_Object *widget_object; /* pointer into Poly heap, or 0; strong */ PolyObject *alpha; /* pointer into Poly heap; strong */ PolyObject *handler; /* pointer into Poly heap; strong */ int expired; /* here */ }; /* NB precisely one of window_object and widget_object should be non-zero */ /* In C heap */ typedef struct C_List_struct C_List; struct C_List_struct { PolyObject *function; /* pointer into Poly heap; strong */ X_Widget_Object *widget_object; /* pointer into Poly heap; strong */ C_List *next; /* pointer into C heap */ }; /* lists of X objects currently in Poly heap i.e. those created in this session */ #define XLISTSIZE 1001 /* must be coprime to 4 ('cos pointers are PolyWord-aligned) */ static X_List *XList[XLISTSIZE] = {0}; static T_List *TList = 0; /* C pending messages list, ordered by arrival time */ static C_List *CList = 0; /* Acts as root for objects "owned" by C callbacks */ static PolyWord FList = TAGGED(0); /* ML Callback list - acts as a Root for the Heap */ static PolyWord GList = TAGGED(0); /* ML Event list - acts as a Root for the Heap */ static Bool callbacks_enabled = False; /******************************************************************************/ /* */ /* High-speed XList routines */ /* */ /******************************************************************************/ /* maps an (X_Object *) to an (unsigned); this mapping from must give the same */ /* (unsigned) for each (X_Object) for an entire Poly/ML session, even though its */ /* address may change at every garbage collection. */ /* The way we achieve this is by returning the address of the corresponding C */ /* object. Note that since the ML object doesn't necessarily correspond to a real*/ /* C object, this value may be neither valid nor sensible (but it WILL be a */ /* constant). */ /* Unfortunately, we can't do this for GCs or VISUALS, since the actual C object */ /* contains the id we want, and we can't access the id if we haven't got the */ /* object. For these, we return a constant instead. */ static unsigned long hashId(X_Object *P) { #define HASH_GC 0 #define HASH_VISUAL 1 switch(UNTAGGED(P->type)) { case X_GC: return HASH_GC; case X_Font: return (unsigned long)(*(((X_Font_Object*)P)->font)); case X_Cursor: return (unsigned long)(*(((X_Cursor_Object*)P)->cursor)); case X_Window: return (unsigned long)(*(((X_Window_Struct*)P)->drawable)); case X_Pixmap: return (unsigned long)(*(((X_Pixmap_Object*)P)->pixmap)); case X_Colormap: return (unsigned long)(*(((X_Colormap_Object*)P)->cmap)); case X_Visual: return HASH_VISUAL; case X_Display: return (unsigned long)(((X_Display_Object*)P)->display); case X_Widget: return (unsigned long)(*(((X_Widget_Object*)P)->widget)); case X_Trans: return (unsigned long)(((X_Trans_Object*)P)->table); case X_Acc: return (unsigned long)(((X_Acc_Object*)P)->acc); default: Crash ("Bad X_Object type (%d) in hashId",UNTAGGED(P->type)); } /*NOTREACHED*/ } static void initXList(void) { int i; for (i = 0; i < XLISTSIZE; i++) { XList[i] = NULL; } } static X_List **hashXList(X_Object *P) { unsigned long id = hashId(P); unsigned n = (id % XLISTSIZE); /* a poor hash function, but good enough for now */ return &(XList[n]); } static X_List *findXList(unsigned long id) { unsigned n = (id % XLISTSIZE); /* a poor hash function, but good enough for now */ return XList[n]; } /******************************************************************************/ /* */ /* C lists (Polymorphic functions) */ /* */ /******************************************************************************/ // Creates a list from a vector of items. static Handle CreateList4(TaskData *taskData, unsigned n, void *p, unsigned objSize, Handle (*f)(TaskData *, void *)) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); // Process the vector in reverse order. That way we can make the // cells as immutable objects rather than having to create them as // mutable and then lock them. while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static Handle CreateList4I(TaskData *taskData, unsigned n, void *p, unsigned objSize, Handle (*f)(TaskData *, void *, unsigned i)) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP, n); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static Handle CreateList5(TaskData *taskData, POLYUNSIGNED n, void *p, POLYUNSIGNED objSize, Handle (*f)(TaskData *, void *, Handle), Handle a1) { Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); // Process the vector in reverse order. That way we can make the // cells as immutable objects rather than having to create them as // mutable and then lock them. while (n) { n--; byte *objP = (byte*)p + objSize*n; Handle value = (* f)(taskData, objP, a1); Handle next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value); DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list); /* reset save vector to stop it overflowing */ taskData->saveVec.reset(saved); list = SAVE(DEREFHANDLE(next)); } return list; } static void GetList4(TaskData *taskData, PolyWord list, void *v, unsigned bytes, void (*get)(TaskData *, PolyWord, void*, unsigned)) { unsigned i = 0; byte *s = (byte*)v; for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { (* get)(taskData, ((ML_Cons_Cell*)p.AsObjPtr())->h, s, i); s += bytes; i++; } } /* ListLength no longer requires indirection via handle SPF 4/11/93 */ static unsigned ListLength(PolyWord list) { unsigned n = 0; for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) n++; return n; } /******************************************************************************/ /* */ /* TList Purge Functions (SPF 29/11/93) */ /* */ /******************************************************************************/ static void PurgePendingWidgetMessages(X_Widget_Object *P) { T_List **T = &TList; while(*T) { T_List *t = *T; if (t->widget_object == P) /* clear out pending messages for this widget */ { *T = t->next; free(t); } else T = &t->next; } } static void PurgePendingWindowMessages(X_Window_Object *P) { T_List **T = &TList; while(*T) { T_List *t = *T; if (t->window_object == P) /* clear out pending messages for this window */ { *T = t->next; free(t); } else T = &t->next; } } /******************************************************************************/ /* */ /* CList Purge Functions (SPF 29/2/96) */ /* */ /******************************************************************************/ static void PurgeCCallbacks(X_Widget_Object *P, Widget w) { C_List **C = &CList; while(*C) { C_List *c = *C; if (c->widget_object == P) /* clear out callback info for this widget */ { debugReclaimCallback(P,w,c); *C = c->next; free(c); } else C = &c->next; } } /******************************************************************************/ /* */ /* XObjects (Polymorphic functions 1) */ /* */ /******************************************************************************/ static int ResourceExists(X_Object *P) { X_List *L; for(L = *hashXList(P); L; L = L->next) { if (L->object == P) return 1; } return 0; } /* SafeResourceExists is like ResourceExists but doesn't assume that we actually have a valid X object, so it doesn't use hashing. SPF 6/4/95 */ static int SafeResourceExists(X_Object *P) { unsigned n; for (n = 0; n < XLISTSIZE; n++) { X_List *L; for(L = XList[n]; L; L = L->next) { if (L->object == P) return 1; } } return 0; } static void DestroyXObject(X_Object *P) { TaskData *taskData = processes->GetTaskDataForThread(); X_List **X = hashXList(P); switch(UNTAGGED(P->type)) { case X_GC: { X_GC_Object *G = GCObject(P); GC gc = *G->gc; Display *d = G->ds->display; if (gc == DefaultGC(d,G->ds->screen)) { debugReclaimRef(GC,gc->gid); } else { debugReclaim(GC,gc->gid); XFreeGC(d,gc); /* SAFE(?) */ } break; } case X_Font: { Font f = GetFont(taskData, P); if (f == None) { debugReclaimRef(Font,f); } else { debugReclaim(Font,f); #if NEVER XUnloadFont(GetDisplay(taskData, P),f); #endif } break; } case X_Cursor: { Cursor cursor = GetCursor(taskData, P); if (cursor == None) { debugReclaimRef(Cursor,cursor); } else { debugReclaim(Cursor,cursor); #if NEVER XFreeCursor(GetDisplay(taskData, P),cursor); #endif } break; } case X_Window: { /* added 29/11/93 SPF */ PurgePendingWindowMessages(WindowObject(P)); if (((X_Window_Object *)P)->parent != 0) /* this clients window */ { debugReclaim(Window,GetWindow(taskData, P)); DestroyWindow(P); } else /* None, ParentRelative, and other clients windows */ { debugReclaimRef(Window,GetWindow(taskData, P)); } break; } case X_Pixmap: { Pixmap pixmap = GetPixmap(taskData, P); if (pixmap == None) { debugReclaimRef(Pixmap,pixmap); } else { debugReclaim(Pixmap,pixmap); #if NEVER XFreePixmap(GetDisplay(taskData, P),pixmap); #endif } break; } case X_Colormap: { Colormap cmap = GetColormap(taskData, P); if (cmap == None) { debugReclaimRef(Colormap,cmap); } else { debugReclaim(Colormap,cmap); #if NEVER XFreeColormap(GetDisplay(taskData, P),cmap); #endif } break; } case X_Visual: { Visual *visual = GetVisual(taskData, P); debugReclaimRef(Visual,visual->visualid); break; } case X_Widget: { Widget widget = GetNWidget(taskData, P); PurgePendingWidgetMessages(WidgetObject(taskData, P)); debugReclaimRef(Widget,widget); break; } case X_Trans: { XtTranslations table = GetTrans(taskData, P); debugReclaimRef(Trans,table); break; } case X_Acc: { XtAccelerators acc = GetAcc(taskData, (X_Object *)P); debugReclaimRef(Acc,acc); break; } default: Crash ("Unknown X_Object type %d",UNTAGGED(P->type)); } while(*X) { X_List *L = *X; if (L->object == P) { *X = L->next; free(L); return; } else X = &L->next; } printf("DestroyXObject: destroy failed\n"); } #define CheckExists(P,resource) \ {\ if (! ResourceExists(P)) RaiseXWindows(taskData, (char*) "Non-existent " #resource); \ } static X_Font_Object *FontObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Font); return (X_Font_Object *)P; } static X_Object *FindResource ( Handle dsHandle, /* Handle to (X_Display_Object *) */ X_types type, unsigned long id, unsigned long hashid ) { X_List *L; X_Display_Object *d = (type == X_Widget) ? NULL : DEREFDISPLAYHANDLE(dsHandle); for(L = findXList(hashid); L; L = L->next) { X_Object *P = L->object; if (UNTAGGED(P->type) == type) { switch(type) { case X_GC: if (((X_GC_Object*)P)->ds == d && (*((X_GC_Object*)P)->gc)->gid == id) return P; break; case X_Font: if (((X_Font_Object*)P)->ds == d && (*((X_Font_Object*)P)->font) == id) return P; break; case X_Cursor: if (((X_Cursor_Object*)P)->ds == d && (*((X_Cursor_Object*)P)->cursor) == id) return P; break; case X_Window: if (((X_Window_Object*)P)->ds == d && (*((X_Window_Object*)P)->drawable) == id) return P; break; case X_Pixmap: if (((X_Pixmap_Object*)P)->ds == d && (*((X_Pixmap_Object*)P)->pixmap) == id) return P; break; case X_Colormap: if (((X_Colormap_Object*)P)->ds == d && (*((X_Colormap_Object*)P)->cmap) == id) return P; break; case X_Visual: if (((X_Visual_Object*)P)->ds == d && (*((X_Visual_Object*)P)->visual)->visualid == id) return P; break; case X_Widget: if (*(((X_Widget_Object*)P)->widget) == (Widget) id) return P; break; case X_Display: break; case X_Trans: break; case X_Acc: break; default: Crash ("Bad X_Object type (%d) in FindResource", type); } } } return 0; } // Why are there these casts to unsigned here???? #define FindWindow(d,id) ((X_Window_Object *) FindResource(d,X_Window,(unsigned long)id,(unsigned long)id)) #define FindPixmap(d,id) ((X_Pixmap_Object *) FindResource(d,X_Pixmap,(unsigned long)id,(unsigned long)id)) #define FindCursor(d,id) ((X_Cursor_Object *) FindResource(d,X_Cursor,(unsigned long)id,(unsigned long)id)) #define FindFont(d,id) ((X_Font_Object *) FindResource(d,X_Font,(unsigned long)id,(unsigned long)id)) #define FindColormap(d,id) ((X_Colormap_Object *) FindResource(d,X_Colormap,(unsigned long)id,(unsigned long)id)) #define FindWidget(id) ((X_Widget_Object *) FindResource((Handle)NULL,X_Widget,(unsigned long)id,(unsigned long)id)) /* can't use id for hashing in the following, so use arbitrary values instead */ #define FindGC(d,id) ((X_GC_Object *) FindResource(d,X_GC,(unsigned long)id,HASH_GC)) #define FindVisual(d,id) ((X_Visual_Object *) FindResource(d,X_Visual,(unsigned long)id,HASH_VISUAL)) static Handle AddXObject(Handle objectHandle) { X_List **X = hashXList(DEREFXOBJECTHANDLE(objectHandle)); X_List *L = (X_List *) malloc(sizeof(X_List)); L->next = *X; L->object = (X_Object *)DEREFHANDLE(objectHandle); *X = L; return objectHandle; } /******************************************************************************/ /* */ /* MLXPoint - implements ML XPoint datatype */ /* */ /******************************************************************************/ typedef struct /* depends on XPoint datatype + ML compiler hash function */ { PolyWord x; /* ML int */ PolyWord y; /* ML int */ } MLXPoint; inline MLXPoint * Point(PolyWord p) { return (MLXPoint *) p.AsObjPtr(); } /* shouldn't these be long values? */ inline short GetPointX(TaskData *taskData, PolyWord p) { return get_C_short(taskData, Point(p)->x); } inline short GetPointY(TaskData *taskData, PolyWord p) { return get_C_short(taskData, Point(p)->y); } inline short GetOffsetX(TaskData *taskData, PolyWord p) { return get_C_ushort(taskData, Point(p)->x); } inline short GetOffsetY(TaskData *taskData, PolyWord p) { return get_C_ushort(taskData, Point(p)->y); } static Handle CreatePoint(TaskData *taskData, int x, int y) { Handle pointHandle = alloc_and_save(taskData, SIZEOF(MLXPoint), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define point ((MLXPoint *)DEREFHANDLE(pointHandle)) point->x = DEREFWORD(Make_int(x)); point->y = DEREFWORD(Make_int(y)); #undef point return FINISHED(taskData, pointHandle); } static void GetPoints(TaskData *taskData, PolyWord p, void *v, unsigned) { XPoint *A = (XPoint *)v; A->x = GetPointX(taskData, p); A->y = GetPointY(taskData, p); } /******************************************************************************/ /* */ /* MLXRectangle - implements ML XRectangle datatype */ /* */ /******************************************************************************/ typedef struct /* depends on XRectangle datatype + ML compiler hash function */ { PolyWord top; /* ML int */ PolyWord left; /* ML int */ PolyWord right; /* ML int */ PolyWord bottom; /* ML int */ } MLXRectangle; inline MLXRectangle *Rect(PolyWord R) { return (MLXRectangle *) R.AsObjPtr(); } inline short GetRectTop(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->top); } inline short GetRectLeft(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->left); } inline short GetRectRight(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->right); } inline short GetRectBottom(TaskData *taskData, PolyWord R) { return get_C_short(taskData, Rect(R)->bottom); } #define GetRectX(taskData, R) GetRectLeft(taskData, R) #define GetRectY(taskData, R) GetRectTop(taskData, R) /* functions added 29/10/93 SPF */ static unsigned GetRectW(TaskData *taskData, PolyWord R) { long result = GetRectRight(taskData, R) - GetRectLeft(taskData, R); if (result < 0) RaiseRange(taskData); return (unsigned)result; } static unsigned GetRectH(TaskData *taskData, PolyWord R) { long result = GetRectBottom(taskData, R) - GetRectTop(taskData, R); if (result < 0) RaiseRange(taskData); return (unsigned)result; } /* static MLXRectangle **CreateRect(top,left,bottom,right) */ static Handle CreateRect(TaskData *taskData, int top, int left, int bottom, int right) { Handle rectHandle = alloc_and_save(taskData, SIZEOF(MLXRectangle), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define rect ((MLXRectangle *)DEREFHANDLE(rectHandle)) rect->top = DEREFWORD(Make_int(top)); rect->left = DEREFWORD(Make_int(left)); rect->right = DEREFWORD(Make_int(right)); rect->bottom = DEREFWORD(Make_int(bottom)); #undef rect return FINISHED(taskData, rectHandle); } #define CreateArea(w,h) CreateRect(taskData, 0,0,(int)h,(int)w) static void GetRects(TaskData *taskData, PolyWord p, void *v, unsigned) { XRectangle *A = (XRectangle *)v; A->x = GetRectX(taskData, p); A->y = GetRectY(taskData, p); A->width = GetRectW(taskData, p); A->height = GetRectH(taskData, p); } static void CheckZeroRect(TaskData *taskData, PolyWord R) { unsigned x = GetRectX(taskData, R); unsigned y = GetRectY(taskData, R); unsigned w = GetRectW(taskData, R); unsigned h = GetRectH(taskData, R); if (x != 0 || y != 0 || /* w <= 0 || h <= 0 || w,h now unsigned SPF 29/10/93 */ w == 0 || h == 0 || w > 65535 || h > 65535) RaiseRange(taskData); } /******************************************************************************/ /* */ /* MLXArc - implements ML XArc datatype */ /* */ /******************************************************************************/ /* MLXArc added 31/10/93 SPF; depends on ML XArc datatype */ typedef struct { PolyWord r; /* MMLXRectangle* */ PolyWord a1; /* ML int */ PolyWord a2; /* ML int */ } MLXArc; inline MLXArc *Arc(PolyWord A) { return (MLXArc *) A.AsObjPtr(); } inline PolyWord GetArcR(PolyWord A) { return Arc(A)->r; } inline short GetArcA1(TaskData *taskData, PolyWord A) { return get_C_short(taskData, Arc(A)->a1); } inline short GetArcA2(TaskData *taskData, PolyWord A) { return get_C_short(taskData, Arc(A)->a2); } static void GetArcs(TaskData *taskData, PolyWord p, void *v, unsigned) { XArc *A = (XArc *)v; A->x = GetRectX(taskData, GetArcR(p)); A->y = GetRectY(taskData, GetArcR(p)); A->width = GetRectW(taskData, GetArcR(p)); A->height = GetRectH(taskData, GetArcR(p)); A->angle1 = GetArcA1(taskData, p); A->angle2 = GetArcA2(taskData, p); } /******************************************************************************/ /* */ /* Colormap */ /* */ /******************************************************************************/ static X_Colormap_Object *ColormapObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Colormap); return (X_Colormap_Object *)P; } static Colormap GetColormap(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Colormap); /* val NoColormap = xcall (23,0) : Colormap; */ /* special case for NoColormap - correct(?) */ if ( *(((X_Colormap_Object *)P)->cmap) == None) return None; CheckExists(P,colormap); return *(((X_Colormap_Object *)P)->cmap); } static Handle EmptyColormap ( TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */, Colormap id ) { X_Colormap_Object *E = FindColormap(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Colormap_Object), F_MUTABLE_BIT); Handle cmapHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT | F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Colormap_Object *object = (X_Colormap_Object *)DEREFHANDLE(objectHandle); Colormap *cmap = (Colormap *)DEREFHANDLE(cmapHandle); *cmap = id; FINISHED(taskData, cmapHandle); object->type = TAGGED(X_Colormap); object->cmap = cmap; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Colormap,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Visual */ /* */ /******************************************************************************/ static Visual *GetVisual(TaskData *taskData, X_Object *P) { static Visual EMPTYVISUAL = { 0 }; assert(UNTAGGED(P->type) == X_Visual); /* val NoVisual = xcall (24,0) : Visual; */ /* special case for NoVisual */ if (*(((X_Visual_Object *)P)->visual) == None) return &EMPTYVISUAL; /* FISHY (?) */ CheckExists(P,visual); return *(((X_Visual_Object *)P)->visual); } static Handle EmptyVisual ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Visual *v ) { if (v != None) { X_Visual_Object *E = FindVisual(dsHandle,v->visualid); if (E) return SAVE(E); } /* else */ { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Visual_Object), F_MUTABLE_BIT); Handle visualHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Visual_Object *object = (X_Visual_Object *)DEREFHANDLE(objectHandle); Visual **visual = (Visual **)DEREFHANDLE(visualHandle); *visual = v; FINISHED(taskData, visualHandle); object->type = TAGGED(X_Visual); object->visual = visual; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Visual,(v == None) ? None : v->visualid); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* GC */ /* */ /******************************************************************************/ static X_GC_Object *GCObject(X_Object *P) { assert(UNTAGGED(P->type) == X_GC); return (X_GC_Object *)P; } static GC GetGC(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_GC); CheckExists(P,gc); return *(((X_GC_Object *)P)->gc); } static Handle GetDefaultGC(TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */) { GC defaultGC = DefaultGC(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen); X_GC_Object *G = FindGC(dsHandle,defaultGC->gid); if (G) { return SAVE(G); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_GC_Object), F_MUTABLE_BIT); Handle GCHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_GC_Object *object = (X_GC_Object *)DEREFHANDLE(objectHandle); GC *gc = (GC *)DEREFHANDLE(GCHandle); *gc = defaultGC; FINISHED(taskData, GCHandle); debugRefer(GC,defaultGC->gid); object->type = TAGGED(X_GC); object->gc = gc; object->ds = DEREFDISPLAYHANDLE(dsHandle); /* object->font_object = 0; object->tile = 0; object->stipple = 0; object->clipMask = 0; */ return AddXObject(objectHandle); /* must stay MUTABLE */ } } static void ChangeGC(TaskData *taskData, X_GC_Object *G, unsigned n, PolyWord P) { XGCValues v; unsigned mask = 1 << n; switch(mask) { case GCFunction: v.function = get_C_ushort(taskData, P); break; case GCPlaneMask: v.plane_mask = get_C_ulong (taskData, P); break; case GCForeground: v.foreground = get_C_ulong (taskData, P); break; case GCBackground: v.background = get_C_ulong (taskData, P); break; case GCLineWidth: v.line_width = get_C_short (taskData, P); break; case GCLineStyle: v.line_style = get_C_ushort(taskData, P); break; case GCCapStyle: v.cap_style = get_C_ushort(taskData, P); break; case GCJoinStyle: v.join_style = get_C_ushort(taskData, P); break; case GCFillStyle: v.fill_style = get_C_ushort(taskData, P); break; case GCFillRule: v.fill_rule = get_C_ushort(taskData, P); break; case GCTileStipXOrigin: v.ts_x_origin = get_C_short (taskData, P); break; case GCTileStipYOrigin: v.ts_y_origin = get_C_short (taskData, P); break; case GCSubwindowMode: v.subwindow_mode = get_C_ushort(taskData, P); break; case GCGraphicsExposures: v.graphics_exposures = get_C_ushort(taskData, P); break; case GCClipXOrigin: v.clip_x_origin = get_C_short (taskData, P); break; case GCClipYOrigin: v.clip_y_origin = get_C_short (taskData, P); break; case GCDashOffset: v.dash_offset = get_C_ushort(taskData, P); break; case GCDashList: v.dashes = get_C_uchar (taskData, P); break; case GCArcMode: v.arc_mode = get_C_ushort(taskData, P); break; case GCFont: v.font = GetFont(taskData, (X_Object *)P.AsObjPtr()); G->font_object = FontObject((X_Object *)P.AsObjPtr()); break; case GCTile: v.tile = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->tile = PixmapObject((X_Object *)P.AsObjPtr()); break; case GCStipple: v.stipple = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->stipple = PixmapObject((X_Object *)P.AsObjPtr()); break; case GCClipMask: v.clip_mask = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); G->clipMask = PixmapObject((X_Object *)P.AsObjPtr()); break; default: Crash ("Bad gc mask %u",mask); } XChangeGC(GetDisplay(taskData, (X_Object *)G),GetGC(taskData, (X_Object *)G),mask,&v); } static Handle CreateGC ( TaskData *taskData, Handle dsHandle /* Handle to (X_Display_Object *) */, Drawable w ) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_GC_Object), F_MUTABLE_BIT); Handle GCHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_GC_Object *object = (X_GC_Object *)DEREFHANDLE(objectHandle); GC *gc = (GC *)DEREFHANDLE(GCHandle); *gc = XCreateGC(DEREFDISPLAYHANDLE(dsHandle)->display,w,0,0); FINISHED(taskData, GCHandle); debugCreate(GC,(*gc)->gid); object->type = TAGGED(X_GC); object->gc = gc; object->ds = DEREFDISPLAYHANDLE(dsHandle); /* object->font_object = 0; object->tile = 0; object->stipple = 0; object->clipMask = 0; */ return AddXObject(objectHandle); /* must remain MUTABLE */ } /******************************************************************************/ /* */ /* Window */ /* */ /******************************************************************************/ static X_Window_Object *WindowObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Window); return (X_Window_Object *)P; } static Window GetWindow(TaskData *taskData, X_Object *P) { if (UNTAGGED(P->type) == X_Pixmap) { if (*((X_Pixmap_Object*)P)->pixmap == None) return None; RaiseXWindows(taskData, "Not a window"); } assert(UNTAGGED(P->type) == X_Window); CheckExists(P,window); return *(((X_Window_Object*)P)->drawable); } static Handle EmptyWindow ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { X_Window_Object *W = FindWindow(dsHandle,w); if (W) { return SAVE(W); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Window_Object), F_MUTABLE_BIT); Handle eventMaskHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle drawableHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Window_Object *object = DEREFWINDOWHANDLE(objectHandle); Drawable *drawable = (Drawable *)DEREFHANDLE(drawableHandle); PolyObject *eventMask = DEREFHANDLE(eventMaskHandle); *drawable = w; FINISHED(taskData, drawableHandle); #ifdef nodef /* DCJM: This gets in the way of trying to handle ButtonPress events - get rid of it. */ /* so that Motif windows get ButtonClick XEvent structures */ eventMask->Set(0, PolyWord::FromUnsigned(ButtonClickMask)); /* eventMask must remain MUTABLE */ #else eventMask->Set(0, PolyWord::FromUnsigned(0)); #endif object->type = TAGGED(X_Window); object->drawable = drawable; object->handler = TAGGED(0); object->state = TAGGED(0); object->eventMask = eventMask; /* object->colormap_object = 0; object->cursor_object = 0; object->backgroundPixmap = 0; object->borderPixmap = 0; object->parent = 0; */ object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Window,w); return AddXObject(objectHandle); /* must remain MUTABLE */ } } /******************************************************************************/ /* */ /* Pixmap */ /* */ /******************************************************************************/ static X_Pixmap_Object *PixmapObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Pixmap); return (X_Pixmap_Object *)P; } static Pixmap GetPixmap(TaskData *taskData, X_Object *P) { if (UNTAGGED(P->type) == X_Window) { if (! ResourceExists(P)) { debug1("Non-existent window %lx\n",(long)P); } if (*(((X_Window_Object*)P)->drawable) == None) return None; RaiseXWindows(taskData, "Not a pixmap"); } assert(UNTAGGED(P->type) == X_Pixmap); /* val NoDrawable = xcall (20,0) : Drawable; */ /* val ParentRelative = xcall (20,1) : Drawable; */ /* special case for NoDrawable */ if (*((X_Pixmap_Object*)P)->pixmap == 0) return None; /* special case for ParentRelative */ if (*((X_Pixmap_Object*)P)->pixmap == 1) return None; CheckExists(P,pixmap); return *(((X_Pixmap_Object*)P)->pixmap); } static Handle EmptyPixmap ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Pixmap id ) { X_Pixmap_Object *E = FindPixmap(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Pixmap_Object), F_MUTABLE_BIT); Handle pixmapHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Pixmap_Object *object = (X_Pixmap_Object *)DEREFHANDLE(objectHandle); Pixmap *pixmap = (Pixmap *)DEREFHANDLE(pixmapHandle); *pixmap = id; FINISHED(taskData, pixmapHandle); object->type = TAGGED(X_Pixmap); object->pixmap = pixmap; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugCreate(Pixmap,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Drawable */ /* */ /******************************************************************************/ static Drawable GetDrawable(TaskData *taskData, X_Object *P) { CheckExists(P,drawable); switch(UNTAGGED(P->type)) { case X_Window: return *(((X_Window_Object*)P)->drawable); case X_Pixmap: return *(((X_Pixmap_Object*)P)->pixmap); default: Crash ("Bad X_Object type (%d) in GetDrawable",UNTAGGED(P->type)); } /*NOTREACHED*/ } /******************************************************************************/ /* */ /* DS / Display */ /* */ /******************************************************************************/ static Handle GetDS(TaskData *taskData, X_Object *P) { X_Display_Object *ds; CheckExists(P,resource); switch(UNTAGGED(P->type)) { case X_GC: ds = ((X_GC_Object*)P)->ds; break; case X_Font: ds = ((X_Font_Object*)P)->ds; break; case X_Cursor: ds = ((X_Cursor_Object*)P)->ds; break; case X_Window: ds = ((X_Window_Object*)P)->ds; break; case X_Pixmap: ds = ((X_Pixmap_Object*)P)->ds; break; case X_Colormap: ds = ((X_Colormap_Object*)P)->ds; break; case X_Visual: ds = ((X_Visual_Object*)P)->ds; break; case X_Widget: ds = ((X_Widget_Object*)P)->ds; break; case X_Display: ds = (X_Display_Object*)P; break; /* i.e. P cast to the right type */ default: Crash ("Bad X_Object type (%d) in GetDS",UNTAGGED(P->type)); } assert((PolyWord)ds != TAGGED(0)); return SAVE(ds); } static Display *GetDisplay(TaskData *taskData, X_Object *P) { CheckExists(P,resource); switch(UNTAGGED(P->type)) { case X_GC: return ((X_GC_Object*)P)->ds->display; case X_Font: return ((X_Font_Object*)P)->ds->display; case X_Cursor: return ((X_Cursor_Object*)P)->ds->display; case X_Window: return ((X_Window_Object*)P)->ds->display; case X_Pixmap: return ((X_Pixmap_Object*)P)->ds->display; case X_Colormap: return ((X_Colormap_Object*)P)->ds->display; case X_Visual: return ((X_Visual_Object*)P)->ds->display; case X_Widget: return ((X_Widget_Object*)P)->ds->display; case X_Display: return ((X_Display_Object*)P)->display; default: Crash ("Bad X_Object type (%d) in GetDisplay",UNTAGGED(P->type)); } /*NOTREACHED*/ } /******************************************************************************/ /* */ /* FS / Font */ /* */ /******************************************************************************/ static Font GetFont(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Font); /* val NoFont = xcall (22,0) : Font; */ /* special case for NoFont - valid(?) */ if (*(((X_Font_Object *)P)->font) == None) return None; CheckExists(P,font); return *(((X_Font_Object *)P)->font); } static Handle EmptyFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font id, XFontStruct *fs ) { X_Font_Object *E = FindFont(dsHandle,id); if (E && (fs == NULL || *(E->fs) == fs)) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Font_Object), F_MUTABLE_BIT); Handle fontHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle FSHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Font_Object *object = (X_Font_Object *)DEREFHANDLE(objectHandle); Font *font = (Font *)DEREFHANDLE(fontHandle); XFontStruct **xfstr = (XFontStruct **)DEREFHANDLE(FSHandle); *font = id; FINISHED(taskData, fontHandle); *xfstr = fs; FINISHED(taskData, FSHandle); object->type = TAGGED(X_Font); object->font = font; object->fs = xfstr; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugCreate(Font,id); return AddXObject(FINISHED(taskData, objectHandle)); } } /******************************************************************************/ /* */ /* Cursor */ /* */ /******************************************************************************/ static X_Cursor_Object *CursorObject(X_Object *P) { assert(UNTAGGED(P->type) == X_Cursor); return (X_Cursor_Object *)P; } static Cursor GetCursor(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Cursor); /* val NoCursor = xcall (21,0) : Cursor; */ /* special case for NoCursor */ if (*(((X_Cursor_Object *)P)->cursor) == None) return None; CheckExists(P,cursor); return *(((X_Cursor_Object *)P)->cursor); } static Handle EmptyCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Cursor id ) { X_Cursor_Object *E = FindCursor(dsHandle,id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Cursor_Object), F_MUTABLE_BIT); Handle cursorHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Cursor_Object *object = (X_Cursor_Object *)DEREFHANDLE(objectHandle); Cursor *cursor = (Cursor *)DEREFHANDLE(cursorHandle); *cursor = id; FINISHED(taskData, cursorHandle); object->type = TAGGED(X_Cursor); object->cursor = cursor; object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Cursor,id); return AddXObject(FINISHED(taskData, objectHandle)); } } static Handle CreateFontCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ unsigned shape ) { return EmptyCursor(taskData, dsHandle,XCreateFontCursor(DEREFDISPLAYHANDLE(dsHandle)->display,shape)); } static Handle CreateGlyphCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font sf, Font mf, unsigned sc, unsigned mc, XColor *foreground, XColor *background ) { return EmptyCursor(taskData, dsHandle,XCreateGlyphCursor(DEREFDISPLAYHANDLE(dsHandle)->display,sf,mf,sc,mc,foreground,background)); } static Handle CreatePixmapCursor ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Pixmap source, Pixmap mask, XColor *foreground, XColor *background, unsigned x, unsigned y ) { return EmptyCursor(taskData, dsHandle,XCreatePixmapCursor(DEREFDISPLAYHANDLE(dsHandle)->display,source,mask,foreground,background,x,y)); } /******************************************************************************/ /* */ /* Widget */ /* */ /******************************************************************************/ static Widget GetNWidget(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); if (*(((X_Widget_Object *)P)->widget) == NULL) return NULL; CheckExists(P,widget); return *(((X_Widget_Object *)P)->widget); } static Widget GetWidget(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); if (*(((X_Widget_Object *)P)->widget) == NULL) { RaiseXWindows(taskData, "Not a real widget"); } CheckExists(P,widget); return *(((X_Widget_Object *)P)->widget); } /* added 6/11/94 SPF */ static Widget GetRealizedWidget(TaskData *taskData, char *where, X_Object *P) { Widget w; assert(UNTAGGED(P->type) == X_Widget); w = *(((X_Widget_Object *)P)->widget); if (w == NULL) { RaiseXWindows2(where,": not a real widget"); } CheckExists(P,widget); if (XtIsRealized(w) == False) { RaiseXWindows2(where,": widget is not realized"); } return w; } /* P is a pointer to an X_Widget_Object */ static X_Widget_Object *WidgetObjectToken(X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); return (X_Widget_Object *)P; } /* P is a pointer to an X_Widget_Object, which is bound to a C widget */ static X_Widget_Object *WidgetObject(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Widget); CheckExists(P,widget); return (X_Widget_Object *)P; } static Handle EmptyWidget ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget id ) { X_Widget_Object *E = FindWidget(id); if (E) { return SAVE(E); } else { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Widget_Object), F_MUTABLE_BIT); Handle widgetHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Widget_Object *object = (X_Widget_Object *)DEREFHANDLE(objectHandle); Widget *widget = (Widget *)DEREFHANDLE(widgetHandle); *widget = id; FINISHED(taskData, widgetHandle); object->type = TAGGED(X_Widget); object->widget = widget; object->callbackList = ListNull; object->state = TAGGED(0); object->ds = DEREFDISPLAYHANDLE(dsHandle); debugRefer(Widget,id); return AddXObject(objectHandle); /* Must stay MUTABLE */ } } static Handle NewWidget ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget id ) { X_Widget_Object *E = FindWidget(id); if (E) DestroyXObject((X_Object *)E); return EmptyWidget(taskData, dsHandle,id); } /******************************************************************************/ /* */ /* Text Widgets */ /* */ /******************************************************************************/ static Widget GetTextWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsText(w)) return w; /* Text operations are also legal on TextField widgets */ if (XmIsTextField(w)) return w; RaiseXWindows2(funcname,": not a Text or TextField widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* TextField Widgets */ /* */ /******************************************************************************/ static Widget GetTextFieldWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsTextField(w)) return w; RaiseXWindows2(funcname,": not a TextField widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* List Widgets */ /* */ /******************************************************************************/ static Widget GetListWidget(TaskData *taskData, char *funcname, X_Object *P) { Widget w = GetWidget(taskData, P); if (XmIsList(w)) return w; RaiseXWindows2(funcname,": not a List widget"); /*NOTREACHED*/ } /******************************************************************************/ /* */ /* Window */ /* */ /******************************************************************************/ static void RemoveWindowEvents(Display *d, Window w) { XEvent event; XSync(d,False); while(XCheckWindowEvent(d,w,~0,&event)) { /* do nothing */ } } static Handle AddWindow ( TaskData *taskData, Window W, Handle handlerHandle, /* Handle to (PolyWord *) (?) */ Handle stateHandle, /* Handle to (PolyWord *) (?) */ Handle parentHandle /* Handle to (X_Window_Object *) */ ) { XWMHints hints; Atom deleteWindow; /* was int SPF 6/1/94 */ Display *d = GetDisplay(taskData, DEREFXOBJECTHANDLE(parentHandle)); Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Window_Object), F_MUTABLE_BIT); Handle eventMaskHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); Handle drawableHandle = alloc_and_save(taskData, 1, F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Window_Object *object = DEREFWINDOWHANDLE(objectHandle); Drawable *drawable = (Drawable *)DEREFHANDLE(drawableHandle); PolyObject *eventMask = DEREFHANDLE(eventMaskHandle); eventMask->Set(0, PolyWord::FromUnsigned(0)); /* eventMask must remain MUTABLE */ *drawable = W; FINISHED(taskData, drawableHandle); hints.flags = InputHint; hints.input = True; XSetWMHints(d,W,&hints); deleteWindow = WM_DELETE_WINDOW(d); if (deleteWindow != None) XSetWMProtocols(d,W,&deleteWindow,1); debugCreate(Window,W); object->type = TAGGED(X_Window); object->drawable = drawable; object->eventMask = eventMask; object->handler = DEREFHANDLE(handlerHandle); object->state = DEREFHANDLE(stateHandle); object->parent = DEREFWINDOWHANDLE(parentHandle); object->ds = DEREFWINDOWHANDLE(parentHandle)->ds; /* Tidy up (?) */ /* object->colormap_object = 0; object->cursor_object = 0; object->backgroundPixmap = 0; object->borderPixmap = 0; */ if (ISNIL(DEREFHANDLE(handlerHandle))) Crash ("No handler set"); return AddXObject(objectHandle); /* object must remain MUTABLE */ } static void DestroyWindow(X_Object *W /* Should be a Window Object! */) { TaskData *taskData = processes->GetTaskDataForThread(); Window w = GetWindow(taskData, W); Display *d = GetDisplay(taskData, W); debugReclaim(Window,w); XUnmapWindow(d,w); DestroySubwindows(W); XDestroyWindow(d,w); RemoveWindowEvents(d,w); } static Handle CreateSimpleWindow ( TaskData *taskData, Handle parent, /* Handle to (X_Window_Object *) */ int x, int y, unsigned w, unsigned h, unsigned borderWidth, unsigned border, unsigned background, Handle handler, /* Handle to (PolyWord *) (?) */ Handle state /* Handle to (PolyWord *) (?) */ ) { Window W = XCreateSimpleWindow(GetDisplay(taskData, DEREFXOBJECTHANDLE(parent)), GetWindow(taskData, DEREFXOBJECTHANDLE(parent)), x,y,w,h, borderWidth,border,background); if (W == 0) RaiseXWindows(taskData, "XCreateSimpleWindow failed"); return AddWindow(taskData,W,handler,state,parent); } static Handle CreateWindow ( TaskData *taskData, Handle parent, /* Handle to (X_Window_Object *) */ int x, int y, unsigned w, unsigned h, unsigned borderWidth, unsigned depth, unsigned clas, Visual *visual, Handle handler, /* Handle to (PolyWord *) (?) */ Handle state /* Handle to (PolyWord *) (?) */ ) { Window W; W = XCreateWindow(GetDisplay(taskData, DEREFXOBJECTHANDLE(parent)), GetWindow(taskData, DEREFXOBJECTHANDLE(parent)), x,y,w,h, borderWidth,depth,clas,visual,0,0); if (W == 0) RaiseXWindows(taskData, "XCreateWindow failed"); return AddWindow(taskData,W,handler,state,parent); } static void DestroySubwindows(X_Object *W /* should be a Window object! */) { TaskData *taskData = processes->GetTaskDataForThread(); Window root,parent,*children; unsigned n; int s; Window w = GetWindow(taskData, W); Display *d = GetDisplay(taskData, W); s = XQueryTree(d,w,&root,&parent,&children,&n); if (s == 0) { RaiseXWindows(taskData, "XDestroySubwindows failed"); return; } XUnmapSubwindows(d,w); if (n) { Handle dsHandle = GetDS(taskData, W); while(n--) { X_Window_Object *child = FindWindow(dsHandle,children[n]); if (child) DestroyXObject((X_Object *)child); } XFree((char *)children); } XDestroySubwindows(d,w); } /******************************************************************************/ /* */ /* Translations / Accelerators */ /* */ /******************************************************************************/ static Handle EmptyTrans(TaskData *taskData, XtTranslations table) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Trans_Object), F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Trans_Object *object = (X_Trans_Object *)DEREFHANDLE(objectHandle); /* OK to store C values because this is a byte object */ object->type = TAGGED(X_Trans); object->table = table; debugRefer(Trans,table); return AddXObject(FINISHED(taskData, objectHandle)); } static XtTranslations GetTrans(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Trans); CheckExists(P,trans); return ((X_Trans_Object *)P)->table; } static Handle EmptyAcc(TaskData *taskData, XtTranslations acc) { Handle objectHandle = alloc_and_save(taskData, SIZEOF(X_Acc_Object), F_MUTABLE_BIT|F_BYTE_OBJ); /* Must do all allocations before we do the first dereference */ X_Acc_Object *object = (X_Acc_Object *)DEREFHANDLE(objectHandle); /* OK to store C values because this is a byte object */ object->type = TAGGED(X_Acc); object->acc = acc; debugRefer(Acc,acc); return AddXObject(FINISHED(taskData, objectHandle)); } static XtAccelerators GetAcc(TaskData *taskData, X_Object *P) { assert(UNTAGGED(P->type) == X_Acc); CheckExists(P,acc); return ((X_Acc_Object *)P)->acc; } /******************************************************************************/ /* */ /* Utility functions */ /* */ /******************************************************************************/ static XtGrabKind GetXtGrabKind(TaskData *taskData, PolyWord P) { int i = get_C_long(taskData, P); /* This encoding must be the same as that used in Motif/ml_bind.ML */ switch (i) { case 0: return XtGrabNone; case 1: return XtGrabNonexclusive; case 2: return XtGrabExclusive; default: Crash ("Bad XtGrabKind index (%d) in GetXtGrabKind",i); } return XtGrabNone; /* to keep lint/gcc happy */ } /******************************************************************************/ /* */ /* MLXStandardColormap - implements ML XStandardColormap datatype */ /* */ /******************************************************************************/ typedef struct { X_Colormap_Object *Colormap; PolyWord redMax; /* ML int */ PolyWord redMult; /* ML int */ PolyWord greenMax; /* ML int */ PolyWord greenMult; /* ML int */ PolyWord blueMax; /* ML int */ PolyWord blueMult; /* ML int */ PolyWord basePixel; /* ML int */ X_Visual_Object *visual; } MLXStandardColormap; static void GetStandardColormap(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXStandardColormap *P = (MLXStandardColormap *)p.AsObjPtr(); XStandardColormap *s = (XStandardColormap *)v; s->colormap = GetColormap(taskData, (X_Object *)P->Colormap); s->red_max = get_C_ulong(taskData, P->redMax); s->red_mult = get_C_ulong(taskData, P->redMult); s->green_max = get_C_ulong(taskData, P->greenMax); s->green_mult = get_C_ulong(taskData, P->greenMult); s->blue_max = get_C_ulong(taskData, P->blueMax); s->blue_mult = get_C_ulong(taskData, P->blueMult); s->base_pixel = get_C_ulong(taskData, P->basePixel); s->visualid = GetVisual(taskData, (X_Object *)P->visual)->visualid; /* UNSAFE(?) */ s->killid = None; } static Handle CreateStandardColormap ( TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { XStandardColormap *s = (XStandardColormap *)v; XVisualInfo T; XVisualInfo *info; int count; Handle tupleHandle = alloc_and_save(taskData, SIZEOF(MLXStandardColormap), F_MUTABLE_BIT); T.visualid = s->visualid; T.visual = None; info = XGetVisualInfo(DEREFDISPLAYHANDLE(dsHandle)->display,VisualIDMask,&T,&count); if (info) { T.visual = info->visual; XFree((char *)info); } /* Still allocating, so must use explicit DEREF for each element */ #define tuple /* hack */((MLXStandardColormap *)DEREFHANDLE(tupleHandle)) tuple->Colormap = (X_Colormap_Object *)DEREFHANDLE(EmptyColormap(taskData, dsHandle,s->colormap)); tuple->redMax = DEREFWORD(Make_arbitrary_precision(taskData, s->red_max)); tuple->redMult = DEREFWORD(Make_arbitrary_precision(taskData, s->red_mult)); tuple->greenMax = DEREFWORD(Make_arbitrary_precision(taskData, s->green_max)); tuple->greenMult = DEREFWORD(Make_arbitrary_precision(taskData, s->green_mult)); tuple->blueMax = DEREFWORD(Make_arbitrary_precision(taskData, s->blue_max)); tuple->blueMult = DEREFWORD(Make_arbitrary_precision(taskData, s->blue_mult)); tuple->basePixel = DEREFWORD(Make_arbitrary_precision(taskData, s->base_pixel)); tuple->visual = (X_Visual_Object *)DEREFHANDLE(EmptyVisual(taskData, dsHandle,T.visual)); #undef tuple return FINISHED(taskData, tupleHandle); } /******************************************************************************/ /* */ /* Polymorphic pairs */ /* */ /******************************************************************************/ class MLPair: public PolyObject { public: PolyWord x0; /* first value */ PolyWord x1; /* second value */ }; /* Polymorphic pair creation */ static Handle CreatePair(TaskData *taskData, Handle p1, Handle p2) { Handle pairHandle = alloc_and_save(taskData, SIZEOF(MLPair), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define pair ((MLPair *)DEREFHANDLE(pairHandle)) pair->x0 = DEREFWORD(p1); pair->x1 = DEREFWORD(p2); #undef pair return FINISHED(taskData, pairHandle); } /******************************************************************************/ /* */ /* Polymorphic triples */ /* */ /******************************************************************************/ class MLTriple: public PolyObject { public: PolyWord x0; /* first value */ PolyWord x1; /* second value */ PolyWord x2; /* third value */ }; inline PolyWord FST(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x0; } inline PolyWord SND(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x1; } inline PolyWord THIRD(PolyWord P) { return ((MLTriple*)P.AsObjPtr())->x2; } static Handle CreateTriple(TaskData *taskData, Handle p1, Handle p2, Handle p3) { Handle tripleHandle = alloc_and_save(taskData, SIZEOF(MLTriple), F_MUTABLE_BIT); /* Still allocating, so must use explicit DEREF for each element */ #define triple ((MLTriple *)DEREFHANDLE(tripleHandle)) triple->x0 = DEREFWORD(p1); triple->x1 = DEREFWORD(p2); triple->x2 = DEREFWORD(p3); #undef triple return FINISHED(taskData, tripleHandle); } /******************************************************************************/ /* */ /* MLXImage - Implements ML XImage datatype */ /* */ /******************************************************************************/ typedef struct { PolyWord data; /* ML (abstype containing) string */ PolyWord size; /* MLXRectangle * */ PolyWord depth; /* ML int */ PolyWord format; /* (short ML int) XYBitmap | XYPixmap | ZPixmap */ PolyWord xoffset; /* ML int */ PolyWord bitmapPad; /* ML int */ PolyWord byteOrder; /* (short ML int) LSBFirst | MSBFirst */ PolyWord bitmapUnit; /* ML int */ PolyWord bitsPerPixel; /* ML int */ PolyWord bytesPerLine; /* ML int */ PolyWord visualRedMask; /* ML int */ PolyWord bitmapBitOrder; /* (short ML int) LSBFirst | MSBFirst */ PolyWord visualBlueMask; /* ML int */ PolyWord visualGreenMask; /* ML int */ } MLXImage; #define MLImageFormat(n) (n+1) #define MLImageOrder(n) (n+1) #define CImageFormat(n) (n-1) #define CImageOrder(n) (n-1) static unsigned ImageBytes(XImage *image) { unsigned dsize = image->bytes_per_line * image->height; if (image->format == XYPixmap) dsize = dsize * image->depth; return dsize; } static XImage *GetXImage(TaskData *taskData, Display *d, PolyWord p) /* can only be called once per X opcode */ { MLXImage *I = (MLXImage *)p.AsObjPtr(); static XImage image = { 0 }; PolyStringObject *data = GetString(I->data); unsigned width = GetRectW(taskData, I->size); unsigned height = GetRectH(taskData, I->size); unsigned depth = get_C_ulong(taskData, I->depth); unsigned format = get_C_ulong(taskData, I->format); int xoffset = get_C_short(taskData, I->xoffset); int bitmapPad = get_C_short(taskData, I->bitmapPad); int bytesPerLine = get_C_long (taskData, I->bytesPerLine); unsigned byteOrder = get_C_ulong(taskData, I->byteOrder); unsigned bitmapUnit = get_C_ulong(taskData, I->bitmapUnit); unsigned bitsPerPixel = get_C_ulong(taskData, I->bitsPerPixel); unsigned bitmapBitOrder = get_C_ulong(taskData, I->bitmapBitOrder); format = CImageFormat(format); byteOrder = CImageOrder(byteOrder); bitmapBitOrder = CImageOrder(bitmapBitOrder); image.width = width; image.height = height; image.xoffset = xoffset; image.format = format; image.data = data->chars; image.byte_order = byteOrder; image.bitmap_unit = bitmapUnit; image.bitmap_bit_order = bitmapBitOrder; image.bitmap_pad = bitmapPad; image.depth = depth; image.bytes_per_line = bytesPerLine; image.bits_per_pixel = bitsPerPixel; image.red_mask = get_C_ulong(taskData, I->visualRedMask); image.green_mask = get_C_ulong(taskData, I->visualGreenMask); image.blue_mask = get_C_ulong(taskData, I->visualBlueMask); if (ImageBytes(&image) != data->length) RaiseXWindows(taskData, "Bad image string length"); XInitImage(&image); return ℑ } static Handle CreateImage(TaskData *taskData, XImage *image) { Handle XHandle = alloc_and_save(taskData, SIZEOF(MLXImage), F_MUTABLE_BIT); int dsize = ImageBytes(image); /* Still allocating, so must use explicit DEREF for each element */ #define X ((MLXImage *)DEREFHANDLE(XHandle)) X->data = C_string_to_Poly(taskData, image->data,dsize); X->size = DEREFWORD(CreateArea(image->width,image->height)); X->depth = DEREFWORD(Make_arbitrary_precision(taskData, image->depth)); X->format = DEREFWORD(Make_arbitrary_precision(taskData, MLImageFormat(image->format))); X->xoffset = DEREFWORD(Make_int(image->xoffset)); X->bitmapPad = DEREFWORD(Make_int(image->bitmap_pad)); X->byteOrder = DEREFWORD(Make_arbitrary_precision(taskData, MLImageOrder(image->byte_order))); X->bitmapUnit = DEREFWORD(Make_arbitrary_precision(taskData, image->bitmap_unit)); X->bitsPerPixel = DEREFWORD(Make_arbitrary_precision(taskData, image->bits_per_pixel)); X->bytesPerLine = DEREFWORD(Make_int(image->bytes_per_line)); X->visualRedMask = DEREFWORD(Make_arbitrary_precision(taskData, image->red_mask)); X->bitmapBitOrder = DEREFWORD(Make_arbitrary_precision(taskData, MLImageOrder(image->bitmap_bit_order))); X->visualBlueMask = DEREFWORD(Make_arbitrary_precision(taskData, image->blue_mask)); X->visualGreenMask = DEREFWORD(Make_arbitrary_precision(taskData, image->green_mask)); #undef X XDestroyImage(image); return FINISHED(taskData, XHandle); } static Handle GetImage ( TaskData *taskData, Display *d, Drawable drawable, int x, int y, unsigned w, unsigned h, unsigned /* long */ mask, int format ) { XImage *image = XGetImage(d,drawable,x,y,w,h,mask,CImageFormat(format)); if (image == 0) RaiseXWindows(taskData, "XGetImage failed"); return CreateImage(taskData, image); } static Handle SubImage ( TaskData *taskData, XImage *image, int x, int y, unsigned w, unsigned h ) { XImage *subimage = XSubImage(image,x,y,w,h); if (subimage == 0) RaiseXWindows(taskData, "XSubImage failed"); return CreateImage(taskData, subimage); } /******************************************************************************/ /* */ /* XImage */ /* */ /******************************************************************************/ static void GetSubImage ( Display *d, Drawable drawable, int sx, int sy, unsigned sw, unsigned sh, unsigned /* long */ mask, int format, XImage *image, int dx, int dy ) { XGetSubImage(d,drawable,sx,sy,sw,sh,mask,CImageFormat(format),image,dx,dy); /* XFree((char *)image); */ } static void PutImage ( Display *d, Drawable drawable, GC gc, XImage *image, int sx, int sy, int dx, int dy, unsigned dw, unsigned dh ) { XPutImage(d,drawable,gc,image,sx,sy,dx,dy,dw,dh); /* XFree((char *)image); */ } static Handle GetPixel(TaskData *taskData, XImage *image, int x, int y) { unsigned pixel = XGetPixel(image,x,y); /* XFree((char *)image); */ return Make_arbitrary_precision(taskData, pixel); } static void PutPixel(XImage *image, int x, int y, unsigned pixel) { XPutPixel(image,x,y,pixel); /* XFree((char *)image); */ } static void AddPixel(XImage *image, unsigned value) { XAddPixel(image,value); /* XFree((char *)image); */ } /******************************************************************************/ /* */ /* TimeVal */ /* */ /******************************************************************************/ static int DoubleClickTime = 250; /* Double click time in milliseconds */ static int MouseDrift = 5; /* Mouse movement allowed in button events */ static void NormaliseTime(TimeVal *t) { while(t->tv_usec >= 1000000) { t->tv_usec -= 1000000; t->tv_sec++; } while(t->tv_usec < 0) { t->tv_usec += 1000000; t->tv_sec--; } } static void TimeAdd(TimeVal *a, TimeVal *b, TimeVal *t) { t->tv_sec = a->tv_sec + b->tv_sec; t->tv_usec = a->tv_usec + b->tv_usec; NormaliseTime(t); } static int TimeLt(TimeVal *a, TimeVal *b) { return ((a->tv_sec < b->tv_sec) || ((a->tv_sec == b->tv_sec) && (a->tv_usec < b->tv_usec))); } static int TimeLeq(TimeVal *a, TimeVal *b) { return ((a->tv_sec < b->tv_sec) || ((a->tv_sec == b->tv_sec) && (a->tv_usec <= b->tv_usec))); } /******************************************************************************/ /* */ /* (?) */ /* */ /******************************************************************************/ typedef struct { XButtonEvent *button; /* initial button press event */ int up,down; /* count of button transitions */ } PredicateArgs; static Bool SameClickEvent(Display *dpy, XEvent *ev, XPointer arg) { PredicateArgs *A = (PredicateArgs *)arg; switch(ev->type) { case MotionNotify: { int dx = ev->xmotion.x - A->button->x; int dy = ev->xmotion.y - A->button->y; if (ev->xmotion.window != A->button->window) return False; if (abs(dx) > MouseDrift) return False; if (abs(dy) > MouseDrift) return False; return True; } case ButtonPress: case ButtonRelease: { int dx = ev->xbutton.x - A->button->x; int dy = ev->xbutton.y - A->button->y; if (ev->xbutton.window != A->button->window) return False; if (ev->xbutton.button != A->button->button) return False; if (abs(dx) > MouseDrift) return False; if (abs(dy) > MouseDrift) return False; if (ev->type == ButtonPress) A->down++; else A->up++; return True; } } return False; } static void WaitDoubleClickTime(Handle dsHandle, PredicateArgs *A) { XEvent N; TimeVal start_time,end_time,dt; Display *d = DEREFDISPLAYHANDLE(dsHandle)->display; /* AIX doesn't document support for NULL pointers in the select call, so we have to initialise empty fd_sets instead. SPF 30/10/95 */ fd_set read_fds, write_fds, except_fds; FD_ZERO(&read_fds); FD_ZERO(&write_fds); FD_ZERO(&except_fds); { int fd = d->fd; assert (0 <= fd && fd < FD_SETSIZE); FD_SET(fd,&read_fds); } gettimeofday(&start_time, NULL); dt.tv_sec = 0; dt.tv_usec = DoubleClickTime * 1000; TimeAdd(&start_time,&dt,&end_time); for (;;) { int extended = 0; while(XCheckIfEvent(d,&N,SameClickEvent,(char *) A)) { if (DEREFDISPLAYHANDLE(dsHandle)->app_context) XtDispatchEvent(&N); extended = 1; } if (QLength(d)) break; /* some other event to be processed next */ if (extended) /* button event extended, so extend time period */ { dt.tv_sec = 0; dt.tv_usec = DoubleClickTime * 1000; TimeAdd(&end_time,&dt,&end_time); } if (TimeLeq(&end_time,&start_time)) break; /* the time period has elapsed */ select(FD_SETSIZE,&read_fds,&write_fds,&except_fds,&dt); gettimeofday(&start_time, NULL); } } static Handle GetKeyVector(TaskData *taskData, void *k, unsigned i) { uchar *keys = (uchar*)k; unsigned index = i / 8; unsigned mask = 1 << (i % 8); return Make_bool(keys[index] & mask); } static Handle QueryKeymap(TaskData *taskData, Display *d) { char keys[32]; XQueryKeymap(d, keys); return CreateList4I(taskData, 256,keys,0,GetKeyVector); } /******************************************************************************/ /* */ /* EventName */ /* */ /******************************************************************************/ typedef struct { const char *name; int type; } EventName; static EventName EventNames[] = { { "KeyPress",KeyPress }, { "KeyRelease",KeyRelease }, { "ButtonPress",ButtonPress }, { "ButtonRelease",ButtonRelease }, { "MotionNotify",MotionNotify }, { "EnterNotify",EnterNotify }, { "LeaveNotify",LeaveNotify }, { "FocusIn",FocusIn }, { "FocusOut",FocusOut }, { "KeymapNotify",KeymapNotify }, { "Expose",Expose }, { "GraphicsExpose",GraphicsExpose }, { "NoExpose",NoExpose }, { "VisibilityNotify",VisibilityNotify }, { "CreateNotify",CreateNotify }, { "DestroyNotify",DestroyNotify }, { "UnmapNotify",UnmapNotify }, { "MapNotify",MapNotify }, { "MapRequest",MapRequest }, { "ReparentNotify",ReparentNotify }, { "ConfigureNotify",ConfigureNotify }, { "ConfigureRequest",ConfigureRequest }, { "GravityNotify",GravityNotify }, { "ResizeRequest",ResizeRequest }, { "CirculateNotify",CirculateNotify }, { "CirculateRequest",CirculateRequest }, { "PropertyNotify",PropertyNotify }, { "SelectionClear",SelectionClear }, { "SelectionRequest",SelectionRequest }, { "SelectionNotify",SelectionNotify }, { "ColormapNotify",ColormapNotify }, { "ClientMessage",ClientMessage }, { "MappingNotify",MappingNotify }, }; #define NEVENTS (sizeof(EventNames)/sizeof(EventName)) static const char *DebugEventName(int type) { for(unsigned i = 0; i < NEVENTS; i++) { if (EventNames[i].type == type) return EventNames[i].name; } return "** BAD EVENT **"; } static int WM_PROTOCOLS(Display *d) { static int protocols = None; if (protocols == None) protocols = XInternAtom(d,"WM_PROTOCOLS",True); return protocols; } static Atom WM_DELETE_WINDOW(Display *d) { static Atom deleteWindow = None; if (deleteWindow == None) deleteWindow = XInternAtom(d,"WM_DELETE_WINDOW",True); return deleteWindow; } /******************************************************************************/ /* */ /* Structures used by CreateEvent function. */ /* */ /* These typedefs should correspond with the tuples used by MakeXKeyEvent etc */ /* */ /******************************************************************************/ typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord keycode; /* ML int */ } ML_KeyEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord button; /* ML int */ } ML_ButtonEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord button; /* ML int */ PolyWord up; /* ML int */ PolyWord down; /* ML int */ } ML_ButtonClick_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord modifiers; /* ML modifier (int) */ PolyWord isHint; /* ML bool */ } ML_MotionEvent_Data; typedef struct { X_Window_Object *root; X_Window_Object *subwindow; PolyWord time; /* ML int */ MLXPoint *pointer; MLXPoint *rootPointer; PolyWord mode; /* ? */ PolyWord detail; /* ? */ PolyWord focus; /* ? */ PolyWord modifiers; /* ML modifier (int) */ } ML_CrossingEvent_Data; typedef struct { MLXRectangle *region; PolyWord count; /* ML int */ } ML_ExposeEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; /* ML int */ X_Window_Object *above; PolyWord overrideRedirect; /* ML bool */ } ML_ConfigureNotify_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; X_Window_Object *above; PolyWord detail; /* ? */ } ML_ConfigureRequest_Data; typedef struct { MLXRectangle *region; PolyWord count; /* ML int */ PolyWord code; /* ML int */ } ML_GraphicsExposeEvent_Data; typedef struct { PolyWord mode; /* ML int ? */ PolyWord detail; /* ML int ? */ } ML_FocusChangeEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; MLXRectangle *size; PolyWord borderWidth; /* ML int */ PolyWord overrideRedirect; /* ML bool */ } ML_CreateEvent_Data; typedef struct { X_Window_Object *window; PolyWord fromConfigure; /* ML bool */ } ML_UnmapEvent_Data; typedef struct { X_Window_Object *window; PolyWord overrideRedirect; /* ML bool */ } ML_MapEvent_Data; typedef struct { X_Window_Object *window; X_Window_Object *parent; MLXPoint *position; PolyWord overrideRedirect; /* ML bool */ } ML_ReparentEvent_Data; typedef struct { X_Window_Object *window; MLXPoint *position; } ML_GravityEvent_Data; typedef struct { X_Window_Object *window; PolyWord place; } ML_CirculateEvent_Data; typedef struct { X_Colormap_Object *colormap_object; PolyWord c_new; /* ML bool */ PolyWord installed; /* ML bool */ } ML_ColormapEvent_Data; typedef struct { PolyWord selection; /* ML int */ PolyWord time; /* ML int */ } ML_SelectionClear_Data; typedef struct { X_Window_Object *requestor; PolyWord selection; /* ML int */ PolyWord target; /* ML int */ PolyWord property; /* ML int */ PolyWord time; /* ML int */ } ML_SelectionRequest_Data; typedef struct { PolyWord selection; /* ML int */ PolyWord target; /* ML int */ PolyWord property; /* ML int */ PolyWord time; /* ML int */ } ML_Selection_Data; class ML_Event: public PolyObject { public: PolyWord type; /* ML (?) */ PolyWord sendEvent; /* ML bool */ PolyWord window; /* X_Window_Object* */ PolyWord data; /* pointer to event-specific data, in ML_XXX_Data format */ PolyWord callbacks; /* ML list of something */ PolyWord events; /* ML list */ }; /******************************************************************************/ /* */ /* CreateEvent function */ /* */ /******************************************************************************/ static Handle CreateEvent ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ XEvent *ev, Handle W /* Handle to (X_Window_Object *) */ ) { Handle eventHandle = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); Display *d = DEREFDISPLAYHANDLE(dsHandle)->display; int type = ev->xany.type; int send_event = ev->xany.send_event; assert(d == ev->xany.display); if (debugOptions & DEBUG_X) { printf("CreateEvent called, type=%s,", DebugEventName(type)); printf(" window=%lx\n", ev->xany.window); } #define event ((ML_Event *)DEREFHANDLE(eventHandle)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, type)); event->sendEvent = DEREFWORD(Make_bool(send_event)); event->window = DEREFWINDOWHANDLE(W); switch(type) { case KeyPress: case KeyRelease: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_KeyEvent_Data), F_MUTABLE_BIT); #define data ((ML_KeyEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xkey.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xkey.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.time)); data->pointer = (MLXPoint *)DEREFHANDLE(CreatePoint(taskData, ev->xkey.x,ev->xkey.y)); data->rootPointer = (MLXPoint *)DEREFHANDLE(CreatePoint(taskData, ev->xkey.x_root,ev->xkey.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.state)); data->keycode = DEREFWORD(Make_arbitrary_precision(taskData, ev->xkey.keycode)); #undef data event->data = DEREFHANDLE(FINISHED(taskData, dataHandle)); break; } case ButtonPress: case ButtonRelease: { if (DEREFWINDOWHANDLE(W)->eventMask->Get(0).AsUnsigned() & ButtonClickMask) { Handle dataHandle; PredicateArgs A; A.button = &ev->xbutton; A.up = (ev->type == ButtonRelease); A.down = (ev->type == ButtonPress); WaitDoubleClickTime(dsHandle,&A); dataHandle = alloc_and_save(taskData, SIZEOF(ML_ButtonClick_Data), F_MUTABLE_BIT); #define data ((ML_ButtonClick_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x,ev->xbutton.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x_root,ev->xbutton.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.state)); data->button = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.button)); data->up = DEREFWORD(Make_arbitrary_precision(taskData, A.up)); data->down = DEREFWORD(Make_arbitrary_precision(taskData, A.down)); #undef data event->type = DEREFWORD(Make_arbitrary_precision(taskData, 42)); /* What's this for? */ event->data = DEREFWORD(FINISHED(taskData, dataHandle)); } else { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ButtonEvent_Data), F_MUTABLE_BIT); #define data ((ML_ButtonEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xbutton.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x,ev->xbutton.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xbutton.x_root,ev->xbutton.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.state)); data->button = DEREFWORD(Make_arbitrary_precision(taskData, ev->xbutton.button)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); } break; } case MotionNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_MotionEvent_Data), F_MUTABLE_BIT); #define data ((ML_MotionEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmotion.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmotion.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xmotion.x,ev->xmotion.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xmotion.x_root,ev->xmotion.y_root)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.state)); data->isHint = DEREFWORD(Make_arbitrary_precision(taskData, ev->xmotion.is_hint)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case EnterNotify: case LeaveNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CrossingEvent_Data), F_MUTABLE_BIT); #define data ((ML_CrossingEvent_Data *)DEREFHANDLE(dataHandle)) data->root = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcrossing.root)); data->subwindow = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcrossing.subwindow)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.time)); data->pointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcrossing.x,ev->xcrossing.y)); data->rootPointer = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcrossing.x_root,ev->xcrossing.y_root)); data->mode = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.mode)); data->detail = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.detail)); data->focus = DEREFWORD(Make_bool(ev->xcrossing.focus)); data->modifiers = DEREFWORD(Make_arbitrary_precision(taskData, ev->xcrossing.state)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case Expose: { int left = ev->xexpose.x; int top = ev->xexpose.y; int right = left + ev->xexpose.width; int bottom = top + ev->xexpose.height; Handle dataHandle; while(XCheckTypedWindowEvent(d,ev->xexpose.window,Expose,ev)) { int L = ev->xexpose.x; int T = ev->xexpose.y; int R = L + ev->xexpose.width; int B = T + ev->xexpose.height; assert(ev->type == Expose); left = min(left,L); top = min(top,T); right = max(right,R); bottom = max(bottom,B); } dataHandle = alloc_and_save(taskData, SIZEOF(ML_ExposeEvent_Data), F_MUTABLE_BIT); #define data ((ML_ExposeEvent_Data *)DEREFHANDLE(dataHandle)) data->region = (MLXRectangle *)DEREFHANDLE(CreateRect(taskData, top,left,bottom,right)); data->count = DEREFWORD(Make_arbitrary_precision(taskData, 0)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case GraphicsExpose: { int left = ev->xgraphicsexpose.x; int top = ev->xgraphicsexpose.y; int right = left + ev->xgraphicsexpose.width; int bottom = top + ev->xgraphicsexpose.height; Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_GraphicsExposeEvent_Data), F_MUTABLE_BIT); #define data ((ML_GraphicsExposeEvent_Data *)DEREFHANDLE(dataHandle)) data->region = (MLXRectangle *)DEREFHANDLE(CreateRect(taskData, top,left,bottom,right)); data->count = DEREFWORD(Make_arbitrary_precision(taskData, ev->xgraphicsexpose.count)); data->code = DEREFWORD(Make_arbitrary_precision(taskData, ev->xgraphicsexpose.major_code)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case NoExpose: { event->data = DEREFWORD(Make_arbitrary_precision(taskData, ev->xnoexpose.major_code)); break; } case ConfigureNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ConfigureNotify_Data), F_MUTABLE_BIT); #define data ((ML_ConfigureNotify_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigure.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xconfigure.x,ev->xconfigure.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xconfigure.width,ev->xconfigure.height)); data->borderWidth = DEREFWORD(Make_int(ev->xconfigure.border_width)); data->above = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigure.above)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xconfigure.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case FocusIn: case FocusOut: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_FocusChangeEvent_Data), F_MUTABLE_BIT); #define data ((ML_FocusChangeEvent_Data *)DEREFHANDLE(dataHandle)) data->mode = DEREFWORD(Make_int(ev->xfocus.mode)); data->detail = DEREFWORD(Make_int(ev->xfocus.detail)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case VisibilityNotify: { event->data = DEREFWORD(Make_int(ev->xvisibility.state)); break; } case CreateNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CreateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CreateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcreatewindow.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xcreatewindow.x,ev->xcreatewindow.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xcreatewindow.width,ev->xcreatewindow.height)); data->borderWidth = DEREFWORD(Make_int(ev->xcreatewindow.border_width)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xcreatewindow.override_redirect)); #undef data event->data = DEREFHANDLE(FINISHED(taskData, dataHandle)); break; } case DestroyNotify: { debugReclaim(Window,ev->xdestroywindow.window); event->data = DEREFWORD(EmptyWindow(taskData, dsHandle,ev->xdestroywindow.window)); break; } case UnmapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_UnmapEvent_Data), F_MUTABLE_BIT); #define data ((ML_UnmapEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xunmap.window)); data->fromConfigure = DEREFWORD(Make_bool(ev->xunmap.from_configure)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_MapEvent_Data), F_MUTABLE_BIT); #define data ((ML_MapEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xmap.window)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xmap.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MapRequest: { event->data = DEREFWORD(EmptyWindow(taskData, dsHandle,ev->xmaprequest.window)); break; } case ReparentNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ReparentEvent_Data), F_MUTABLE_BIT); #define data ((ML_ReparentEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xreparent.window)); data->parent = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xreparent.parent)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xreparent.x,ev->xreparent.y)); data->overrideRedirect = DEREFWORD(Make_bool(ev->xreparent.override_redirect)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ConfigureRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ConfigureRequest_Data), F_MUTABLE_BIT); #define data ((ML_ConfigureRequest_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigurerequest.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xconfigurerequest.x,ev->xconfigurerequest.y)); data->size = (MLXRectangle *) DEREFHANDLE(CreateArea(ev->xconfigurerequest.width,ev->xconfigurerequest.height)); data->borderWidth = DEREFWORD(Make_int(ev->xconfigurerequest.border_width)); data->above = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xconfigurerequest.above)); data->detail = DEREFWORD(Make_int(ev->xconfigurerequest.detail)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case GravityNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_GravityEvent_Data), F_MUTABLE_BIT); #define data ((ML_GravityEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xgravity.window)); data->position = (MLXPoint *) DEREFHANDLE(CreatePoint(taskData, ev->xgravity.x,ev->xgravity.y)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ResizeRequest: { event->data = DEREFWORD(CreateArea(ev->xresizerequest.width,ev->xresizerequest.height)); break; } case CirculateNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CirculateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CirculateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcirculate.window)); data->place = DEREFWORD(Make_int(ev->xcirculate.place)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case CirculateRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_CirculateEvent_Data), F_MUTABLE_BIT); #define data ((ML_CirculateEvent_Data *)DEREFHANDLE(dataHandle)) data->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xcirculaterequest.window)); data->place = DEREFWORD(Make_int(ev->xcirculaterequest.place)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ColormapNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_ColormapEvent_Data), F_MUTABLE_BIT); #define data ((ML_ColormapEvent_Data *)DEREFHANDLE(dataHandle)) data->colormap_object = (X_Colormap_Object *)DEREFHANDLE(EmptyColormap(taskData, dsHandle,ev->xcolormap.colormap)); data->c_new = DEREFWORD(Make_bool(ev->xcolormap.c_new)); data->installed = DEREFWORD(Make_bool(ev->xcolormap.state == ColormapInstalled)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case MappingNotify: { XRefreshKeyboardMapping((XMappingEvent *)ev); /* cast added SPF 6/1/94 */ return 0; /* HACK !!!! */ } case SelectionClear: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_SelectionClear_Data), F_MUTABLE_BIT); #define data ((ML_SelectionClear_Data *)DEREFHANDLE(dataHandle)) data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionclear.selection)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionclear.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case SelectionNotify: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_Selection_Data), F_MUTABLE_BIT); #define data ((ML_Selection_Data *)DEREFHANDLE(dataHandle)) data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.selection)); data->target = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.target)); data->property = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.property)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselection.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case SelectionRequest: { Handle dataHandle = alloc_and_save(taskData, SIZEOF(ML_SelectionRequest_Data), F_MUTABLE_BIT); #define data ((ML_SelectionRequest_Data *)DEREFHANDLE(dataHandle)) data->requestor = DEREFWINDOWHANDLE(EmptyWindow(taskData, dsHandle,ev->xselectionrequest.requestor)); data->selection = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.selection)); data->target = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.target)); data->property = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.property)); data->time = DEREFWORD(Make_arbitrary_precision(taskData, ev->xselectionrequest.time)); #undef data event->data = DEREFWORD(FINISHED(taskData, dataHandle)); break; } case ClientMessage: { unsigned protocols = WM_PROTOCOLS(d); int deleteWindow = WM_DELETE_WINDOW(d); if (protocols != None && deleteWindow != None && ev->xclient.message_type == protocols && ev->xclient.format == 32 && ev->xclient.data.l[0] == deleteWindow) { event->type = DEREFWORD(Make_arbitrary_precision(taskData, 43)); /* (?) */ break; } else return 0; } case PropertyNotify: return 0; case KeymapNotify: return 0; /* Broken: the window field does not tell me the window requesting this event */ default: Crash ("Bad event type %x",ev->type); } event->callbacks = FList; /* Safe, since FList is a Root */ FList = TAGGED(0); event->events = GList; /* Safe, since GList is a Root */ GList = TAGGED(0); return FINISHED(taskData, eventHandle); #undef event } /******************************************************************************/ /* */ /* HERE */ /* */ /******************************************************************************/ static Handle LookupString(TaskData *taskData, Display *d, unsigned keycode, unsigned modifiers) { XKeyEvent ev; int n; KeySym keysym; /* was int SPF 6/1/94 */ char buffer[500]; ev.display = d; ev.keycode = keycode; ev.state = modifiers; n = XLookupString(&ev,buffer,sizeof(buffer)-1,&keysym,NULL); buffer[n] = '\0'; return CreatePair(taskData, Make_string(buffer),Make_arbitrary_precision(taskData, keysym)); } static Handle GetScreenSaver(TaskData *taskData, Display *d) { int timeout,interval,blanking,exposures; Handle tuple; XGetScreenSaver(d,&timeout,&interval,&blanking,&exposures); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_int(timeout))); data->Set(1, DEREFWORD(Make_int(interval))); data->Set(2, DEREFWORD(Make_arbitrary_precision(taskData, blanking))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, exposures))); #undef data return FINISHED(taskData, tuple); } static Handle TranslateCoordinates ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window src, Window dst, int x, int y ) { Window child; int dx,dy,s; s = XTranslateCoordinates(DEREFDISPLAYHANDLE(dsHandle)->display,src,dst,x,y,&dx,&dy,&child); if (s == 0) RaiseXWindows(taskData, "XTranslateCoordinates failed"); return CreatePair(taskData, CreatePoint(taskData, dx,dy),EmptyWindow(taskData, dsHandle,child)); } static Handle QueryBest ( TaskData *taskData, int (*f)(Display*, Drawable, unsigned, unsigned, unsigned *, unsigned *), Display *d, Drawable drawable, unsigned width, unsigned height ) { unsigned W,H; int s = (* f)(d,drawable,width,height,&W,&H); if (s == 0) RaiseXWindows(taskData, "XQueryBest failed"); return CreateArea(W,H); } static Handle QueryPointer ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window root,child; int rootX,rootY; int winX,winY; unsigned mask; int s; Handle tuple; s = XQueryPointer(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&child,&rootX,&rootY,&winX,&winY,&mask); tuple = alloc_and_save(taskData, 6, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, s))); data->Set(1, DEREFWORD(EmptyWindow(taskData, dsHandle,root))); data->Set(2, DEREFWORD(EmptyWindow(taskData, dsHandle,child))); data->Set(3, DEREFWORD(CreatePoint(taskData, rootX,rootY))); data->Set(4, DEREFWORD(CreatePoint(taskData, winX,winY))); data->Set(5, DEREFWORD(Make_arbitrary_precision(taskData, mask))); #undef data return FINISHED(taskData, tuple); } static Handle ReadBitmap ( TaskData *taskData, Handle dsHandle, /* handle to (X_Display_Object *) */ Drawable w, PolyStringObject *string ) { unsigned width,height; char name[500]; int s,xhot,yhot; Pixmap pixmap; Handle tuple; Poly_string_to_C(string,name,sizeof(name)); s = XReadBitmapFile(DEREFDISPLAYHANDLE(dsHandle)->display,w,name,&width,&height,&pixmap,&xhot,&yhot); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0,DEREFWORD(Make_arbitrary_precision(taskData, s))); if (s == BitmapSuccess) { data->Set(1, DEREFWORD(EmptyPixmap(taskData, dsHandle,pixmap))); data->Set(2, DEREFWORD(CreateArea(width,height))); data->Set(3, DEREFWORD(CreatePoint(taskData, xhot,yhot))); } /******************** What if we don't succeed? Badly-formed tuple !!!! */ #undef data return FINISHED(taskData, tuple); } static Handle WriteBitmapFile ( TaskData *taskData, PolyStringObject *string, Display *d, Pixmap bitmap, unsigned w, unsigned h, int x, int y ) { char name[500]; int s; Poly_string_to_C(string,name,sizeof(name)); s = XWriteBitmapFile(d,name,bitmap,w,h,x,y); return Make_arbitrary_precision(taskData, s); } static Handle GetDefault(TaskData *taskData, Display *d, PolyStringObject *s1, PolyStringObject *s2) { char program[500]; char option[500]; char *s; Poly_string_to_C(s1,program,sizeof(program)); Poly_string_to_C(s2,option ,sizeof(option)); s = XGetDefault(d,program,option); if (s == NULL) RaiseXWindows(taskData, "XGetDefault failed"); return Make_string(s); } static void GetWindows(TaskData *taskData, PolyWord p, void *w, unsigned) { *(Window *)w = GetWindow(taskData, (X_Object *)p.AsObjPtr()); } static void GetSegments(TaskData *taskData, PolyWord pp, void *w, unsigned) { XSegment *A = (XSegment *)w; PolyObject *p = pp.AsObjPtr(); A->x1 = GetPointX(taskData, p->Get(0)); A->y1 = GetPointY(taskData, p->Get(0)); A->x2 = GetPointX(taskData, p->Get(1)); A->y2 = GetPointY(taskData, p->Get(1)); } static void GetChar2(TaskData *taskData, PolyWord p, void *v, unsigned) { XChar2b *A = (XChar2b *)v; unsigned short u = get_C_ushort(taskData, p); A->byte1 = u >> 8; A->byte2 = u &0xFF; } static void CopyString(TaskData *, PolyWord w, void *v, unsigned) { char **p = (char**)v; PolyStringObject *s = GetString(w); POLYUNSIGNED n = s->length+1; *p = (char*)malloc(n); Poly_string_to_C(s,*p,n); } static void GetText(TaskData *taskData, PolyWord p, void *w, unsigned) { XTextItem *A = (XTextItem *)w; PolyObject *obj = p.AsObjPtr(); CopyString(taskData, obj->Get(0), &A->chars, 0); A->nchars = strlen(A->chars); A->delta = get_C_short(taskData, obj->Get(1)); A->font = GetFont(taskData, (X_Object *)obj->Get(2).AsObjPtr()); } static void GetText16(TaskData *taskData, PolyWord p, void *v, unsigned) { XTextItem16 *A = (XTextItem16 *)v; PolyObject *obj = p.AsObjPtr(); unsigned N = ListLength(obj->Get(0)); XChar2b *L = (XChar2b *) malloc(N * sizeof(XChar2b)); GetList4(taskData,obj->Get(0),L,sizeof(XChar2b),GetChar2); A->chars = L; A->nchars = N; A->delta = get_C_short(taskData, obj->Get(1)); A->font = GetFont(taskData, (X_Object *)obj->Get(2).AsObjPtr()); } typedef void (*GetFunc)(TaskData *taskData, PolyWord, void*, unsigned); static void SetClipRectangles ( TaskData *taskData, Display *d, GC gc, int x, int y, Handle list, unsigned order ) { if (ISNIL(DEREFWORD(list))) { XSetClipRectangles(d,gc,x,y,NULL,0,order); } else { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *) alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XSetClipRectangles(d,gc,x,y,L,N,order); } } static void GetUChars(TaskData *taskData, PolyWord p, void *u, unsigned) { *(uchar*)u = get_C_uchar(taskData, p); } static void SetDashes ( TaskData *taskData, Display *d, GC gc, unsigned offset, Handle list ) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); char *D = (char *) alloca(N); GetList4(taskData,DEREFWORD(list),D,sizeof(uchar),GetUChars); XSetDashes(d,gc,offset,D,N); } } static Handle CreateDrawable ( TaskData *taskData, void *p, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { return EmptyWindow(taskData, dsHandle,*(Window*)p); } static Handle QueryTree ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window root,parent,*children; unsigned n; Handle data; int s = XQueryTree(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&parent,&children,&n); if (s == 0) RaiseXWindows(taskData, "XQueryTree failed"); data = CreateTriple(taskData, EmptyWindow(taskData, dsHandle,root), EmptyWindow(taskData, dsHandle,parent), CreateList5(taskData, n,children,sizeof(Window),CreateDrawable,dsHandle)); if (n) XFree((char *)children); return data; } static void RestackWindows(TaskData *taskData, Handle list /* handle to list of X_Window_Objects (?) */) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); Window *W = (Window *) alloca(N * sizeof(Window)); Display *d = GetDisplay(taskData, (X_Object *)DEREFLISTHANDLE(list)->h.AsObjPtr()); GetList4(taskData, DEREFWORD(list),W,sizeof(Window),GetWindows); XRestackWindows(d,W,N); } } static Handle GetGeometry ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Drawable w ) { int x,y; unsigned width,height,borderWidth,depth; Window root; Handle dataHandle; int s = XGetGeometry(DEREFDISPLAYHANDLE(dsHandle)->display,w,&root,&x,&y,&width,&height,&borderWidth,&depth); if (s == 0) RaiseXWindows(taskData, "XGetGeometry failed"); dataHandle = alloc_and_save(taskData, 5, F_MUTABLE_BIT); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(EmptyWindow(taskData, dsHandle,root))); data->Set(1, DEREFWORD(CreatePoint(taskData, x,y))); data->Set(2, DEREFWORD(CreateArea(width,height))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, borderWidth))); data->Set(4, DEREFWORD(Make_arbitrary_precision(taskData, depth))); #undef data return FINISHED(taskData, dataHandle); } static Handle GetWindowAttributes ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Drawable w ) { XWindowAttributes wa; Handle dataHandle; int s = XGetWindowAttributes(DEREFDISPLAYHANDLE(dsHandle)->display,w,&wa); if (s == 0) RaiseXWindows(taskData, "XGetWindowAttributes failed"); dataHandle = alloc_and_save(taskData, 20, F_MUTABLE_BIT); /* HACKY - should define struct? */ DEREFHANDLE(dataHandle)->Set( 0, DEREFWORD(CreatePoint(taskData, wa.x,wa.y))); DEREFHANDLE(dataHandle)->Set( 1, DEREFWORD(CreateArea(wa.width,wa.height))); DEREFHANDLE(dataHandle)->Set( 2, DEREFWORD(Make_int(wa.border_width))); DEREFHANDLE(dataHandle)->Set( 3, DEREFWORD(Make_arbitrary_precision(taskData, wa.depth))); DEREFHANDLE(dataHandle)->Set( 4, DEREFWORD(EmptyVisual(taskData, dsHandle,wa.visual))); DEREFHANDLE(dataHandle)->Set( 5, DEREFWORD(EmptyWindow(taskData, dsHandle,wa.root))); DEREFHANDLE(dataHandle)->Set( 6, DEREFWORD(Make_arbitrary_precision(taskData, wa.c_class))); DEREFHANDLE(dataHandle)->Set( 7, DEREFWORD(Make_arbitrary_precision(taskData, wa.bit_gravity))); DEREFHANDLE(dataHandle)->Set( 8, DEREFWORD(Make_arbitrary_precision(taskData, wa.win_gravity))); DEREFHANDLE(dataHandle)->Set( 9, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_store))); DEREFHANDLE(dataHandle)->Set(10, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_planes))); DEREFHANDLE(dataHandle)->Set(11, DEREFWORD(Make_arbitrary_precision(taskData, wa.backing_pixel))); DEREFHANDLE(dataHandle)->Set(12, DEREFWORD(Make_bool(wa.save_under))); DEREFHANDLE(dataHandle)->Set(13, DEREFWORD(EmptyColormap(taskData, dsHandle,wa.colormap))); DEREFHANDLE(dataHandle)->Set(14, DEREFWORD(Make_bool(wa.map_installed))); DEREFHANDLE(dataHandle)->Set(15, DEREFWORD(Make_arbitrary_precision(taskData, wa.map_state))); DEREFHANDLE(dataHandle)->Set(16, DEREFWORD(Make_arbitrary_precision(taskData, wa.all_event_masks))); DEREFHANDLE(dataHandle)->Set(17, DEREFWORD(Make_arbitrary_precision(taskData, wa.your_event_mask))); DEREFHANDLE(dataHandle)->Set(18, DEREFWORD(Make_arbitrary_precision(taskData, wa.do_not_propagate_mask))); DEREFHANDLE(dataHandle)->Set(19, DEREFWORD(Make_bool(wa.override_redirect))); return FINISHED(taskData, dataHandle); } static void ChangeWindowAttributes ( TaskData *taskData, X_Window_Object *W, unsigned n, PolyWord P ) { XSetWindowAttributes a; unsigned mask = 1 << n; switch(mask) { case CWBitGravity: a.bit_gravity = get_C_ulong(taskData, P); break; case CWWinGravity: a.win_gravity = get_C_ulong(taskData, P); break; case CWBackingStore: a.backing_store = get_C_ulong(taskData, P); break; case CWBackingPlanes: a.backing_planes = get_C_ulong(taskData, P); break; case CWBackingPixel: a.backing_pixel = get_C_ulong(taskData, P); break; case CWOverrideRedirect: a.override_redirect = get_C_ulong(taskData, P); break; case CWSaveUnder: a.save_under = get_C_ulong(taskData, P); break; case CWEventMask: a.event_mask = get_C_ulong(taskData, P); break; case CWDontPropagate: a.do_not_propagate_mask = get_C_ulong(taskData, P); break; case CWBackPixel: a.background_pixel = get_C_ulong(taskData, P); W->backgroundPixmap = 0; break; case CWBackPixmap: a.background_pixmap = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); W->backgroundPixmap = PixmapObject((X_Object *)P.AsObjPtr()); break; case CWBorderPixel: a.border_pixel = get_C_ulong(taskData, P); W->borderPixmap = 0; break; case CWBorderPixmap: a.border_pixmap = GetPixmap(taskData, (X_Object *)P.AsObjPtr()); W->borderPixmap = PixmapObject((X_Object *)P.AsObjPtr()); break; case CWColormap: a.colormap = GetColormap(taskData, (X_Object *)P.AsObjPtr()); W->colormap_object = ColormapObject((X_Object *)P.AsObjPtr()); break; case CWCursor: a.cursor = GetCursor(taskData, (X_Object *)P.AsObjPtr()); W->cursor_object = CursorObject((X_Object *)P.AsObjPtr()); break; default: Crash ("Bad window mask %u",mask); } XChangeWindowAttributes(GetDisplay(taskData, (X_Object *)W),GetWindow(taskData, (X_Object *)W),mask,&a); } static void ConfigureWindow ( TaskData *taskData, Display *d, Window w, PolyWord tup /* (P,S,w,d,s,flags) */ ) { PolyObject *tuple = tup.AsObjPtr(); XWindowChanges wc; unsigned mask = get_C_ulong(taskData, tuple->Get(5)); CheckZeroRect(taskData, tuple->Get(1)); wc.x = GetPointX (taskData,tuple->Get(0)); wc.y = GetPointY (taskData,tuple->Get(0)); wc.width = GetRectW (taskData,tuple->Get(1)); wc.height = GetRectH (taskData,tuple->Get(1)); wc.border_width = get_C_ulong(taskData, tuple->Get(2)); wc.sibling = GetWindow (taskData,(X_Object *)tuple->Get(3).AsObjPtr()); wc.stack_mode = get_C_ulong(taskData, tuple->Get(4)); XConfigureWindow(d,w,mask,&wc); } /* The order of these depends on the XColor datatype */ typedef struct { PolyWord red; /* ML bool */ PolyWord blue; /* ML bool */ PolyWord doRed; /* ML bool */ PolyWord green; /* ML int */ PolyWord pixel; /* ML int */ PolyWord doBlue; /* ML int */ PolyWord doGreen; /* ML int */ } MLXColor; /* in Poly heap */ static void ClearXColor(XColor *x) { x->red = x->green = x->blue = x->pixel = x->flags = 0; } static Handle CreateXColor(TaskData *taskData, XColor *x) { Handle XHandle = alloc_and_save(taskData, SIZEOF(MLXColor), F_MUTABLE_BIT); #define X ((MLXColor *)DEREFHANDLE(XHandle)) X->red = DEREFWORD(Make_arbitrary_precision(taskData, x->red)); X->green = DEREFWORD(Make_arbitrary_precision(taskData, x->green)); X->blue = DEREFWORD(Make_arbitrary_precision(taskData, x->blue)); X->pixel = DEREFWORD(Make_arbitrary_precision(taskData, x->pixel)); X->doRed = DEREFWORD(Make_bool(x->flags &DoRed)); X->doGreen = DEREFWORD(Make_bool(x->flags &DoGreen)); X->doBlue = DEREFWORD(Make_bool(x->flags &DoBlue)); #undef X return FINISHED(taskData, XHandle); } static Handle CreateXColorF(TaskData *taskData, void *p) { return CreateXColor(taskData, (XColor*)p); } static XColor xcolor1 = { 0 }; static XColor xcolor2 = { 0 }; static void GetXColor(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXColor *P = (MLXColor *)p.AsObjPtr(); XColor *x = (XColor *)v; x->red = get_C_ushort(taskData, P->red); x->green = get_C_ushort(taskData, P->green); x->blue = get_C_ushort(taskData, P->blue); x->pixel = get_C_ulong (taskData, P->pixel); x->flags = (DoRed * get_C_ulong(taskData, P->doRed)) | (DoGreen * get_C_ulong(taskData, P->doGreen)) | (DoBlue * get_C_ulong(taskData, P->doBlue)); } static XColor *GetXColor1(TaskData *taskData, PolyWord P) { GetXColor(taskData, P, &xcolor1, 0); return &xcolor1; } static XColor *GetXColor2(TaskData *taskData, PolyWord P) { GetXColor(taskData, P, &xcolor2, 0); return &xcolor2; } static Handle AllocColor(TaskData *taskData, Display *d, Colormap cmap, XColor *x) { int s = XAllocColor(d,cmap,x); if (s == 0) RaiseXWindows(taskData, "XAllocColor failed"); return CreateXColor(taskData, x); } static Handle CreateUnsigned(TaskData *taskData, void *q) { unsigned *p = (unsigned *)q; return Make_arbitrary_precision(taskData, *p); } static Handle CreateUnsignedLong(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(unsigned long*)p); } static Handle AllocColorCells ( TaskData *taskData, Display *d, Colormap cmap, unsigned contig, unsigned nplanes, unsigned ncolors ) { unsigned long *masks; /* was unsigned SPF 6/1/94 */ unsigned long *pixels; /* was unsigned SPF 6/1/94 */ int s; if (ncolors < 1) RaiseRange(taskData); masks = (unsigned long *) alloca(nplanes * sizeof(unsigned long)); pixels = (unsigned long *) alloca(ncolors * sizeof(unsigned long)); s = XAllocColorCells(d,cmap,contig,masks,nplanes,pixels,ncolors); if (s == 0) RaiseXWindows (taskData, "XAllocColorCells failed"); return CreatePair(taskData, CreateList4(taskData,nplanes,masks ,sizeof(unsigned long),CreateUnsignedLong), CreateList4(taskData,ncolors,pixels,sizeof(unsigned long),CreateUnsignedLong)); } static Handle AllocColorPlanes ( TaskData *taskData, Display *d, Colormap cmap, unsigned contig, unsigned ncolors, unsigned nreds, unsigned ngreens, unsigned nblues ) { unsigned long rmask; /* was unsigned SPF 6/1/94 */ unsigned long gmask; /* was unsigned SPF 6/1/94 */ unsigned long bmask; /* was unsigned SPF 6/1/94 */ unsigned long *pixels; /* was unsigned SPF 6/1/94 */ Handle tuple; int s; if (ncolors < 1) RaiseRange(taskData); pixels = (unsigned long *) alloca(ncolors * sizeof(unsigned long)); s = XAllocColorPlanes(d,cmap,contig,pixels,ncolors,nreds,ngreens,nblues,&rmask,&gmask,&bmask); if (s == 0) RaiseXWindows (taskData, "XAllocColorPlanes failed"); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(CreateList4(taskData,ncolors,pixels,sizeof(unsigned long),CreateUnsignedLong))); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, rmask))); data->Set(2, DEREFWORD(Make_arbitrary_precision(taskData, gmask))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, bmask))); #undef data return FINISHED(taskData, tuple); } static Handle AllocNamedColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor hardware; XColor database; ClearXColor(&hardware); ClearXColor(&database); Poly_string_to_C(string,name,sizeof(name)); s = XAllocNamedColor(d,cmap,name,&hardware,&database); if (s == 0) RaiseXWindows (taskData, "XAllocNamedColor failed"); return CreatePair(taskData, CreateXColor(taskData, &hardware),CreateXColor(taskData, &database)); } static Handle LookupColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor hardware; XColor database; ClearXColor(&hardware); ClearXColor(&database); Poly_string_to_C(string,name,sizeof(name)); s = XLookupColor(d,cmap,name,&database,&hardware); if (s == 0) RaiseXWindows (taskData, "XLookupColor failed"); return CreatePair(taskData, CreateXColor(taskData, &database),CreateXColor(taskData, &hardware)); } static Handle ParseColor(TaskData *taskData, Display *d, Colormap cmap, PolyStringObject *string) { char name[500]; int s; XColor x; ClearXColor(&x); Poly_string_to_C(string,name,sizeof(name)); s = XParseColor(d,cmap,name,&x); if (s == 0) RaiseXWindows(taskData, "XParseColor failed"); return CreateXColor(taskData, &x); } static Handle QueryColor(TaskData *taskData, Display *d, Colormap cmap, unsigned pixel) { XColor x; ClearXColor(&x); x.pixel = pixel; XQueryColor(d,cmap,&x); return CreateXColor(taskData, &x); } static void GetXPixel(TaskData *taskData, PolyWord p, void *v, unsigned) { XColor *X = (XColor *)v; ClearXColor(X); X->pixel = get_C_ulong(taskData, p); } static Handle QueryColors(TaskData *taskData, Display *d, Colormap cmap, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XColor *P = (XColor *) alloca(N * sizeof(XColor)); GetList4(taskData, DEREFWORD(list),P,sizeof(XColor),GetXPixel); XQueryColors(d,cmap,P,N); return CreateList4(taskData,N,P,sizeof(XColor),CreateXColorF); } static void StoreNamedColor ( Display *d, Colormap cmap, PolyStringObject *string, unsigned pixel, unsigned doRed, unsigned doGreen, unsigned doBlue ) { unsigned flags = (DoRed * doRed) | (DoGreen * doGreen) | (DoBlue * doBlue); char name[500]; Poly_string_to_C(string,name,sizeof(name)); XStoreNamedColor(d,cmap,name,pixel,flags); } static void StoreColors(TaskData *taskData, Display *d, Colormap cmap, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XColor *P = (XColor *) alloca(N * sizeof(XColor)); GetList4(taskData, DEREFWORD(list),P,sizeof(XColor),GetXColor); XStoreColors(d,cmap,P,N); } static void GetUnsigned(TaskData *taskData, PolyWord p, void *v, unsigned) { unsigned *u = (unsigned *)v; *u = get_C_ulong(taskData, p); } static void GetUnsignedLong(TaskData *taskData, PolyWord p, void *v, unsigned) { unsigned long *u = (unsigned long *)v; *u = get_C_ulong(taskData, p); } static void FreeColors ( TaskData *taskData, Display *d, Colormap cmap, Handle list, unsigned planes ) { unsigned N = ListLength(DEREFWORD(list)); unsigned long *P = (unsigned long *) alloca(N * sizeof(unsigned long)); GetList4(taskData,DEREFWORD(list),P,sizeof(unsigned long),GetUnsignedLong); XFreeColors(d,cmap,P,N,planes); } static Handle CreateColormap ( TaskData *taskData, void *p, Handle dsHandle /* handle to (X_Display_Object *) */ ) { return EmptyColormap(taskData, dsHandle,*(Colormap *)p); } static Handle ListInstalledColormaps ( TaskData *taskData, Handle dsHandle, /* handle to (X_Display_Object *) */ Drawable drawable ) { int count; Colormap *cmaps; Handle list; cmaps = XListInstalledColormaps(DEREFDISPLAYHANDLE(dsHandle)->display,drawable,&count); if (cmaps == 0) RaiseXWindows(taskData, "XListInstalledColormaps failed"); list = CreateList5(taskData,count,cmaps,sizeof(Colormap),CreateColormap,dsHandle); XFree((char *)cmaps); return list; } static Handle GetTimeOfDay(TaskData *taskData) { TimeVal now; gettimeofday(&now, NULL); return CreatePair(taskData, Make_arbitrary_precision(taskData, now.tv_sec),Make_arbitrary_precision(taskData, now.tv_usec)); } static Handle GetState(TaskData *taskData, X_Window_Object *P) { assert(UNTAGGED(P->type) == X_Window); CheckExists((X_Object *)P,window); if (ISNIL(P->handler)) Crash ("No handler set"); return CreatePair(taskData, SAVE(P->handler),SAVE(P->state)); } static void SetState(X_Window_Object *W, PolyWord handler, PolyWord state) { if (! ResourceExists((X_Object *)W)) return; assert(W->type == TAGGED(X_Window)); if (NONNIL(handler)) { /* we are setting the handler and initial state */ /* so we need to remove all pending messages for */ /* this window since they will have the wrong type */ PurgePendingWindowMessages(W); W->handler = handler; W->state = state; } else W->state = state; /* just update state */ } /* Check if the first timer event has already expired. */ static void CheckTimerQueue(void) { if (TList) { TimeVal now; gettimeofday(&now, NULL); TList->expired = TimeLeq(&TList->timeout,&now); } } static void InsertTimeout ( TaskData *taskData, X_Window_Object *window_object, unsigned ms, PolyWord alpha, PolyWord handler ) { T_List **tail; T_List *newp; TimeVal now; assert(window_object->type == TAGGED(X_Window)); CheckExists((X_Object *)window_object,window); if (ISNIL(window_object->handler)) Crash ("No handler set"); if (window_object->handler != handler) RaiseXWindows(taskData, "Handler mismatch"); { /* find insertion point in list */ TimeVal dt; gettimeofday(&now, NULL); dt.tv_sec = ms / 1000; dt.tv_usec = 1000 * (ms % 1000); newp = (T_List *) malloc(sizeof(T_List)); TimeAdd(&now,&dt,&newp->timeout); /* We use TimeLt here, not TimeLeq, because we want to add new messages AFTER existing ones. SPF 21/3/97 */ for(tail = &TList; *tail; tail = &(*tail)->next) { if (TimeLt(&newp->timeout,&(*tail)->timeout)) break; } } newp->next = *tail; newp->window_object = window_object; newp->widget_object = (X_Widget_Object *)0; newp->alpha = alpha.AsObjPtr(); newp->handler = handler.AsObjPtr(); newp->expired = 0; *tail = newp; } /* called when a widget is destroyed by Xt/Motif */ static void DestroyWidgetCallback ( Widget widget, XtPointer client_data, XtPointer call_data ) { /* find the ML widget (if any) associated with the C widget */ X_Widget_Object *widget_object = FindWidget(widget); if (widget_object != NULL) { /* Destroy the ML widget representations */ DestroyXObject((X_Object *)widget_object); /* Assume we can't get a C callback from a destroyed widget */ PurgeCCallbacks(widget_object,widget); } debugReclaim(Widget,widget); } #if 0 #define CheckRealized(Widget,Where)\ { \ if (XtIsRealized(Widget) == False) \ RaiseXWindows(taskData, #Where ": widget is not realized"); \ } static Window WindowOfWidget(TaskData *taskData, Widget widget) { CheckRealized(widget,WindowOfWidget); return XtWindowOfObject(widget); } #endif /* Now returns NULL (None) for unrealized widgets SPF 1/2/94 */ static Window WindowOfWidget(Widget widget) { return XtIsRealized(widget) ? XtWindowOfObject(widget) : None; } static void InsertWidgetTimeout ( TaskData *taskData, X_Widget_Object *widget_object, unsigned ms, PolyWord alpha, PolyWord handler ) { T_List **tail; T_List *newp; TimeVal now; assert(widget_object->type == TAGGED(X_Widget)); CheckExists((X_Object *)widget_object,widget); #if NEVER CheckRealized(GetWidget(taskData, (X_Object *)widget_object),InsertWidgetTimeout); #endif /* check that handler occurs in widget's callback list */ { PolyWord p = widget_object->callbackList; for(; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { MLPair *q = (MLPair *)((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr(); if (SND(q) == handler) break; } if (ISNIL(p)) RaiseXWindows(taskData, "Handler mismatch"); } { TimeVal dt; gettimeofday(&now, NULL); dt.tv_sec = ms / 1000; dt.tv_usec = 1000 * (ms % 1000); newp = (T_List *) malloc(sizeof(T_List)); TimeAdd(&now,&dt,&newp->timeout); /* We use TimeNegative here, not TimeExpired, because we want to add new messages AFTER existing ones. SPF 21/3/97 */ for(tail = &TList; *tail; tail = &(*tail)->next) { if (TimeLt(&newp->timeout,&(*tail)->timeout)) break; } } newp->next = *tail; newp->window_object = (X_Window_Object *)0; newp->widget_object = widget_object; newp->alpha = alpha.AsObjPtr(); newp->handler = handler.AsObjPtr(); newp->expired = 0; *tail = newp; } static Handle NextEvent(TaskData *taskData, Handle dsHandle /* handle to (X_Display_Object *) */) { for (;;) { /* Added here SPF 23/2/95 - check whether a timer event has expired */ CheckTimerQueue(); if (TList && TList->expired) { T_List *next = TList->next; EventHandle E = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); #define event ((ML_Event *)DEREFHANDLE(E)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, 99)); event->sendEvent = DEREFWORD(Make_bool(True)); event->data = TList->alpha; if (TList->window_object != 0) { assert(TList->widget_object == 0); event->window = TList->window_object; event->callbacks = ListNull; event->events = ListNull; assert(TList->window_object->handler == TList->handler); } else /* it is a Widget message */ { /* TList->widget_object etc. act like Roots */ assert(TList->widget_object != 0); { Window w = WindowOfWidget(GetWidget(taskData, (X_Object *)TList->widget_object)); event->window = DEREFWINDOWHANDLE(EmptyWindow(taskData, GetDS(taskData, (X_Object *)TList->widget_object),w)); } { /* create callback list - allocates storage */ Handle tailHandle = SAVE(ListNull); Handle widgetHandle = SAVE(TList->widget_object); Handle handlerHandle = SAVE(TList->handler); Handle pairHandle = CreatePair(taskData, widgetHandle,handlerHandle); event->callbacks = DEREFLISTHANDLE(CreatePair(taskData, pairHandle,tailHandle)); event->events = ListNull; } } #undef event free(TList); TList = next; return FINISHED(taskData, E); } else /* ! (TList && TList->expired) */ if (DEREFDISPLAYHANDLE(dsHandle)->app_context == 0) /* use XNextEvent to get next event */ { Display *display = DEREFDISPLAYHANDLE(dsHandle)->display; int pending = XPending(display); if (pending == 0) { WaitInputFD waiter(display->fd); processes->ThreadPauseForIO(taskData, &waiter); } else /* X Event arrived */ { XEvent ev; X_Window_Object *W; XNextEvent(display,&ev); W = FindWindow(dsHandle,ev.xany.window); if (W && NONNIL(W->handler)) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,SAVE(W)); if (E) return E; } } } else /* use XtAppNextEvent to get next event */ { /* should use Xt to do time events as well */ int pending = XtAppPending(DEREFDISPLAYHANDLE(dsHandle)->app_context); if (pending == 0) { WaitInputFD waiter(DEREFDISPLAYHANDLE(dsHandle)->display->fd); processes->ThreadPauseForIO(taskData, &waiter); } else { if ((pending & XtIMXEvent) == 0) /* not an X Event, probably an Xt timer event */ { assert(FList == TAGGED(0)); callbacks_enabled = True; XtAppProcessEvent(DEREFDISPLAYHANDLE(dsHandle)->app_context,pending); callbacks_enabled = False; if (FList != TAGGED(0)) { EventHandle E = alloc_and_save(taskData, SIZEOF(ML_Event), F_MUTABLE_BIT); #define event ((ML_Event *)DEREFHANDLE(E)) event->type = DEREFWORD(Make_arbitrary_precision(taskData, 100)); event->sendEvent = DEREFWORD(Make_bool(True)); event->window = TAGGED(0); event->data = TAGGED(0); event->callbacks = FList; /* FList != 0 */ event->events = GList; #undef event FList = TAGGED(0); GList = TAGGED(0); return FINISHED(taskData, E); } } else /* Xt Event arrived */ { XEvent ev; int dispatched; assert(FList == TAGGED(0)); XtAppNextEvent(DEREFDISPLAYHANDLE(dsHandle)->app_context,&ev); callbacks_enabled = True; dispatched = XtDispatchEvent(&ev); callbacks_enabled = False; if (!dispatched) { X_Window_Object *W = FindWindow(dsHandle,ev.xany.window); assert(FList == TAGGED(0) && GList == TAGGED(0)); if (W && NONNIL(W->handler)) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,SAVE(W)); if (E) return E; } } else if (! FList.IsTagged() || ! GList.IsTagged()) { EventHandle E = CreateEvent(taskData, dsHandle,&ev,EmptyWindow(taskData, dsHandle,ev.xany.window)); if (E) return E; } } } } } } static Handle GetInputFocus(TaskData *taskData, Handle dsHandle /* handle to (X_Display_Object *) */) { Window focus; int revertTo; XGetInputFocus(DEREFDISPLAYHANDLE(dsHandle)->display,&focus,&revertTo); return CreatePair(taskData, EmptyWindow(taskData, dsHandle,focus),Make_arbitrary_precision(taskData, revertTo)); } static void SetSelectionOwner ( Handle dsHandle, /* handle to (X_Display_Object *) */ unsigned selection, Window owner, unsigned time ) { Window old = XGetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display,selection); if (old != owner) { /* SelectionClear is only sent by the server when the ownership of a */ /* selection passes from one client to another. We want every ML */ /* window to behave like a separate client, so when the ownership of */ /* a selection passes from one ML window to another we have to send */ /* the SelectionClear ourselves. */ X_Window_Object *W = FindWindow(dsHandle,old); if (W && NONNIL(W->handler)) /* this clients window */ { XEvent event; /* was XSelectionClearEvent SPF 6/1/94 */ event.xselectionclear.type = SelectionClear; event.xselectionclear.serial = 0; event.xselectionclear.send_event = True; event.xselectionclear.display = DEREFDISPLAYHANDLE(dsHandle)->display; event.xselectionclear.window = old; event.xselectionclear.selection = selection; event.xselectionclear.time = time; XSendEvent(DEREFDISPLAYHANDLE(dsHandle)->display,old,True,0,&event); } } XSetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display,selection,owner,time); } static void SendSelectionNotify ( Display *d, unsigned selection, unsigned target, unsigned property, Window requestor, unsigned time ) { XEvent event; /* was XSelectionEvent SPF 6/1/94 */ event.xselection.type = SelectionNotify; event.xselection.serial = 0; event.xselection.send_event = True; event.xselection.display = d; event.xselection.requestor = requestor; event.xselection.selection = selection; event.xselection.target = target; event.xselection.property = property; event.xselection.time = time; XSendEvent(d,requestor,True,0,&event); } static Handle InternAtom ( TaskData *taskData, Display *d, PolyStringObject *string, Bool only_if_exists ) { char name[500]; Poly_string_to_C(string,name,sizeof(name)); return Make_arbitrary_precision(taskData, XInternAtom(d,name,only_if_exists)); } static Handle GetAtomName(TaskData *taskData, Display *d, unsigned atom) { Handle s; char *name = XGetAtomName(d,atom); if (name == NULL) RaiseXWindows(taskData, "XGetAtomName failed"); s = Make_string(name); XFree((char *)name); return s; } /* The order of these depends on the XCharStruct datatype */ typedef struct { PolyWord width; /* ML int */ PolyWord ascent; /* ML int */ PolyWord descent; /* ML int */ PolyWord lbearing; /* ML int */ PolyWord rbearing; /* ML int */ PolyWord attributes; /* ML int */ } MLXCharStruct; static Handle CreateCharStruct(TaskData *taskData, void *v) { XCharStruct *cs = (XCharStruct *)v; Handle dataHandle = alloc_and_save(taskData, SIZEOF(MLXCharStruct), F_MUTABLE_BIT); #define data ((MLXCharStruct *)DEREFHANDLE(dataHandle)) data->width = DEREFWORD(Make_int(cs->width)); data->ascent = DEREFWORD(Make_int(cs->ascent)); data->descent = DEREFWORD(Make_int(cs->descent)); data->lbearing = DEREFWORD(Make_int(cs->lbearing)); data->rbearing = DEREFWORD(Make_int(cs->rbearing)); data->attributes = DEREFWORD(Make_arbitrary_precision(taskData, cs->attributes)); #undef data return FINISHED(taskData, dataHandle); } /* The order of these depends on the XFontStruct datatype */ typedef struct { X_Font_Object *font_object; PolyWord ascent; /* ML int */ PolyWord descent; /* ML int */ PolyWord maxChar; /* ML int */ PolyWord minChar; /* ML int */ PolyWord perChar; /* ML XCharStruct list */ PolyWord maxByte1; /* ML int */ PolyWord minByte1; /* ML int */ PolyWord direction; /* (short ML int) FontLeftToRight | FontRightToLeft */ MLXCharStruct *maxBounds; MLXCharStruct *minBounds; PolyWord defaultChar; /* ML int */ PolyWord allCharsExist; /* ML bool */ } MLXFontStruct; static Handle CreateFontStruct ( TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */ ) { XFontStruct *fs = (XFontStruct *)v; Handle dataHandle = alloc_and_save(taskData, SIZEOF(MLXFontStruct), F_MUTABLE_BIT); int n = fs->max_char_or_byte2 - fs->min_char_or_byte2 + 1; if (fs->per_char == 0) n = 0; #define data ((MLXFontStruct *)DEREFHANDLE(dataHandle)) data->font_object = (X_Font_Object *)DEREFHANDLE(EmptyFont(taskData, dsHandle,fs->fid,fs)); data->ascent = DEREFWORD(Make_int(fs->ascent)); data->descent = DEREFWORD(Make_int(fs->descent)); data->maxChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->max_char_or_byte2)); data->minChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->min_char_or_byte2)); data->perChar = DEREFHANDLE(CreateList4(taskData,n,fs->per_char,sizeof(XCharStruct),CreateCharStruct)); data->maxByte1 = DEREFWORD(Make_arbitrary_precision(taskData, fs->max_byte1)); data->minByte1 = DEREFWORD(Make_arbitrary_precision(taskData, fs->min_byte1)); data->direction = DEREFWORD(Make_arbitrary_precision(taskData, (fs->direction == FontLeftToRight) ? 1 : 2)); data->maxBounds = (MLXCharStruct *)DEREFHANDLE(CreateCharStruct(taskData, &fs->max_bounds)); data->minBounds = (MLXCharStruct *)DEREFHANDLE(CreateCharStruct(taskData, &fs->min_bounds)); data->defaultChar = DEREFWORD(Make_arbitrary_precision(taskData, fs->default_char)); data->allCharsExist = DEREFWORD(Make_bool(fs->all_chars_exist)); #undef data return FINISHED(taskData, dataHandle); } static XFontStruct *GetFS(TaskData *taskData, X_Font_Object *P) { assert(UNTAGGED(P->type) == X_Font); if (*(P->fs) == NULL) RaiseXWindows(taskData, "Not a real XFontStruct"); CheckExists((X_Object *)P,font); return *(P->fs); } static XFontStruct *GetFontStruct(TaskData *taskData,PolyWord p) { MLXFontStruct *P = (MLXFontStruct *)p.AsObjPtr(); return GetFS(taskData,P->font_object); } static Handle CreateString(TaskData *taskData, void *s) { return Make_string(*(char **)s); } static Handle GetFontPath(TaskData *taskData, Display *d) { Handle list; char **names; int count; names = XGetFontPath(d,&count); if (names == 0) RaiseXWindows(taskData, "XGetFontPath failed"); list = CreateList4(taskData,count,names,sizeof(char *),CreateString); XFreeFontNames(names); return list; } static void FreeStrings(char **s, int n) { while(n--) free(*s++); return; } static void SetFontPath(TaskData *taskData, Display *d, Handle list) { if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); char **D = (char **) alloca(N * sizeof(char *)); GetList4(taskData, DEREFWORD(list),D,sizeof(char *),CopyString); XSetFontPath(d,D,N); FreeStrings(D,N); } return; } static Handle ListFonts(TaskData *taskData,Display *d, PolyStringObject *string, unsigned maxnames) { char name[500]; Handle list; char **names; int count; Poly_string_to_C(string,name,sizeof(name)); names = XListFonts(d,name,maxnames,&count); if (names == 0) RaiseXWindows(taskData, "XListFonts failed"); list = CreateList4(taskData,count,names,sizeof(char *),CreateString); XFreeFontNames(names); return list; } static Handle ListFontsWithInfo ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string, unsigned maxnames ) { char name[500]; char **names; int count; XFontStruct *info; Handle pair; Poly_string_to_C(string,name,sizeof(name)); names = XListFontsWithInfo(DEREFDISPLAYHANDLE(dsHandle)->display,name,maxnames,&count,&info); if (names == 0) RaiseXWindows(taskData, "XListFontsWithInfo failed"); pair = CreatePair(taskData, CreateList4(taskData,count,names,sizeof(char *),CreateString), CreateList5(taskData,count,info,sizeof(XFontStruct),CreateFontStruct,dsHandle)); XFree((char *)info); XFreeFontNames(names); return pair; } static Handle LoadFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string ) { char name[500]; Font font; Poly_string_to_C(string,name,sizeof(name)); font = XLoadFont(DEREFDISPLAYHANDLE(dsHandle)->display,name); if (font == 0) RaiseXWindows(taskData, "XLoadFont failed"); return EmptyFont(taskData, dsHandle,font,(XFontStruct *)NULL); } static Handle LoadQueryFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *string ) { char name[500]; XFontStruct *fs; Poly_string_to_C(string,name,sizeof(name)); fs = XLoadQueryFont(DEREFDISPLAYHANDLE(dsHandle)->display,name); if (fs == 0) RaiseXWindows(taskData, "XLoadQueryFont failed"); return CreateFontStruct(taskData,fs,dsHandle); } static Handle QueryFont ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Font font ) { XFontStruct *fs; fs = XQueryFont(DEREFDISPLAYHANDLE(dsHandle)->display,font); if (fs == 0) RaiseXWindows(taskData, "XQueryFont failed"); return CreateFontStruct(taskData,fs,dsHandle); } static Handle TextExtents(TaskData *taskData, XFontStruct *fs, PolyStringObject *s) { Handle dataHandle = alloc_and_save(taskData, 4, F_MUTABLE_BIT); int direction,ascent,descent; XCharStruct overall; XTextExtents(fs,s->chars,s->length,&direction,&ascent,&descent,&overall); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, (direction == FontLeftToRight) ? 1 : 2))); data->Set(1, DEREFWORD(Make_int(ascent))); data->Set(2, DEREFWORD(Make_int(descent))); data->Set(3, DEREFWORD(CreateCharStruct(taskData, &overall))); #undef data return FINISHED(taskData, dataHandle); } static Handle TextExtents16(TaskData *taskData, XFontStruct *fs, Handle list) { Handle dataHandle = alloc_and_save(taskData, 4, F_MUTABLE_BIT); int direction,ascent,descent; XCharStruct overall; unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *) alloca(N * sizeof(XChar2b)); GetList4(taskData,DEREFWORD(list),L,sizeof(XChar2b),GetChar2); XTextExtents16(fs,L,N,&direction,&ascent,&descent,&overall); #define data DEREFHANDLE(dataHandle) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, (direction == FontLeftToRight) ? 1 : 2))); data->Set(1, DEREFWORD(Make_int(ascent))); data->Set(2, DEREFWORD(Make_int(descent))); data->Set(3, DEREFWORD(CreateCharStruct(taskData, &overall))); #undef data return FINISHED(taskData, dataHandle); } static Handle TextWidth(TaskData *taskData, XFontStruct *fs, PolyStringObject *s) { if (fs->per_char == 0) return Make_int(s->length * fs->max_bounds.width); return Make_int(XTextWidth(fs,s->chars,s->length)); } static Handle TextWidth16(TaskData *taskData, XFontStruct *fs, Handle list) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *) alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L,sizeof(XChar2b),GetChar2); return Make_int(XTextWidth16(fs,L,N)); } static Handle GetTextProperty(TaskData *taskData, Display *d, Window w, unsigned property) { XTextProperty T; Handle tuple; int s = XGetTextProperty(d,w,&T,property); if (s == 0) RaiseXWindows(taskData, "XGetTextProperty failed"); tuple = alloc_and_save(taskData, 4, F_MUTABLE_BIT); #define data DEREFHANDLE(tuple) data->Set(0, C_string_to_Poly(taskData, (char *)T.value,T.nitems * T.format / 8)); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, T.encoding))); data->Set(2, DEREFWORD(Make_int(T.format))); data->Set(3, DEREFWORD(Make_arbitrary_precision(taskData, T.nitems))); #undef data return FINISHED(taskData, tuple); } static void GetXWMHints(TaskData *taskData, PolyWord p, void *v, unsigned) { PolyObject *P = p.AsObjPtr(); XWMHints *H = (XWMHints *)v; H->input = get_C_ulong(taskData, P->Get(0)); H->initial_state = get_C_ulong(taskData, P->Get(1)); H->icon_pixmap = GetPixmap(taskData, (X_Object *)P->Get(2).AsObjPtr()); H->icon_window = GetWindow(taskData, (X_Object *)P->Get(3).AsObjPtr()); H->icon_x = GetPointX(taskData, P->Get(4)); H->icon_y = GetPointY(taskData, P->Get(4)); H->icon_mask = GetPixmap(taskData, (X_Object *)P->Get(5).AsObjPtr()); H->flags = get_C_ulong(taskData, P->Get(6)); H->window_group = 0; } typedef struct { PolyWord x0; PolyWord x1; PolyWord x2; PolyWord x3; PolyWord x4; PolyWord x5; /* pair of points */ PolyWord x6; PolyWord x7; PolyWord x8; } MLXWMSizeHintsTuple; static void GetXWMSizeHints(TaskData *taskData, PolyWord p, void *v, unsigned) { MLXWMSizeHintsTuple *P = (MLXWMSizeHintsTuple *)p.AsObjPtr(); XSizeHints *H = (XSizeHints *)v; CheckZeroRect(taskData, P->x1); CheckZeroRect(taskData, P->x2); CheckZeroRect(taskData, P->x3); CheckZeroRect(taskData, P->x4); CheckZeroRect(taskData, P->x6); H->x = GetPointX(taskData, P->x0); H->y = GetPointY(taskData, P->x0); H->width = GetRectW(taskData, P->x1); H->height = GetRectH(taskData, P->x1); H->min_width = GetRectW(taskData, P->x2); H->min_height = GetRectH(taskData, P->x2); H->max_width = GetRectW(taskData, P->x3); H->max_height = GetRectH(taskData, P->x3); H->width_inc = GetRectW(taskData, P->x4); H->height_inc = GetRectH(taskData, P->x4); H->min_aspect.x = GetPointX(taskData, FST(P->x5)); H->min_aspect.y = GetPointY(taskData, FST(P->x5)); H->max_aspect.x = GetPointX(taskData, SND(P->x5)); H->max_aspect.y = GetPointY(taskData, SND(P->x5)); H->base_width = GetRectW(taskData, P->x6); H->base_height = GetRectH(taskData, P->x6); H->win_gravity = get_C_ulong(taskData, P -> x7); H->flags = get_C_ulong(taskData, P -> x8); } static void GetIconSize(TaskData *taskData, PolyWord p, void *v, unsigned) { MLTriple *P = (MLTriple *)p.AsObjPtr(); XIconSize *s = (XIconSize *)v; CheckZeroRect(taskData, FST(P)); CheckZeroRect(taskData, SND(P)); CheckZeroRect(taskData, THIRD(P)); s->min_width = GetRectW(taskData, FST(P)); s->min_height = GetRectH(taskData, FST(P)); s->max_width = GetRectW(taskData, SND(P)); s->max_height = GetRectH(taskData, SND(P)); s->width_inc = GetRectW(taskData, THIRD(P)); s->height_inc = GetRectH(taskData, THIRD(P)); } static void GetSigned(TaskData *taskData, PolyWord p, void *i, unsigned) { *(int*)i = get_C_long(taskData, p); } static void GetPixmaps(TaskData *taskData, PolyWord pp, void *m, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Pixmap *)m = GetPixmap(taskData, p); } static void GetColormaps(TaskData *taskData, PolyWord pp, void *v, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Colormap *)v = GetColormap(taskData, p); } static void GetCursors(TaskData *taskData, PolyWord pp, void *c, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Cursor *)c = GetCursor(taskData, p); } static void GetDrawables(TaskData *taskData, PolyWord pp, void *d, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Drawable *)d = GetDrawable(taskData, p); } static void GetFonts(TaskData *taskData, PolyWord pp, void *f, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(Font *)f = GetFont(taskData, p); } static void GetVisualIds(TaskData *taskData, PolyWord pp, void *u, unsigned) { X_Object *p = (X_Object *)pp.AsObjPtr(); *(unsigned *)u = GetVisual(taskData, p)->visualid; } static void SetProperty ( TaskData *taskData, Display *d, Window w, unsigned property, unsigned target, Handle list, unsigned encoding ) { unsigned format; unsigned bytes; uchar *value; /* SPF 7/7/94 - XA_STRING pulled out as special case; this enables */ /* gcc to understand the previously data-dependant control flow. */ if (encoding == XA_STRING) { PolyStringObject *s = GetString (DEREFHANDLE(list)); format = 8; bytes = s->length; value = (uchar *) s->chars; } else { unsigned length = ListLength(DEREFWORD(list)); unsigned size; GetFunc get; switch(encoding) { case XA_ATOM: size = sizeof(unsigned); get = GetUnsigned; format = 32; break; case XA_BITMAP: size = sizeof(Pixmap); get = GetPixmaps; format = 32; break; case XA_COLORMAP: size = sizeof(Colormap); get = GetColormaps; format = 32; break; case XA_CURSOR: size = sizeof(Cursor); get = GetCursors; format = 32; break; case XA_DRAWABLE: size = sizeof(Drawable); get = GetDrawables; format = 32; break; case XA_FONT: size = sizeof(Font); get = GetFonts; format = 32; break; case XA_PIXMAP: size = sizeof(Pixmap); get = GetPixmaps; format = 32; break; case XA_VISUALID: size = sizeof(unsigned); get = GetVisualIds; format = 32; break; case XA_CARDINAL: size = sizeof(unsigned); get = GetUnsigned; format = 32; break; case XA_INTEGER: size = sizeof(int); get = GetSigned; format = 32; break; case XA_WINDOW: size = sizeof(Window); get = GetWindows; format = 32; break; case XA_ARC: size = sizeof(XArc); get = GetArcs; format = 16; break; case XA_POINT: size = sizeof(XPoint); get = GetPoints; format = 16; break; case XA_RECTANGLE: size = sizeof(XRectangle); get = GetRects; format = 16; break; case XA_RGB_COLOR_MAP: size = sizeof(XStandardColormap); get = GetStandardColormap; format = 32; break; case XA_WM_HINTS: size = sizeof(XWMHints); get = GetXWMHints; format = 32; break; case XA_WM_SIZE_HINTS: size = sizeof(XSizeHints); get = GetXWMSizeHints; format = 32; break; case XA_WM_ICON_SIZE: size = sizeof(XIconSize); get = GetIconSize; format = 32; break; default: Crash ("Bad property type %x",encoding); /*NOTREACHED*/ } bytes = length * size; value = (uchar *) alloca(bytes); GetList4(taskData, DEREFWORD(list),value,(int)size,get); } { XTextProperty T; T.value = value; T.encoding = target; T.format = format; T.nitems = (bytes * 8) / format; XSetTextProperty(d,w,&T,property); } } static Handle GetWMHints ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Handle tuple = alloc_and_save(taskData, 7, F_MUTABLE_BIT); XWMHints *H = XGetWMHints(DEREFDISPLAYHANDLE(dsHandle)->display,w); if (H) { #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(Make_arbitrary_precision(taskData, H->input))); data->Set(1, DEREFWORD(Make_arbitrary_precision(taskData, H->initial_state))); data->Set(2, DEREFWORD(EmptyPixmap(taskData, dsHandle,H->icon_pixmap))); data->Set(3, DEREFWORD(EmptyWindow(taskData, dsHandle,H->icon_window))); data->Set(4, DEREFWORD(CreatePoint(taskData, H->icon_x,H->icon_y))); data->Set(5, DEREFWORD(EmptyPixmap(taskData, dsHandle,H->icon_mask))); data->Set(6, DEREFWORD(Make_arbitrary_precision(taskData, H->flags))); #undef data XFree((char *)H); } /* else what (?) */ return FINISHED(taskData, tuple); } static Handle GetWMSizeHints ( TaskData *taskData, Display *d, Window w, unsigned property ) { XSizeHints H; long supplied; /* was unsigned SPF 6/1/94 */ Handle tuple = alloc_and_save(taskData, 9, F_MUTABLE_BIT); int s = XGetWMSizeHints(d,w,&H,&supplied,property); if (s) { Handle p1 = CreatePoint(taskData, H.min_aspect.x,H.min_aspect.y); Handle p2 = CreatePoint(taskData, H.max_aspect.x,H.max_aspect.y); #define data DEREFHANDLE(tuple) data->Set(0, DEREFWORD(CreatePoint(taskData, H.x,H.y))); data->Set(1, DEREFWORD(CreateArea(H.width,H.height))); data->Set(2, DEREFWORD(CreateArea(H.min_width,H.min_height))); data->Set(3, DEREFWORD(CreateArea(H.max_width,H.max_height))); data->Set(4, DEREFWORD(CreateArea(H.width_inc,H.height_inc))); data->Set(5, DEREFWORD(CreatePair(taskData, p1,p2))); data->Set(6, DEREFWORD(CreateArea(H.base_width,H.base_height))); data->Set(7, DEREFWORD(Make_arbitrary_precision(taskData, H.win_gravity))); data->Set(8, DEREFWORD(Make_arbitrary_precision(taskData, H.flags))); #undef data } /* else (?) */ return FINISHED(taskData, tuple); } #if 0 typedef struct { MLPair *x0; /* pair of points */ MLXRectangle *x1; PolyWord x2; /* ML int */ } MLWMGeometryTriple; #endif static Handle WMGeometry ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ PolyStringObject *user, PolyStringObject *def, unsigned borderWidth, PolyWord P ) { XSizeHints H; int x,y,width,height,gravity,mask; char userGeometry[500],defaultGeometry[500]; GetXWMSizeHints(taskData, P, &H, 0); Poly_string_to_C(user,userGeometry ,sizeof(userGeometry)); Poly_string_to_C(def ,defaultGeometry,sizeof(defaultGeometry)); mask = XWMGeometry(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen, userGeometry, defaultGeometry, borderWidth, &H,&x,&y,&width,&height,&gravity); return CreateTriple(taskData, CreatePoint(taskData, x,y),CreateArea(width,height),Make_arbitrary_precision(taskData, gravity)); } static Handle CreateIconSize(TaskData *taskData, void *v) { XIconSize *s = (XIconSize *)v; return CreateTriple(taskData, CreateArea(s->min_width,s->min_height), CreateArea(s->max_width,s->max_height), CreateArea(s->width_inc,s->height_inc)); } static Handle GetIconSizes(TaskData *taskData, Display *d, Window w) { XIconSize *sizes; int count; int s = XGetIconSizes(d,w,&sizes,&count); if (s) { Handle list = CreateList4(taskData,count,sizes,sizeof(XIconSize),CreateIconSize); XFree((char *)sizes); return list; } return SAVE(ListNull); } static Handle GetTransientForHint ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w ) { Window p; int s = XGetTransientForHint(DEREFDISPLAYHANDLE(dsHandle)->display,w,&p); if (s == 0) RaiseXWindows(taskData, "XGetTransientForHint failed"); return EmptyWindow(taskData, dsHandle,p); } static Handle GetWMColormapWindows ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window parent ) { Window *windows; int count; int s = XGetWMColormapWindows(DEREFDISPLAYHANDLE(dsHandle)->display,parent,&windows,&count); if (s) { Handle list = CreateList5(taskData,count,windows,sizeof(Window),CreateDrawable,dsHandle); XFree((char *)windows); return list; } return SAVE(ListNull); } static Handle GetRGBColormaps ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Window w, unsigned property ) { XStandardColormap *maps; int count; int s = XGetRGBColormaps(DEREFDISPLAYHANDLE(dsHandle)->display,w,&maps,&count,property); if (s) { Handle list = CreateList5(taskData,count,maps,sizeof(XStandardColormap),CreateStandardColormap,dsHandle); XFree((char *)maps); return list; } return SAVE(ListNull); } static Handle GetID(TaskData *taskData, X_Object *P) { switch(UNTAGGED(P->type)) { case X_GC: return Make_arbitrary_precision(taskData, GetGC(taskData, P)->gid); /* GCID */ case X_Font: return Make_arbitrary_precision(taskData, GetFont(taskData, P)); /* FontID */ case X_Cursor: return Make_arbitrary_precision(taskData, GetCursor(taskData, P)); /* CursorId */ case X_Window: return Make_arbitrary_precision(taskData, GetWindow(taskData, P)); /* DrawableID */ case X_Pixmap: return Make_arbitrary_precision(taskData, GetPixmap(taskData, P)); /* DrawableID */ case X_Colormap: return Make_arbitrary_precision(taskData, GetColormap(taskData, P)); /* ColormapID */ case X_Visual: return Make_arbitrary_precision(taskData, GetVisual(taskData, P)->visualid); /* VisualID */ case X_Widget: return Make_arbitrary_precision(taskData, (unsigned long)GetNWidget(taskData, P)); /* Widget -- SAFE(?) */ default: Crash ("Bad X_Object type (%d) in GetID",UNTAGGED(P->type)) /*NOTREACHED*/; } } static Handle OpenDisplay(TaskData *taskData, PolyStringObject *string) { char name[500]; Display *display; Handle dsHandle /* Handle to (X_Display_Object *) */; Poly_string_to_C(string,name,sizeof(name)); display = XOpenDisplay(name); if (display == 0) RaiseXWindows(taskData, "XOpenDisplay failed"); /* I don't think this is needed. DCJM 26/5/2000. */ /* add_file_descr(display->fd); */ dsHandle = alloc_and_save(taskData, SIZEOF(X_Display_Object), F_MUTABLE_BIT|F_BYTE_OBJ); debug1 ("%s display opened\n",DisplayString(display)); debug1 ("%x display fd\n",display->fd); #define ds DEREFDISPLAYHANDLE(dsHandle) /* Ok to store C values because this is a byte object */ ds->type = TAGGED(X_Display); ds->display = display; ds->screen = DefaultScreen(display); ds->app_context = 0; #undef ds return AddXObject(FINISHED(taskData, dsHandle)); } /* indirection removed SPF 11/11/93 */ static XmFontList GetXmFontList(PolyWord p /* NOT a handle */) { if (NONNIL(p)) { char charset[500]; XmFontList L; MLPair *q = (MLPair *)(((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr()); Poly_string_to_C(SND(q),charset,sizeof(charset)); L = XmFontListCreate((XFontStruct *)FST(q).AsObjPtr(),charset); /* cast added SPF 6/1/94 */ p = ((ML_Cons_Cell*)p.AsObjPtr())->t; while(NONNIL(p)) { q = (MLPair *)(((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr()); Poly_string_to_C(SND(q),charset,sizeof(charset)); L = XmFontListAdd(L,(XFontStruct *)FST(q).AsObjPtr(),charset); /* cast added SPF 6/1/94 */ p = ((ML_Cons_Cell*)p.AsObjPtr())->t; } return L; } return 0; } /* datatype CType = CAccelerators of XtAccelerators | CBool of bool | CColormap of Colormap | CCursor of Cursor | CDimension of int | CFontList of (XFontStruct * string) list | CInt of int | CIntTable of int list | CKeySym of int | CPixmap of Drawable | CPosition of int | CString of string | CStringTable of string list | CTrans of XtTranslations | CUnsignedChar of int | CUnsignedTable of int list | CVisual of Visual | CWidget of Widget | CWidgetList of Widget list | CXmString of XmString | CXmStringTable of XmString list; */ #define CAccelerators 1 #define CBool 2 #define CColormap 3 #define CCursor 4 #define CDimension 5 #define CFontList 6 #define CInt 7 #define CIntTable 8 #define CKeySym 9 #define CPixmap 10 #define CPosition 11 #define CString 12 #define CStringTable 13 #define CTrans 14 #define CUnsignedChar 15 #define CUnsignedTable 16 #define CVisual 17 #define CWidget 18 #define CWidgetList 19 #define CXmString 20 #define CXmStringTable 21 typedef struct { unsigned tag; unsigned N; char *name; union { XtAccelerators acc; Boolean boolean; Colormap cmap; Cursor cursor; Dimension dim; XmFontList F; int i; int *I; KeySym keysym; Pixmap pixmap; Position posn; char *string; char **S; XtTranslations trans; uchar u; uchar *U; Visual *visual; Widget widget; WidgetList W; XmString xmString; XmString *X; } u; } ArgType; static void GetXmString(TaskData *taskData, PolyWord w, void *v, unsigned ) { XmString *p = (XmString *)v; char *s; CopyString(taskData, w, &s, 0); *p = XmStringCreateLtoR(s, (char *)XmSTRING_DEFAULT_CHARSET); free(s); } static void GetXmStrings(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.X = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.X = (XmString *) malloc(T->N * sizeof(XmString)); GetList4(taskData, list,T->u.X,sizeof(XmString),GetXmString); } } static void GetStrings(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.S = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.S = (char **) malloc(T->N * sizeof(char *)); GetList4(taskData, list,T->u.S,sizeof(char *),CopyString); } } static void FreeXmStrings(ArgType *T) { for(unsigned i = 0; i < T->N; i++) XmStringFree (T->u.X[i]); free(T->u.X); } static void GetITable(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.I = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.I = (int *) malloc(T->N * sizeof(int)); GetList4(taskData, list,T->u.I,sizeof(int),GetUnsigned); } } static void GetUTable(TaskData *taskData, PolyWord list, ArgType *T) { T->N = 0; T->u.U = 0; if (NONNIL(list)) { T->N = ListLength(list); T->u.U = (uchar *)malloc(T->N * sizeof(uchar)); GetList4(taskData, list,T->u.U,sizeof(uchar),GetUChars); } } /* case CIntTable: GetITable ((ML_Cons_Cell *)v,T); break; case CUnsignedTable: GetUTable ((ML_Cons_Cell *)v,T); break; case CString: CopyString (v,&T->u.string); break; case CStringTable: GetStrings ((ML_Cons_Cell *)v,T); break; case CXmString: GetXmString (v,&T->u.xmString); break; case CXmStringTable: GetXmStrings((ML_Cons_Cell *)v,T); break; */ static void FreeArgs(ArgType *T, unsigned N) { while(N--) { free(T->name); switch(T->tag) { case CAccelerators: break; case CBool: break; case CColormap: break; case CCursor: break; case CDimension: break; case CFontList: XmFontListFree(T->u.F); break; case CInt: break; case CIntTable: break; case CKeySym: break; case CPixmap: break; case CPosition: break; case CString: XtFree(T->u.string); break; case CStringTable: FreeStrings(T->u.S,T->N); free(T->u.S); break; case CTrans: break; case CUnsignedChar: break; case CUnsignedTable: break; case CVisual: break; case CWidget: break; case CWidgetList: break; case CXmString: XmStringFree (T->u.xmString); break; case CXmStringTable: FreeXmStrings(T); break; default: Crash ("Bad arg type %x",T->tag); } T++; } } /* type Arg sharing type Arg = exn; val Exn: Arg -> Exn = Cast; val Arg: Exn -> Arg = Cast; datatype Exn = EXN of unit ref * string * unit; */ /* (string,(v,tag)) */ static void SetArgTypeP(TaskData *taskData, PolyWord fst, PolyWord snd, ArgType *T) { PolyWord v = FST(snd); T->tag = UNTAGGED(SND(snd)); T->N = 0; T->u.i = 0; CopyString(taskData, fst, &T->name, 0); switch(T->tag) { case CAccelerators: T->u.acc = GetAcc (taskData, (X_Object *)v.AsObjPtr()); break; case CBool: T->u.boolean = get_C_ulong (taskData, v); break; case CColormap: T->u.cmap = GetColormap (taskData, (X_Object *)v.AsObjPtr()); break; case CCursor: T->u.cursor = GetCursor (taskData, (X_Object *)v.AsObjPtr()); break; case CDimension: T->u.dim = get_C_ushort (taskData, v); break; case CFontList: T->u.F = GetXmFontList(v); break; case CInt: T->u.i = get_C_long (taskData, v); break; case CKeySym: T->u.keysym = get_C_ulong (taskData, v); break; case CPixmap: T->u.pixmap = GetPixmap (taskData, (X_Object *)v.AsObjPtr()); break; case CPosition: T->u.posn = get_C_short (taskData, v); break; case CTrans: T->u.trans = GetTrans (taskData, (X_Object *)v.AsObjPtr()); break; case CUnsignedChar: T->u.u = get_C_uchar (taskData, v); break; case CVisual: T->u.visual = GetVisual (taskData, (X_Object *)v.AsObjPtr()); break; case CWidget: T->u.widget = GetNWidget (taskData, (X_Object *)v.AsObjPtr()); break; /* The following types allocate memory, but only in the C heap */ case CIntTable: GetITable (taskData, v,T); break; case CUnsignedTable: GetUTable (taskData, v,T); break; case CString: CopyString (taskData, v, &T->u.string, 0); break; case CStringTable: GetStrings (taskData, v,T); break; case CXmString: GetXmString (taskData, v, &T->u.xmString, 0); break; case CXmStringTable: GetXmStrings(taskData, v,T); break; default: Crash ("Bad arg type %x",T->tag); } } static void SetArgType(TaskData *taskData, PolyWord p, void *v, unsigned) { ArgType *T = (ArgType *)v; SetArgTypeP(taskData, FST(p), SND(p), T); } static void SetArgs(Arg *A, ArgType *T, unsigned N) { while(N--) { A->name = T->name; switch(T->tag) { case CAccelerators: A->value = (XtArgVal) T->u.acc; break; case CBool: A->value = (XtArgVal) T->u.boolean; break; case CColormap: A->value = (XtArgVal) T->u.cmap; break; case CCursor: A->value = (XtArgVal) T->u.cursor; break; case CDimension: A->value = (XtArgVal) T->u.dim; break; case CFontList: A->value = (XtArgVal) T->u.F; break; case CInt: A->value = (XtArgVal) T->u.i; break; case CIntTable: A->value = (XtArgVal) T->u.I; break; case CKeySym: A->value = (XtArgVal) T->u.keysym; break; case CPixmap: A->value = (XtArgVal) T->u.pixmap; break; case CPosition: A->value = (XtArgVal) T->u.posn; break; case CString: A->value = (XtArgVal) T->u.string; break; case CStringTable: A->value = (XtArgVal) T->u.S; break; case CTrans: A->value = (XtArgVal) T->u.trans; break; case CUnsignedChar: A->value = (XtArgVal) T->u.u; break; case CUnsignedTable: A->value = (XtArgVal) T->u.U; break; case CVisual: A->value = (XtArgVal) T->u.visual; break; case CWidget: A->value = (XtArgVal) T->u.widget; break; case CXmString: A->value = (XtArgVal) T->u.xmString; break; case CXmStringTable: A->value = (XtArgVal) T->u.X; break; default: Crash ("Bad arg type %x",T->tag); } A++; T++; } } /* add current callback to (pending?) FList */ static void RunWidgetCallback(Widget w, XtPointer closure, XtPointer call_data) { C_List *C = (C_List *)closure; if (callbacks_enabled) { // Only synchronous callbacks are handled. TaskData *taskData = processes->GetTaskDataForThread(); Handle tailHandle = SAVE(FList); Handle widgetHandle = SAVE(C->widget_object); Handle functionHandle = SAVE(C->function); Handle pairHandle = CreatePair(taskData, widgetHandle,functionHandle); FList = DEREFWORD(CreatePair(taskData, pairHandle,tailHandle)); } #if 0 else printf("Ignoring event for widget %p\n",C->widget_object); #endif } static void SetCallbacks(TaskData *taskData, X_Widget_Object *W, PolyWord list, PolyWord initial) { char name[100]; Widget w = GetWidget(taskData, (X_Object *)W); assert(w != NULL); /* SPF */ assert(w != (Widget)1); /* SPF */ for(PolyWord pp = W->callbackList; NONNIL(pp); pp = ((ML_Cons_Cell*)pp.AsObjPtr())->t) { MLPair *q = (MLPair *)((ML_Cons_Cell*)pp.AsObjPtr())->h.AsObjPtr(); Poly_string_to_C(FST(q),name,sizeof(name)); if (strcmp(name,"messageCallback") != 0 && strcmp(name,XtNdestroyCallback) != 0) { XtRemoveAllCallbacks(w,name); } } #if 0 /* We no longer need the old callback data for this widget, assuming we've replaced all the callbacks. But what if we've only replaced some of them? It's probably better to allow this space leak that to delete vital callback data. I'll have to think about this hard sometime. (Of course, the user isn't supposed to call XtSetCallbacks more than once, in which case the problem doesn't even arise.) SPF 29/2/96 */ PurgeCCallbacks(W,w); #endif for(PolyWord p = list; NONNIL(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { C_List *C = (C_List *)malloc(sizeof(C_List)); MLPair *q = (MLPair *)((ML_Cons_Cell*)p.AsObjPtr())->h.AsObjPtr(); C->function = SND(q).AsObjPtr(); C->widget_object = W; C->next = CList; debugCreateCallback(W,w,C); CList = C; Poly_string_to_C(FST(q),name,sizeof(name)); if (strcmp(name,"messageCallback") != 0 && strcmp(name,XtNdestroyCallback) != 0) { XtAddCallback(w,name,RunWidgetCallback,C); } } W->state = initial; W->callbackList = list; } static void RunWidgetEventhandler (Widget w, XtPointer p, XEvent *ev, Boolean *c) { C_List *C = (C_List *)p; if ( callbacks_enabled ) { TaskData *taskData = processes->GetTaskDataForThread(); Handle tailHandle = SAVE(GList); Handle widgetHandle = SAVE(C->widget_object); Handle functionHandle = SAVE(C->function); Handle pairHandle = CreatePair(taskData, widgetHandle,functionHandle); GList = (ML_Cons_Cell *)DEREFHANDLE(CreatePair(taskData, pairHandle,tailHandle)); } } static void AddEventhandler ( TaskData *taskData, X_Widget_Object *W, EventMask EventM, Boolean nonmask, Handle p) { Widget w = GetWidget(taskData, (X_Object *)W) ; C_List *C = (C_List *) malloc ( sizeof(C_List) ) ; /* Add the function to the callback list, so that it will not be G.C'ed away. */ C->function = DEREFHANDLE(p); C->widget_object = W ; C->next = CList ; CList = C ; XtAddEventHandler (w, EventM, nonmask, RunWidgetEventhandler, C); } static Handle AppInitialise ( TaskData *taskData, PolyWord s1, PolyWord s2, PolyWord s3, Handle fallbackHead, Handle argHead ) { char displayName[500]; char appName[500]; char appClass[500]; XtAppContext app_context; Display *display; Widget shell; Handle dsHandle /* Handle to (X_Display_Object *) */; int argc = 0; /* an "int" for Solaris, but should be "unsigned" for SunOS */ unsigned F = ListLength(DEREFWORD(fallbackHead)) + 1; unsigned N = ListLength(DEREFWORD(argHead)); char **S = (char **) alloca(F * sizeof(char *)); Arg *R = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); Poly_string_to_C(s1,displayName ,sizeof(displayName)); Poly_string_to_C(s2,appName ,sizeof(appName)); Poly_string_to_C(s3,appClass ,sizeof(appClass)); app_context = XtCreateApplicationContext(); GetList4(taskData, DEREFWORD(fallbackHead),S,sizeof(char *),CopyString); S[F-1] = NULL; /* list must be NULL terminated */ XtAppSetFallbackResources(app_context,S); display = XtOpenDisplay(app_context,displayName,appName,appClass,NULL,0,&argc,0); if (display == 0) RaiseXWindows(taskData, "XtAppInitialise failed (can't open display)"); /* I don't think this is needed. DCJM 26/5/2000 */ /* add_file_descr(display->fd); */ debug1 ("%s display opened\n",DisplayString(display)); debug1 ("%x display fd\n",display->fd); /* ok to store C values because this is a BYTE object */ dsHandle = alloc_and_save(taskData, SIZEOF(X_Display_Object), F_MUTABLE_BIT|F_BYTE_OBJ); DEREFDISPLAYHANDLE(dsHandle)->type = TAGGED(X_Display); DEREFDISPLAYHANDLE(dsHandle)->display = display; DEREFDISPLAYHANDLE(dsHandle)->screen = DefaultScreen(display); DEREFDISPLAYHANDLE(dsHandle)->app_context = app_context; AddXObject(FINISHED(taskData, dsHandle)); GetList4(taskData, DEREFWORD(argHead),T,sizeof(ArgType),SetArgType); SetArgs(R,T,N); shell = XtAppCreateShell(appName,appClass,applicationShellWidgetClass,display,R,N); FreeArgs(T,N); if (shell == 0) RaiseXWindows(taskData, "XtAppInitialise failed (can't create application shell)"); /* added 7/12/94 SPF */ XtAddCallback(shell,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,shell); } static Handle CreatePopupShell ( TaskData *taskData, PolyStringObject *s, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget parent, Handle list ) { char name[100]; Widget shell; unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); Poly_string_to_C(s,name,sizeof(name)); shell = XtCreatePopupShell(name,applicationShellWidgetClass,parent,A,N); FreeArgs(T,N); if (shell == 0) RaiseXWindows(taskData, "XtCreatePopupShell failed"); /* added 7/12/94 SPF */ XtAddCallback(shell,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,shell); } static Handle CreateXm ( TaskData *taskData, Widget (*create)(Widget, String, ArgList, Cardinal), char *failed, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget parent, PolyStringObject *s, Handle list /* Handle to (ML_Cons_Cell *) */ ) { char name[100]; Widget w; unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); Poly_string_to_C(s,name,sizeof(name)); w = (* create)(parent,name,A,N); FreeArgs(T,N); if (w == 0) RaiseXWindows(taskData, failed); XtAddCallback(w,XtNdestroyCallback,DestroyWidgetCallback,NULL); return NewWidget(taskData, dsHandle,w); } static void SetValues(TaskData *taskData, Widget w, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Arg *A = (Arg *) alloca(N * sizeof(Arg)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); GetList4(taskData, DEREFWORD(list),T,sizeof(ArgType),SetArgType); SetArgs(A,T,N); XtSetValues(w,A,N); FreeArgs(T,N); } typedef struct { const char *listName; char *intName; } StringPair; static StringPair listTypes[] = { {"argv" ,(char *) "argc"}, {"buttonAccelerators" ,(char *) "buttonCount"}, {"buttonAcceleratorText" ,(char *) "buttonCount"}, {"buttonMnemonicCharSets",(char *) "buttonCount"}, {"buttonMnemonics" ,(char *) "buttonCount"}, {"buttons" ,(char *) "buttonCount"}, {"buttonType" ,(char *) "buttonCount"}, {"children" ,(char *) "numChildren"}, {"dirListItems" ,(char *) "dirListItemCount"}, {"fileListItems" ,(char *) "fileListItemCount"}, {"historyItems" ,(char *) "historyItemCount"}, {"items" ,(char *) "itemCount"}, {"listItems" ,(char *) "listItemCount"}, {"selectedItems" ,(char *) "selectedItemCount"}, {"selectionArray" ,(char *) "selectionArrayCount"}, }; #define MAXListTYPES (sizeof(listTypes)/sizeof(listTypes[0])) /* (string,(v,tag)) - ML (string*Ctype) */ static void GetArgType ( TaskData *taskData, PolyWord p, ArgType *T, int i, /* not used; needed to keep function type right */ Widget w ) { T->tag = UNTAGGED(SND(SND(p))); T->N = 0; T->u.i = 0; CopyString(taskData, FST(p), &T->name, 0); if (T->tag == CIntTable || T->tag == CUnsignedTable || T->tag == CWidgetList || T->tag == CStringTable || T->tag == CXmStringTable) /* if it is a list type we need to get the length from another resource */ { Arg arg; unsigned i; int result; for(i = 0; i < MAXListTYPES; i++) { if (strcmp(listTypes[i].listName,T->name) == 0) break; } if (i == MAXListTYPES) Crash ("Bad list resource name %s",T->name); arg.name = listTypes[i].intName; arg.value = (XtArgVal) &result; /* Bug fix here which only appeared in OpenMotif and LessTif. We need to pass the address of an integer here to receive the result. DCJM 17/5/02. */ XtGetValues(w, &arg, 1); T->N = result; } } static Handle CreateWidget(TaskData *taskData, void *p, Handle dsHandle /* Handle to (X_Display_Object *) */) { return EmptyWidget(taskData, dsHandle, *(Widget*)p); } static Handle CreateXmString(TaskData *taskData, void *t) { char *s; Handle S; XmStringGetLtoR(*(XmString *)t,(char *) XmSTRING_DEFAULT_CHARSET,&s); S = Make_string(s); XtFree(s); return S; } static Handle CreateFontList ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ XmFontList F ) { XmFontContext C; XmStringCharSet charset; XFontStruct *fs; Handle list = 0; Handle tail = 0; if (XmFontListInitFontContext(&C,F) == False) return SAVE(ListNull); // TODO: This previously reset the save vector each time to make sure it // didn't overflow. I've removed that code but it needs to be put back. while (XmFontListGetNextFont(C,&charset,&fs)) { Handle L = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell), F_MUTABLE_BIT); if (list == 0) list = L; // This is the first. if (tail != 0) { DEREFLISTHANDLE(tail)->t = DEREFWORD(L); FINISHED(taskData, tail); } tail = L; /* the new list element is joined on, but not filled in */ DEREFLISTHANDLE(tail)->h = DEREFWORD(CreatePair(taskData, CreateFontStruct(taskData,fs,dsHandle),Make_string(charset))); DEREFLISTHANDLE(tail)->t = ListNull; } XmFontListFreeFontContext(C); if (tail != 0) FINISHED(taskData, tail); return list; } static Handle CreateUChar(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(uchar *)p); } static Handle CreateArg(TaskData *taskData, void *v, Handle dsHandle /* Handle to (X_Display_Object *) */) { ArgType *T = (ArgType *)v; Handle value; switch(T->tag) { case CAccelerators: value = EmptyAcc (taskData, T->u.acc); break; case CBool: value = Make_bool (T->u.boolean); break; case CColormap: value = EmptyColormap (taskData, dsHandle,T->u.cmap); break; case CCursor: value = EmptyCursor (taskData, dsHandle,T->u.cursor); break; case CDimension: value = Make_int (T->u.dim); break; case CFontList: value = CreateFontList(taskData, dsHandle,T->u.F); break; case CInt: value = Make_int (T->u.i); break; case CKeySym: value = Make_arbitrary_precision (taskData, T->u.keysym); break; case CPixmap: value = EmptyPixmap (taskData, dsHandle,T->u.pixmap); break; case CPosition: value = Make_int (T->u.posn); break; case CString: value = Make_string (T->u.string); break; case CTrans: value = EmptyTrans (taskData, T->u.trans); break; case CUnsignedChar: value = Make_arbitrary_precision (taskData, T->u.u); break; case CVisual: value = EmptyVisual (taskData, dsHandle,T->u.visual); break; case CWidget: value = EmptyWidget (taskData, dsHandle,T->u.widget); break; case CXmString: value = CreateXmString(taskData, &T->u.xmString); break; case CIntTable: value = CreateList4(taskData, T->N,T->u.I,sizeof(int), CreateUnsigned); break; case CUnsignedTable: value = CreateList4(taskData, T->N,T->u.U,sizeof(uchar), CreateUChar); break; case CStringTable: value = CreateList4(taskData, T->N,T->u.S,sizeof(char *), CreateString); break; case CWidgetList: value = CreateList5(taskData,T->N,T->u.W,sizeof(Widget), CreateWidget,dsHandle); break; case CXmStringTable: value = CreateList4(taskData, T->N,T->u.X,sizeof(XmString),CreateXmString); break; default: Crash ("Bad arg type %x",T->tag); /*NOTREACHED*/ } return value; } static Handle GetValue ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, PolyWord pair /* ML (string*Ctype) */ ) { Arg A; ArgType T; XmString *X = (XmString *) 0x55555555; XmString *Y = (XmString *) 0xAAAAAAAA; GetArgType(taskData,pair,&T,0,w); A.name = T.name; A.value = (XtArgVal) &T.u; T.u.X = X; /* The value is set to X. If it is left set to X */ /* then this may be a value this widget doesn't have. */ XtGetValues(w,&A,1); if (T.u.X == X) { T.u.X = Y; XtGetValues(w,&A,1); if (T.u.X == Y) { char buffer[500]; sprintf(buffer,"XtGetValues (%s) failed",T.name); RaiseXWindows(taskData, buffer); } } return CreateArg(taskData, &T,dsHandle); } /* What is the real ML type of p? (string*Ctype*string*string*string*Ctype) */ static void GetResource ( TaskData *taskData, PolyWord pp, XtResource *R, int i, ArgType *T, ArgType *D, Widget w ) { PolyObject *p = pp.AsObjPtr(); GetArgType(taskData,pp,&T[i],0,w); /* HACK !!! */ CopyString(taskData, p->Get(0), &R->resource_name, 0); CopyString(taskData, p->Get(2), &R->resource_class, 0); CopyString(taskData, p->Get(3), &R->resource_type, 0); R->resource_size = 4; R->resource_offset = (byte*)(&T[i].u) - (byte*)(T); SetArgTypeP(taskData, p->Get(4), p->Get(5), &D[i]); /* This was a hack. I hope I converted it correctly. DCJM */ R->default_type = D[i].name; if (UNTAGGED(p->Get(5).AsObjPtr()->Get(1)) == CString) R->default_addr = (XtPointer) D[i].u.string; else R->default_addr = (XtPointer) &D[i].u; } static Handle GetSubresources ( TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, PolyStringObject *s1, PolyStringObject *s2, Handle list ) { char name [100]; char clas[100]; unsigned N = ListLength(DEREFWORD(list)); ArgType *T = (ArgType *) alloca(N * sizeof(ArgType)); ArgType *D = (ArgType *) alloca(N * sizeof(ArgType)); XtResource *R = (XtResource *) alloca(N * sizeof(XtResource)); { unsigned i = 0; for(PolyWord p = DEREFWORD(list); NONNIL(p); p = ((ML_Cons_Cell *)p.AsObjPtr())->t) { GetResource(taskData,((ML_Cons_Cell *)p.AsObjPtr())->h,&R[i],i,T,D,w); i++; } } Poly_string_to_C(s1,name ,sizeof(name)); Poly_string_to_C(s2,clas,sizeof(clas)); XtGetSubresources(w,T,name,clas,R,N,NULL,0); return CreateList5(taskData,N,T,sizeof(ArgType),CreateArg,dsHandle); } static Handle GetApplicationResources (TaskData *taskData, Handle dsHandle, /* Handle to (X_Display_Object *) */ Widget w, Handle list ) { unsigned N = ListLength (DEREFLISTHANDLE(list)) ; ArgType *T = (ArgType *) alloca ( N * sizeof(ArgType) ) ; ArgType *D = (ArgType *) alloca ( N * sizeof(ArgType) ) ; XtResource *R = (XtResource *) alloca ( N * sizeof(XtResource) ) ; { unsigned i = 0; for(PolyWord p = DEREFWORD(list); NONNIL(p); p = ((ML_Cons_Cell *)p.AsObjPtr())->t) { GetResource(taskData,((ML_Cons_Cell *)p.AsObjPtr())->h,&R[i],i,T,D,w); i++; } } XtGetApplicationResources ( w,T,R,N,NULL,0 ) ; return CreateList5 (taskData, N,T,sizeof(ArgType),CreateArg,dsHandle ) ; } static void GetChild(TaskData *taskData, PolyWord p, void *v, unsigned) { Widget *w = (Widget *)v; *w = GetWidget(taskData, (X_Object *)p.AsObjPtr()); if (XtParent(*w) == NULL) RaiseXWindows(taskData, "not a child"); } static void ManageChildren(TaskData *taskData, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Widget *W = (Widget *) alloca(N * sizeof(Widget)); GetList4(taskData, DEREFWORD(list),W,sizeof(Widget),GetChild); XtManageChildren(W,N); } static void UnmanageChildren(TaskData *taskData, Handle list) { unsigned N = ListLength(DEREFWORD(list)); Widget *W = (Widget *) alloca(N * sizeof(Widget)); GetList4(taskData, DEREFWORD(list),W,sizeof(Widget),GetChild); XtUnmanageChildren(W,N); } static Handle ParseTranslationTable(TaskData *taskData, PolyStringObject *s) { XtTranslations table; int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); table = XtParseTranslationTable(buffer); return EmptyTrans(taskData, table); } static void CommandError(TaskData *taskData, Widget w, PolyWord s) { XmString p; GetXmString(taskData, s, &p, 0); XmCommandError(w,p); XmStringFree (p); } static void FileSelectionDoSearch(TaskData *taskData, Widget w, PolyWord s) { XmString p; GetXmString(taskData, s, &p, 0); XmFileSelectionDoSearch(w,p); XmStringFree (p); } static void MenuPosition (Widget w, int x, int y) { XButtonPressedEvent ev; memset (&ev, 0, sizeof(ev)); ev.type = 4; /* Must be button. */ ev.x_root = x; ev.y_root = y; ev.button = 3; /* Is this required? */ ev.same_screen = 1; /* Assume this. */ XmMenuPosition (w, &ev); } static Handle XmIsSomething(TaskData *taskData, unsigned is_code, Widget widget) { unsigned i; switch(is_code) { case 1: i = XmIsArrowButton (widget); break; case 2: i = XmIsArrowButtonGadget (widget); break; case 3: i = XmIsBulletinBoard (widget); break; case 4: i = XmIsCascadeButton (widget); break; case 5: i = XmIsCascadeButtonGadget(widget); break; case 6: i = XmIsCommand (widget); break; case 7: i = XmIsDesktopObject (widget); break; /* ok - SPF 9/8/94 */ case 8: i = XmIsDialogShell (widget); break; /* Unsupported in Motif 1.2 case 9: i = XmIsDisplayObject (widget); break; */ case 10: i = XmIsDrawingArea (widget); break; case 11: i = XmIsDrawnButton (widget); break; case 12: i = XmIsExtObject (widget); break; /* ok - SPF 9/8/94 */ case 13: i = XmIsFileSelectionBox (widget); break; case 14: i = XmIsForm (widget); break; case 15: i = XmIsFrame (widget); break; case 16: i = XmIsGadget (widget); break; case 17: i = XmIsLabel (widget); break; case 18: i = XmIsLabelGadget (widget); break; case 19: i = XmIsList (widget); break; case 20: i = XmIsMainWindow (widget); break; case 21: i = XmIsManager (widget); break; case 22: i = XmIsMenuShell (widget); break; case 23: i = XmIsMessageBox (widget); break; case 24: i = XmIsMotifWMRunning (widget); break; case 25: i = XmIsPanedWindow (widget); break; case 26: i = XmIsPrimitive (widget); break; case 27: i = XmIsPushButton (widget); break; case 28: i = XmIsPushButtonGadget (widget); break; case 29: i = XmIsRowColumn (widget); break; case 30: i = XmIsScale (widget); break; /* Unsupported in Motif 1.2 case 31: i = XmIsScreenObject (widget); break; */ case 32: i = XmIsScrollBar (widget); break; case 33: i = XmIsScrolledWindow (widget); break; case 34: i = XmIsSelectionBox (widget); break; case 35: i = XmIsSeparator (widget); break; case 36: i = XmIsSeparatorGadget (widget); break; #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case 37: RaiseXWindows(taskData, "XmIsShellExt: not implemented"); #else case 37: i = XmIsShellExt (widget); break; /* ok - SPF 9/8/94 */ #endif case 38: i = XmIsText (widget); break; case 39: i = XmIsTextField (widget); break; case 40: i = XmIsToggleButton (widget); break; case 41: i = XmIsToggleButtonGadget (widget); break; case 42: i = XmIsVendorShell (widget); break; case 43: i = XmIsVendorShellExt (widget); break; /* ok - SPF 9/8/94 */ /* Unsupported in Motif 1.2 case 44: i = XmIsWorldObject (widget); break; */ default: Crash ("Bad code (%d) in XmIsSomething",is_code); /* NOTREACHED*/ } return Make_bool(i); } /******************************************************************************/ /* */ /* Wrappers for standard widget operations */ /* */ /******************************************************************************/ /************************* 0 parameters, no result ****************************/ /* widget -> unit */ static void WidgetAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData,func_name,arg1); applyFunc(w); } /************************* 1 parameter, no result *****************************/ /* widget -> bool -> unit */ static void WidgetBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, Boolean), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); Boolean b = (get_C_short(taskData, arg2) != 0); applyFunc(w,b); } /* widget -> int -> unit */ static void WidgetIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); int i = get_C_long(taskData, arg2); applyFunc(w,i); } /* widget -> int -> unit */ static void WidgetLongAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, long), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); long i = get_C_long(taskData, arg2); applyFunc(w,i); } /* widget -> string -> unit */ static void WidgetXmstringAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; GetXmString(taskData, arg2, &s, 0); applyFunc(w,s); XmStringFree(s); } /* widget -> string list -> unit */ static void WidgetXmstringlistAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString *, int), X_Object *arg1, ML_Cons_Cell *arg2 ) { Widget w = getWidget(taskData,func_name,arg1); unsigned n = ListLength(arg2); XmString *strings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, arg2,strings,sizeof(XmString),GetXmString); applyFunc(w,strings,n); for (unsigned i = 0; i < n; i ++) XmStringFree(strings[i]); } /************************* 2 parameters, no result ****************************/ /* widget -> int -> bool -> unit */ static void WidgetIntBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int, Boolean), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); int i = get_C_long(taskData, arg2); Boolean b = (get_C_ushort(taskData, arg3) != 0); applyFunc(w,i,b); } /* widget -> int -> int -> unit */ static void WidgetIntIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, int, int), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); int x = get_C_long(taskData, arg2); int y = get_C_long(taskData, arg3); applyFunc(w,x,y); } /* widget -> string -> bool -> unit */ static void WidgetXmstringBoolAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString, Boolean), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; Boolean b = (get_C_ushort(taskData, arg3) != 0); GetXmString(taskData, arg2, &s, 0); applyFunc(w,s,b); XmStringFree(s); } /* widget -> string -> int -> unit */ static void WidgetXmstringIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString, int), X_Object *arg1, PolyWord arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; int i = get_C_long(taskData, arg3); GetXmString(taskData, arg2, &s, 0); applyFunc(w,s,i); XmStringFree(s); } /* widget -> string list -> int -> unit */ static void WidgetXmstringlistIntAction ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), void applyFunc(Widget, XmString *, int, int), X_Object *arg1, ML_Cons_Cell *arg2, PolyWord arg3 ) { Widget w = getWidget(taskData,func_name,arg1); unsigned n = ListLength(arg2); int i = get_C_long(taskData, arg3); XmString *strings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, arg2,strings,sizeof(XmString),GetXmString); applyFunc(w,strings,n,i); for (unsigned i = 0; i < n; i ++) XmStringFree(strings[i]); } /************************* n parameters, some result **************************/ static Handle int_ptr_to_arb(TaskData *taskData, void *p) { return Make_arbitrary_precision(taskData, *(int *)p); } /* widget -> int */ static Handle WidgetToInt ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), int applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); int res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } /* widget -> int */ static Handle WidgetToLong ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *taskData, char *, X_Object *), long applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); long res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } #if 0 /* widget -> int */ static Handle WidgetToUnsigned ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), unsigned applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); unsigned res = applyFunc(w); return(Make_arbitrary_precision(taskData, res)); } #endif /* widget -> bool */ static Handle WidgetToBool ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); Boolean res = applyFunc(w); return(Make_bool(res)); } /* widget -> string */ static Handle WidgetToString ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), char *applyFunc(Widget), X_Object *arg1 ) { Widget w = getWidget(taskData, func_name,arg1); char *s = applyFunc(w); Handle res = Make_string(s); /* safe, even if C pointer is NULL */ XtFree(s); return(res); } /* widget -> int list */ static Handle WidgetToIntlist ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, int**, int *), X_Object *arg1 ) { int item_count, *items; Boolean non_empty; Widget w = getWidget(taskData,func_name,arg1); non_empty = applyFunc(w, &items, &item_count); if (non_empty != TRUE) /* nothing found, and Motif hasn't allocated any space */ /* so just retun nil */ { return (SAVE(ListNull)); } else /* copy the list into the ML heap, then free it */ { Handle res = CreateList4(taskData, item_count,items,sizeof(int),int_ptr_to_arb); XtFree((char *)items); return res; } } /* widget -> string -> int list */ static Handle WidgetXmstringToIntlist ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, XmString, int**, int *), X_Object *arg1, PolyWord arg2 ) { int item_count, *items; Boolean non_empty; Widget w = getWidget(taskData,func_name,arg1); XmString s; GetXmString(taskData, arg2, &s, 0); non_empty = applyFunc(w, s, &items, &item_count); XmStringFree(s); if (non_empty != TRUE) /* nothing found, so just retun nil */ { return (SAVE(ListNull)); } else /* copy the list into the ML heap, then free it */ { Handle res = CreateList4(taskData, item_count,items,sizeof(int),int_ptr_to_arb); XtFree((char *)items); return res; } } /* widget -> string -> int */ static Handle WidgetXmstringToInt ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), int applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; int res; GetXmString(taskData, arg2, &s, 0); res = applyFunc(w, s); XmStringFree(s); return (Make_int(res)); } /* widget -> string -> bool */ static Handle WidgetXmstringToBool ( TaskData *taskData, char *func_name, Widget getWidget(TaskData *, char *, X_Object *), Boolean applyFunc(Widget, XmString), X_Object *arg1, PolyWord arg2 ) { Widget w = getWidget(taskData,func_name,arg1); XmString s; Boolean res; GetXmString(taskData, arg2, &s, 0); res = applyFunc(w, s); XmStringFree(s); return (Make_bool(res)); } /******************************************************************************/ /* code added SPF 25/2/95 */ static bool isPossibleString(PolyObject *P) { if (!OBJ_IS_DATAPTR(P)) return false; POLYUNSIGNED L = P->LengthWord(); if (! OBJ_IS_BYTE_OBJECT(L)) return false; /* get object PolyWord count */ POLYUNSIGNED n = OBJ_OBJECT_LENGTH(L); if (n < 1) return false; /* get string byte count */ POLYUNSIGNED m = P->Get(0).AsUnsigned(); /* number of words to hold the bytes */ m = (m + 3) / 4; /* number of words to hold the bytes, plus the byte count */ m = m + 1; /* If that's the same as the object PolyWord count, we've probably got a genuine string! */ return (m == n); } /* Prints out the contents of a PolyWord in the X interface tuple */ static void DebugPrintWord(PolyWord P /* was X_Object *P */) { TaskData *taskData = processes->GetTaskDataForThread(); if (IS_INT((P))) { printf("Short %d", (int)UNTAGGED(P)); return; } if (isPossibleString(P.AsObjPtr())) { if (((PolyStringObject*)P.AsObjPtr())->length <= 40) { printf("String: \""); print_string((PolyStringObject*) P.AsObjPtr()); printf("\""); return; } else { printf("Long String: %p", P.AsAddress()); return; } } /* The problem with the following code was that we can't be sure that the object we have is really an X_Object - it might just look like one. If this is the case, when we try to validate the object using ResourceExists we may get a core dump because ResourceExists assumes it has a valid X_Object and calls hashId which dereferences fields within the so-called X_object. That's why we redefine ResourceExists to be SafeResourceExists which doesn't make any assumptions about the contents of the so-called X_object. SPF 6/4/95 */ #define XP ((X_Object *)P.AsObjPtr()) #define ResourceExists SafeResourceExists { switch(UNTAGGED(XP->type)) { case X_GC: (ResourceExists(XP) ? printf("GC %lx", GetGC(taskData, XP)->gid) : printf("Old GC <%lx>",P.AsUnsigned())); return; case X_Font: (ResourceExists(XP) ? printf("Font %lx",GetFont(taskData, XP)) : printf("Old Font <%x>",(int)P.AsUnsigned())); return; case X_Cursor: (ResourceExists(XP) ? printf("Cursor %lx",GetCursor(taskData, XP)) : printf("Old Cursor <%x>",(int)P.AsUnsigned())); return; case X_Window: (ResourceExists(XP) ? printf("Window %lx",GetWindow(taskData, XP)) : printf("Old Window <%p>",P.AsAddress())); return; case X_Pixmap: (ResourceExists(XP) ? printf("Pixmap %lx",GetPixmap(taskData, XP)) : printf("Old Pixmap <%p>",P.AsAddress())); return; case X_Colormap: (ResourceExists(XP) ? printf("Colormap %lx",GetColormap(taskData, XP)) : printf("Old Colormap <%p>",P.AsAddress())); return; case X_Visual: (ResourceExists(XP) ? printf("Visual %lx",GetVisual(taskData, XP)->visualid) : printf("Old Visual <%p>",P.AsAddress())); return; case X_Widget: (ResourceExists(XP) ? printf("Widget %p",GetNWidget(taskData, XP)) : printf("Old Widget <%p>",P.AsAddress())); return; case X_Trans: (ResourceExists(XP) ? printf("Trans %p",GetTrans(taskData, XP)) : printf("Old Trans <%p>",P.AsAddress())); return; case X_Acc: (ResourceExists(XP) ? printf("Acc %p",GetAcc(taskData, XP)) : printf("Old Acc <%p>",P.AsAddress())); return; case X_Display: (ResourceExists(XP) ? printf("Display %s", DisplayString(GetDisplay(taskData, XP))) + printf(":%x", GetDisplay(taskData, XP)->fd) : printf("Old Display <%p>",P.AsAddress())); return; default: printf("Pointer "ZERO_X"%p",P.AsAddress()); return; } } #undef ResourceExists #undef XP } /* Prints out the contents of the X interface tuple */ static void DebugPrintCode(PolyObject *pt) { POLYUNSIGNED N = pt->Length(); POLYUNSIGNED i = 1; assert(IS_INT(pt->Get(0))); printf("%ld:(", UNTAGGED(pt->Get(0))); while(i < N) { DebugPrintWord(pt->Get(i++)); if (i < N) printf(","); } printf(")\n"); } #define P0 DEREFHANDLE(params)->Get(0) #define P1 DEREFHANDLE(params)->Get(1) #define P2 DEREFHANDLE(params)->Get(2) #define P3 DEREFHANDLE(params)->Get(3) #define P4 DEREFHANDLE(params)->Get(4) #define P5 DEREFHANDLE(params)->Get(5) #define P6 DEREFHANDLE(params)->Get(6) #define P7 DEREFHANDLE(params)->Get(7) #define P8 DEREFHANDLE(params)->Get(8) #define P9 DEREFHANDLE(params)->Get(9) #define P10 DEREFHANDLE(params)->Get(10) #define P11 DEREFHANDLE(params)->Get(11) #define P12 DEREFHANDLE(params)->Get(12) #define XP1 ((X_Object *)P1.AsObjPtr()) #define XP2 ((X_Object *)P2.AsObjPtr()) #define XP3 ((X_Object *)P3.AsObjPtr()) #define XP4 ((X_Object *)P4.AsObjPtr()) #define XP5 ((X_Object *)P5.AsObjPtr()) #define XP6 ((X_Object *)P6.AsObjPtr()) #define XP7 ((X_Object *)P7.AsObjPtr()) /* Xwindows_c gets passed the address of an object in save_vec, */ /* which is itself a pointer to a tuple in the Poly heap. */ Handle XWindows_c(TaskData *taskData, Handle params) { int code = get_C_short(taskData, P0); if ((debugOptions & DEBUG_X)) DebugPrintCode(DEREFHANDLE(params)); switch(code) { case XCALL_Not: return Make_arbitrary_precision(taskData, ~ get_C_ulong(taskData, P1)); case XCALL_And: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) & get_C_ulong(taskData, P2)); case XCALL_Or: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) | get_C_ulong(taskData, P2)); case XCALL_Xor: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) ^ get_C_ulong(taskData, P2)); case XCALL_DownShift: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) >> get_C_ulong(taskData, P2)); case XCALL_UpShift: return Make_arbitrary_precision(taskData, get_C_ulong(taskData, P1) << get_C_ulong(taskData, P2)); case XCALL_NoDrawable: return EmptyPixmap(taskData, SAVE(ListNull),(Pixmap)get_C_ulong(taskData, P1)); case XCALL_NoCursor: return EmptyCursor(taskData, SAVE(ListNull),(Cursor)None); case XCALL_NoFont: return EmptyFont(taskData, SAVE(ListNull),(Font)None,(XFontStruct *)NULL); case XCALL_NoColormap: return EmptyColormap(taskData, SAVE(ListNull),(Colormap) None); case XCALL_NoVisual: return EmptyVisual(taskData, SAVE(ListNull),(Visual *)None); case XCALL_GetTimeOfDay: return GetTimeOfDay(taskData); /* Colorcells 100 */ case XCALL_XAllocColor: return AllocColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetXColor1(taskData, P2)); case XCALL_XAllocColorCells: return AllocColorCells(taskData, GetDisplay(taskData, XP1), GetColormap(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4)); case XCALL_XAllocColorPlanes: return AllocColorPlanes(taskData, GetDisplay(taskData, XP1), GetColormap(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5), get_C_ulong(taskData, P6)); case XCALL_XAllocNamedColor: return AllocNamedColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XFreeColors: FreeColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2),get_C_ulong(taskData, P3)); break; case XCALL_XLookupColor: return LookupColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XParseColor: return ParseColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetString(P2)); case XCALL_XQueryColor: return QueryColor(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XQueryColors: return QueryColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2)); case XCALL_XStoreColor: XStoreColor(GetDisplay(taskData, XP1),GetColormap(taskData, XP1),GetXColor1(taskData, P2)); break; case XCALL_XStoreColors: StoreColors(taskData, GetDisplay(taskData, XP1),GetColormap(taskData, XP1),SAVE(P2)); break; case XCALL_XStoreNamedColor: StoreNamedColor(GetDisplay(taskData, XP1), GetColormap(taskData, XP1), GetString(P2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5), get_C_ulong(taskData, P6)); break; case XCALL_BlackPixel: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, BlackPixel(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_WhitePixel: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, WhitePixel(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } /* Colormaps 150 */ case XCALL_XCopyColormapAndFree: return EmptyColormap(taskData, GetDS(taskData, XP1),XCopyColormapAndFree(GetDisplay(taskData, XP1),GetColormap(taskData, XP1))); case XCALL_XCreateColormap: return EmptyColormap(taskData, GetDS(taskData, XP1),XCreateColormap(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetVisual(taskData, XP2),get_C_ulong(taskData, P3))); case XCALL_XInstallColormap: XInstallColormap(GetDisplay(taskData, XP1),GetColormap(taskData, XP1)); break; case XCALL_XListInstalledColormaps: return ListInstalledColormaps(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XUninstallColormap: XUninstallColormap(GetDisplay(taskData, XP1),GetColormap(taskData, XP1)); break; case XCALL_DefaultColormap: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyColormap(taskData, dsHandle, DefaultColormap(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DefaultVisual: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyVisual(taskData, dsHandle, DefaultVisual(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DisplayCells: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, DisplayCells(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_VisualClass: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->c_class); case XCALL_VisualRedMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->red_mask); case XCALL_VisualGreenMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->green_mask); case XCALL_VisualBlueMask: return Make_arbitrary_precision(taskData, GetVisual(taskData, XP1)->blue_mask); /* Cursors 200 */ case XCALL_XCreateFontCursor: return CreateFontCursor(taskData, GetDS(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XCreateGlyphCursor: return CreateGlyphCursor(taskData, GetDS(taskData, XP1), GetFont(taskData, XP1), GetFont(taskData, XP2), get_C_ulong(taskData, P3), get_C_ulong(taskData, P4), GetXColor1(taskData, P5), GetXColor2(taskData, P6)); case XCALL_XCreatePixmapCursor: return CreatePixmapCursor(taskData, GetDS(taskData, XP1), GetPixmap(taskData, XP1), /* source */ GetPixmap(taskData, XP2), /* mask */ GetXColor1(taskData, P3), /* foreground */ GetXColor2(taskData, P4), /* background */ GetOffsetX(taskData, P5), /* x */ GetOffsetY(taskData, P5) /* y */); case XCALL_XDefineCursor: XDefineCursor(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),GetCursor(taskData, XP2)); WindowObject(XP1)->cursor_object = CursorObject(XP2); break; case XCALL_XQueryBestCursor: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestCursor, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XRecolorCursor: XRecolorCursor(GetDisplay(taskData, XP1), GetCursor(taskData, XP1), GetXColor1(taskData, P2), GetXColor2(taskData, P3)); break; case XCALL_XUndefineCursor: XUndefineCursor(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); WindowObject(XP1)->cursor_object = 0; break; /* Display Specifications 250 */ case XCALL_XOpenDisplay: return OpenDisplay(taskData, GetString(XP1)); #define DODISPLAYOP(op) \ {\ Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1);\ return Make_arbitrary_precision(taskData, op(DEREFDISPLAYHANDLE(dsHandle)->display,\ DEREFDISPLAYHANDLE(dsHandle)->screen));\ } case XCALL_CellsOfScreen: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, CellsOfScreen(ScreenOfDisplay(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen))); } case XCALL_DefaultDepth: DODISPLAYOP(DefaultDepth) case XCALL_DisplayHeight: DODISPLAYOP(DisplayHeight) case XCALL_DisplayHeightMM: DODISPLAYOP(DisplayHeightMM) case XCALL_DisplayPlanes: DODISPLAYOP(DisplayPlanes) case XCALL_DisplayString: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_string(DisplayString(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_DisplayWidth: DODISPLAYOP(DisplayWidth) case XCALL_DisplayWidthMM: DODISPLAYOP(DisplayWidthMM) #undef DODISPLAYOP #define DODISPLAYSCREENOP(op) \ {\ Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1);\ return Make_arbitrary_precision(taskData, op(ScreenOfDisplay(DEREFDISPLAYHANDLE(dsHandle)->display,\ DEREFDISPLAYHANDLE(dsHandle)->screen)));\ } case XCALL_DoesBackingStore: DODISPLAYSCREENOP(DoesBackingStore) case XCALL_DoesSaveUnders: DODISPLAYSCREENOP(DoesSaveUnders) case XCALL_EventMaskOfScreen: DODISPLAYSCREENOP(EventMaskOfScreen) case XCALL_MaxCmapsOfScreen: DODISPLAYSCREENOP(MaxCmapsOfScreen) case XCALL_MinCmapsOfScreen: DODISPLAYSCREENOP(MinCmapsOfScreen) #undef DODISPLAYSCREENOP case XCALL_ProtocolRevision: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, ProtocolRevision(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_ProtocolVersion: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, ProtocolVersion(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_ServerVendor: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_string (ServerVendor(DEREFDISPLAYHANDLE(dsHandle)->display)); } case XCALL_VendorRelease: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return Make_arbitrary_precision(taskData, VendorRelease(DEREFDISPLAYHANDLE(dsHandle)->display)); } /* Drawing Primitives 300 */ case XCALL_XClearArea: XClearArea(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3)); break; case XCALL_XClearWindow: XClearWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XCopyArea: XCopyArea(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetDrawable(taskData, XP2), GetGC(taskData, XP3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectW(taskData, P5), GetRectH(taskData, P5), GetRectX(taskData, P5), GetRectY(taskData, P5)); break; case XCALL_XCopyPlane: XCopyPlane(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetDrawable(taskData, XP2), GetGC(taskData, XP3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectW(taskData, P5), GetRectH(taskData, P5), GetRectX(taskData, P5), GetRectY(taskData, P5), get_C_ulong(taskData, P6)); break; case XCALL_XDrawArc: XDrawArc(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, GetArcR(P3)), GetRectY(taskData, GetArcR(P3)), GetRectW(taskData, GetArcR(P3)), GetRectH(taskData, GetArcR(P3)), GetArcA1(taskData, P3), GetArcA2(taskData, P3)); break; case XCALL_XDrawArcs: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XArc *L = (XArc *)alloca(N * sizeof(XArc)); GetList4(taskData, DEREFWORD(list), L, sizeof(XArc), GetArcs); XDrawArcs(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N); } } break; case XCALL_XDrawImageString: XDrawImageString(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetString(P4)->chars, GetString(P4)->length); break; case XCALL_XDrawImageString16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *)alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L, sizeof(XChar2b), GetChar2); XDrawImageString16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); } } break; case XCALL_XDrawLine: XDrawLine(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetPointX(taskData, P4), GetPointY(taskData, P4)); break; case XCALL_XDrawLines: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list), L, sizeof(XPoint), GetPoints); XDrawLines(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N, get_C_ulong(taskData, P4)); } } break; case XCALL_XDrawPoint: XDrawPoint(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); break; case XCALL_XDrawPoints: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list),L,sizeof(XPoint),GetPoints); XDrawPoints(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), L, N, get_C_ulong(taskData, P4)); } } break; case XCALL_XDrawRectangle: XDrawRectangle(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XDrawRectangles: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *)alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XDrawRectangles(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XDrawSegments: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XSegment *L = (XSegment *)alloca(N * sizeof(XSegment)); GetList4(taskData, DEREFWORD(list),L,sizeof(XSegment),GetSegments); XDrawSegments(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XDrawString: XDrawString(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3), GetString(P4)->chars, GetString(P4)->length); break; case XCALL_XDrawString16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XChar2b *L = (XChar2b *)alloca(N * sizeof(XChar2b)); GetList4(taskData, DEREFWORD(list),L,sizeof(XChar2b),GetChar2); XDrawString16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); } } break; case XCALL_XDrawText: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XTextItem *L = (XTextItem *)alloca(N * sizeof(XTextItem)); GetList4(taskData, DEREFWORD(list),L,sizeof(XTextItem),GetText); XDrawText(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); while (N--) { free(L->chars); L++; } } } break; case XCALL_XDrawText16: { Handle list = SAVE(P4); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XTextItem16 *L = (XTextItem16 *)alloca(N * sizeof(XTextItem16)); GetList4(taskData, DEREFWORD(list),L,sizeof(XTextItem16), GetText16); XDrawText16(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),GetPointX(taskData, P3),GetPointY(taskData, P3),L,N); while (N--) { free(L->chars); L++; } } } break; case XCALL_XFillArc: XFillArc(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, GetArcR(P3)), GetRectY(taskData, GetArcR(P3)), GetRectW(taskData, GetArcR(P3)), GetRectH(taskData, GetArcR(P3)), GetArcA1(taskData, P3), GetArcA2(taskData, P3)); break; case XCALL_XFillArcs: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XArc *L = (XArc *)alloca(N * sizeof(XArc)); GetList4(taskData, DEREFWORD(list),L,sizeof(XArc),GetArcs); XFillArcs(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; case XCALL_XFillPolygon: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XPoint *L = (XPoint *)alloca(N * sizeof(XPoint)); GetList4(taskData, DEREFWORD(list),L,sizeof(XPoint),GetPoints); XFillPolygon(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N,get_C_ulong(taskData, P4),get_C_ulong(taskData, P5)); } } break; case XCALL_XFillRectangle: XFillRectangle(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XFillRectangles: { Handle list = SAVE(P3); if (NONNIL(DEREFWORD(list))) { unsigned N = ListLength(DEREFWORD(list)); XRectangle *L = (XRectangle *)alloca(N * sizeof(XRectangle)); GetList4(taskData, DEREFWORD(list),L,sizeof(XRectangle),GetRects); XFillRectangles(GetDisplay(taskData, XP1),GetDrawable(taskData, XP1),GetGC(taskData, XP2),L,N); } } break; /* Events 350 */ case XCALL_XSelectInput: (WindowObject(XP1))->eventMask->Set(0, PolyWord::FromUnsigned(get_C_ulong(taskData, P2))); XSelectInput(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),XMASK((WindowObject(XP1))->eventMask->Get(0).AsUnsigned())); break; case XCALL_XSynchronize: XSynchronize(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_GetState: return GetState(taskData, WindowObject(XP1)); /* WindowObject added SPF */ case XCALL_SetState: SetState(WindowObject(XP1),P2,P3); /* WindowObject added SPF */ break; case XCALL_NextEvent: return NextEvent(taskData, GetDS(taskData, XP1)); case XCALL_InsertTimeout: InsertTimeout(taskData, WindowObject(XP1),get_C_ulong(taskData, P2),P3,P4); /* WindowObject added SPF */ break; case XCALL_XSetInputFocus: XSetInputFocus(GetDisplay(taskData, XP1),GetWindow(taskData, XP2),get_C_ulong(taskData, P3),get_C_ulong(taskData, P4)); break; case XCALL_XGetInputFocus: return GetInputFocus(taskData, GetDS(taskData, XP1)); case XCALL_XSetSelectionOwner: SetSelectionOwner(GetDS(taskData, XP1),get_C_ulong(taskData, P2),GetWindow(taskData, XP3),get_C_ulong(taskData, P4)); break; case XCALL_XGetSelectionOwner: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyWindow(taskData, dsHandle,XGetSelectionOwner(DEREFDISPLAYHANDLE(dsHandle)->display, get_C_ulong(taskData, P2))); } case XCALL_XConvertSelection: XConvertSelection(GetDisplay(taskData, XP4), get_C_ulong(taskData, P1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), GetWindow(taskData, XP4), get_C_ulong(taskData, P5)); break; case XCALL_XSendSelectionNotify: SendSelectionNotify(GetDisplay(taskData, XP4), get_C_ulong(taskData, P1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), GetWindow(taskData, XP4), get_C_ulong(taskData, P5)); break; case XCALL_XDeleteProperty: XDeleteProperty(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XInternAtom: return InternAtom(taskData, GetDisplay(taskData, XP1),GetString(P2),get_C_long(taskData, P3)); case XCALL_XGetAtomName: return GetAtomName(taskData, GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); /* Fonts 400 */ case XCALL_XGetFontPath: return GetFontPath(taskData, GetDisplay(taskData, XP1)); case XCALL_XListFonts: return ListFonts(taskData, GetDisplay(taskData, XP1),GetString(P2),get_C_ulong(taskData, P3)); case XCALL_XListFontsWithInfo: return ListFontsWithInfo(taskData, GetDS(taskData, XP1),GetString(P2),get_C_ulong(taskData, P3)); case XCALL_XLoadFont: return LoadFont(taskData, GetDS(taskData, XP1),GetString(P2)); case XCALL_XLoadQueryFont: return LoadQueryFont(taskData, GetDS(taskData, XP1),GetString(P2)); case XCALL_XQueryFont: return QueryFont(taskData, GetDS(taskData, XP1),GetFont(taskData, XP1)); case XCALL_XSetFontPath: SetFontPath(taskData, GetDisplay(taskData, XP1),SAVE(P2)); break; /* Grabbing 450 */ /* Graphics Context 500 */ case XCALL_DefaultGC: return GetDefaultGC(taskData, GetDS(taskData, XP1)); case XCALL_UpdateGC: ChangeGC(taskData, GCObject(XP1),get_C_ulong(taskData, P2),P3); break; case XCALL_XCreateGC: return CreateGC(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XSetClipRectangles: SetClipRectangles(taskData, GetDisplay(taskData, XP1), GetGC(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2), SAVE(P3), get_C_ulong(taskData, P4)); break; case XCALL_XSetDashes: SetDashes(taskData, GetDisplay(taskData, XP1), GetGC(taskData, XP1), get_C_ulong(taskData, P2), SAVE(P3)); break; /* Images 550 */ case XCALL_XAddPixel: AddPixel(GetXImage(taskData, GetDisplay(taskData, XP1),P2),get_C_ulong(taskData, P3)); break; case XCALL_XGetImage: return GetImage(taskData, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3), get_C_long(taskData, P4)); case XCALL_XGetPixel: return GetPixel(taskData, GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetPointX(taskData, P3), GetPointY(taskData, P3)); case XCALL_XGetSubImage: GetSubImage(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectX(taskData, P2), GetRectY(taskData, P2), GetRectW(taskData, P2), GetRectH(taskData, P2), get_C_ulong(taskData, P3), get_C_long(taskData, P4), GetXImage(taskData, GetDisplay(taskData, XP1),P5), GetPointX(taskData, P6), GetPointY(taskData, P6)); break; case XCALL_XPutImage: PutImage(GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetGC(taskData, XP2), GetXImage(taskData, GetDisplay(taskData, XP1),P3), GetPointX(taskData, P4), GetPointY(taskData, P4), GetRectX(taskData, P5), GetRectY(taskData, P5), GetRectW(taskData, P5), GetRectH(taskData, P5)); break; case XCALL_XPutPixel: PutPixel(GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetPointX(taskData, P3), GetPointY(taskData, P3), get_C_ulong(taskData, P4)); break; case XCALL_XSubImage: return SubImage(taskData, GetXImage(taskData, GetDisplay(taskData, XP1),P2), GetRectX(taskData, P3), GetRectY(taskData, P3), GetRectW(taskData, P3), GetRectH(taskData, P3)); case XCALL_BitmapBitOrder: return Make_arbitrary_precision(taskData, MLImageOrder(BitmapBitOrder(GetDisplay(taskData, XP1)))); case XCALL_BitmapPad: return Make_arbitrary_precision(taskData, BitmapPad(GetDisplay(taskData, XP1))); case XCALL_BitmapUnit: return Make_arbitrary_precision(taskData, BitmapUnit(GetDisplay(taskData, XP1))); case XCALL_ByteOrder: return Make_arbitrary_precision(taskData, MLImageOrder(ImageByteOrder(GetDisplay(taskData, XP1)))); /* Keyboard 600 */ case XCALL_XLookupString: return LookupString(taskData, GetDisplay(taskData, XP1),get_C_ulong(taskData, P2),get_C_ulong(taskData, P3)); case XCALL_XQueryKeymap: return QueryKeymap(taskData, GetDisplay(taskData, XP1)); case XCALL_IsCursorKey: return Make_bool(IsCursorKey(get_C_ulong(taskData, P1))); case XCALL_IsFunctionKey: return Make_bool(IsFunctionKey(get_C_ulong(taskData, P1))); case XCALL_IsKeypadKey: return Make_bool(IsKeypadKey(get_C_ulong(taskData, P1))); case XCALL_IsMiscFunctionKey: return Make_bool(IsMiscFunctionKey(get_C_ulong(taskData, P1))); case XCALL_IsModifierKey: return Make_bool(IsModifierKey(get_C_ulong(taskData, P1))); case XCALL_IsPFKey: return Make_bool(IsPFKey(get_C_ulong(taskData, P1))); /* Output Buffer 650 */ case XCALL_XFlush: XFlush(GetDisplay(taskData, XP1)); break; case XCALL_XSync: XSync(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; /* Pointers 700 */ case XCALL_XQueryPointer: return QueryPointer(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); /* Regions 750*/ /* SAVE Set 800 */ /* Screen Saver 850 */ case XCALL_XActivateScreenSaver: XActivateScreenSaver(GetDisplay(taskData, XP1)); break; case XCALL_XForceScreenSaver: XForceScreenSaver(GetDisplay(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XGetScreenSaver: return GetScreenSaver(taskData, GetDisplay(taskData, XP1)); case XCALL_XResetScreenSaver: XResetScreenSaver(GetDisplay(taskData, XP1)); break; case XCALL_XSetScreenSaver: XSetScreenSaver(GetDisplay(taskData, XP1), get_C_long(taskData, P2), get_C_long(taskData, P3), get_C_ulong(taskData, P4), get_C_ulong(taskData, P5)); break; /* Standard Geometry 900 */ case XCALL_XTranslateCoordinates: return TranslateCoordinates(taskData, GetDS(taskData, XP1), GetWindow(taskData, XP1), GetWindow(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); /* Text 950 */ case XCALL_XTextExtents: return TextExtents(taskData, GetFontStruct(taskData, P1),GetString(P2)); case XCALL_XTextExtents16: return TextExtents16(taskData, GetFontStruct(taskData, P1),SAVE(P2)); case XCALL_XTextWidth: return TextWidth(taskData, GetFontStruct(taskData, P1),GetString(P2)); case XCALL_XTextWidth16: return TextWidth16(taskData, GetFontStruct(taskData, P1),SAVE(P2)); /* Tiles, Pixmaps, Stipples and Bitmaps 1000 */ case XCALL_XCreateBitmapFromData: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P3); return EmptyPixmap(taskData, dsHandle, XCreateBitmapFromData( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetString(P2)->chars, /* data */ GetRectW(taskData, P3), /* width */ GetRectH(taskData, P3))); /* height */ } case XCALL_XCreatePixmap: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P2); return EmptyPixmap(taskData, dsHandle, XCreatePixmap( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetRectW(taskData, P2), /* width */ GetRectH(taskData, P2), /* height */ get_C_ulong(taskData, P3))); /* depth */ } case XCALL_XCreatePixmapFromBitmapData: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); CheckZeroRect(taskData, P3); return EmptyPixmap(taskData, dsHandle, XCreatePixmapFromBitmapData( DEREFDISPLAYHANDLE(dsHandle)->display, GetDrawable(taskData, XP1), /* drawable */ GetString(P2)->chars, /* data */ GetRectW(taskData, P3), /* width */ GetRectH(taskData, P3), /* height */ get_C_ulong(taskData, P4), /* foreground */ get_C_ulong(taskData, P5), /* background */ get_C_ulong(taskData, P6))); /* depth */ } case XCALL_XQueryBestStipple: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestStipple, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XQueryBestTile: CheckZeroRect(taskData, P2); return QueryBest(taskData, XQueryBestTile, GetDisplay(taskData, XP1), GetDrawable(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); case XCALL_XReadBitmapFile: return ReadBitmap(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1),GetString(P2)); case XCALL_XWriteBitmapFile: CheckZeroRect(taskData, P3); return WriteBitmapFile(taskData, GetString(XP1), GetDisplay(taskData, XP2), GetPixmap(taskData, XP2), GetRectW(taskData, P3), GetRectH(taskData, P3), GetPointX(taskData, P4), GetPointY(taskData, P4)); /* User Preferences 1050 */ case XCALL_XAutoRepeatOff: XAutoRepeatOff(GetDisplay(taskData, XP1)); break; case XCALL_XAutoRepeatOn: XAutoRepeatOn (GetDisplay(taskData, XP1)); break; case XCALL_XBell: XBell(GetDisplay(taskData, XP1),get_C_short(taskData, P2)); break; case XCALL_XGetDefault: return GetDefault(taskData, GetDisplay(taskData, XP1),GetString(P2),GetString(P3)); /* Window Attributes 1100 */ case XCALL_ChangeWindow: ChangeWindowAttributes(taskData, WindowObject(XP1),get_C_ulong(taskData, P2),P3); break; case XCALL_XGetGeometry: return GetGeometry(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XGetWindowAttributes: return GetWindowAttributes(taskData, GetDS(taskData, XP1),GetDrawable(taskData, XP1)); case XCALL_XSetWindowBorderWidth: XSetWindowBorderWidth(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; /* Window Configuration 1150 */ case XCALL_XCirculateSubwindows: XCirculateSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XConfigureWindow: ConfigureWindow(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1), P2); break; case XCALL_XLowerWindow: XLowerWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapRaised: XMapRaised(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapSubwindows: XMapSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMapWindow: XMapWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XMoveResizeWindow: CheckZeroRect(taskData, P3); XMoveResizeWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2), GetRectW(taskData, P3), GetRectH(taskData, P3)); break; case XCALL_XMoveWindow: XMoveWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetPointX(taskData, P2), GetPointY(taskData, P2)); break; case XCALL_XQueryTree: return QueryTree(taskData,GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XRaiseWindow: XRaiseWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XReparentWindow: XReparentWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetWindow(taskData, XP2), GetPointX(taskData, P3), GetPointY(taskData, P3)); break; case XCALL_XResizeWindow: CheckZeroRect(taskData, P2); XResizeWindow(GetDisplay(taskData, XP1), GetWindow(taskData, XP1), GetRectW(taskData, P2), GetRectH(taskData, P2)); break; case XCALL_XRestackWindows: RestackWindows(taskData, SAVE(P1)); break; case XCALL_XUnmapSubwindows: XUnmapSubwindows(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; case XCALL_XUnmapWindow: XUnmapWindow(GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); break; /* Window Existence 1200 */ case XCALL_RootWindow: { Handle dsHandle /* Handle to (X_Display_Object *) */ = GetDS(taskData, XP1); return EmptyWindow(taskData, dsHandle, RootWindow(DEREFDISPLAYHANDLE(dsHandle)->display, DEREFDISPLAYHANDLE(dsHandle)->screen)); } case XCALL_DestroyXObject: DestroyXObject(XP1); break; case XCALL_XDestroySubwindows: DestroySubwindows(XP1); break; case XCALL_XCreateSimpleWindow: CheckZeroRect(taskData, P3); return CreateSimpleWindow(taskData, SAVE(XP1), /* parent */ GetPointX(taskData, P2), /* x */ GetPointY(taskData, P2), /* y */ GetRectW(taskData, P3), /* w */ GetRectH(taskData, P3), /* h */ get_C_ulong(taskData, P4), /* borderWidth */ get_C_ulong(taskData, P5), /* border */ get_C_ulong(taskData, P6), /* background */ SAVE(P7), /* handler */ SAVE(P8)); /* state */ case XCALL_XCreateWindow: CheckZeroRect(taskData, P3); return CreateWindow(taskData, SAVE(XP1), /* parent */ GetPointX(taskData, P2), /* x */ GetPointY(taskData, P2), /* y */ GetRectW(taskData, P3), /* w */ GetRectH(taskData, P3), /* h */ get_C_ulong(taskData, P4), /* borderWidth */ get_C_ulong(taskData, P5), /* depth */ get_C_ulong(taskData, P6), /* class */ GetVisual(taskData, XP7), /* visual */ SAVE(P8), /* handler */ SAVE(P9)); /* state */ /* Window Manager 1250 */ case XCALL_XSetProperty: SetProperty(taskData, GetDisplay(taskData, XP1), GetWindow(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), SAVE(P4), get_C_ulong(taskData, P5)); break; case XCALL_XGetTextProperty: return GetTextProperty(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XGetWMHints: return GetWMHints(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetWMSizeHints: return GetWMSizeHints(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XGetIconSizes: return GetIconSizes(taskData, GetDisplay(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetTransientForHint: return GetTransientForHint(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetWMColormapWindows: return GetWMColormapWindows(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1)); case XCALL_XGetRGBColormaps: return GetRGBColormaps(taskData, GetDS(taskData, XP1),GetWindow(taskData, XP1),get_C_ulong(taskData, P2)); case XCALL_XWMGeometry: return WMGeometry(taskData, GetDS(taskData, XP1), GetString(P2), GetString(P3), get_C_ulong(taskData, P4), P5); /* Miscellaneous 1300 */ case XCALL_GetID: return GetID(taskData, XP1); case XCALL_ResourceExists: return Make_bool(ResourceExists(XP1)); case XCALL_GetDisplay: return GetDS(taskData, XP1); /******************************************************************************/ /* */ /* Xt Calls */ /* */ /******************************************************************************/ case XCALL_NoWidget: return EmptyWidget(taskData, SAVE(ListNull), (Widget)NULL); case XCALL_AppInitialise: return AppInitialise(taskData, P1, /* display name */ P2, /* application name */ P3, /* application class */ SAVE(P4), /* Fallback list */ SAVE(P5) /* Arg list */); case XCALL_XtRealizeWidget: XtRealizeWidget(GetWidget(taskData, XP1)); break; case XCALL_XtManageChildren: ManageChildren(taskData, SAVE(P1)); break; case XCALL_XtUnmanageChildren: UnmanageChildren(taskData, SAVE(P1)); break; case XCALL_XtDestroyWidget: { Widget w = GetWidget(taskData, XP1); XtDestroyWidget(w); /* The following test seems necessary - sometimes the callback from */ /* the above call destroys the widget, sometimes it doesn't. I think */ /* it always should, and I can't work out why this strange behaviour */ /* occurs. SPF 9/12/93 */ if (ResourceExists(XP1)) { DestroyXObject(XP1); PurgeCCallbacks((X_Widget_Object *)XP1,w); } break; } case XCALL_SetCallbacks: SetCallbacks (taskData, WidgetObject(taskData, XP1),P2,P3); break; /* WidgetObject added SPF */ case XCALL_XtSetValues: SetValues(taskData, GetWidget(taskData, XP1),SAVE(P2)); break; case XCALL_GetValue: return GetValue(taskData, GetDS(taskData, XP1),GetWidget(taskData, XP1),P2); case XCALL_XtParent: return EmptyWidget(taskData, GetDS(taskData, XP1),XtParent(GetWidget(taskData, XP1))); case XCALL_XtWindow: return EmptyWindow(taskData, GetDS(taskData, XP1),WindowOfWidget(GetWidget(taskData, XP1))); case XCALL_XtDisplay: return GetDS(taskData, XP1); case XCALL_XtUnrealizeWidget: XtUnrealizeWidget(GetWidget(taskData, XP1)); break; case XCALL_XtName: return Make_string(XtName(GetWidget(taskData, XP1))); case XCALL_XtParseTranslationTable: return ParseTranslationTable(taskData, GetString(XP1)); case XCALL_XtOverrideTranslations: XtOverrideTranslations(GetWidget(taskData, XP1),GetTrans(taskData, XP2)); break; case XCALL_XtAugmentTranslations: XtAugmentTranslations(GetWidget(taskData, XP1),GetTrans(taskData, XP2)); break; case XCALL_XtUninstallTranslations: XtUninstallTranslations(GetWidget(taskData, XP1)); break; /* case XCALL_XtTranslateTablePrint: _XtTranslateTablePrint(GetTrans(taskData, XP1)); break; */ case XCALL_XtCreatePopupShell: return CreatePopupShell(taskData, GetString(XP1),GetDS(taskData, XP2),GetWidget(taskData, XP2),SAVE(P3)); case XCALL_InsertWidgetTimeout: InsertWidgetTimeout(taskData, WidgetObject(taskData, XP1),get_C_ulong(taskData, P2),P3,P4); break; /* WidgetObject added SPF */ case XCALL_GetWidgetState: return SAVE(WidgetObjectToken(XP1)->state); /* was WidgetObject(XP1) (SPF) */ case XCALL_SetWidgetState: WidgetObjectToken(XP1)->state = P2; break; /* was WidgetObject(XP1) (SPF) */ case XCALL_XtSetSensitive: XtSetSensitive(GetWidget(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XtIsSensitive: return Make_bool(XtIsSensitive(GetWidget(taskData, XP1))); case XCALL_GetSubresources: return GetSubresources(taskData, GetDS(taskData, XP1), GetWidget(taskData, XP1), GetString(P2), GetString(P3), SAVE(P4)); case XCALL_Cast: return SAVE(P1); case XCALL_XtPopup: XtPopup(GetWidget(taskData, XP1),GetXtGrabKind(taskData, P2)); break; case XCALL_XtPopdown: XtPopdown(GetWidget(taskData, XP1)); break; case XCALL_XtMapWidget: XtMapWidget(GetRealizedWidget(taskData, (char *) "XtMapWidget",XP1)); break; case XCALL_XtUnmapWidget: XtUnmapWidget(GetRealizedWidget(taskData, (char *) "XtUnmapWidget",XP1)); break; case XCALL_XtIsManaged: return Make_bool(XtIsManaged(GetWidget(taskData, XP1))); case XCALL_XtIsRealized: return Make_bool(XtIsRealized(GetWidget(taskData, XP1))); /* Added DCJM. */ case XCALL_XtGetApplicationResources: return GetApplicationResources (taskData, GetDS(taskData, XP1),GetWidget(taskData, XP1),SAVE(P2) ) ; case XCALL_XtAddEventHandler: AddEventhandler (taskData, WidgetObject(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3), SAVE(P4)); break; /******************************************************************************/ /* */ /* Motif Calls - widget creation */ /* */ /******************************************************************************/ /* Motif 4000 */ #define XMCREATE(number,name) \ case number: return CreateXm(taskData, name, (char *) \ #name " failed", \ GetDS(taskData, XP1), \ GetWidget(taskData, XP1), \ GetString(P2), \ SAVE(P3)) XMCREATE(XCALL_XmCreateArrowButton,XmCreateArrowButton); XMCREATE(XCALL_XmCreateArrowButtonGadget,XmCreateArrowButtonGadget); XMCREATE(XCALL_XmCreateBulletinBoard,XmCreateBulletinBoard); XMCREATE(XCALL_XmCreateBulletinBoardDialog,XmCreateBulletinBoardDialog); XMCREATE(XCALL_XmCreateCascadeButton,XmCreateCascadeButton); XMCREATE(XCALL_XmCreateCascadeButtonGadget,XmCreateCascadeButtonGadget); XMCREATE(XCALL_XmCreateCommand,XmCreateCommand); XMCREATE(XCALL_XmCreateDialogShell,XmCreateDialogShell); XMCREATE(XCALL_XmCreateDrawingArea,XmCreateDrawingArea); XMCREATE(XCALL_XmCreateDrawnButton,XmCreateDrawnButton); XMCREATE(XCALL_XmCreateErrorDialog,XmCreateErrorDialog); XMCREATE(XCALL_XmCreateFileSelectionBox,XmCreateFileSelectionBox); XMCREATE(XCALL_XmCreateFileSelectionDialog,XmCreateFileSelectionDialog); XMCREATE(XCALL_XmCreateForm,XmCreateForm); XMCREATE(XCALL_XmCreateFormDialog,XmCreateFormDialog); XMCREATE(XCALL_XmCreateFrame,XmCreateFrame); XMCREATE(XCALL_XmCreateInformationDialog,XmCreateInformationDialog); XMCREATE(XCALL_XmCreateLabel,XmCreateLabel); XMCREATE(XCALL_XmCreateLabelGadget,XmCreateLabelGadget); XMCREATE(XCALL_XmCreateList,XmCreateList); XMCREATE(XCALL_XmCreateMainWindow,XmCreateMainWindow); XMCREATE(XCALL_XmCreateMenuBar,XmCreateMenuBar); XMCREATE(XCALL_XmCreateMenuShell,XmCreateMenuShell); XMCREATE(XCALL_XmCreateMessageBox,XmCreateMessageBox); XMCREATE(XCALL_XmCreateMessageDialog,XmCreateMessageDialog); XMCREATE(XCALL_XmCreateOptionMenu,XmCreateOptionMenu); XMCREATE(XCALL_XmCreatePanedWindow,XmCreatePanedWindow); XMCREATE(XCALL_XmCreatePopupMenu,XmCreatePopupMenu); XMCREATE(XCALL_XmCreatePromptDialog,XmCreatePromptDialog); XMCREATE(XCALL_XmCreatePulldownMenu,XmCreatePulldownMenu); XMCREATE(XCALL_XmCreatePushButton,XmCreatePushButton); XMCREATE(XCALL_XmCreatePushButtonGadget,XmCreatePushButtonGadget); XMCREATE(XCALL_XmCreateQuestionDialog,XmCreateQuestionDialog); XMCREATE(XCALL_XmCreateRadioBox,XmCreateRadioBox); XMCREATE(XCALL_XmCreateRowColumn,XmCreateRowColumn); XMCREATE(XCALL_XmCreateScale,XmCreateScale); XMCREATE(XCALL_XmCreateScrollBar,XmCreateScrollBar); XMCREATE(XCALL_XmCreateScrolledList,XmCreateScrolledList); XMCREATE(XCALL_XmCreateScrolledText,XmCreateScrolledText); XMCREATE(XCALL_XmCreateScrolledWindow,XmCreateScrolledWindow); XMCREATE(XCALL_XmCreateSelectionBox,XmCreateSelectionBox); XMCREATE(XCALL_XmCreateSelectionDialog,XmCreateSelectionDialog); XMCREATE(XCALL_XmCreateSeparator,XmCreateSeparator); XMCREATE(XCALL_XmCreateSeparatorGadget,XmCreateSeparatorGadget); XMCREATE(XCALL_XmCreateSimpleCheckBox,XmCreateSimpleCheckBox); XMCREATE(XCALL_XmCreateSimpleMenuBar,XmCreateSimpleMenuBar); XMCREATE(XCALL_XmCreateSimpleOptionMenu,XmCreateSimpleOptionMenu); XMCREATE(XCALL_XmCreateSimplePopupMenu,XmCreateSimplePopupMenu); XMCREATE(XCALL_XmCreateSimplePulldownMenu,XmCreateSimplePulldownMenu); XMCREATE(XCALL_XmCreateSimpleRadioBox,XmCreateSimpleRadioBox); XMCREATE(XCALL_XmCreateText,XmCreateText); XMCREATE(XCALL_XmCreateTextField,XmCreateTextField); XMCREATE(XCALL_XmCreateToggleButton,XmCreateToggleButton); XMCREATE(XCALL_XmCreateToggleButtonGadget,XmCreateToggleButtonGadget); XMCREATE(XCALL_XmCreateWarningDialog,XmCreateWarningDialog); XMCREATE(XCALL_XmCreateWorkArea,XmCreateWorkArea); XMCREATE(XCALL_XmCreateWorkingDialog,XmCreateWorkingDialog); #undef XMCREATE /******************************************************************************/ /* */ /* Motif Calls - miscellaneous */ /* */ /******************************************************************************/ case XCALL_XmCascadeButtonHighlight: XmCascadeButtonHighlight(GetWidget(taskData, XP1),get_C_ulong(taskData, P2)); break; case XCALL_XmCommandError: CommandError(taskData, GetWidget(taskData, XP1),P2); break; case XCALL_XmCommandGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmCommandGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmFileSelectionBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmFileSelectionBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmFileSelectionDoSearch: FileSelectionDoSearch(taskData, GetWidget(taskData, XP1),P2); break; case XCALL_XmIsSomething: return XmIsSomething(taskData, get_C_ulong(taskData, P1),GetWidget(taskData, XP2)); case XCALL_XmMainWindowSetAreas: XmMainWindowSetAreas(GetWidget(taskData, XP1), GetNWidget(taskData, XP2), GetNWidget(taskData, XP3), GetNWidget(taskData, XP4), GetNWidget(taskData, XP5), GetNWidget(taskData, XP6)); break; case XCALL_XmMainWindowSepX: switch(get_C_ulong(taskData, P2)) { case 1: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep1(GetWidget(taskData, XP1))); case 2: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep2(GetWidget(taskData, XP1))); default: return EmptyWidget(taskData, GetDS(taskData, XP1),XmMainWindowSep3(GetWidget(taskData, XP1))); } case XCALL_XmMessageBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmMessageBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmOptionButtonGadget: return EmptyWidget(taskData, GetDS(taskData, XP1),XmOptionButtonGadget(GetWidget(taskData, XP1))); case XCALL_XmOptionLabelGadget: return EmptyWidget(taskData, GetDS(taskData, XP1),XmOptionLabelGadget (GetWidget(taskData, XP1))); case XCALL_XmSelectionBoxGetChild: return EmptyWidget(taskData, GetDS(taskData, XP1), XmSelectionBoxGetChild(GetWidget(taskData, XP1),get_C_ulong(taskData, P2))); case XCALL_XmSetMenuCursor: XmSetMenuCursor(GetDisplay(taskData, XP1),GetCursor(taskData, XP2)); break; case XCALL_XmScrolledWindowSetAreas: XmScrolledWindowSetAreas(GetWidget(taskData, XP1), GetNWidget(taskData, XP2), GetNWidget(taskData, XP3), GetNWidget(taskData, XP4)); break; /******************************************************************************/ /* */ /* Operations on XmText widgets */ /* */ /******************************************************************************/ #define TextWidgetToLong(func) \ case XCALL_ ## func : \ return(WidgetToLong(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToInt(func) \ case XCALL_ ## func : \ return(WidgetToInt(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToBool(func) \ case XCALL_ ## func : \ return(WidgetToBool(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetToString(func) \ case XCALL_ ## func : \ return(WidgetToString(taskData,(char *) #func,GetTextWidget,func,XP1)) #define TextWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break #define TextWidgetLongAction(func) \ case XCALL_ ## func : \ WidgetLongAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break #define TextWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData,(char *) #func,GetTextWidget,func,XP1,P2); \ break /* XmTextClearSelection not supported */ /* XmTextCopy not supported */ /* XmTextCut not supported */ #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case XCALL_XmTextGetAddMode: RaiseXWindows(taskData, "XmTextGetAddMode: not implemented"); #else TextWidgetToBool(XmTextGetAddMode); #endif TextWidgetToLong(XmTextGetCursorPosition); TextWidgetToInt(XmTextGetBaseline); TextWidgetToBool(XmTextGetEditable); TextWidgetToLong(XmTextGetInsertionPosition); TextWidgetToLong(XmTextGetLastPosition); TextWidgetToInt(XmTextGetMaxLength); TextWidgetToString(XmTextGetSelection); /* XmTextGetSelectionPosition not supported */ TextWidgetToString(XmTextGetString); /* XmTextGetSource not supported */ TextWidgetToLong(XmTextGetTopCharacter); case XCALL_XmTextInsert: { Widget w = GetTextWidget(taskData, (char *) "XmTextInsert",XP1); { unsigned pos = get_C_ulong(taskData, P2); PolyStringObject *s = GetString(P3); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextInsert(w,pos,buffer); break; } } TextWidgetToBool(XmTextPaste); /* with side effect! */ /* XmTextPosToXY not supported */ TextWidgetToBool(XmTextRemove); /* with side effect! */ case XCALL_XmTextReplace: { Widget w = GetTextWidget(taskData, (char *) "XmTextReplace",XP1); { unsigned from_pos = get_C_ulong(taskData, P2); unsigned to_pos = get_C_ulong(taskData, P3); PolyStringObject *s = GetString(P4); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextReplace(w,from_pos,to_pos,buffer); break; } } TextWidgetIntAction(XmTextScroll); /* for side effect! */ TextWidgetBoolAction(XmTextSetAddMode); TextWidgetLongAction(XmTextSetCursorPosition); TextWidgetBoolAction(XmTextSetEditable); /* XmTextSetHighlight not supported */ TextWidgetLongAction(XmTextSetInsertionPosition); TextWidgetIntAction(XmTextSetMaxLength); /* XmTextSetSelection not supported */ /* XmTextSetSource not supported */ /* inlined SPF 15/2/94 */ case XCALL_XmTextSetString: { Widget w = GetTextWidget(taskData, (char *) "XmTextSetString",XP1); { PolyStringObject *s = GetString(P2); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextSetString(w,buffer); break; } } TextWidgetLongAction(XmTextSetTopCharacter); TextWidgetLongAction(XmTextShowPosition); case XCALL_XmTextXYToPos: { Widget w = GetTextWidget(taskData, (char *) "XmTextXYToPos",XP1); { int x = get_C_long(taskData, P2); int y = get_C_long(taskData, P3); return Make_int(XmTextXYToPos(w,x,y)); } } #undef TextWidgetToLong #undef TextWidgetToInt #undef TextWidgetToBool #undef TextWidgetToString #undef TextWidgetIntAction #undef TextWidgetBoolAction /******************************************************************************/ /* */ /* Operations on XmTextField widgets */ /* */ /******************************************************************************/ #define TextFieldWidgetToLong(func) \ case XCALL_ ## func : \ return(WidgetToLong(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToInt(func) \ case XCALL_ ## func : \ return(WidgetToInt(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToBool(func) \ case XCALL_ ## func : \ return(WidgetToBool(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetToString(func) \ case XCALL_ ## func : \ return(WidgetToString(taskData, (char *) #func,GetTextFieldWidget,func,XP1)) #define TextFieldWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break #define TextFieldWidgetLongAction(func) \ case XCALL_ ## func : \ WidgetLongAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break #define TextFieldWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData, (char *) #func,GetTextFieldWidget,func,XP1,P2); \ break /* XmTextFieldClearSelection not supported */ /* XmTextFieldCopy not supported */ /* XmTextFieldCut not supported */ #ifdef LESSTIF_VERSION /* This is not supported in LessTif, at least not 0.89. */ case XCALL_XmTextFieldGetAddMode: RaiseXWindows(taskData, "XmTextFieldGetAddMode: not implemented"); #else TextFieldWidgetToBool(XmTextFieldGetAddMode); #endif TextFieldWidgetToInt(XmTextFieldGetBaseline); TextFieldWidgetToLong(XmTextFieldGetCursorPosition); TextFieldWidgetToBool(XmTextFieldGetEditable); TextFieldWidgetToLong(XmTextFieldGetInsertionPosition); TextFieldWidgetToLong(XmTextFieldGetLastPosition); TextFieldWidgetToInt(XmTextFieldGetMaxLength); TextFieldWidgetToString(XmTextFieldGetSelection); /* XmTextFieldGetSelectionPosition not supported */ TextFieldWidgetToString(XmTextFieldGetString); /* XmTextFieldGetSource not supported */ case XCALL_XmTextFieldInsert: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldInsert",XP1); { unsigned pos = get_C_ulong(taskData, P2); PolyStringObject *s = GetString(P3); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldInsert(w,pos,buffer); break; } } TextFieldWidgetToBool(XmTextFieldPaste); /* for side effect! */ /* XmTextFieldPosToXY not supported */ TextFieldWidgetToBool(XmTextFieldRemove); /* for side effect! */ case XCALL_XmTextFieldReplace: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldReplace",XP1); { unsigned from_pos = get_C_ulong(taskData, P2); unsigned to_pos = get_C_ulong(taskData, P3); PolyStringObject *s = GetString(P4); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldReplace(w,from_pos,to_pos,buffer); break; } } TextFieldWidgetBoolAction(XmTextFieldSetAddMode); TextFieldWidgetLongAction(XmTextFieldSetCursorPosition); TextFieldWidgetBoolAction(XmTextFieldSetEditable); /* XmTextFieldSetHighlight not supported */ TextFieldWidgetLongAction(XmTextFieldSetInsertionPosition); TextFieldWidgetIntAction(XmTextFieldSetMaxLength); /* XmTextFieldSetSelection not supported */ /* inlined SPF 15/2/94 */ case XCALL_XmTextFieldSetString: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldSetString",XP1); { PolyStringObject *s = GetString(P2); int size = s->length + 1; char *buffer = (char *)alloca(size); Poly_string_to_C(s,buffer,size); XmTextFieldSetString(w,buffer); break; } } TextFieldWidgetLongAction(XmTextFieldShowPosition); /* for side effect! */ case XCALL_XmTextFieldXYToPos: { Widget w = GetTextFieldWidget(taskData, (char *) "XmTextFieldXYToPos",XP1); { int x = get_C_long(taskData, P2); int y = get_C_long(taskData, P3); return Make_int(XmTextFieldXYToPos(w,x,y)); } } case XCALL_XmTrackingLocate: return EmptyWidget(taskData, GetDS(taskData, XP1), XmTrackingLocate(GetWidget(taskData, XP1),GetCursor(taskData, XP2),get_C_ulong(taskData, P3))); case XCALL_XmUpdateDisplay: XmUpdateDisplay(GetWidget(taskData, XP1)); break; #undef TextFieldWidgetToLong #undef TextFieldWidgetToInt #undef TextFieldWidgetToBool #undef TextFieldWidgetToString #undef TextFieldWidgetIntAction #undef TextFieldWidgetLongAction #undef TextFieldWidgetBoolAction /******************************************************************************/ /* */ /* Operations on XmList widgets */ /* */ /******************************************************************************/ #define ListWidgetAction(func) \ case XCALL_ ## func : \ WidgetAction(taskData, (char *) #func,GetListWidget,func,XP1); \ break #define ListWidgetBoolAction(func) \ case XCALL_ ## func : \ WidgetBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetXmstringAction(func) \ case XCALL_ ## func : \ WidgetXmstringAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetXmstringlistAction(func) \ case XCALL_ ## func : \ WidgetXmstringlistAction(taskData, (char *) #func,GetListWidget,func,XP1,(ML_Cons_Cell *)XP2); \ break #define ListWidgetIntAction(func) \ case XCALL_ ## func : \ WidgetIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2); \ break #define ListWidgetIntIntAction(func) \ case XCALL_ ## func : \ WidgetIntIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringIntAction(func) \ case XCALL_ ## func : \ WidgetXmstringIntAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetIntBoolAction(func) \ case XCALL_ ## func : \ WidgetIntBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringBoolAction(func) \ case XCALL_ ## func : \ WidgetXmstringBoolAction(taskData, (char *) #func,GetListWidget,func,XP1,P2,P3); \ break #define ListWidgetXmstringlistIntAction(func) \ case XCALL_ ## func : \ WidgetXmstringlistIntAction(taskData, (char *) #func,GetListWidget,func,XP1,(ML_Cons_Cell *)XP2,P3); \ break #define ListWidgetXmstringToIntlist(func) \ case XCALL_ ## func : \ return(WidgetXmstringToIntlist(taskData, (char *) #func,GetListWidget,func,XP1,P2)) #define ListWidgetToIntlist(func) \ case XCALL_ ## func : \ return(WidgetToIntlist(taskData, (char *) #func,GetListWidget,func,XP1)) #define ListWidgetXmstringToBool(func) \ case XCALL_ ## func : \ return(WidgetXmstringToBool(taskData, (char *) #func,GetListWidget,func,XP1,P2)) #define ListWidgetXmstringToInt(func) \ case XCALL_ ## func : \ return(WidgetXmstringToInt(taskData, (char *) #func,GetListWidget,func,XP1,P2)) /************************* Adding Items to List *******************************/ ListWidgetXmstringIntAction(XmListAddItem); ListWidgetXmstringIntAction(XmListAddItemUnselected); ListWidgetXmstringlistIntAction(XmListAddItems); /************************* Deleting Items from List ***************************/ ListWidgetAction(XmListDeleteAllItems); ListWidgetXmstringAction(XmListDeleteItem); ListWidgetXmstringlistAction(XmListDeleteItems); ListWidgetIntAction(XmListDeletePos); ListWidgetIntIntAction(XmListDeleteItemsPos); /************************* Deselecting Items **********************************/ ListWidgetAction(XmListDeselectAllItems); ListWidgetXmstringAction(XmListDeselectItem); ListWidgetIntAction(XmListDeselectPos); /************************* Query Functions ************************************/ ListWidgetXmstringToIntlist(XmListGetMatchPos); ListWidgetToIntlist(XmListGetSelectedPos); ListWidgetXmstringToBool(XmListItemExists); ListWidgetXmstringToInt(XmListItemPos); /************************* Replacing Items in the List ************************/ case XCALL_XmListReplaceItems: /* Unpairing the strings is done in the ML, because it's easier there. */ { Widget w = GetListWidget(taskData, (char *) "XmListReplaceItems",XP1); unsigned n = ListLength(P2); unsigned n2 = ListLength(P3); if (n != n2) { RaiseXWindows(taskData, "XmListReplaceItems: strings lists are different lengths"); } else { XmString *oldstrings = (XmString *)alloca(n * sizeof(XmString)); XmString *newstrings = (XmString *)alloca(n * sizeof(XmString)); GetList4(taskData, P2,oldstrings,sizeof(XmString),GetXmString); GetList4(taskData, P3,newstrings,sizeof(XmString),GetXmString); XmListReplaceItems(w,oldstrings,n,newstrings); for (unsigned i = 0; i < n; i ++) XmStringFree(oldstrings[i]); for (unsigned i = 0; i < n; i ++) XmStringFree(newstrings[i]); } break; } ListWidgetXmstringlistIntAction(XmListReplaceItemsPos); /************************* Selecting Items in the List ************************/ ListWidgetXmstringBoolAction(XmListSelectItem); ListWidgetIntBoolAction(XmListSelectPos); /************************* Set Add Mode ***************************************/ ListWidgetBoolAction(XmListSetAddMode); /************************* Set Appearance *************************************/ ListWidgetXmstringAction(XmListSetBottomItem); ListWidgetIntAction(XmListSetBottomPos); ListWidgetIntAction(XmListSetHorizPos); ListWidgetXmstringAction(XmListSetItem); ListWidgetIntAction(XmListSetPos); #undef ListWidgetAction #undef ListWidgetBoolAction #undef ListWidgetXmstringAction #undef ListWidgetXmstringlistAction #undef ListWidgetIntAction #undef ListWidgetIntIntAction #undef ListWidgetXmstringIntAction #undef ListWidgetXmstringBoolAction #undef ListWidgetXmstringlistIntAction #undef ListWidgetXmstringToIntlist #undef ListWidgetToIntlist #undef ListWidgetXmstringToBool #undef ListWidgetXmstringToInt /* Calls added by DCJM. */ case XCALL_XmMenuPosition: MenuPosition( GetWidget(taskData, XP1), get_C_ulong(taskData, P2), get_C_ulong(taskData, P3)); break; /******************************************************************************/ /* */ /* Default case */ /* */ /******************************************************************************/ default: Crash ("Unimplemented X Windows call %d", code); } return Make_bool(False); } typedef struct { int code; const char *name; } CodeName; static CodeName ProtocolNames[] = { { X_CreateWindow,"XCreateWindow"}, { X_ChangeWindowAttributes,"XChangeWindowAttributes"}, { X_GetWindowAttributes,"XGetWindowAttributes"}, { X_DestroyWindow,"XDestroyWindow"}, { X_DestroySubwindows,"XDestroySubwindows"}, { X_ChangeSaveSet,"XChangeSAVESet"}, { X_ReparentWindow,"XReparentWindow"}, { X_MapWindow,"XMapWindow"}, { X_MapSubwindows,"XMapSubwindows"}, { X_UnmapWindow,"XUnmapWindow"}, { X_UnmapSubwindows,"XUnmapSubwindows"}, { X_ConfigureWindow,"XConfigureWindow"}, { X_CirculateWindow,"XCirculateWindow"}, { X_GetGeometry,"XGetGeometry"}, { X_QueryTree,"XQueryTree"}, { X_InternAtom,"XInternAtom"}, { X_GetAtomName,"XGetAtomName"}, { X_ChangeProperty,"XChangeProperty"}, { X_DeleteProperty,"XDeleteProperty"}, { X_GetProperty,"XGetProperty"}, { X_ListProperties,"XListProperties"}, { X_SetSelectionOwner,"XSetSelectionOwner"}, { X_GetSelectionOwner,"XGetSelectionOwner"}, { X_ConvertSelection,"XConvertSelection"}, { X_SendEvent,"XSendEvent"}, { X_GrabPointer,"XGrabPointer"}, { X_UngrabPointer,"XUngrabPointer"}, { X_GrabButton,"XGrabButton"}, { X_UngrabButton,"XUngrabButton"}, { X_ChangeActivePointerGrab,"XChangeActivePointerGrab"}, { X_GrabKeyboard,"XGrabKeyboard"}, { X_UngrabKeyboard,"XUngrabKeyboard"}, { X_GrabKey,"XGrabKey"}, { X_UngrabKey,"XUngrabKey"}, { X_AllowEvents,"XAllowEvents"}, { X_GrabServer,"XGrabServer"}, { X_UngrabServer,"XUngrabServer"}, { X_QueryPointer,"XQueryPointer"}, { X_GetMotionEvents,"XGetMotionEvents"}, { X_TranslateCoords,"XTranslateCoords"}, { X_WarpPointer,"XWarpPointer"}, { X_SetInputFocus,"XSetInputFocus"}, { X_GetInputFocus,"XGetInputFocus"}, { X_QueryKeymap,"XQueryKeymap"}, { X_OpenFont,"XOpenFont"}, { X_CloseFont,"XCloseFont"}, { X_QueryFont,"XQueryFont"}, { X_QueryTextExtents,"XQueryTextExtents"}, { X_ListFonts,"XListFonts"}, { X_ListFontsWithInfo,"XListFontsWithInfo"}, { X_SetFontPath,"XSetFontPath"}, { X_GetFontPath,"XGetFontPath"}, { X_CreatePixmap,"XCreatePixmap"}, { X_FreePixmap,"XFreePixmap"}, { X_CreateGC,"XCreateGC"}, { X_ChangeGC,"XChangeGC"}, { X_CopyGC,"XCopyGC"}, { X_SetDashes,"XSetDashes"}, { X_SetClipRectangles,"XSetClipRectangles"}, { X_FreeGC,"XFreeGC"}, { X_ClearArea,"XClearArea"}, { X_CopyArea,"XCopyArea"}, { X_CopyPlane,"XCopyPlane"}, { X_PolyPoint,"XPolyPoint"}, { X_PolyLine,"XPolyLine"}, { X_PolySegment,"XPolySegment"}, { X_PolyRectangle,"XPolyRectangle"}, { X_PolyArc,"XPolyArc"}, { X_FillPoly,"XFillPoly"}, { X_PolyFillRectangle,"XPolyFillRectangle"}, { X_PolyFillArc,"XPolyFillArc"}, { X_PutImage,"XPutImage"}, { X_GetImage,"XGetImage"}, { X_PolyText8,"XPolyText8"}, { X_PolyText16,"XPolyText16"}, { X_ImageText8,"XImageText8"}, { X_ImageText16,"XImageText16"}, { X_CreateColormap,"XCreateColormap"}, { X_FreeColormap,"XFreeColormap"}, { X_CopyColormapAndFree,"XCopyColormapAndFree"}, { X_InstallColormap,"XInstallColormap"}, { X_UninstallColormap,"XUninstallColormap"}, { X_ListInstalledColormaps,"XListInstalledColormaps"}, { X_AllocColor,"XAllocColor"}, { X_AllocNamedColor,"XAllocNamedColor"}, { X_AllocColorCells,"XAllocColorCells"}, { X_AllocColorPlanes,"XAllocColorPlanes"}, { X_FreeColors,"XFreeColors"}, { X_StoreColors,"XStoreColors"}, { X_StoreNamedColor,"XStoreNamedColor"}, { X_QueryColors,"XQueryColors"}, { X_LookupColor,"XLookupColor"}, { X_CreateCursor,"XCreateCursor"}, { X_CreateGlyphCursor,"XCreateGlyphCursor"}, { X_FreeCursor,"XFreeCursor"}, { X_RecolorCursor,"XRecolorCursor"}, { X_QueryBestSize,"XQueryBestSize"}, { X_QueryExtension,"XQueryExtension"}, { X_ListExtensions,"XListExtensions"}, { X_ChangeKeyboardMapping,"XChangeKeyboardMapping"}, { X_GetKeyboardMapping,"XGetKeyboardMapping"}, { X_ChangeKeyboardControl,"XChangeKeyboardControl"}, { X_GetKeyboardControl,"XGetKeyboardControl"}, { X_Bell,"XBell"}, { X_ChangePointerControl,"XChangePointerControl"}, { X_GetPointerControl,"XGetPointerControl"}, { X_SetScreenSaver,"XSetScreenSaver"}, { X_GetScreenSaver,"XGetScreenSaver"}, { X_ChangeHosts,"XChangeHosts"}, { X_ListHosts,"XListHosts"}, { X_SetAccessControl,"XSetAccessControl"}, { X_SetCloseDownMode,"XSetCloseDownMode"}, { X_KillClient,"XKillClient"}, { X_RotateProperties,"XRotateProperties"}, { X_ForceScreenSaver,"XForceScreenSaver"}, { X_SetPointerMapping,"XSetPointerMapping"}, { X_GetPointerMapping,"XGetPointerMapping"}, { X_SetModifierMapping,"XSetModifierMapping"}, { X_GetModifierMapping,"XGetModifierMapping"}, { X_NoOperation,"XNoOperation"} }; static CodeName ProtocolErrors[] = { { Success,"Success"}, { BadRequest,"BadRequest"}, { BadValue,"BadValue"}, { BadWindow,"BadWindow"}, { BadPixmap,"BadPixmap"}, { BadAtom,"BadAtom"}, { BadCursor,"BadCursor"}, { BadFont,"BadFont"}, { BadMatch,"BadMatch"}, { BadDrawable,"BadDrawable"}, { BadAccess,"BadAccess"}, { BadAlloc,"BadAlloc"}, { BadColor,"BadColor"}, { BadGC,"BadGC"}, { BadIDChoice,"BadIDChoice"}, { BadName,"BadName"}, { BadLength,"BadLength"}, { BadImplementation,"BadImplementation"} }; static int XWindowsError(Display *display, XErrorEvent *error) { const char *errorName = "unknown"; const char *requestName = "unknown"; int i,n; char buffer[500]; n = sizeof(ProtocolErrors) / sizeof(ProtocolErrors[0]); for(i = 0; i < n; i++) { if (ProtocolErrors[i].code == error->error_code) { errorName = ProtocolErrors[i].name; } } n = sizeof(ProtocolNames) / sizeof(ProtocolNames[0]); for(i = 0; i < n; i++) { if (ProtocolNames[i].code == error->request_code) { requestName = ProtocolNames[i].name; } } sprintf(buffer,"%s in %s",errorName,requestName); printf("\nX Error %s\n\n", buffer); #if NEVER /* Raise exception if we are running in synchronous mode */ if (display->private15) RaiseXWindows(taskData, buffer); #endif return 0; /* DUMMY value - SPF 6/1/94 */ } struct _entrypts xwindowsEPT[] = { { "PolyXWindowsGeneral", (polyRTSFunction)&PolyXWindowsGeneral}, { NULL, NULL} // End of list. }; class XWinModule: public RtsModule { public: virtual void Init(void); void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static XWinModule xwinModule; void XWinModule::GarbageCollect(ScanAddress *process) { /* Process all the objects in the list. If an object */ /* is not found from outside then it is removed. */ T_List **T = &TList; C_List **C = &CList; int i; /* process all XList headers */ for (i = 0; i < XLISTSIZE; i++) { X_List *L = XList[i]; while(L) { PolyObject *P = L->object; /* copy object pointer */ X_List *N = L->next; /* copy next pointer */ process->ScanRuntimeAddress(&P, ScanAddress::STRENGTH_WEAK); /* P may have been moved, or overwritten with a 0 if not accessible */ if (P == 0) DestroyXObject(L->object); else L->object = (X_Object*)P; L = N; } } /* Process the timeout/message list */ while (*T) { T_List *t = *T; process->ScanRuntimeAddress(&t->alpha, ScanAddress::STRENGTH_STRONG); process->ScanRuntimeAddress(&t->handler, ScanAddress::STRENGTH_STRONG); PolyObject *obj = t->window_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_WEAK); t->window_object = (X_Window_Object*)obj; obj = t->widget_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); t->widget_object = (X_Widget_Object*)obj; // DCJM: I don't understand this. The widget entry will never go // to zero since it's strong not weak. if (t->window_object == 0 && t->widget_object == 0) { *T = t->next; free(t); } else T = &t->next; } /* Process the callback list */ while(*C) { C_List *c = *C; process->ScanRuntimeAddress(&c->function, ScanAddress::STRENGTH_STRONG); PolyObject *obj = c->widget_object; process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); c->widget_object = (X_Widget_Object*)obj; /* DCJM: This doesn't make sense. The widget entry will only go to zero if the G.C. operation was weak, not strong as in the line above. */ if (c->widget_object == 0) { *C = c->next; free(c); } else C = &c->next; } /* Process the callback waiting list */ if (! FList.IsTagged()) { PolyObject *obj = FList.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); FList = obj; } /* and the Xt event waiting list. */ if (! GList.IsTagged()) { PolyObject *obj = GList.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG) ; GList = obj; } } void XWinModule::Init(void) { initXList(); /* added 9/12/93 SPF */ XtToolkitThreadInitialize(); XtToolkitInitialize(); XSetErrorHandler(XWindowsError); } -POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params) +POLYUNSIGNED PolyXWindowsGeneral(POLYUNSIGNED threadId, POLYUNSIGNED params) { TaskData *taskData = TaskData::FindTaskForId(threadId); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(params); Handle result = 0; try { result = XWindows_c(taskData, pushedArg); } catch (KillException &) { processes->ThreadExit(taskData); // May test for kill } 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(); } #else // We haven't got X or we haven't got Motif #include "globals.h" #include "run_time.h" #include "sys.h" #include "save_vec.h" #include "machine_dep.h" #include "processes.h" #include "rtsentry.h" #include "xwindows.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord params); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(POLYUNSIGNED threadId, POLYUNSIGNED params); } Handle XWindows_c(TaskData *taskData, Handle/*params*/) { raise_exception_string(taskData, EXC_XWindows, "Not implemented"); /*NOTREACHED*/ return taskData->saveVec.push(TAGGED(0)); /* just to keep lint happy */ } -POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord /*params*/) +POLYUNSIGNED PolyXWindowsGeneral(POLYUNSIGNED threadId, POLYUNSIGNED /*params*/) { TaskData *taskData = TaskData::FindTaskForId(threadId); taskData->PreRTSCall(); try { raise_exception_string(taskData, EXC_XWindows, "Not implemented"); } catch (...) { } // Handle the C++ exception taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Return unit since we're raising an exception } struct _entrypts xwindowsEPT[] = { { "PolyXWindowsGeneral", (polyRTSFunction)&PolyXWindowsGeneral}, { NULL, NULL} // End of list. }; #endif