diff --git a/libpolyml/arb.cpp b/libpolyml/arb.cpp index a1878363..eba4cee7 100644 --- a/libpolyml/arb.cpp +++ b/libpolyml/arb.cpp @@ -1,2033 +1,2033 @@ /* 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(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolySubtractArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyMultiplyArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyDivideArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRemainderArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyQuotRemArbitraryPair(PolyObject *threadId, PolyWord arg1, PolyWord arg2); + 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(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLCMArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLowOrderAsLargeWord(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyOrArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyAndArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyXorArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGCDArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLCMArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLowOrderAsLargeWord(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyOrArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyAndArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXorArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2); } static Handle add_longc(TaskData *taskData, Handle,Handle); static Handle sub_longc(TaskData *taskData, Handle,Handle); static Handle 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, (byte*)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); byte *long_y = 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(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyAddArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // Could raise an exception if out of memory. result = add_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolySubtractArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolySubtractArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = sub_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyMultiplyArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyMultiplyArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = mult_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyDivideArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyDivideArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // May raise divide exception result = div_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyRemainderArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyRemainderArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { result = rem_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This is the older version that took a container as an argument. -POLYUNSIGNED PolyQuotRemArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3) +POLYUNSIGNED PolyQuotRemArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); // arg3 is an address on the stack. It is not a PolyWord. if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // The result handle will almost certainly point into the stack. // This should now be safe within the GC. Handle remHandle, divHandle; quotRem(taskData, pushedArg2, pushedArg1, remHandle, divHandle); arg3.AsObjPtr()->Set(0, divHandle->Word()); arg3.AsObjPtr()->Set(1, remHandle->Word()); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return 0; // Result is unit } // This is the newer version that returns a pair. It's simpler and works with 32-in-64. -POLYUNSIGNED PolyQuotRemArbitraryPair(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyQuotRemArbitraryPair(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; // arg3 is an address on the stack. It is not a PolyWord. if (profileMode == kProfileEmulation) taskData->addProfileCount(1); try { // The result handle will almost certainly point into the stack. // This should now be safe within the GC. Handle remHandle, divHandle; quotRem(taskData, pushedArg2, pushedArg1, remHandle, divHandle); result = alloc_and_save(taskData, 2); result->WordP()->Set(0, divHandle->Word()); result->WordP()->Set(1, remHandle->Word()); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This can be a fast call. It does not need to allocate or use handles. POLYSIGNED PolyCompareArbitrary(PolyWord arg1, PolyWord arg2) { return TAGGED(compareLong(arg2, arg1)).AsSigned(); } -POLYUNSIGNED PolyGCDArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyGCDArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { result = gcd_arbitrary(taskData, pushedArg2, pushedArg1); // Generally shouldn't raise an exception but might run out of store. } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyLCMArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyLCMArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { result = lcm_arbitrary(taskData, pushedArg2, pushedArg1); // Generally shouldn't raise an exception but might run out of store. } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Extract the low order part of an arbitrary precision value as a boxed LargeWord.word // value. If the value is negative it is treated as a twos complement value. // This is used Word.fromLargeInt and LargeWord.fromLargeInt with long-form // arbitrary precision values. -POLYUNSIGNED PolyGetLowOrderAsLargeWord(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyGetLowOrderAsLargeWord(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); uintptr_t p = 0; if (arg.IsTagged()) p = arg.UnTagged(); else { bool negative = OBJ_IS_NEGATIVE(GetLengthWord(arg)) ? true : false; #ifdef USE_GMP mp_limb_t c = *(mp_limb_t*)arg.AsCodePtr(); p = c; #else POLYUNSIGNED length = get_length(arg); if (length > sizeof(uintptr_t)) length = sizeof(uintptr_t); byte *ptr = arg.AsCodePtr(); while (length--) { p = (p << 8) | ptr[length]; } #endif if (negative) p = 0-p; } Handle result = 0; try { result = Make_sysword(taskData, p); } catch (...) {} // We could run out of memory. taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyOrArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyOrArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = or_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyAndArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyAndArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = and_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyXorArbitrary(PolyObject *threadId, PolyWord arg1, PolyWord arg2) +POLYUNSIGNED PolyXorArbitrary(FirstArgument threadId, PolyWord arg1, PolyWord arg2) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg1 = taskData->saveVec.push(arg1); Handle pushedArg2 = taskData->saveVec.push(arg2); Handle result = 0; try { // Could raise an exception if out of memory. result = xor_longc(taskData, pushedArg2, pushedArg1); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts arbitraryPrecisionEPT[] = { { "PolyAddArbitrary", (polyRTSFunction)&PolyAddArbitrary}, { "PolySubtractArbitrary", (polyRTSFunction)&PolySubtractArbitrary}, { "PolyMultiplyArbitrary", (polyRTSFunction)&PolyMultiplyArbitrary}, { "PolyDivideArbitrary", (polyRTSFunction)&PolyDivideArbitrary}, { "PolyRemainderArbitrary", (polyRTSFunction)&PolyRemainderArbitrary}, { "PolyQuotRemArbitrary", (polyRTSFunction)&PolyQuotRemArbitrary}, { "PolyQuotRemArbitraryPair", (polyRTSFunction)&PolyQuotRemArbitraryPair }, { "PolyCompareArbitrary", (polyRTSFunction)&PolyCompareArbitrary}, { "PolyGCDArbitrary", (polyRTSFunction)&PolyGCDArbitrary}, { "PolyLCMArbitrary", (polyRTSFunction)&PolyLCMArbitrary}, { "PolyGetLowOrderAsLargeWord", (polyRTSFunction)&PolyGetLowOrderAsLargeWord}, { "PolyOrArbitrary", (polyRTSFunction)&PolyOrArbitrary}, { "PolyAndArbitrary", (polyRTSFunction)&PolyAndArbitrary}, { "PolyXorArbitrary", (polyRTSFunction)&PolyXorArbitrary}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/basicio.cpp b/libpolyml/basicio.cpp index 6d79025b..e9d3e070 100644 --- a/libpolyml/basicio.cpp +++ b/libpolyml/basicio.cpp @@ -1,1106 +1,1106 @@ /* Title: Basic IO. Copyright (c) 2000, 2015-2019 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(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(PolyObject *threadId, PolyWord code, PolyWord strm, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(PolyObject *threadId, PolyWord streamVec, PolyWord bitVec, PolyWord maxMillisecs); + 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); } 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. 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) { // Legacy: During the bootstrap we may have old file descriptors for // the standard streams which are tagged integers. if (strm.IsTagged()) return strm.UnTagged(); return *(int*)(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); *(int*)(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) { if (nDescr == 0) pollResult = 0; else { if (maxTime < maxMillisecs) maxMillisecs = maxTime; pollResult = poll(fdVec, nDescr, maxMillisecs); if (pollResult < 0) errorResult = ERRORNUMBER; } } -POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(PolyObject *threadId, PolyWord streamVector, PolyWord bitVector, PolyWord maxMillisecs) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVector, PolyWord bitVector, PolyWord 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(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord 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 */ // Legacy: During the bootstrap we will have old format references. if (strm->Word().IsTagged()) return Make_fixed_precision(taskData, 0); 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. */ { 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(PolyObject *threadId, PolyWord code, PolyWord strm, PolyWord arg) +POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord 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(); } struct _entrypts basicIOEPT[] = { { "PolyChDir", (polyRTSFunction)&PolyChDir}, { "PolyBasicIOGeneral", (polyRTSFunction)&PolyBasicIOGeneral}, { "PolyPollIODescriptors", (polyRTSFunction)&PolyPollIODescriptors }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/exporter.cpp b/libpolyml/exporter.cpp index 65a3e714..3d2285bc 100644 --- a/libpolyml/exporter.cpp +++ b/libpolyml/exporter.cpp @@ -1,913 +1,913 @@ /* Title: exporter.cpp - Export a function as an object or C file Copyright (c) 2006-7, 2015, 2016-19 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) && ! defined(__CYGWIN__)) #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) && ! defined(__CYGWIN__)) #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #define ERRORNUMBER _doserrno #else #define NOMEMORY ENOMEM #define ERRORNUMBER errno #endif extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyExport(PolyObject *threadId, PolyWord fileName, PolyWord root); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyExportPortable(PolyObject *threadId, PolyWord fileName, PolyWord root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord 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.SpaceForAddress((PolyWord*)obj - 1); 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 words = OBJ_OBJECT_LENGTH(lengthWord); PolyObject *newObj = 0; bool isMutableObj = obj->IsMutable(); bool isNoOverwrite = false; bool isByteObj = false; bool isCodeObj = false; if (isMutableObj) { isNoOverwrite = obj->IsNoOverwriteObject(); isByteObj = obj->IsByteObject(); } else isCodeObj = obj->IsCodeObject(); // Allocate a new address for the object. for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { PermanentMemSpace *space = *i; if (isMutableObj == space->isMutable && isNoOverwrite == space->noOverwrite && isByteObj == space->byteOnly && isCodeObj == space->isCode) { 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->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; if (isMutableObj) { if (isNoOverwrite) spaceWords = defaultNoOverSize; else spaceWords = defaultMutSize; } else { if (isCodeObj) spaceWords = defaultCodeSize; else spaceWords = defaultImmSize; } if (spaceWords <= words) spaceWords = words + 1; // Make sure there's space for this object. PermanentMemSpace *space = gMem.NewExportSpace(spaceWords, isMutableObj, isNoOverwrite, isCodeObj); if (isByteObj) space->byteOnly = 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->topPointer = PolyWord::FromUnsigned(0); space->topPointer++; } #endif ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom); } newObj->SetLengthWord(lengthWord); // copy length word memcpy(newObj, 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 (isCodeObj) { 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. } #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. else if (isCodeObj) { POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj-globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT); obj->SetLengthWord(ll); } #endif else obj->SetForwardingPtr(newObj); // Put forwarding pointer in old object. if (OBJ_IS_CODE_OBJECT(lengthWord)) { // We don't need to worry about flushing the instruction cache // since we're not going to execute this code here. // We do 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. machineDependent->ScanConstantsWithinCode(newObj, obj, words, this); } *pt = newObj; // Update it to the newly copied object. return lengthWord; // This new object needs to be scanned. } // 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.SpaceForAddress((PolyWord*)obj - 1); 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.SpaceForAddress((PolyWord*)forwardedTo-1); if (space->spaceType == ST_EXPORT) 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) 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) && ! defined(__CYGWIN__)) 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(PolyObject *threadId, PolyWord fileName, PolyWord root) +POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord 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) && ! defined(__CYGWIN__)) 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(PolyObject *threadId, PolyWord fileName, PolyWord root) +POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord 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 } // 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() ); p->GetConstSegmentForCode(cp, constCount); /* Now the constants. */ for (POLYUNSIGNED i = 0; i < constCount; i++) relocateValue(&(cp[i])); } else if (p->IsClosureObject()) { #ifndef POLYML32IN64 ASSERT(0); #endif // This should only be used in 32-in-64 where we don't use relocations. } else /* Ordinary objects, essentially tuples. */ { 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; strings = (char*)realloc(strings, stringAvailable); if (strings == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to realloc string table, size: %lu.\n", stringAvailable); throw MemoryException(); } } 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 021df832..33c46875 100644 --- a/libpolyml/network.cpp +++ b/libpolyml/network.cpp @@ -1,1653 +1,1653 @@ /* 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 #ifndef HAVE_SOCKLEN_T typedef int socklen_t; #endif #if (defined(_WIN32) && ! defined(__CYGWIN__)) #include #else typedef int SOCKET; #endif #ifdef HAVE_WINDOWS_H #include #endif #include #ifdef max #undef max #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 PolyNetworkGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByName(PolyObject *threadId, PolyWord servName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(PolyObject *threadId, PolyWord servName, PolyWord protName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPort(PolyObject *threadId, PolyWord portNo); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(PolyObject *threadId, PolyWord portNo, PolyWord protName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByName(PolyObject *threadId, PolyWord protocolName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByNo(PolyObject *threadId, PolyWord protoNo); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostName(PolyObject *threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostByName(PolyObject *threadId, PolyWord hostName); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostByAddr(PolyObject *threadId, PolyWord hostAddr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCloseSocket(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(PolyObject *threadId, PolyWord fdVecTriple, PolyWord maxMillisecs); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSocketError(PolyObject *threadId, PolyWord skt); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(PolyObject *threadId, PolyWord skt, PolyWord addr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(PolyObject *threadId, PolyWord skt); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(PolyObject *threadId, PolyWord args); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(PolyObject *threadId, PolyWord args); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(PolyObject *threadId, PolyWord args); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(PolyObject *threadId, PolyWord args); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGeneral(FirstArgument threadId, PolyWord code, 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 PolyNetworkGetHostByName(FirstArgument threadId, PolyWord hostName); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostByAddr(FirstArgument threadId, PolyWord hostAddr); + 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); } #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) && ! defined(__CYGWIN__)) 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 }, #endif #ifdef AF_NATM { "NATM", AF_NATM }, #endif #ifdef AF_ATM { "ATM", AF_ATM }, #endif #ifdef AF_NETGRAPH { "NETGRAPH", AF_NETGRAPH }, #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 } }; static Handle makeHostEntry(TaskData *taskData, struct hostent *host); 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 args, int level, int opt); static Handle getSocketOption(TaskData *taskData, Handle args, int level, int opt); static Handle getSocketInt(TaskData *taskData, Handle args, int level, int opt); #if (defined(_WIN32) && ! defined(__CYGWIN__)) #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) && ! defined(__CYGWIN__)) 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 Net_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, code->Word()); Handle hSave = taskData->saveVec.mark(); TryAgain: // Used for various retries. // N.B. If we call ThreadPause etc we may GC. We MUST reload any handles so for // safety we always come back here. switch (c) { case 11: { /* Return a list of known address families. */ return makeList(taskData, sizeof(af_table)/sizeof(af_table[0]), (char*)af_table, sizeof(af_table[0]), 0, mkAftab); } case 12: { /* Return a list of known socket types. */ return makeList(taskData, sizeof(sk_table)/sizeof(sk_table[0]), (char*)sk_table, sizeof(sk_table[0]), 0, mkSktab); } case 13: /* Return the "any" internet address. */ return Make_arbitrary_precision(taskData, INADDR_ANY); case 14: /* Create a socket */ { int af = get_C_int(taskData, DEREFHANDLE(args)->Get(0)); int type = get_C_int(taskData, DEREFHANDLE(args)->Get(1)); int proto = get_C_int(taskData, DEREFHANDLE(args)->Get(2)); SOCKET skt = socket(af, type, proto); if (skt == INVALID_SOCKET) { switch (GETERROR) { case CALLINTERRUPTED: taskData->saveVec.reset(hSave); goto TryAgain; default: 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); } return wrapStreamSocket(taskData, skt); } case 15: /* Set TCP No-delay option. */ return setSocketOption(taskData, args, IPPROTO_TCP, TCP_NODELAY); case 16: /* Get TCP No-delay option. */ return getSocketOption(taskData, args, IPPROTO_TCP, TCP_NODELAY); case 17: /* Set Debug option. */ return setSocketOption(taskData, args, SOL_SOCKET, SO_DEBUG); case 18: /* Get Debug option. */ return getSocketOption(taskData, args, SOL_SOCKET, SO_DEBUG); case 19: /* Set REUSEADDR option. */ return setSocketOption(taskData, args, SOL_SOCKET, SO_REUSEADDR); case 20: /* Get REUSEADDR option. */ return getSocketOption(taskData, args, SOL_SOCKET, SO_REUSEADDR); case 21: /* Set KEEPALIVE option. */ return setSocketOption(taskData, args, SOL_SOCKET, SO_KEEPALIVE); case 22: /* Get KEEPALIVE option. */ return getSocketOption(taskData, args, SOL_SOCKET, SO_KEEPALIVE); case 23: /* Set DONTROUTE option. */ return setSocketOption(taskData, args, SOL_SOCKET, SO_DONTROUTE); case 24: /* Get DONTROUTE option. */ return getSocketOption(taskData, args, SOL_SOCKET, SO_DONTROUTE); case 25: /* Set BROADCAST option. */ return setSocketOption(taskData, args, SOL_SOCKET, SO_BROADCAST); case 26: /* Get BROADCAST option. */ return getSocketOption(taskData, args, SOL_SOCKET, SO_BROADCAST); case 27: /* Set OOBINLINE option. */ return setSocketOption(taskData, args, SOL_SOCKET, SO_OOBINLINE); case 28: /* Get OOBINLINE option. */ return getSocketOption(taskData, args, SOL_SOCKET, SO_OOBINLINE); case 29: /* Set SNDBUF size. */ return setSocketOption(taskData, args, SOL_SOCKET, SO_SNDBUF); case 30: /* Get SNDBUF size. */ return getSocketInt(taskData, args, SOL_SOCKET, SO_SNDBUF); case 31: /* Set RCVBUF size. */ return setSocketOption(taskData, args, SOL_SOCKET, SO_RCVBUF); case 32: /* Get RCVBUF size. */ return getSocketInt(taskData, args, SOL_SOCKET, SO_RCVBUF); case 33: /* Get socket type e.g. SOCK_STREAM. */ return getSocketInt(taskData, args, SOL_SOCKET, SO_TYPE); case 34: /* Get error status and clear it. */ return getSocketOption(taskData, args, SOL_SOCKET, SO_ERROR); case 35: /* Set Linger time. */ { struct linger linger; SOCKET skt = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); int lTime = get_C_int(taskData, DEREFHANDLE(args)->Get(1)); /* 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); return Make_arbitrary_precision(taskData, 0); } case 36: /* Get Linger time. */ { struct linger linger; SOCKET skt = getStreamSocket(taskData, args->Word()); socklen_t size = sizeof(linger); int lTime = 0; 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; return Make_arbitrary_precision(taskData, lTime); } case 37: /* Get peer name. */ { SOCKET skt = getStreamSocket(taskData, args->Word()); 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. */ return(SAVE(C_string_to_Poly(taskData, (char*)&sockA, size))); } case 38: /* Get socket name. */ { SOCKET skt = getStreamSocket(taskData, args->Word()); 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); return(SAVE(C_string_to_Poly(taskData, (char*)&sockA, size))); } case 39: /* Return the address family from an address. */ { PolyStringObject *psAddr = (PolyStringObject *)args->WordP(); struct sockaddr *psock = (struct sockaddr *)&psAddr->chars; return Make_arbitrary_precision(taskData, psock->sa_family); } case 40: /* Create a socket address from a port number and internet address. */ { struct sockaddr_in sockaddr; memset(&sockaddr, 0, sizeof(sockaddr)); sockaddr.sin_family = AF_INET; sockaddr.sin_port = htons(get_C_ushort(taskData, DEREFHANDLE(args)->Get(0))); sockaddr.sin_addr.s_addr = htonl(get_C_unsigned(taskData, DEREFHANDLE(args)->Get(1))); return(SAVE(C_string_to_Poly(taskData, (char*)&sockaddr, sizeof(sockaddr)))); } case 41: /* Return port number from an internet socket address. Assumes that we've already checked the address family. */ { PolyStringObject *psAddr = (PolyStringObject *)args->WordP(); struct sockaddr_in *psock = (struct sockaddr_in *)&psAddr->chars; return Make_arbitrary_precision(taskData, ntohs(psock->sin_port)); } case 42: /* Return internet address from an internet socket address. Assumes that we've already checked the address family. */ { PolyStringObject * psAddr = (PolyStringObject *)args->WordP(); struct sockaddr_in *psock = (struct sockaddr_in *)&psAddr->chars; return Make_arbitrary_precision(taskData, ntohl(psock->sin_addr.s_addr)); } /* 43 - Set non-blocking mode. Now removed. */ case 44: /* Find number of bytes available. */ { SOCKET skt = getStreamSocket(taskData, args->Word()); #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 return Make_arbitrary_precision(taskData, readable); } case 45: /* Find out if we are at the mark. */ { SOCKET skt = getStreamSocket(taskData, args->Word()); #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 return Make_arbitrary_precision(taskData, atMark == 0 ? 0 : 1); } case 47: /* Bind an address to a socket. */ { SOCKET skt = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); PolyStringObject * psAddr = (PolyStringObject *)args->WordP()->Get(1).AsObjPtr(); struct sockaddr *psock = (struct sockaddr *)&psAddr->chars; if (bind(skt, psock, (int)psAddr->length) != 0) raise_syscall(taskData, "bind failed", GETERROR); return Make_arbitrary_precision(taskData, 0); } case 49: /* Put socket into listening mode. */ { SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); int backlog = get_C_int(taskData, DEREFHANDLE(args)->Get(1)); if (listen(sock, backlog) != 0) raise_syscall(taskData, "listen failed", GETERROR); return Make_arbitrary_precision(taskData, 0); } case 50: /* Shutdown the socket. */ { SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); int mode = 0; switch (get_C_ulong(taskData, DEREFHANDLE(args)->Get(1))) { 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); return Make_arbitrary_precision(taskData, 0); } case 55: /* Create a socket pair. */ #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* Not implemented. */ raise_syscall(taskData, "socketpair not implemented", WSAEAFNOSUPPORT); #else { Handle pair; int af = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int type = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int proto = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); int onOff = 1; SOCKET skt[2]; if (socketpair(af, type, proto, skt) != 0) { switch (GETERROR) { case CALLINTERRUPTED: taskData->saveVec.reset(hSave); goto TryAgain; default: raise_syscall(taskData, "socketpair failed", GETERROR); } } /* 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. */ pair = ALLOC(2); DEREFHANDLE(pair)->Set(0, DEREFWORD(str_token1)); DEREFHANDLE(pair)->Set(1, DEREFWORD(str_token2)); return pair; } #endif case 56: /* Create a Unix socket address from a string. */ #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(DEREFWORD(args), addr.sun_path, sizeof(addr.sun_path)); if (length > (int)sizeof(addr.sun_path)) raise_syscall(taskData, "Address too long", ENAMETOOLONG); return SAVE(C_string_to_Poly(taskData, (char*)&addr, sizeof(addr))); } #endif case 57: /* Get the file name from a Unix socket address. */ #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* Not implemented. */ raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT); #else { PolyStringObject * psAddr = (PolyStringObject *)args->WordP(); struct sockaddr_un *psock = (struct sockaddr_un *)&psAddr->chars; return SAVE(C_string_to_Poly(taskData, psock->sun_path)); } #endif default: { char msg[100]; sprintf(msg, "Unknown net function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } static Handle mkAddr(TaskData *taskData, void *arg, char *p) { int j; struct hostent *host = (struct hostent *)arg; unsigned long addr = 0; /* Addresses are in network order so this is fairly easy. In practice they will be 4 byte entries so we could just use ntohl. */ for (j = 0; j < host->h_length; j++) addr = (addr << 8) | ((*(char**)p)[j] & 255); return Make_arbitrary_precision(taskData, addr); } /* Convert a host entry into a tuple for ML. */ static Handle makeHostEntry(TaskData *taskData, struct hostent *host) { /* We need to do all this in the right order. We cannot construct the result tuple until all the values are ready. We have to save each entry on the save stack just in case of a garbage collection. */ int i; char **p; Handle aliases, name, addrType, result; Handle addrList = SAVE(ListNull); /* Canonical name. */ name = SAVE(C_string_to_Poly(taskData, host->h_name)); /* Aliases. */ for (i=0, p = host->h_aliases; *p != NULL; p++, i++); aliases = convert_string_list(taskData, i, host->h_aliases); /* Address type. */ addrType = Make_arbitrary_precision(taskData, host->h_addrtype); /* Addresses. */ /* Count them first and then work from the end back. */ for (i=0, p = host->h_addr_list; *p != NULL; p++, i++); addrList = makeList(taskData, i, (char*)host->h_addr_list, sizeof(char*), host, mkAddr); /* Make the result structure. */ result = ALLOC(4); DEREFHANDLE(result)->Set(0, name->Word()); DEREFHANDLE(result)->Set(1, aliases->Word()); DEREFHANDLE(result)->Set(2, addrType->Word()); DEREFHANDLE(result)->Set(3, addrList->Word()); return result; } 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_arbitrary_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_arbitrary_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_arbitrary_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_arbitrary_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 args, int level, int opt) { SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0)); int onOff = get_C_int(taskData, DEREFHANDLE(args)->Get(1)); if (setsockopt(sock, level, opt, (char*)&onOff, sizeof(int)) != 0) raise_syscall(taskData, "setsockopt failed", GETERROR); return Make_arbitrary_precision(taskData, 0); } /* Get a socket option as a boolean */ static Handle getSocketOption(TaskData *taskData, Handle args, int level, int opt) { SOCKET sock = getStreamSocket(taskData, args->Word()); int onOff = 0; socklen_t size = sizeof(int); if (getsockopt(sock, level, opt, (char*)&onOff, &size) != 0) raise_syscall(taskData, "getsockopt failed", GETERROR); return Make_arbitrary_precision(taskData, onOff == 0 ? 0 : 1); } /* Get a socket option as an integer */ static Handle getSocketInt(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_arbitrary_precision(taskData, optVal); } -POLYUNSIGNED PolyNetworkGetSocketError(PolyObject *threadId, PolyWord skt) +POLYUNSIGNED PolyNetworkGetSocketError(FirstArgument threadId, PolyWord 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); 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(PolyObject *threadId, PolyWord fdVecTriple, PolyWord maxMillisecs) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(FirstArgument threadId, PolyWord fdVecTriple, PolyWord maxMillisecs) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned(); Handle fdVecTripleHandle = taskData->saveVec.push(fdVecTriple); /* Set up the bitmaps for the select call from the arrays. */ try { WaitSelect waitSelect(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(PolyObject *threadId, PolyWord skt, PolyWord addr) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(FirstArgument threadId, PolyWord skt, PolyWord 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()); 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(PolyObject *threadId, PolyWord skt) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(FirstArgument threadId, PolyWord 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); 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(PolyObject *threadId, PolyWord argsAsWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord argsAsWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord argsAsWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord argsAsWord) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(FirstArgument threadId, PolyWord 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_arbitrary_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(); } // General interface to networking. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyNetworkGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyNetworkGeneral(FirstArgument threadId, PolyWord code, PolyWord 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 = Net_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); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetServByName(PolyObject *threadId, PolyWord serviceName) +POLYUNSIGNED PolyNetworkGetServByName(FirstArgument threadId, PolyWord 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)); 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(PolyObject *threadId, PolyWord serviceName, PolyWord protName) +POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(FirstArgument threadId, PolyWord serviceName, PolyWord 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)); 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(PolyObject *threadId, PolyWord portNo) +POLYUNSIGNED PolyNetworkGetServByPort(FirstArgument threadId, PolyWord 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)); 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(PolyObject *threadId, PolyWord portNo, PolyWord protName) +POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(FirstArgument threadId, PolyWord portNo, PolyWord 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)); 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(PolyObject *threadId, PolyWord protocolName) +POLYUNSIGNED PolyNetworkGetProtByName(FirstArgument threadId, PolyWord 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)); 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(PolyObject *threadId, PolyWord protoNo) +POLYUNSIGNED PolyNetworkGetProtByNo(FirstArgument threadId, PolyWord 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); 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(PolyObject *threadId) +POLYUNSIGNED PolyNetworkGetHostName(FirstArgument 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. */ size_t size = 4096; TempCString hostName((char *)malloc(size)); if (hostName == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); int err; while ((err = gethostname(hostName, size)) != 0 && GETERROR == ENAMETOOLONG) { if (size > std::numeric_limits::max() / 2) raise_fail(taskData, "gethostname needs too large a buffer"); size *= 2; char *new_buf = (char *)realloc(hostName, size); if (new_buf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); hostName = new_buf; } if (err != 0) raise_syscall(taskData, "gethostname failed", GETERROR); 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 PolyNetworkGetHostByName(PolyObject *threadId, PolyWord hName) +POLYUNSIGNED PolyNetworkGetHostByName(FirstArgument threadId, PolyWord hName) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Look up a host name. */ TempCString hostName(Poly_string_to_C_alloc(hName)); struct hostent *host = gethostbyname(hostName); // If this fails the ML function returns NONE Handle result = host == NULL ? 0 : makeHostEntry(taskData, host); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkGetHostByAddr(PolyObject *threadId, PolyWord hostAddr) +POLYUNSIGNED PolyNetworkGetHostByAddr(FirstArgument threadId, PolyWord hostAddr) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); /* Look up entry by address. */ unsigned long addr = htonl(get_C_unsigned(taskData, hostAddr)); /* Look up a host name given an address. */ struct hostent *host = gethostbyaddr((char*)&addr, sizeof(addr), AF_INET); Handle result = host == NULL ? 0 : makeHostEntry(taskData, host); taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyNetworkCloseSocket(PolyObject *threadId, PolyWord strm) +POLYUNSIGNED PolyNetworkCloseSocket(FirstArgument threadId, PolyWord 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) && ! defined(__CYGWIN__)) 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(); } struct _entrypts networkingEPT[] = { { "PolyNetworkGeneral", (polyRTSFunction)&PolyNetworkGeneral}, { "PolyNetworkGetServByName", (polyRTSFunction)&PolyNetworkGetServByName}, { "PolyNetworkGetServByNameAndProtocol", (polyRTSFunction)&PolyNetworkGetServByNameAndProtocol}, { "PolyNetworkGetServByPort", (polyRTSFunction)&PolyNetworkGetServByPort}, { "PolyNetworkGetServByPortAndProtocol", (polyRTSFunction)&PolyNetworkGetServByPortAndProtocol}, { "PolyNetworkGetProtByName", (polyRTSFunction)&PolyNetworkGetProtByName}, { "PolyNetworkGetProtByNo", (polyRTSFunction)&PolyNetworkGetProtByNo}, { "PolyNetworkGetHostName", (polyRTSFunction)&PolyNetworkGetHostName}, { "PolyNetworkGetHostByName", (polyRTSFunction)&PolyNetworkGetHostByName}, { "PolyNetworkGetHostByAddr", (polyRTSFunction)&PolyNetworkGetHostByAddr}, { "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 }, { 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) && ! defined(__CYGWIN__)) #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) && ! defined(__CYGWIN__)) if (winsock_init) WSACleanup(); winsock_init = 0; #endif } diff --git a/libpolyml/objsize.cpp b/libpolyml/objsize.cpp index ec2892ac..a39dc18d 100644 --- a/libpolyml/objsize.cpp +++ b/libpolyml/objsize.cpp @@ -1,432 +1,432 @@ /* Title: Object size Copyright (c) 2000 Cambridge University Technical Services Limited Further development David C.J. Matthews 2016, 2017 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(PolyObject *threadId, PolyWord obj); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowSize(PolyObject *threadId, PolyWord obj); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjProfile(PolyObject *threadId, PolyWord obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjSize(FirstArgument threadId, PolyWord obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowSize(FirstArgument threadId, PolyWord obj); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyObjProfile(FirstArgument threadId, PolyWord 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(PolyWord 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(PolyWord p) { for (unsigned i = 0; i < nBitmaps; i++) { VisitBitmap *bm = bitmaps[i]; if (bm->InRange(p.AsStackAddr())) 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 = start->ConstPtrForCode(); 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; } } 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; p->GetConstSegmentForCode(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(PolyObject *threadId, PolyWord obj) +POLYUNSIGNED PolyObjSize(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(false); if (!obj.IsTagged()) process.ScanObjectAddress(obj.AsObjPtr()); Handle result = Make_arbitrary_precision(taskData, process.total_length); taskData->PostRTSCall(); return result->Word().AsUnsigned(); } -POLYUNSIGNED PolyShowSize(PolyObject *threadId, PolyWord obj) +POLYUNSIGNED PolyShowSize(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(true); if (!obj.IsTagged()) process.ScanObjectAddress(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(PolyObject *threadId, PolyWord obj) +POLYUNSIGNED PolyObjProfile(FirstArgument threadId, PolyWord obj) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); ProcessVisitAddresses process(false); if (!obj.IsTagged()) process.ScanObjectAddress(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 d4d91f5d..9781f56d 100644 --- a/libpolyml/poly_specific.cpp +++ b/libpolyml/poly_specific.cpp @@ -1,553 +1,584 @@ /* Title: poly_specific.cpp - Poly/ML specific RTS calls. Copyright (c) 2006, 2015-17 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 "exporter.h" #include "version.h" #include "sharedata.h" #include "memmgr.h" #include "processes.h" #include "savestate.h" #include "statistics.h" #include "../polystatistics.h" #include "gc.h" #include "rtsentry.h" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(PolyObject * threadId, PolyWord byteSeg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(PolyObject * threadId, PolyWord closure); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(PolyObject *threadId, PolyWord byteVec); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToClosure(PolyObject *threadId, PolyWord byteVec, PolyWord closure); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(FirstArgument threadId, PolyWord byteSeg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(FirstArgument threadId, PolyWord byteVec); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure); POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord c, 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 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); } #define SAVE(x) taskData->saveVec.push(x) static const char *poly_runtime_system_copyright = "Copyright (c) 2002-17 David C.J. Matthews, CUTS and contributors."; #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; default: version = "Unknown-" TextVersion; break; } return SAVE(C_string_to_Poly(taskData, version)); } case 11: // Return the RTS copyright string // Is this used?? return SAVE(C_string_to_Poly(taskData, poly_runtime_system_copyright)); case 12: // Return the architecture // Is this used?? { 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; 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())); case 20: // Write a saved state file. return SaveState(taskData, args); case 21: // Load a saved state file and any ancestors. return LoadState(taskData, false, args); case 22: // Show the hierarchy. return ShowHierarchy(taskData); case 23: // Change the name of the immediate parent stored in a child return RenameParent(taskData, args); case 24: // Return the name of the immediate parent stored in a child return ShowParent(taskData, args); case 27: // Get number of user statistics available return Make_arbitrary_precision(taskData, N_PS_USER); case 28: // Set an entry in the user stats table. { unsigned index = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(0)); if (index >= N_PS_USER) raise_exception0(taskData, EXC_subscript); POLYSIGNED value = getPolySigned(taskData, DEREFHANDLE(args)->Get(1)); globalStats.setUserCounter(index, value); Make_arbitrary_precision(taskData, 0); } case 29: // Get local statistics. return globalStats.getLocalStatistics(taskData); case 30: // Get remote statistics. The argument is the process ID to get the statistics. return globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, args->Word())); case 31: // Store a module return StoreModule(taskData, args); case 32: // Load a module return LoadModule(taskData, args); case 33: // Load hierarchy. This provides a complete list of children and parents. return LoadState(taskData, true, args); case 34: // Return the system directory for modules. This is configured differently // in Unix and in Windows. #if (defined(MODULEDIR)) return SAVE(C_string_to_Poly(taskData, MODULEDIR)); #elif (defined(_WIN32) && ! defined(__CYGWIN__)) { // 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) { RegCloseKey(hk); // The registry entry should end with a backslash. _tcscat(buff, MODULEDIR); return SAVE(C_string_to_Poly(taskData, buff)); } } RegCloseKey(hk); } return SAVE(C_string_to_Poly(taskData, "")); } #else return SAVE(C_string_to_Poly(taskData, "")); #endif case 106: // Lock a mutable code segment and return the executable address. // Legacy - used by bootstrap code only { ASSERT(0); // Should no longer be used PolyObject *codeObj = args->WordP(); if (! codeObj->IsCodeObject() || ! codeObj->IsMutable()) raise_fail(taskData, "Not mutable code area"); POLYUNSIGNED segLength = codeObj->Length(); codeObj->SetLengthWord(segLength, F_CODE_OBJ); 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. return args; // Return the original address. } case 107: // Copy a byte segment into the code area and make it mutable code // Legacy - used by bootstrap code only { ASSERT(0); // Should no longer be used if (! args->WordP()->IsByteObject()) raise_fail(taskData, "Not byte data area"); while (true) { PolyObject *initCell = args->WordP(); POLYUNSIGNED requiredSize = initCell->Length(); PolyObject *result = gMem.AllocCodeSpace(requiredSize); if (result != 0) { memcpy(result, initCell, requiredSize * sizeof(PolyWord)); return taskData->saveVec.push(result); } // Could not allocate - must GC. if (! QuickGC(taskData, args->WordP()->Length())) raise_fail(taskData, "Insufficient memory"); } } case 108: ASSERT(0); // Should no longer be used // Return the ABI. For 64-bit we need to know if this is Windows. // Legacy - used by bootstrap code only #if (SIZEOF_VOIDP == 8) #if(defined(_WIN32) || defined(__CYGWIN__)) return taskData->saveVec.push(TAGGED(2)); #else return taskData->saveVec.push(TAGGED(1)); #endif #else return taskData->saveVec.push(TAGGED(0)); #endif 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(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord 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. // PolyCopyByteVecToCode is now replaced by PolyCopyByteVecToClosure -POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(PolyObject * threadId, PolyWord byteVec) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(FirstArgument threadId, PolyWord byteVec) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(byteVec); PolyObject *result = 0; try { if (!pushedArg->WordP()->IsByteObject()) raise_fail(taskData, "Not byte data area"); do { PolyObject *initCell = pushedArg->WordP(); POLYUNSIGNED requiredSize = initCell->Length(); result = gMem.AllocCodeSpace(requiredSize); if (result == 0) { // Could not allocate - must GC. if (!QuickGC(taskData, pushedArg->WordP()->Length())) raise_fail(taskData, "Insufficient memory"); } else memcpy(result, initCell, requiredSize * sizeof(PolyWord)); } while (result == 0); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return ((PolyWord)result).AsUnsigned(); } // Copy the byte vector into code space. -POLYUNSIGNED PolyCopyByteVecToClosure(PolyObject *threadId, PolyWord byteVec, PolyWord closure) +POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord 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; 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(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); 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 PolyLockMutableCode(PolyObject * threadId, PolyWord byteSeg) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(FirstArgument threadId, PolyWord byteSeg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(byteSeg); Handle result = 0; try { PolyObject *codeObj = pushedArg->WordP(); if (!codeObj->IsCodeObject() || !codeObj->IsMutable()) raise_fail(taskData, "Not mutable code area"); POLYUNSIGNED segLength = codeObj->Length(); codeObj->SetLengthWord(segLength, F_CODE_OBJ); // This is really a legacy of the PPC code-generator. 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. result = pushedArg; // Return the original address. } 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(); } // Replacement for above -POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(PolyObject * threadId, PolyWord closure) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); PolyObject *codeObj = *(PolyObject**)(closure.AsObjPtr()); try { if (!codeObj->IsCodeObject() || !codeObj->IsMutable()) raise_fail(taskData, "Not mutable code area"); POLYUNSIGNED segLength = codeObj->Length(); codeObj->SetLengthWord(segLength, F_CODE_OBJ); // This is really a legacy of the PPC code-generator. 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 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) { byte *pointer; // 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()); // pointer is the start of the code segment. // c will usually be an address. // offset is a byte offset pointer += offset.UnTaggedUnsigned(); switch (UNTAGGED(flags)) { case 0: // Absolute constant - size PolyWord { POLYUNSIGNED c = cWord.AsUnsigned(); for (unsigned i = 0; i < sizeof(PolyWord); i++) { pointer[i] = (byte)(c & 255); c >>= 8; } 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()); size_t c = target - pointer - 4; for (unsigned i = 0; i < sizeof(PolyWord); i++) { pointer[i] = (byte)(c & 255); c >>= 8; } break; } } 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) { byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); pointer[UNTAGGED_UNSIGNED(offset)] = (byte)UNTAGGED_UNSIGNED(cWord); return TAGGED(0).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset) { byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr()); return TAGGED(pointer[UNTAGGED_UNSIGNED(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) { if (!array.IsDataPtr()) return(TAGGED(0)).AsUnsigned(); PolyObject *arrayP = array.AsObjPtr(); POLYUNSIGNED numberOfItems = arrayP->Length(); if (!arrayP->IsMutable()) return(TAGGED(0)).AsUnsigned(); qsort(arrayP, numberOfItems, sizeof(PolyWord), compare); return (TAGGED(1)).AsUnsigned(); } +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4) +{ + switch (arg1.UnTaggedUnsigned()) + { + case 1: return arg1.AsUnsigned(); + case 2: return arg2.AsUnsigned(); + case 3: return arg3.AsUnsigned(); + case 4: return arg4.AsUnsigned(); + default: return TAGGED(0).AsUnsigned(); + } +} + +POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5) +{ + switch (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(); + default: return TAGGED(0).AsUnsigned(); + } + +} + + struct _entrypts polySpecificEPT[] = { { "PolySpecificGeneral", (polyRTSFunction)&PolySpecificGeneral}, { "PolyGetABI", (polyRTSFunction)&PolyGetABI }, { "PolyCopyByteVecToCode", (polyRTSFunction)&PolyCopyByteVecToCode }, { "PolyCopyByteVecToClosure", (polyRTSFunction)&PolyCopyByteVecToClosure }, { "PolyLockMutableCode", (polyRTSFunction)&PolyLockMutableCode }, { "PolyLockMutableClosure", (polyRTSFunction)&PolyLockMutableClosure }, { "PolySetCodeConstant", (polyRTSFunction)&PolySetCodeConstant }, { "PolySetCodeByte", (polyRTSFunction)&PolySetCodeByte }, { "PolyGetCodeByte", (polyRTSFunction)&PolyGetCodeByte }, { "PolySortArrayOfAddresses", (polyRTSFunction)&PolySortArrayOfAddresses }, + { "PolyTest4", (polyRTSFunction)&PolyTest4 }, + { "PolyTest5", (polyRTSFunction)&PolyTest5 }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/polyffi.cpp b/libpolyml/polyffi.cpp index 5424dd84..7c9feb2a 100644 --- a/libpolyml/polyffi.cpp +++ b/libpolyml/polyffi.cpp @@ -1,687 +1,687 @@ /* Title: New Foreign Function Interface Copyright (c) 2015, 2018 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 #if (defined(_WIN32) || (defined(HAVE_DLOPEN))) #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 #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) && ! defined(__CYGWIN__)) #include #include "winstartup.h" /* For hApplicationInstance. */ #endif #include "scanaddrs.h" #include "diagnostics.h" #include "reals.h" #include "rts_module.h" #include "rtsentry.h" static Handle poly_ffi (TaskData *taskData, Handle args, Handle code); extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeFloat(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeDouble(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetError(PolyWord addr); POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFISetError(PolyWord err); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(PolyObject *threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg); } 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_ANY) {"sysv", FFI_SYSV}, {"unix64", FFI_UNIX64}, #endif { "default", FFI_DEFAULT_ABI} }; // Table of constants returned by call 51 static int constantTable[] = { FFI_DEFAULT_ABI, // Default ABI FFI_TYPE_VOID, // Type codes FFI_TYPE_INT, FFI_TYPE_FLOAT, FFI_TYPE_DOUBLE, FFI_TYPE_UINT8, FFI_TYPE_SINT8, FFI_TYPE_UINT16, FFI_TYPE_SINT16, FFI_TYPE_UINT32, FFI_TYPE_SINT32, FFI_TYPE_UINT64, FFI_TYPE_SINT64, FFI_TYPE_STRUCT, FFI_TYPE_POINTER, FFI_SIZEOF_ARG // Minimum size for result space }; // Table of predefined ffi types static ffi_type *ffiTypeTable[] = { &ffi_type_void, &ffi_type_uint8, &ffi_type_sint8, &ffi_type_uint16, &ffi_type_sint16, &ffi_type_uint32, &ffi_type_sint32, &ffi_type_uint64, &ffi_type_sint64, &ffi_type_float, &ffi_type_double, &ffi_type_pointer, &ffi_type_uchar, // These are all aliases for the above &ffi_type_schar, &ffi_type_ushort, &ffi_type_sshort, &ffi_type_uint, &ffi_type_sint, &ffi_type_ulong, &ffi_type_slong }; // Callback entry table static struct _cbStructEntry { PolyWord mlFunction; // The ML function to call void *closureSpace; // Space allocated for the closure void *resultFunction; // Executable address for the function. Needed to free. } *callbackTable; static unsigned callBackEntries = 0; static PLock callbackTableLock; // Mutex to protect table. static Handle mkAbitab(TaskData *taskData, void*, char *p); static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data); static Handle toSysWord(TaskData *taskData, void *p) { return Make_sysword(taskData, (uintptr_t)p); } Handle poly_ffi(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, code->Word()); switch (c) { case 0: // malloc { POLYUNSIGNED size = getPolyUnsigned(taskData, args->Word()); return toSysWord(taskData, malloc(size)); } case 1: // free { void *mem = *(void**)(args->WordP()); free(mem); return taskData->saveVec.push(TAGGED(0)); } case 2: // Load library { TempString libName(args->Word()); #if (defined(_WIN32) && ! defined(__CYGWIN__)) 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 return toSysWord(taskData, lib); } case 3: // Load address of executable. { #if (defined(_WIN32) && ! defined(__CYGWIN__)) 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 return toSysWord(taskData, lib); } case 4: // Unload library - Is this actually going to be used? { #if (defined(_WIN32) && ! defined(__CYGWIN__)) HMODULE hMod = *(HMODULE*)(args->WordP()); if (! FreeLibrary(hMod)) raise_syscall(taskData, "FreeLibrary failed", GetLastError()); #else void *lib = *(void**)(args->WordP()); 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 return taskData->saveVec.push(TAGGED(0)); } case 5: // Load the address of a symbol from a library. { TempCString symName(args->WordP()->Get(1)); #if (defined(_WIN32) && ! defined(__CYGWIN__)) HMODULE hMod = *(HMODULE*)(args->WordP()->Get(0).AsAddress()); 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**)(args->WordP()->Get(0).AsAddress()); 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 return toSysWord(taskData, sym); } // Libffi functions case 50: // Return a list of available ABIs return makeList(taskData, sizeof(abiTable)/sizeof(abiTable[0]), (char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab); case 51: // A constant from the table { unsigned index = get_C_unsigned(taskData, args->Word()); if (index >= sizeof(constantTable) / sizeof(constantTable[0])) raise_exception_string(taskData, EXC_foreign, "Index out of range"); return Make_arbitrary_precision(taskData, constantTable[index]); } case 52: // Return an FFI type { unsigned index = get_C_unsigned(taskData, args->Word()); if (index >= sizeof(ffiTypeTable) / sizeof(ffiTypeTable[0])) raise_exception_string(taskData, EXC_foreign, "Index out of range"); return toSysWord(taskData, ffiTypeTable[index]); } case 53: // Extract fields from ffi type. { ffi_type *ffit = *(ffi_type**)(args->WordP()); Handle sizeHandle = Make_arbitrary_precision(taskData, ffit->size); Handle alignHandle = Make_arbitrary_precision(taskData, ffit->alignment); Handle typeHandle = Make_arbitrary_precision(taskData, ffit->type); Handle elemHandle = toSysWord(taskData, ffit->elements); Handle resHandle = alloc_and_save(taskData, 4); resHandle->WordP()->Set(0, sizeHandle->Word()); resHandle->WordP()->Set(1, alignHandle->Word()); resHandle->WordP()->Set(2, typeHandle->Word()); resHandle->WordP()->Set(3, elemHandle->Word()); return resHandle; } case 54: // Construct an ffi type. { // This is probably only used to create structs. size_t size = getPolyUnsigned(taskData, args->WordP()->Get(0)); unsigned short align = get_C_ushort(taskData, args->WordP()->Get(1)); unsigned short type = get_C_ushort(taskData, args->WordP()->Get(2)); unsigned nElems = 0; for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nElems++; size_t space = sizeof(ffi_type); // If we need the elements add space for the elements plus // one extra for the zero terminator. if (nElems != 0) space += (nElems+1) * sizeof(ffi_type *); ffi_type *result = (ffi_type*)calloc(1, space); // Raise an exception rather than returning zero. if (result == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type **elem = 0; if (nElems != 0) elem = (ffi_type **)(result+1); result->size = size; result->alignment = align; result->type = type; result->elements = elem; if (elem != 0) { for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; *elem++ = *(ffi_type**)(e.AsAddress()); } *elem = 0; } return toSysWord(taskData, result); } case 55: // Create a CIF. This contains all the types and some extra information. // The result is in allocated memory followed immediately by the argument type vector. { ffi_abi abi = (ffi_abi)get_C_ushort(taskData, args->WordP()->Get(0)); ffi_type *rtype = *(ffi_type **)args->WordP()->Get(1).AsAddress(); unsigned nArgs = 0; for (PolyWord p = args->WordP()->Get(2); !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 **atypes = (ffi_type **)(cif+1); // Copy the arguments types. ffi_type **at = atypes; for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; *at++ = *(ffi_type**)(e.AsAddress()); } 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"); return toSysWord(taskData, cif); } case 56: // Call a function. { ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(0).AsAddress(); void *f = *(void**)args->WordP()->Get(1).AsAddress(); void *res = *(void**)args->WordP()->Get(2).AsAddress(); void **arg = *(void***)args->WordP()->Get(3).AsAddress(); // We release the ML memory across the call so a GC can occur // even if this thread is blocked in the C code. processes->ThreadReleaseMLMemory(taskData); ffi_call(cif, FFI_FN(f), res, arg); // Do we need to save the value of errno/GetLastError here? processes->ThreadUseMLMemory(taskData); return taskData->saveVec.push(TAGGED(0)); } case 57: // Create a callback. { #ifdef INTERPRETED raise_exception_string(taskData, EXC_foreign, "Callbacks are not implemented in the byte code interpreter"); #endif Handle mlFunction = taskData->saveVec.push(args->WordP()->Get(0)); ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(1).AsAddress(); void *resultFunction; // Allocate the memory. resultFunction is set to the executable address in or related to // the memory. ffi_closure *closure = (ffi_closure *)ffi_closure_alloc(sizeof(ffi_closure), &resultFunction); if (closure == 0) raise_exception_string(taskData, EXC_foreign, "Callbacks not implemented or insufficient memory"); PLocker pLocker(&callbackTableLock); // Find a free entry in the table if there is one. unsigned entryNo = 0; while (entryNo < callBackEntries && callbackTable[entryNo].closureSpace != 0) entryNo++; if (entryNo == callBackEntries) { // Need to grow the table. struct _cbStructEntry *newTable = (struct _cbStructEntry*)realloc(callbackTable, (callBackEntries+1)*sizeof(struct _cbStructEntry)); if (newTable == 0) raise_exception_string(taskData, EXC_foreign, "Unable to allocate memory for callback table"); callbackTable = newTable; callBackEntries++; } callbackTable[entryNo].mlFunction = mlFunction->Word(); callbackTable[entryNo].closureSpace = closure; callbackTable[entryNo].resultFunction = resultFunction; if (ffi_prep_closure_loc(closure, cif, callbackEntryPt, (void*)((uintptr_t)entryNo), resultFunction) != FFI_OK) raise_exception_string(taskData, EXC_foreign,"libffi error: ffi_prep_closure_loc failed"); return toSysWord(taskData, resultFunction); } case 58: // Free an existing callback. { // The address returned from call 57 above is the executable address that can // be passed as a callback function. The writable memory address returned // as the result of ffi_closure_alloc may or may not be the same. To be safe // we need to search the table. void *resFun = *(void**)args->Word().AsAddress(); PLocker pLocker(&callbackTableLock); for (unsigned i = 0; i < callBackEntries; i++) { if (callbackTable[i].resultFunction == resFun) { ffi_closure_free(callbackTable[i].closureSpace); callbackTable[i].closureSpace = 0; callbackTable[i].resultFunction = 0; callbackTable[i].mlFunction = TAGGED(0); // Release the ML function return taskData->saveVec.push(TAGGED(0)); } } raise_exception_string(taskData, EXC_foreign, "Invalid callback entry"); } default: { char msg[100]; sprintf(msg, "Unknown ffi function: %d", c); raise_exception_string(taskData, EXC_foreign, msg); return 0; } } } // 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; } // This is the C function that will get control when any callback is made. The "data" // argument is the index of the entry in the callback table.. static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data) { uintptr_t cbIndex = (uintptr_t)data; ASSERT(cbIndex < callBackEntries); // 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(0, 0, 0, TAGGED(0)); } catch (std::bad_alloc &) { ::Exit("Unable to create thread data - insufficient memory"); } catch (MemoryException &) { ::Exit("Unable to create thread data - insufficient memory"); } } else processes->ThreadUseMLMemory(taskData); // We may get multiple calls to call-backs and we mustn't risk // overflowing the save-vec. Handle mark = taskData->saveVec.mark(); // In the future we might want to call C functions without some of the // overhead that comes with an RTS call which may allocate in ML // memory. If we do that we also have to ensure that callbacks // don't allocate, so this code would have to change. Handle mlEntryHandle; { // Get the ML function. Lock to avoid another thread moving // callbackTable under our feet. PLocker pLocker(&callbackTableLock); struct _cbStructEntry *cbEntry = &callbackTable[cbIndex]; mlEntryHandle = taskData->saveVec.push(cbEntry->mlFunction); } // Create a pair of the arg vector and the result pointer. Handle argHandle = toSysWord(taskData, args); Handle resHandle = toSysWord(taskData, ret); // Result must go in here. Handle pairHandle = alloc_and_save(taskData, 2); pairHandle->WordP()->Set(0, argHandle->Word()); pairHandle->WordP()->Set(1, resHandle->Word()); taskData->EnterCallbackFunction(mlEntryHandle, pairHandle); taskData->saveVec.reset(mark); // Release ML memory now we're going back to C. processes->ThreadReleaseMLMemory(taskData); } class PolyFFI: public RtsModule { public: virtual void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static PolyFFI polyFFIModule; // We need to scan the callback table. void PolyFFI::GarbageCollect(ScanAddress *process) { for (unsigned i = 0; i < callBackEntries; i++) process->ScanRuntimeWord(&callbackTable[i].mlFunction); } #else // The foreign function interface isn't available. #include "polyffi.h" #include "run_time.h" #include "sys.h" Handle poly_ffi(TaskData *taskData, Handle args, Handle code) { raise_exception_string(taskData, EXC_foreign, "The foreign function interface is not available on this platform"); } #endif // General interface to IO. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyFFIGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyFFIGeneral(FirstArgument threadId, PolyWord code, PolyWord 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_ffi(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(); } // These functions are needed in the compiler POLYUNSIGNED PolySizeFloat() { return TAGGED((POLYSIGNED)ffi_type_float.size).AsUnsigned(); } POLYUNSIGNED PolySizeDouble() { return TAGGED((POLYSIGNED)ffi_type_double.size).AsUnsigned(); } // Get either errno or GetLastError POLYUNSIGNED PolyFFIGetError(PolyWord addr) { #if (defined(_WIN32) && ! defined(__CYGWIN__)) addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned(GetLastError())); #else 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) { #if (defined(_WIN32) && ! defined(__CYGWIN__)) SetLastError((DWORD)(err.AsObjPtr()->Get(0).AsUnsigned())); #else errno = 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(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord 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(); } struct _entrypts polyFFIEPT[] = { { "PolyFFIGeneral", (polyRTSFunction)&PolyFFIGeneral}, { "PolySizeFloat", (polyRTSFunction)&PolySizeFloat}, { "PolySizeDouble", (polyRTSFunction)&PolySizeDouble}, { "PolyFFIGetError", (polyRTSFunction)&PolyFFIGetError}, { "PolyFFISetError", (polyRTSFunction)&PolyFFISetError}, { "PolyFFICreateExtFn", (polyRTSFunction)&PolyFFICreateExtFn}, { "PolyFFICreateExtData", (polyRTSFunction)&PolyFFICreateExtData }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/process_env.cpp b/libpolyml/process_env.cpp index 329c1eed..5a92f7c3 100644 --- a/libpolyml/process_env.cpp +++ b/libpolyml/process_env.cpp @@ -1,771 +1,771 @@ /* Title: Process environment. Copyright (c) 2000-8, 2016-17 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) && ! defined(__CYGWIN__)) #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(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL void PolyTerminate(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorName(PolyObject *threadId, PolyWord syserr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorMessage(PolyObject *threadId, PolyWord syserr); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorFromString(PolyObject *threadId, PolyWord string); + 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 POLYUNSIGNED PolyGetMaxAllocationSize(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(PolyObject *threadId, PolyWord fnAddr); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr); } #define SAVE(x) mdTaskData->saveVec.push(x) #define ALLOC(n) alloc_and_save(mdTaskData, n) #if (defined(_WIN32) && ! defined(__CYGWIN__)) #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 /* Functions registered with atExit are added to this list. */ static PolyWord at_exit_list = TAGGED(0); /* Once "exit" is called this flag is set and no further calls to atExit are allowed. */ static bool exiting = false; static PLock atExitLock; // Thread lock for above. #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 static Handle process_env_dispatch_c(TaskData *mdTaskData, Handle args, Handle code) { unsigned c = get_C_unsigned(mdTaskData, DEREFWORD(code)); switch (c) { case 0: /* Return the program name. */ return SAVE(C_string_to_Poly(mdTaskData, userOptions.programName)); case 1: /* Return the argument list. */ return convert_string_list(mdTaskData, userOptions.user_arg_count, userOptions.user_arg_strings); case 14: /* Return a string from the environment. */ { TempString buff(args->Word()); if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", NOMEMORY); TCHAR *res = _tgetenv(buff); if (res == NULL) raise_syscall(mdTaskData, "Not Found", 0); else return SAVE(C_string_to_Poly(mdTaskData, res)); } case 21: // Return the whole environment. Only available in Posix.ProcEnv. { /* Count the environment strings */ int env_count = 0; while (environ[env_count] != NULL) env_count++; return convert_string_list(mdTaskData, env_count, environ); } case 15: /* Return the success value. */ return Make_fixed_precision(mdTaskData, EXIT_SUCCESS); case 16: /* Return a failure value. */ return Make_fixed_precision(mdTaskData, EXIT_FAILURE); case 17: /* Run command. */ { TempString buff(args->Word()); if (buff == 0) raise_syscall(mdTaskData, "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(mdTaskData, "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(mdTaskData, &request); int pid = request.pid; if (pid < 0) raise_syscall(mdTaskData, "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(mdTaskData, "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__)) switch (WaitForSingleObject((HANDLE)pid, 0)) { case WAIT_OBJECT_0: { DWORD result; BOOL fResult = GetExitCodeProcess((HANDLE)pid, &result); if (! fResult) raise_syscall(mdTaskData, "Function system failed", GetLastError()); CloseHandle((HANDLE)pid); return Make_fixed_precision(mdTaskData, result); } case WAIT_FAILED: raise_syscall(mdTaskData, "Function system failed", GetLastError()); } // Wait for the process to exit or for the timeout WaitHandle waiter((HANDLE)pid); processes->ThreadPauseForIO(mdTaskData, &waiter); #else int wRes = waitpid(pid, &res, WNOHANG); if (wRes > 0) break; else if (wRes < 0) { raise_syscall(mdTaskData, "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. processes->ThreadPause(mdTaskData); #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; } } return Make_fixed_precision(mdTaskData, res); } case 18: /* Register function to run at exit. */ { PLocker locker(&atExitLock); if (! exiting) { PolyObject *cell = alloc(mdTaskData, 2); cell->Set(0, at_exit_list); cell->Set(1, args->Word()); at_exit_list = cell; } return Make_fixed_precision(mdTaskData, 0); } case 19: /* Return the next function in the atExit list and set the "exiting" flag to true. */ { PLocker locker(&atExitLock); Handle res; exiting = true; /* Ignore further calls to atExit. */ if (at_exit_list == TAGGED(0)) raise_syscall(mdTaskData, "List is empty", 0); PolyObject *cell = at_exit_list.AsObjPtr(); res = SAVE(cell->Get(1)); at_exit_list = cell->Get(0); return res; } case 20: /* Terminate without running the atExit list or flushing buffers. */ { /* I don't like terminating without some sort of clean up but we'll do it this way for the moment. */ int i = get_C_int(mdTaskData, args->Word()); _exit(i); } /************ Error codes **************/ /************ Directory/file paths **************/ case 5: /* Return the string representing the current arc. */ return SAVE(C_string_to_Poly(mdTaskData, ".")); case 6: /* Return the string representing the parent arc. */ /* I don't know that this exists in MacOS. */ return SAVE(C_string_to_Poly(mdTaskData, "..")); case 7: /* Return the string representing the directory separator. */ return SAVE(C_string_to_Poly(mdTaskData, DEFAULTSEPARATOR)); case 8: /* Test the character to see if it matches a separator. */ { int e = get_C_int(mdTaskData, args->Word()); if (ISPATHSEPARATOR(e)) return Make_fixed_precision(mdTaskData, 1); else return Make_fixed_precision(mdTaskData, 0); } case 9: /* Are names case-sensitive? */ #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* Windows - no. */ return Make_fixed_precision(mdTaskData, 0); #else /* Unix - yes. */ return Make_fixed_precision(mdTaskData, 1); #endif // These are no longer used. The code is handled entirely in ML. case 10: /* Are empty arcs redundant? */ /* Unix and Windows - yes. */ return Make_fixed_precision(mdTaskData, 1); case 11: /* Match the volume name part of a path. */ { const TCHAR *volName = NULL; int isAbs = 0; int toRemove = 0; PolyWord path = args->Word(); /* This examines the start of a string and determines how much of it represents the volume name and returns the number of characters to remove, the volume name and whether it is absolute. One would assume that if there is a volume name then it is absolute but there is a peculiar form in Windows/DOS (e.g. A:b\c) which means the file b\c relative to the currently selected directory on the volume A. */ #if (defined(_WIN32) && ! defined(__CYGWIN__)) TempString buff(path); if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", NOMEMORY); size_t length = _tcslen(buff); if (length >= 2 && buff[1] == ':') { /* Volume name? */ if (length >= 3 && ISPATHSEPARATOR(buff[2])) { /* Absolute path. */ toRemove = 3; isAbs = 1; } else { toRemove = 2; isAbs = 0; } volName = buff; buff[2] = '\0'; } else if (length > 3 && ISPATHSEPARATOR(buff[0]) && ISPATHSEPARATOR(buff[1]) && ! ISPATHSEPARATOR(buff[2])) { /* UNC name? */ int i; /* Skip the server name. */ for (i = 3; buff[i] != 0 && !ISPATHSEPARATOR(buff[i]); i++); if (ISPATHSEPARATOR(buff[i])) { i++; /* Skip the share name. */ for (; buff[i] != 0 && !ISPATHSEPARATOR(buff[i]); i++); toRemove = i; if (buff[i] != 0) toRemove++; isAbs = 1; volName = buff; buff[i] = '\0'; } } else if (ISPATHSEPARATOR(buff[0])) /* \a\b strictly speaking is relative to the current drive. It's much easier to treat it as absolute. */ { toRemove = 1; isAbs = 1; volName = _T(""); } #else /* Unix - much simpler. */ char toTest = 0; if (IS_INT(path)) toTest = UNTAGGED(path); else { PolyStringObject * ps = (PolyStringObject *)path.AsObjPtr(); if (ps->length > 1) toTest = ps->chars[0]; } if (ISPATHSEPARATOR(toTest)) { toRemove = 1; isAbs = 1; volName = ""; } #endif /* Construct the result. */ { Handle sVol = SAVE(C_string_to_Poly(mdTaskData, volName)); Handle sRes = ALLOC(3); DEREFWORDHANDLE(sRes)->Set(0, TAGGED(toRemove)); DEREFHANDLE(sRes)->Set(1, sVol->Word()); DEREFWORDHANDLE(sRes)->Set(2, TAGGED(isAbs)); return sRes; } } case 12: /* Construct a name from a volume and whether it is absolute. */ { unsigned isAbs = get_C_unsigned(mdTaskData, DEREFHANDLE(args)->Get(1)); PolyWord volName = DEREFHANDLE(args)->Get(0); /* In Unix the volume name will always be empty. */ if (isAbs == 0) return SAVE(volName); /* N.B. The arguments to strconcatc are in reverse. */ else return strconcatc(mdTaskData, SAVE(C_string_to_Poly(mdTaskData, DEFAULTSEPARATOR)), SAVE(volName)); } case 13: /* Is the string a valid file name? */ { PolyWord volName = DEREFWORD(args); // First check for NULL. This is not allowed in either Unix or Windows. if (IS_INT(volName)) { if (volName == TAGGED(0)) return Make_fixed_precision(mdTaskData, 0); } else { PolyStringObject * volume = (PolyStringObject *)(volName.AsObjPtr()); for (POLYUNSIGNED i = 0; i < volume->length; i++) { if (volume->chars[i] == '\0') return Make_fixed_precision(mdTaskData, 0); } } #if (defined(_WIN32) && ! defined(__CYGWIN__)) // We need to look for certain invalid characters but only after // we've converted it to Unicode if necessary. TempString name(volName); for (const TCHAR *p = name; *p != 0; p++) { switch (*p) { case '<': case '>': case ':': case '"': case '\\': case '|': case '?': case '*': case '\0': #if (0) // This currently breaks the build. case '/': #endif return Make_fixed_precision(mdTaskData, 0); } if (*p >= 0 && *p <= 31) return Make_fixed_precision(mdTaskData, 0); } // Should we check for special names such as aux, con, prn ?? return Make_fixed_precision(mdTaskData, 1); #else // That's all we need for Unix. // TODO: Check for /. It's invalid in a file name arc. return Make_fixed_precision(mdTaskData, 1); #endif } // These were supposed to have been moved to poly-specific but don't seem to have been. case 100: /* Return the maximum word segment size. */ // Legacy - used in bootstrap return mdTaskData->saveVec.push(TAGGED(MAX_OBJECT_SIZE)); case 101: /* Return the maximum string size (in bytes). It is the maximum number of bytes in a segment less one word for the length field. */ // Legacy - used in bootstrap return mdTaskData->saveVec.push(TAGGED((MAX_OBJECT_SIZE)*sizeof(PolyWord) - sizeof(PolyWord))); case 104: return Make_arbitrary_precision(mdTaskData, POLY_version_number); case 105: /* Get the name of the function. */ { PolyObject *pt = DEREFWORDHANDLE(args); if (pt->IsCodeObject()) /* Should now be a code object. */ { /* Compiled code. This is the first constant in the constant area. */ PolyWord *codePt = pt->ConstPtrForCode(); PolyWord name = codePt[0]; /* May be zero indicating an anonymous segment - return null string. */ if (name == PolyWord::FromUnsigned(0)) return SAVE(C_string_to_Poly(mdTaskData, "")); else return SAVE(name); } else raise_syscall(mdTaskData, "Not a code pointer", 0); } default: { char msg[100]; sprintf(msg, "Unknown environment function: %d", c); raise_exception_string(mdTaskData, EXC_Fail, msg); return 0; } } } // General interface to process-env. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyProcessEnvGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord 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(PolyObject *threadId, PolyWord arg) +void PolyFinish(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); int i = get_C_int(taskData, 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(PolyObject *threadId, PolyWord arg) +void PolyTerminate(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); int i = get_C_int(taskData, arg); _exit(i); // Doesn't return. } // Get the name of a numeric error message. -POLYUNSIGNED PolyProcessEnvErrorName(PolyObject *threadId, PolyWord syserr) +POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord 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(); // 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(PolyObject *threadId, PolyWord syserr) +POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord 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()); } 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(PolyObject *threadId, PolyWord string) +POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord 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)); // 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(PolyObject *threadId, PolyWord fnAddr) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord 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(); // 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 = pt->ConstPtrForCode(); 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(); } 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 }, { NULL, NULL} // End of list. }; class ProcessEnvModule: public RtsModule { public: void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static ProcessEnvModule processModule; void ProcessEnvModule::GarbageCollect(ScanAddress *process) /* Ensures that all the objects are retained and their addresses updated. */ { if (at_exit_list.IsDataPtr()) { PolyObject *obj = at_exit_list.AsObjPtr(); process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG); at_exit_list = obj; } } diff --git a/libpolyml/processes.cpp b/libpolyml/processes.cpp index 2102e01a..2137fb73 100644 --- a/libpolyml/processes.cpp +++ b/libpolyml/processes.cpp @@ -1,2250 +1,2250 @@ /* Title: Thread functions Author: David C.J. Matthews Copyright (c) 2007,2008,2013-15, 2017, 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_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) || defined(__CYGWIN__)) && defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H)) #define HAVE_PTHREAD 1 #include #endif #ifdef HAVE_SYS_SYSCTL_H // Used determine number of processors in Mac OS X. #include #endif #if (defined(_WIN32) && ! defined(__CYGWIN__)) #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" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillSelf(PolyObject *threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexBlock(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexUnlock(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWait(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWaitUntil(PolyObject *threadId, PolyWord lockArg, PolyWord timeArg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); + 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(PolyObject *threadId, PolyWord function, PolyWord attrs, PolyWord stack); + 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(PolyObject *threadId); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadTestInterrupt(PolyObject *threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadBroadcastInterrupt(FirstArgument threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumProcessors(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumPhysicalProcessors(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMaxStackSize(PolyObject *threadId, PolyWord newSize); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMaxStackSize(FirstArgument threadId, PolyWord 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[] = { { "PolyThreadGeneral", (polyRTSFunction)&PolyThreadGeneral}, { "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(); virtual void Init(void); virtual void Stop(void); void GarbageCollect(ScanAddress *process); 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(Handle threadId, Handle threadFunction, Handle args, PolyWord flags); // ForkFromRTS. Creates a new thread from within the RTS. virtual bool ForkFromRTS(TaskData *taskData, Handle proc, Handle arg); // 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, Handle args, 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); virtual void SetSingleThreaded(void) { singleThreaded = true; } // 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; #ifdef HAVE_PTHREAD pthread_key_t tlsId; #elif defined(HAVE_WINDOWS_H) 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 // 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); } // General interface to thread. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyThreadGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyThreadGeneral(FirstArgument threadId, PolyWord code, PolyWord 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 = processesModule.ThreadDispatch(taskData, pushedArg, pushedCode); } 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(); } -POLYUNSIGNED PolyThreadMutexBlock(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyThreadMutexBlock(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyThreadMutexUnlock(FirstArgument threadId, PolyWord 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) { schedLock.Lock(); // 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 1 (unlocked) and signalled any waiters // before we actually got to wait. if (UNTAGGED(DEREFHANDLE(hMutex)->Get(0)) < 0) { // 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); } // Return and try and get the lock again. schedLock.Unlock(); // 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 incrementing 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). schedLock.Lock(); // 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(); } schedLock.Unlock(); } -POLYUNSIGNED PolyThreadCondVarWait(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyThreadCondVarWait(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord lockArg, PolyWord timeArg) +POLYUNSIGNED PolyThreadCondVarWaitUntil(FirstArgument threadId, PolyWord lockArg, PolyWord 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) { schedLock.Lock(); // Atomically release the mutex. This is atomic because we hold schedLock // so no other thread can call signal or broadcast. Handle decrResult = taskData->AtomicIncrement(hMutex); if (UNTAGGED(decrResult->Word()) != 1) { taskData->AtomicReset(hMutex); // 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); } schedLock.Unlock(); } // 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) && ! defined(__CYGWIN__)) // 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 schedLock.Lock(); // Atomically release the mutex. This is atomic because we hold schedLock // so no other thread can call signal or broadcast. Handle decrResult = taskData->AtomicIncrement(hMutex); if (UNTAGGED(decrResult->Word()) != 1) { taskData->AtomicReset(hMutex); // 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); } schedLock.Unlock(); } 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. schedLock.Lock(); 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; } } schedLock.Unlock(); return result; } POLYUNSIGNED PolyThreadCondVarWake(PolyWord targetThread) { if (processesModule.WakeThread(targetThread.AsObjPtr())) return TAGGED(1).AsUnsigned(); else return TAGGED(0).AsUnsigned(); } // Test if a thread is active. POLYUNSIGNED PolyThreadIsActive(PolyWord 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()); if (p != 0) return TAGGED(1).AsUnsigned(); else return TAGGED(0).AsUnsigned(); } // Send an interrupt to a specific thread POLYUNSIGNED PolyThreadInterruptThread(PolyWord targetThread) { // Must lock here because the thread may be exiting. processesModule.schedLock.Lock(); TaskData *p = processesModule.TaskForIdentifier(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) { processesModule.schedLock.Lock(); TaskData *p = processesModule.TaskForIdentifier(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(PolyObject * /*threadId*/) +POLYUNSIGNED PolyThreadBroadcastInterrupt(FirstArgument /*threadId*/) { processesModule.BroadcastInterrupt(); return TAGGED(0).AsUnsigned(); } -POLYUNSIGNED PolyThreadTestInterrupt(PolyObject *threadId) +POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument 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(PolyObject *threadId, PolyWord newSize) +POLYUNSIGNED PolyThreadMaxStackSize(FirstArgument threadId, PolyWord newSize) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); 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)), (Handle)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), foreignStack(TAGGED(0)), inML(false), 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". schedLock.Lock(); 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); } } schedLock.Unlock(); } // 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); #ifdef HAVE_PTHREAD // 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(); #ifdef HAVE_PTHREAD pthread_exit(0); #elif defined(HAVE_WINDOWS_H) 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 schedLock.Lock(); ThreadUseMLMemoryWithSchedLock(taskData); schedLock.Unlock(); } void Processes::ThreadReleaseMLMemory(TaskData *taskData) { schedLock.Lock(); ThreadReleaseMLMemoryWithSchedLock(taskData); schedLock.Unlock(); } // 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(PolyObject *threadId) +POLYUNSIGNED PolyThreadKillSelf(FirstArgument 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) && ! defined(__CYGWIN__)) 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 HAVE_WINDOWS_H // Wait for the specified handle to be signalled. void WaitHandle::Wait(unsigned maxMillisecs) { // Wait until we get input or we're woken up. if (m_Handle == NULL) Sleep(maxMillisecs); else WaitForSingleObject(m_Handle, maxMillisecs); } #endif #if (!defined(_WIN32) || defined(__CYGWIN__)) // 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) { #ifdef HAVE_PTHREAD return (TaskData *)pthread_getspecific(tlsId); #elif defined(HAVE_WINDOWS_H) return (TaskData *)TlsGetValue(tlsId); #else // If there's no threading. return taskArray[0]; #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(Handle threadId, Handle threadFunction, Handle args, PolyWord flags) { 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, threadFunction, args); ThreadUseMLMemory(taskData); // If the forking thread has created an ML thread object use that // otherwise create a new one in the current context. if (threadId != 0) taskData->threadObject = (ThreadObject*)threadId->WordP(); else { // 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 = flags != TAGGED(0) ? TAGGED(PFLAG_SYNCH): 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); } #ifdef HAVE_PTHREAD initThreadSignals(taskData); pthread_setspecific(tlsId, taskData); #elif defined(HAVE_WINDOWS_H) 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. #ifdef HAVE_PTHREAD 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 { (void)taskData->EnterPolyCode(); // Will normally (always?) call ExitThread. } catch (KillException &) { processesModule.ThreadExit(taskData); } return 0; } #elif defined(HAVE_WINDOWS_H) 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 { (void)taskData->EnterPolyCode(); } catch (KillException &) { processesModule.ThreadExit(taskData); } return 0; } #else static void NewThreadFunction(void *parameter) { TaskData *taskData = (TaskData *)parameter; initThreadSignals(taskData); taskData->saveVec.init(); // Removal initial data globalStats.incCount(PSC_THREADS); processes->ThreadUseMLMemory(taskData); try { (void)taskData->EnterPolyCode(); } catch (KillException &) { processesModule.ThreadExit(taskData); } } #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), (Handle)0); // 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; #ifdef HAVE_PTHREAD if (pthread_create(&taskData->threadId, NULL, NewThreadFunction, taskData) != 0) errorCode = errno; #elif defined(HAVE_WINDOWS_H) 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. #ifdef HAVE_PTHREAD pthread_join(p->threadId, NULL); #elif defined(HAVE_WINDOWS_H) 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; gMem.ProtectImmutable(false); // GC, sharing and export may all write to the immutable area threadRequest->Perform(); gMem.ProtectImmutable(true); mainThreadPhase = MTP_USER_CODE; 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->inML) 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); } 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, Handle args, 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, args); // Now actually fork the thread. bool success = false; schedLock.Lock(); #ifdef HAVE_PTHREAD success = pthread_create(&newTaskData->threadId, NULL, NewThreadFunction, newTaskData) == 0; #elif defined(HAVE_WINDOWS_H) 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"); } } // ForkFromRTS. Creates a new thread from within the RTS. This is currently used // only to run a signal function. bool Processes::ForkFromRTS(TaskData *taskData, Handle proc, Handle arg) { try { (void)ForkThread(taskData, proc, arg, TAGGED(PFLAG_SYNCH), TAGGED(0)); return true; } catch (IOException &) { // If it failed return false; } } -POLYUNSIGNED PolyThreadForkThread(PolyObject *threadId, PolyWord function, PolyWord attrs, PolyWord stack) +POLYUNSIGNED PolyThreadForkThread(FirstArgument threadId, PolyWord function, PolyWord attrs, PolyWord 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, (Handle)0, attrs, 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. } /******************************************************************************/ /* */ /* catchVTALRM - handler for alarm-clock signal */ /* */ /******************************************************************************/ #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); /* 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. schedLock.Lock(); sigLock->Unlock(); if (sigTask != 0) { schedLock.Unlock(); 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; schedLock.Unlock(); 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(); } #ifdef HAVE_PTHREAD // 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) { #ifdef HAVE_PTHREAD pthread_key_create(&tlsId, threaddata_destructor); #elif defined(HAVE_WINDOWS_H) tlsId = TlsAlloc(); #else singleThreaded = true; #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) { #ifdef HAVE_PTHREAD pthread_key_delete(tlsId); #elif defined(HAVE_WINDOWS_H) 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; } process->ScanRuntimeWord(&foreignStack); } // Return the number of processors. extern unsigned NumberOfProcessors(void) { #if (defined(_WIN32) && ! defined(__CYGWIN__)) 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 bdc7533c..e39041f9 100644 --- a/libpolyml/processes.h +++ b/libpolyml/processes.h @@ -1,362 +1,362 @@ /* Title: Lightweight process library Author: David C.J. Matthews Copyright (c) 2007-8, 2012, 2015, 2017, 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 */ #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 Handle 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, Handle arg) = 0; virtual void SetException(poly_exn *exc) = 0; // If a foreign function calls back to ML we need to set up the call to the // ML callback function. virtual Handle EnterCallbackFunction(Handle func, Handle args) = 0; // The scheduler needs versions of atomic increment and atomic reset that // work in exactly the same way as the code-generated versions (if any). // Atomic decrement isn't needed since it only ever releases a mutex. virtual Handle AtomicIncrement(Handle mutexp) = 0; // Reset a mutex to one. This needs to be atomic with respect to the // atomic increment and decrement instructions. virtual void AtomicReset(Handle 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) { inML = false; } virtual void PostRTSCall(void) { inML = true; } 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) PolyWord foreignStack; // Stack of saved data used in call_sym_and_convert bool inML; // True when this is in ML, false in the RTS // 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(PolyObject *taskId) { - return *(TaskData**)(((ThreadObject*)taskId)->threadRef.AsObjPtr()); + static TaskData *FindTaskForId(PolyWord taskId) { + return *(TaskData**)(((ThreadObject*)taskId.AsObjPtr())->threadRef.AsObjPtr()); } 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 HAVE_WINDOWS_H class WaitHandle: public Waiter { public: WaitHandle(HANDLE h): m_Handle(h) {} virtual void Wait(unsigned maxMillisecs); private: HANDLE m_Handle; }; #endif #if (! defined(_WIN32) || defined(__CYGWIN__)) // 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(Handle threadId, Handle threadFunction, Handle args, PolyWord flags) = 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; // ForkFromRTS. Creates a new thread from within the RTS. virtual bool ForkFromRTS(TaskData *taskData, Handle proc, Handle arg) = 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; // After a Unix fork we only have a single thread in the new process. virtual void SetSingleThreaded(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 713e3f53..92791daa 100644 --- a/libpolyml/profiling.cpp +++ b/libpolyml/profiling.cpp @@ -1,564 +1,564 @@ /* 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 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" extern "C" { - POLYEXTERNALSYMBOL POLYUNSIGNED PolyProfiling(PolyObject *threadId, PolyWord mode); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode); } static POLYUNSIGNED 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; 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; code->GetConstSegmentForCode(consts, constCount); if (constCount < 3 || ! consts[2].IsDataPtr()) return 0; PolyObject *profObject = consts[2].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. // This is called from a signal handler in the case of time profiling. void add_count(TaskData *taskData, 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); PLocker locker(&countLock); if (profObject) profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + incr)); return; } // Didn't find it. { PLocker locker(&countLock); mainThreadCounts[MTP_USER_CODE] += incr; } } // 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 = obj->ConstPtrForCode(); 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; } void handleProfileTrap(TaskData *taskData, SIGNALCONTEXT *context) { if (singleThreadProfile != 0 && singleThreadProfile != taskData) return; /* If we are in the garbage-collector add the count to "gc_count" otherwise try to find out where we are. */ if (mainThreadPhase == MTP_USER_CODE) { if (taskData == 0 || ! taskData->AddTimeProfileCount(context)) 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 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(PolyObject *threadId, PolyWord mode) +POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord 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 b5b979d7..9ef2321e 100644 --- a/libpolyml/reals.cpp +++ b/libpolyml/reals.cpp @@ -1,1121 +1,1121 @@ /* 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-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_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(PolyObject *threadId, PolyWord arg, PolyWord mode, PolyWord digits); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedFromString(PolyObject *threadId, PolyWord str); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealBoxedToLongInt(PolyObject *threadId, PolyWord arg); + 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 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 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(PolyObject *threadId, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyRealFrexp(FirstArgument threadId, PolyWord 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) { return get_arbitrary_precision_as_real(arg); } // Convert a boxed real to a long precision int. -POLYUNSIGNED PolyRealBoxedToLongInt(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyRealBoxedToLongInt(FirstArgument threadId, PolyWord 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) { POLYSIGNED exponent = 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(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyRealFrexp(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord str) +POLYUNSIGNED PolyRealBoxedFromString(FirstArgument threadId, PolyWord 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(); } static double real_arg1(Handle x) { union db r_arg_x; for(unsigned i = 0; i < DBLE; i++) { r_arg_x.words[i] = DEREFHANDLE(x)->Get(0).AsObjPtr()->Get(i).AsUnsigned(); } return r_arg_x.dble; } static double real_arg2(Handle x) { union db r_arg_x; for(unsigned i = 0; i < DBLE; i++) { r_arg_x.words[i] = DEREFHANDLE(x)->Get(1).AsObjPtr()->Get(i).AsUnsigned(); } return r_arg_x.dble; } static Handle powerOf(TaskData *mdTaskData, Handle args) { double x = real_arg1(args), y = real_arg2(args); return real_result(mdTaskData, PolyRealPow(x, y)); } #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) { // Get the rounding and turn the result into a tagged integer. return TAGGED(getrounding()).AsSigned(); } POLYSIGNED PolySetRoundingMode(PolyWord arg) { return TAGGED(setrounding((int)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(PolyObject *threadId, PolyWord arg, PolyWord mode, PolyWord digits) +POLYUNSIGNED PolyRealBoxedToString(FirstArgument threadId, PolyWord arg, PolyWord mode, PolyWord 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. // It also still has some legacy functions. static Handle Real_dispatchc(TaskData *mdTaskData, Handle args, Handle code) { unsigned c = get_C_unsigned(mdTaskData, code->Word()); switch (c) { case 3: /* Legacy: atan2 */ return real_result(mdTaskData, atan2(real_arg1(args), real_arg2(args))); case 4: /* Legacy: pow */ return powerOf(mdTaskData, args); /* 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 case 17: /* Legacy: Get sign bit. Now implemented in ML. */ return mdTaskData->saveVec.push(copysign(1.0, real_arg(args)) < 0.0 ? TAGGED(1) : TAGGED(0)); case 18: /* Legacy: Copy sign. */ return real_result(mdTaskData, copysign(real_arg1(args), real_arg2(args))); case 23: /* Legacy: Compute ldexp */ { int exp = get_C_int(mdTaskData, DEREFHANDLE(args)->Get(1)); return real_result(mdTaskData, ldexp(real_arg1(args), exp)); } case 24: /* Legacy: Get mantissa. */ { int exp; return real_result(mdTaskData, frexp(real_arg(args), &exp)); } case 25: /* Legacy: Get exponent. */ { int exp; (void)frexp(real_arg(args), &exp); return mdTaskData->saveVec.push(TAGGED(exp)); } case 26: /* Legacy: nextafter */ return real_result(mdTaskData, nextafter(real_arg1(args), real_arg2(args))); // 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) { // Return the number of bytes for a real. This is used in PackRealBig/Little. return TAGGED(sizeof(double)).AsUnsigned(); } -POLYUNSIGNED PolyRealGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyRealGeneral(FirstArgument threadId, PolyWord code, PolyWord 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 528cf215..515fce69 100644 --- a/libpolyml/rtsentry.cpp +++ b/libpolyml/rtsentry.cpp @@ -1,187 +1,187 @@ /* 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 "exporter.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, NULL }; extern "C" { #ifdef _MSC_VER __declspec(dllexport) #endif - POLYUNSIGNED PolyCreateEntryPointObject(PolyObject *threadId, PolyWord arg); + POLYUNSIGNED PolyCreateEntryPointObject(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyCreateEntryPointObject(FirstArgument threadId, PolyWord 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())) raise_fail(taskData, "entry point not found"); } 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 61e84e50..abeaa269 100644 --- a/libpolyml/rtsentry.h +++ b/libpolyml/rtsentry.h @@ -1,49 +1,65 @@ /* 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 4b9c3034..255bbccd 100644 --- a/libpolyml/run_time.cpp +++ b/libpolyml/run_time.cpp @@ -1,417 +1,417 @@ /* 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(PolyObject *threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyFullGC(FirstArgument 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(PolyObject *threadId) +POLYUNSIGNED PolyFullGC(FirstArgument 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) || defined(__CYGWIN__)) 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 (val > MAXTAGGED || val < -MAXTAGGED-1) raise_exception0(taskData, EXC_overflow); return taskData->saveVec.push(TAGGED(val)); } Handle Make_fixed_precision(TaskData *taskData, unsigned uval) { if (uval > MAXTAGGED) raise_exception0(taskData, EXC_overflow); 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/sharedata.cpp b/libpolyml/sharedata.cpp index ce39b3c7..dc16aa03 100644 --- a/libpolyml/sharedata.cpp +++ b/libpolyml/sharedata.cpp @@ -1,1135 +1,1135 @@ /* Title: Share common immutable data Copyright (c) 2000 Cambridge University Technical Services Limited and David C. J. Matthews 2006, 2010-13, 2016-17 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 "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" /* 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(PolyObject *threadId, PolyWord root); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyShareCommonData(FirstArgument threadId, PolyWord 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: struct _depthVector { DepthVector **vector; POLYUNSIGNED vectorSize; } depthVectorArray[FIXEDLENGTHSIZE]; POLYUNSIGNED maxVectorSize; }; ShareDataClass::ShareDataClass() { maxVectorSize = 0; for (unsigned i = 0; i < FIXEDLENGTHSIZE; i++) { depthVectorArray[i].vector = 0; depthVectorArray[i].vectorSize = 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 and vector of vectors. for (unsigned i = 0; i < FIXEDLENGTHSIZE; i++) { for (unsigned j = 0; j < depthVectorArray[i].vectorSize; j++) delete(depthVectorArray[i].vector[j]); free(depthVectorArray[i].vector); } } // 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. struct _depthVector *vectorToUse = &(depthVectorArray[length < FIXEDLENGTHSIZE ? length : 0]); if (depth >= maxVectorSize) maxVectorSize = depth+1; if (depth >= vectorToUse->vectorSize) { POLYUNSIGNED newDepth = depth+1; DepthVector **newVec = (DepthVector **)realloc(vectorToUse->vector, sizeof(DepthVector*)*newDepth); if (newVec == 0) throw MemoryException(); vectorToUse->vector = newVec; // Clear new entries first for (POLYUNSIGNED d = vectorToUse->vectorSize; d < newDepth; d++) vectorToUse->vector[d] = 0; for (POLYUNSIGNED d = vectorToUse->vectorSize; d < newDepth; d++) { try { if (length != 0 && length < FIXEDLENGTHSIZE) vectorToUse->vector[d] = new DepthVectorWithFixedLength(length); else vectorToUse->vector[d] = new DepthVectorWithVariableLength; } catch (std::bad_alloc &) { throw MemoryException(); } } vectorToUse->vectorSize = newDepth; } vectorToUse->vector[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.SpaceForAddress((PolyWord*)ptrVector[j]-1); 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++) ptrVector[i]->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; } 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.SpaceForAddress(((PolyWord*)obj)-1); 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); 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) 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].vectorSize) { DepthVector *vec = depthVectorArray[j].vector[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].vectorSize > 0) { DepthVector *v = depthVectorArray[j].vector[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].vectorSize) { DepthVector *v = depthVectorArray[j].vector[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(); // 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(PolyObject *threadId, PolyWord root) +POLYUNSIGNED PolyShareCommonData(FirstArgument threadId, PolyWord root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { if (! 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 6a535e18..f9264223 100644 --- a/libpolyml/sighandler.cpp +++ b/libpolyml/sighandler.cpp @@ -1,586 +1,586 @@ /* Title: Signal handling Author: David C.J. Matthews Copyright (c) 2000-8, 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 */ #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(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H)) // Don't include semaphore.h on Mingw. It's provided but doesn't compile. #include #endif #if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H) && defined(HAVE_SEMAPHORE_H)) // If we have the pthread library and header and we have semaphores we can use the pthread // signalling mechanism. But if this is a native Windows build we don't use semaphores or // pthread even if they're provided. #define USE_PTHREAD_SIGNALS 1 #endif #if (defined(_WIN32) && ! defined(__CYGWIN__)) #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(PolyObject *threadId, PolyWord signalNo, PolyWord action); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyWaitForSignal(PolyObject *threadId); + POLYEXTERNALSYMBOL POLYUNSIGNED PolySetSignalHandler(FirstArgument threadId, PolyWord signalNo, PolyWord action); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyWaitForSignal(FirstArgument 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; #ifdef USE_PTHREAD_SIGNALS 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; #ifdef USE_PTHREAD_SIGNALS // 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 #ifdef USE_PTHREAD_SIGNALS // 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(PolyObject *threadId, PolyWord signalNo, PolyWord action) +POLYUNSIGNED PolySetSignalHandler(FirstArgument threadId, PolyWord signalNo, PolyWord 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); /* 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) { #ifdef USE_PTHREAD_SIGNALS 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(PolyObject *threadId) +POLYUNSIGNED PolyWaitForSignal(FirstArgument 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 */ #ifdef USE_PTHREAD_SIGNALS // 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) || defined(__CYGWIN__)) 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*/); #ifdef USE_PTHREAD_SIGNALS SigHandler() { threadRunning = false; } pthread_t detectionThreadId; bool threadRunning; #endif }; // Declare this. It will be automatically added to the table. static SigHandler sighandlerModule; #ifdef USE_PTHREAD_SIGNALS // 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 #ifdef USE_PTHREAD_SIGNALS 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) { #ifdef USE_PTHREAD_SIGNALS 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/timing.cpp b/libpolyml/timing.cpp index 3144e58f..d38386b6 100644 --- a/libpolyml/timing.cpp +++ b/libpolyml/timing.cpp @@ -1,599 +1,599 @@ /* 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 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_SYS_STAT_H #include #endif #ifdef HAVE_SYS_SIGNAL_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 PolyTimingGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); } #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* 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) && ! defined(__CYGWIN__)) 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 static Handle timing_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, code->Word()); switch (c) { case 0: /* Get ticks per microsecond. */ return Make_arbitrary_precision(taskData, TICKS_PER_MICROSECOND); case 1: /* Return time since the time base. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ft; GetSystemTimeAsFileTime(&ft); return Make_arb_from_Filetime(taskData, ft); #else struct timeval tv; if (gettimeofday(&tv, NULL) != 0) raise_syscall(taskData, "gettimeofday failed", errno); return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #endif } case 2: /* Return the base year. This is the year which corresponds to zero in the timing sequence. */ #if (defined(_WIN32) && ! defined(__CYGWIN__)) return Make_arbitrary_precision(taskData, 1601); #else return Make_arbitrary_precision(taskData, 1970); #endif case 3: /* 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. */ return Make_arbitrary_precision(taskData, 0); case 4: /* Return the time offset which applied/will apply at the specified time (in seconds). */ { int localoff = 0; time_t theTime; int day = 0; #if (defined(HAVE_GMTIME_R) || defined(HAVE_LOCALTIME_R)) struct tm result; #endif #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* 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, args, &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(args)); /* May raise exception. */ #endif { #ifdef HAVE_GMTIME_R struct tm *loctime = gmtime_r(&theTime, &result); #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, &result); #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; } } return Make_arbitrary_precision(taskData, localoff); } case 5: /* Find out if Summer Time (daylight saving) was/will be in effect. */ { time_t theTime; #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. getFileTimeFromArb(taskData, args, &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(args)); /* May raise exception. */ #endif int isDst = 0; #ifdef HAVE_LOCALTIME_R struct tm result; struct tm *loctime = localtime_r(&theTime, &result); 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 return Make_arbitrary_precision(taskData, isDst); } case 6: /* Call strftime. It would be possible to do much of this in ML except that it requires the current locale. */ { struct tm time; char *format, buff[2048]; Handle resString; /* Get the format string. */ format = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); /* Copy the time information. */ time.tm_year = get_C_int(taskData, DEREFHANDLE(args)->Get(1)) - 1900; time.tm_mon = get_C_int(taskData, DEREFHANDLE(args)->Get(2)); time.tm_mday = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); time.tm_hour = get_C_int(taskData, DEREFHANDLE(args)->Get(4)); time.tm_min = get_C_int(taskData, DEREFHANDLE(args)->Get(5)); time.tm_sec = get_C_int(taskData, DEREFHANDLE(args)->Get(6)); time.tm_wday = get_C_int(taskData, DEREFHANDLE(args)->Get(7)); time.tm_yday = get_C_int(taskData, DEREFHANDLE(args)->Get(8)); time.tm_isdst = get_C_int(taskData, DEREFHANDLE(args)->Get(9)); #if (defined(_WIN32) && ! defined(__CYGWIN__)) _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); return resString; } case 7: /* Return User CPU time since the start. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ut, ct, et, kt; if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); return Make_arb_from_Filetime(taskData, ut); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, rusage.ru_utime.tv_usec, 1000000); #endif } case 8: /* Return System CPU time since the start. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ct, et, kt, ut; if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); return Make_arb_from_Filetime(taskData, kt); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, rusage.ru_stime.tv_usec, 1000000); #endif } case 9: /* Return GC time since the start. */ return gHeapSizeParameters.getGCUtime(taskData); case 10: /* Return real time since the start. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ft; GetSystemTimeAsFileTime(&ft); subFiletimes(&ft, &startTime); return Make_arb_from_Filetime(taskData, ft); #else struct timeval tv; if (gettimeofday(&tv, NULL) != 0) raise_syscall(taskData, "gettimeofday failed", errno); subTimevals(&tv, &startTime); return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #endif } /* These next two are used only in the Posix structure. */ case 11: /* Return User CPU time used by child processes. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) return Make_arbitrary_precision(taskData, 0); #else struct rusage rusage; if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, rusage.ru_utime.tv_usec, 1000000); #endif } case 12: /* Return System CPU time used by child processes. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) return Make_arbitrary_precision(taskData, 0); #else struct rusage rusage; if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, rusage.ru_stime.tv_usec, 1000000); #endif } case 13: /* Return GC system time since the start. */ return gHeapSizeParameters.getGCStime(taskData); default: { char msg[100]; sprintf(msg, "Unknown timing function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to timing. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyTimingGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyTimingGeneral(FirstArgument threadId, PolyWord code, PolyWord 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 = timing_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(); } #ifdef HAVE_WINDOWS_H 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[] = { { "PolyTimingGeneral", (polyRTSFunction)&PolyTimingGeneral}, { 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) && ! defined(__CYGWIN__)) // 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 6485fada..66ac58cd 100644 --- a/libpolyml/unix_specific.cpp +++ b/libpolyml/unix_specific.cpp @@ -1,2028 +1,2028 @@ /* Title: Operating Specific functions: Unix version. Copyright (c) 2000-8, 2016-17, 2019 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_SYS_SIGNAL_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SYS_TERMIOS_H #include #elif (defined(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(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetOSType(); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixSleep(PolyObject *threadId, PolyWord maxTime, PolyWord sigCount); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixSleep(FirstArgument threadId, PolyWord maxTime, PolyWord sigCount); } #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); if (pid == 0) processes->SetSingleThreaded(); 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(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord 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(PolyObject *threadId, PolyWord maxMillisecs, PolyWord sigCount) +POLYUNSIGNED PolyPosixSleep(FirstArgument threadId, PolyWord maxMillisecs, PolyWord 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); } struct _entrypts osSpecificEPT[] = { { "PolyGetOSType", (polyRTSFunction)&PolyGetOSType}, { "PolyOSSpecificGeneral", (polyRTSFunction)&PolyOSSpecificGeneral}, { "PolyPosixSleep", (polyRTSFunction)&PolyPosixSleep}, { 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 8425a03e..2a36a20b 100644 --- a/libpolyml/winbasicio.cpp +++ b/libpolyml/winbasicio.cpp @@ -1,1442 +1,1442 @@ /* 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(PolyObject *threadId, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(PolyObject *threadId, PolyWord code, PolyWord strm, PolyWord arg); - POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(PolyObject *threadId, PolyWord streamVec, PolyWord bitVec, PolyWord maxMillisecs); + 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); } // 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::waitUntilAvailable(TaskData *taskData) { while (!isAvailable(taskData)) { WaitHandle waiter(NULL); processes->ThreadPauseForIO(taskData, &waiter); } } void WinStream::waitUntilOutputPossible(TaskData *taskData) { while (!canOutput(taskData)) { // Use the default waiter for the moment since we don't have // one to test for output. processes->ThreadPauseForIO(taskData, Waiter::defaultWaiter); } } void WinStream::unimplemented(TaskData *taskData) { // Called on the random access functions raise_syscall(taskData, "Position error", ERROR_NOT_SUPPORTED); } 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()); } } void WinInOutStream::waitUntilAvailable(TaskData *taskData) { while (!isAvailable(taskData)) { WaitHandle waiter(hEvent); processes->ThreadPauseForIO(taskData, &waiter); } } int WinInOutStream::poll(TaskData *taskData, int test) { if (test & POLL_BIT_IN) { if (isAvailable(taskData)) return POLL_BIT_IN; } if (test & POLL_BIT_OUT) { if (canOutput(taskData)) 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); 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; } void WinInOutStream::waitUntilOutputPossible(TaskData *taskData) { if (isRead) unimplemented(taskData); while (!canOutput(taskData)) { WaitHandle waiter(hEvent); processes->ThreadPauseForIO(taskData, &waiter); } } // 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; // Legacy: during the bootstrap we will have old format references. if (stream->Word().IsTagged() && stream->Word().UnTagged() == 0) strm = standardInput; else 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; // Legacy: During the bootstrap we may have old-format file descriptors // which were assumed to be persistent. if (stream->Word().IsTagged() && stream->Word().UnTagged() == 1) { if (standardOutputValue == 0) { stream = MakeVolatileWord(taskData, standardOutput); standardOutputValue = stream->WordP(); } else stream = taskData->saveVec.push(standardOutputValue); } 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()); } // Wait for the shorter of the times. class WaitUpto : public Waiter { public: WaitUpto(unsigned mSecs) : maxTime(mSecs) {} virtual void Wait(unsigned maxMillisecs) { Sleep(maxTime < maxMillisecs ? maxTime : maxMillisecs); } private: unsigned maxTime; }; // 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(PolyObject *threadId, PolyWord streamVector, PolyWord bitVector, PolyWord maxMillisecs) +POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVector, PolyWord bitVector, PolyWord 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()); // 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. */ WaitUpto waiter(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(PolyObject *threadId, PolyWord arg) +POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord 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->isAvailable(taskData) ? 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->canOutput(taskData) ? 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); } /* Functions added for Posix structure. */ case 30: /* Return underlying file descriptor. */ { // Legacy: This was previously used LibrarySupport.wrapInFileDescr // to see if a stream was one of the standard streams. if (strm->Word().IsTagged()) return strm; else { WinStream *stream = *(WinStream**)(strm->WordP()); if (stream == standardInput) return Make_fixed_precision(taskData, 0); else if (stream == standardOutput) return Make_fixed_precision(taskData, 1); else if (stream == standardError) return Make_fixed_precision(taskData, 2); else return Make_fixed_precision(taskData, 3 /* > 2 */); } } /* 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(PolyObject *threadId, PolyWord code, PolyWord strm, PolyWord arg) +POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord 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(); } struct _entrypts basicIOEPT[] = { { "PolyChDir", (polyRTSFunction)&PolyChDir }, { "PolyBasicIOGeneral", (polyRTSFunction)&PolyBasicIOGeneral }, { "PolyPollIODescriptors", (polyRTSFunction)&PolyPollIODescriptors }, { 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 c3de2d23..3a8cccb3 100644 --- a/libpolyml/windows_specific.cpp +++ b/libpolyml/windows_specific.cpp @@ -1,1113 +1,1113 @@ /* 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 PolyOSSpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetOSType(); } typedef enum { HE_UNUSED, HE_PROCESS } HANDENTRYTYPE; typedef struct { HANDLE hProcess, hInput, hOutput; } PROCESSDATA; static Handle execute(TaskData *taskData, Handle pname); static Handle simpleExecute(TaskData *taskData, Handle args); static Handle openProcessHandle(TaskData *taskData, Handle args, bool fIsRead, bool fIsText); static Handle openRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); static Handle createRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); static Handle queryRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); static Handle setRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); static Handle deleteRegistryKey(TaskData *taskData, Handle args, HKEY hkParent); static Handle deleteRegistryValue(TaskData *taskData, Handle args, HKEY hkParent); static Handle enumerateRegistry(TaskData *taskData, Handle args, HKEY hkey, BOOL isKey); // Vector of constants returned by call1006 static POLYUNSIGNED winConstVec[] = { KEY_ALL_ACCESS, // 0 KEY_CREATE_LINK, KEY_CREATE_SUB_KEY, KEY_ENUMERATE_SUB_KEYS, KEY_EXECUTE, KEY_NOTIFY, KEY_QUERY_VALUE, KEY_READ, KEY_SET_VALUE, KEY_WRITE, // 9 STATUS_ACCESS_VIOLATION, // 10 STATUS_ARRAY_BOUNDS_EXCEEDED, STATUS_BREAKPOINT, STATUS_CONTROL_C_EXIT, STATUS_DATATYPE_MISALIGNMENT, STATUS_FLOAT_DENORMAL_OPERAND, STATUS_FLOAT_DIVIDE_BY_ZERO, STATUS_FLOAT_INEXACT_RESULT, STATUS_FLOAT_INVALID_OPERATION, STATUS_FLOAT_OVERFLOW, STATUS_FLOAT_STACK_CHECK, STATUS_FLOAT_UNDERFLOW, STATUS_GUARD_PAGE_VIOLATION, STATUS_INTEGER_DIVIDE_BY_ZERO, STATUS_INTEGER_OVERFLOW, STATUS_ILLEGAL_INSTRUCTION, STATUS_INVALID_DISPOSITION, #ifdef STATUS_INVALID_HANDLE STATUS_INVALID_HANDLE, #else 0, // Not defined in Win CE #endif STATUS_IN_PAGE_ERROR, STATUS_NONCONTINUABLE_EXCEPTION, STATUS_PENDING, STATUS_PRIVILEGED_INSTRUCTION, STATUS_SINGLE_STEP, STATUS_STACK_OVERFLOW, STATUS_TIMEOUT, STATUS_USER_APC, // 35 VER_PLATFORM_WIN32s, // 36 VER_PLATFORM_WIN32_WINDOWS, VER_PLATFORM_WIN32_NT, // 38 // VER_PLATFORM_WIN32_CE is only defined in the Windows CE headers #ifdef VER_PLATFORM_WIN32_CE VER_PLATFORM_WIN32_CE, // 39 #else 3, // 39 #endif }; HKEY hkPredefinedKeyTab[] = { HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, #ifdef HKEY_PERFORMANCE_DATA HKEY_PERFORMANCE_DATA, #else 0, // Not defined in Win CE #endif #ifdef HKEY_CURRENT_CONFIG HKEY_CURRENT_CONFIG, #else 0, #endif #ifdef HKEY_DYN_DATA HKEY_DYN_DATA #else 0 #endif }; Handle OS_spec_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORD(code)); switch (c) { case 0: /* Return our OS type. Not in any structure. */ return Make_fixed_precision(taskData, 1); /* 1 for Windows. */ /* Windows-specific functions. */ case 1000: /* execute */ return execute(taskData, args); case 1001: /* Get input stream as text. */ return openProcessHandle(taskData, args, true, true); case 1002: /* Get output stream as text. */ return openProcessHandle(taskData, args, false, true); case 1003: /* Get input stream as binary. */ return openProcessHandle(taskData, args, true, false); case 1004: /* Get output stream as binary. */ return openProcessHandle(taskData, args, false, false); case 1005: /* Get result of process. */ { PROCESSDATA *hnd = *(PROCESSDATA**)(args->WordP()); *(PROCESSDATA**)(args->WordP()) = 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); return Make_fixed_precision(taskData, dwResult); } // Block and try again. WaitHandle waiter(hnd->hProcess); processes->ThreadPauseForIO(taskData, &waiter); } } case 1006: /* Return a constant. */ { unsigned i = get_C_unsigned(taskData, DEREFWORD(args)); if (i >= sizeof(winConstVec)/sizeof(winConstVec[0])) raise_syscall(taskData, "Invalid index", 0); return Make_arbitrary_precision(taskData, winConstVec[i]); } /* Registry functions. */ case 1007: // Open a key within one of the roots. { unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); // This should only ever happen as a result of a fault in // the Windows structure. if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) raise_syscall(taskData, "Invalid index", 0); return openRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); } case 1008: // Open a subkey of an opened key. { HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); if (hKey == 0) raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); return openRegistryKey(taskData, args, hKey); } case 1009: // Create a subkey within one of the roots. { unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); // This should only ever happen as a result of a fault in // the Windows structure. if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) raise_syscall(taskData, "Invalid index", 0); return createRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); } case 1010: // Create a subkey within an opened key. { HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); if (hKey == 0) raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); return createRegistryKey(taskData, args, hKey); } case 1011: // Close a registry handle. { HKEY hKey = *(HKEY*)(args->WordP()); if (hKey != 0) { RegCloseKey(hKey); *(void**)(args->WordP()) = 0; } return Make_fixed_precision(taskData, 0); } case 1012: // Get a value { unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); // This should only ever happen as a result of a fault in // the Windows structure. if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) raise_syscall(taskData, "Invalid index", 0); return queryRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); } case 1013: // Get a value { HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); if (hKey == 0) raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); return queryRegistryKey(taskData, args, hKey); } case 1014: // Delete a subkey { unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); // This should only ever happen as a result of a fault in // the Windows structure. if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) raise_syscall(taskData, "Invalid index", 0); return deleteRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); } case 1015: // Delete a subkey { HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); if (hKey == 0) raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); return deleteRegistryKey(taskData, args, hKey); } case 1016: // Set a value { unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); // This should only ever happen as a result of a fault in // the Windows structure. if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) raise_syscall(taskData, "Invalid index", 0); return setRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]); } case 1017: // Set a value { HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); if (hKey == 0) raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); return setRegistryKey(taskData, args, hKey); } case 1018: // Enumerate a key in the predefined keys { unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) raise_syscall(taskData, "Invalid index", 0); return enumerateRegistry(taskData, args, hkPredefinedKeyTab[keyIndex], TRUE); } case 1019: // Enumerate a key in an opened key { HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); if (hKey == 0) raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); return enumerateRegistry(taskData, args, hKey, TRUE); } case 1020: // Enumerate a value in the predefined keys { unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) raise_syscall(taskData, "Invalid index", 0); return enumerateRegistry(taskData, args, hkPredefinedKeyTab[keyIndex], FALSE); } case 1021: // Enumerate a value in an opened key { HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); if (hKey == 0) raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); return enumerateRegistry(taskData, args, hKey, FALSE); } case 1022: // Delete a value { unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0)); // This should only ever happen as a result of a fault in // the Windows structure. if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0])) raise_syscall(taskData, "Invalid index", 0); return deleteRegistryValue(taskData, args, hkPredefinedKeyTab[keyIndex]); } case 1023: // Delete a value { HKEY hKey = *(HKEY*)(args->WordP()->Get(0).AsObjPtr()); if (hKey == 0) raise_syscall(taskData, "Handle is closed", ERROR_INVALID_HANDLE); return deleteRegistryValue(taskData, args, hKey); } case 1030: // Convert UTC time values to local time. -- No longer used?? { FILETIME ftUTC, ftLocal; /* Get the file time. */ getFileTimeFromArb(taskData, args, &ftUTC); if (! FileTimeToLocalFileTime(&ftUTC, &ftLocal)) raise_syscall(taskData, "FileTimeToLocalFileTime failed", GetLastError()); return Make_arb_from_Filetime(taskData, ftLocal); } case 1031: // Convert local time values to UTC. -- No longer used?? { FILETIME ftUTC, ftLocal; /* Get the file time. */ getFileTimeFromArb(taskData, args, &ftLocal); if (! LocalFileTimeToFileTime(&ftLocal, &ftUTC)) raise_syscall(taskData, "LocalFileTimeToFileTime failed", GetLastError()); return Make_arb_from_Filetime(taskData, ftUTC); } case 1032: // Get volume information. { TCHAR rootName[MAX_PATH], volName[MAX_PATH], sysName[MAX_PATH]; DWORD dwVolSerial, dwMaxComponentLen, dwFlags; Handle volHandle, sysHandle, serialHandle, maxCompHandle; Handle resultHandle; POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), rootName, MAX_PATH); if (length > MAX_PATH) raise_syscall(taskData, "Root name too long", ERROR_BAD_LENGTH); if (!GetVolumeInformation(rootName, volName, MAX_PATH, &dwVolSerial, &dwMaxComponentLen, &dwFlags, sysName, MAX_PATH)) raise_syscall(taskData, "GetVolumeInformation failed", GetLastError()); volHandle = SAVE(C_string_to_Poly(taskData, volName)); sysHandle = SAVE(C_string_to_Poly(taskData, sysName)); serialHandle = Make_arbitrary_precision(taskData, dwVolSerial); maxCompHandle = Make_arbitrary_precision(taskData, dwMaxComponentLen); resultHandle = alloc_and_save(taskData, 4); DEREFHANDLE(resultHandle)->Set(0, volHandle->Word()); DEREFHANDLE(resultHandle)->Set(1, sysHandle->Word()); DEREFHANDLE(resultHandle)->Set(2, serialHandle->Word()); DEREFHANDLE(resultHandle)->Set(3, maxCompHandle->Word()); return resultHandle; } case 1033: { TCHAR fileName[MAX_PATH], execName[MAX_PATH]; POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), fileName, MAX_PATH); HINSTANCE hInst; if (length > MAX_PATH) raise_syscall(taskData, "File name too long", ERROR_BAD_LENGTH); hInst = FindExecutable(fileName, NULL, execName); if ((uintptr_t)hInst <= 32) { int error = 0; switch ((uintptr_t)hInst) { case SE_ERR_FNF: error = ERROR_FILE_NOT_FOUND; break; case SE_ERR_PNF: error = ERROR_PATH_NOT_FOUND; break; case SE_ERR_ACCESSDENIED: error = ERROR_ACCESS_DENIED; break; case SE_ERR_OOM: error = ERROR_NOT_ENOUGH_MEMORY; break; case SE_ERR_NOASSOC: error = ERROR_NO_ASSOCIATION; break; } raise_syscall(taskData, "FindExecutable failed", error); } return SAVE(C_string_to_Poly(taskData, execName)); } case 1034: // Open a document { SHELLEXECUTEINFO shellEx; memset(&shellEx, 0, sizeof(shellEx)); shellEx.cbSize = sizeof(shellEx); shellEx.lpVerb = _T("open"); shellEx.lpFile = Poly_string_to_T_alloc(DEREFWORD(args)); shellEx.hwnd = hMainWindow; shellEx.nShow = SW_SHOWNORMAL; BOOL fRes = ShellExecuteEx(&shellEx); free((void*)shellEx.lpFile); if (! fRes) raise_syscall(taskData, "ShellExecuteEx failed", GetLastError()); return Make_fixed_precision(taskData, 0); } case 1035: // Launch an application. { SHELLEXECUTEINFO shellEx; memset(&shellEx, 0, sizeof(shellEx)); shellEx.cbSize = sizeof(shellEx); shellEx.lpVerb = _T("open"); shellEx.lpFile = Poly_string_to_T_alloc(args->WordP()->Get(0)); shellEx.lpParameters = Poly_string_to_T_alloc(args->WordP()->Get(1)); shellEx.nShow = SW_SHOWNORMAL; BOOL fRes = ShellExecuteEx(&shellEx); free((void*)shellEx.lpFile); free((void*)shellEx.lpParameters); if (! fRes) raise_syscall(taskData, "ShellExecuteEx failed", GetLastError()); return Make_fixed_precision(taskData, 0); } case 1036: // Does the process have its own console? return Make_fixed_precision(taskData, hMainWindow != NULL ? 1: 0); case 1037: // Simple execute. return simpleExecute(taskData, args); // DDE case 1038: // Start DDE dialogue. { TCHAR *serviceName = Poly_string_to_T_alloc(args->WordP()->Get(0)); TCHAR *topicName = Poly_string_to_T_alloc(args->WordP()->Get(1)); /* 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. return MakeVolatileWord(taskData, hcDDEConv); } case 1039: // Send DDE execute request. { HCONV hcDDEConv = *(HCONV*)(args->WordP()->Get(0).AsObjPtr()); if (hcDDEConv == 0) raise_syscall(taskData, "DDE Conversation is closed", 0); char *command = Poly_string_to_C_alloc(args->WordP()->Get(1)); /* Send a request to the main thread to do the work. */ LRESULT res = ExecuteDDE(command, hcDDEConv); free(command); if (res == -1) raise_syscall(taskData, "DdeClientTransaction failed", 0); else return Make_arbitrary_precision(taskData, res); } case 1040: // Close a DDE conversation. { HCONV hcDDEConv = *(HCONV*)(args->WordP()->Get(0).AsObjPtr()); if (hcDDEConv != 0) { CloseDDEConversation(hcDDEConv); *(void**)(args->WordP()->Get(0).AsObjPtr()) = 0; } return Make_fixed_precision(taskData, 0); } // Configuration functions. case 1050: // Get version data { OSVERSIONINFO osver; ZeroMemory(&osver, sizeof(OSVERSIONINFO)); osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); // GetVersionEx is deprecated in Windows 8.1 if (! GetVersionEx(&osver)) raise_syscall(taskData, "GetVersionEx failed", GetLastError()); Handle major = Make_fixed_precision(taskData, osver.dwMajorVersion); Handle minor = Make_fixed_precision(taskData, osver.dwMinorVersion); Handle build = Make_fixed_precision(taskData, osver.dwBuildNumber); Handle platform = Make_fixed_precision(taskData, osver.dwPlatformId); Handle version = SAVE(C_string_to_Poly(taskData, osver.szCSDVersion)); Handle resVal = alloc_and_save(taskData, 5); DEREFHANDLE(resVal)->Set(0, major->Word()); DEREFHANDLE(resVal)->Set(1, minor->Word()); DEREFHANDLE(resVal)->Set(2, build->Word()); DEREFHANDLE(resVal)->Set(3, platform->Word()); DEREFHANDLE(resVal)->Set(4, version->Word()); return resVal; } case 1051: // Get windows directory { TCHAR path[MAX_PATH+1]; if (GetWindowsDirectory(path, sizeof(path)/sizeof(TCHAR)) == 0) raise_syscall(taskData, "GetWindowsDirectory failed", GetLastError()); return SAVE(C_string_to_Poly(taskData, path)); } case 1052: // Get system directory { TCHAR path[MAX_PATH+1]; if (GetSystemDirectory(path, sizeof(path)/sizeof(TCHAR)) == 0) raise_syscall(taskData, "GetSystemDirectory failed", GetLastError()); return SAVE(C_string_to_Poly(taskData, path)); } case 1053: // Get computer name { TCHAR name[MAX_COMPUTERNAME_LENGTH +1]; DWORD dwSize = MAX_COMPUTERNAME_LENGTH +1; if (GetComputerName(name, &dwSize) == 0) raise_syscall(taskData, "GetComputerName failed", GetLastError()); return SAVE(C_string_to_Poly(taskData, name)); } case 1054: // Get user name { TCHAR name[UNLEN +1]; DWORD dwSize = UNLEN +1; if (GetUserName(name, &dwSize) == 0) raise_syscall(taskData, "GetUserName failed", GetLastError()); return SAVE(C_string_to_Poly(taskData, name)); } case 1100: // Get the error result from the last call. // This is saved when we make a call to a foreign function. { return(SAVE(TAGGED(taskData->lastError))); } case 1101: // Wait for a message. { HWND hwnd = *(HWND*)(DEREFWORDHANDLE(args)->Get(0).AsCodePtr()); UINT wMsgFilterMin = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); UINT wMsgFilterMax = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); while (1) { MSG msg; processes->ThreadReleaseMLMemory(taskData); // N.B. PeekMessage may directly call the window proc resulting in a // callback to ML. For this to work a callback must not overwrite "args". BOOL result = PeekMessage(&msg, hwnd, wMsgFilterMin, wMsgFilterMax, PM_NOREMOVE); processes->ThreadUseMLMemory(taskData); if (result) return Make_fixed_precision(taskData, 0); // Pause until a message arrives. processes->ThreadPause(taskData); } } // case 1102: // Return the address of the window callback function. case 1103: // Return the application instance. { Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ); *(HINSTANCE*)(result->Word().AsCodePtr()) = hApplicationInstance; return result; } case 1104: // Return the main window handle { Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ); *(HWND*)(result->Word().AsCodePtr()) = hMainWindow; return result; } // case 1105: // Set the callback function default: { char msg[100]; sprintf(msg, "Unknown windows-specific function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } } // General interface to Windows OS-specific. Ideally the various cases will be made into // separate functions. -POLYUNSIGNED PolyOSSpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) +POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord 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 (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(); } POLYUNSIGNED PolyGetOSType() { return TAGGED(1).AsUnsigned(); // Return 1 for Windows } /* 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, Handle args) { 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(args->WordP()->Get(0)); LPTSTR arguments = Poly_string_to_T_alloc(args->WordP()->Get(1)); 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. } } static Handle simpleExecute(TaskData *taskData, Handle args) { HANDLE hNull = INVALID_HANDLE_VALUE; PROCESS_INFORMATION processInfo; TCHAR *commandName = Poly_string_to_T_alloc(args->WordP()->Get(0)); TCHAR *arguments = Poly_string_to_T_alloc(args->WordP()->Get(1)); 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)); } /* Return a stream, either text or binary, connected to an open process. */ static Handle openProcessHandle(TaskData *taskData, Handle args, bool fIsRead, bool fIsText) { PROCESSDATA *hnd = *(PROCESSDATA**)(args->WordP()); 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 result; if (fIsRead) result = stream->openHandle(hnd->hInput, OPENREAD, fIsText); else result = stream->openHandle(hnd->hOutput, OPENWRITE, fIsText); if (!result) { delete(stream); raise_syscall(taskData, "openHandle failed", GetLastError()); } return MakeVolatileWord(taskData, stream); } catch (std::bad_alloc&) { raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); } } // Open a registry key and make an entry in the table for it. static Handle openRegistryKey(TaskData *taskData, Handle args, HKEY hkParent) { TCHAR keyName[MAX_PATH]; REGSAM sam = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH); if (length > MAX_PATH) raise_syscall(taskData, "Key name too long", ERROR_BAD_LENGTH); // Try opening the key. HKEY hkey; LONG lRes = RegOpenKeyEx(hkParent, keyName, 0, sam, &hkey); if (lRes != ERROR_SUCCESS) raise_syscall(taskData, "RegOpenKeyEx failed", lRes); return MakeVolatileWord(taskData, hkey); } // Create a registry key and make an entry in the table for it. static Handle createRegistryKey(TaskData *taskData, Handle args, HKEY hkParent) { TCHAR keyName[MAX_PATH]; HKEY hkey; DWORD dwDisp; REGSAM sam = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(3)); unsigned opt = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH); if (length > MAX_PATH) raise_syscall(taskData, "Key name too long", ERROR_BAD_LENGTH); // Try opening the key. LONG lRes = RegCreateKeyEx(hkParent, keyName, 0, NULL, opt ? REG_OPTION_NON_VOLATILE : REG_OPTION_VOLATILE, sam, NULL, &hkey, &dwDisp); if (lRes != ERROR_SUCCESS) raise_syscall(taskData, "RegCreateKeyEx failed", lRes); // Make an entry in the table. Handle keyResult = MakeVolatileWord(taskData, hkey); // Record whether this was new or old. Handle dispRes = Make_fixed_precision(taskData, dwDisp == REG_CREATED_NEW_KEY ? 0: 1); /* Return a pair of the disposition and the token. */ Handle pair = alloc_and_save(taskData, 2); DEREFHANDLE(pair)->Set(0, dispRes->Word()); DEREFHANDLE(pair)->Set(1, keyResult->Word()); return pair; } // Delete a key. Note that in Windows NT (but not 95) this will fail if // the key has subkeys. static Handle deleteRegistryKey(TaskData *taskData, Handle args, HKEY hkParent) { TCHAR keyName[MAX_PATH]; LONG lRes; POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH); if (length > MAX_PATH) raise_syscall(taskData, "Key name too long", ERROR_BAD_LENGTH); // Try deleting the key. lRes = RegDeleteKey(hkParent, keyName); if (lRes != ERROR_SUCCESS) /* Return the error. */ raise_syscall(taskData, "RegDeleteKey failed", lRes); return Make_fixed_precision(taskData, 0); } static Handle deleteRegistryValue(TaskData *taskData, Handle args, HKEY hkParent) { TCHAR keyName[MAX_PATH]; LONG lRes; POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH); if (length > MAX_PATH) raise_syscall(taskData, "Key name too long", ERROR_BAD_LENGTH); // Try deleting the value. lRes = RegDeleteValue(hkParent, keyName); if (lRes != ERROR_SUCCESS) /* Return the original error. */ raise_syscall(taskData, "RegDeleteValue failed", lRes); return Make_fixed_precision(taskData, 0); } static Handle queryRegistryKey(TaskData *taskData, Handle args, HKEY hkey) { TCHAR valName[MAX_PATH]; byte *keyValue = 0; LONG lRes; DWORD valSize; Handle result, resVal, resType; DWORD dwType; POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), valName, MAX_PATH); if (length > MAX_PATH) raise_syscall(taskData, "Value name too long", ERROR_BAD_LENGTH); // How long is the entry? lRes = RegQueryValueEx(hkey, valName, 0, NULL, NULL, &valSize); // When opening HKEY_PERFORMANCE_DATA we don't get a sensible // answer here. if (lRes == ERROR_MORE_DATA) valSize = 1024; // Guess else if (lRes != ERROR_SUCCESS) raise_syscall(taskData, "RegQueryValueEx failed", lRes); // Allocate that much store and get the value. We could // try reading directly into ML store to save copying but // it hardly seems worthwhile. // Note: It seems that valSize can be zero for some items. if (valSize == 0) resVal = SAVE(C_string_to_Poly(taskData, "", 0)); else { do { byte *newAlloc = (byte*)realloc(keyValue, valSize); if (newAlloc == 0) { free(keyValue); raise_syscall(taskData, "Insufficient memory", ERROR_NOT_ENOUGH_MEMORY); } keyValue = newAlloc; lRes = RegQueryValueEx(hkey, valName, 0, &dwType, keyValue, &valSize); // In the special case of HKEY_PERFORMANCE_DATA we may need to keep // growing the buffer. if (lRes == ERROR_MORE_DATA) valSize = valSize + 1024; } while (lRes == ERROR_MORE_DATA); if (lRes != ERROR_SUCCESS) { free(keyValue); raise_syscall(taskData, "RegQueryValue failed", lRes); } // If we have a string we have to convert this to ANSI/utf-8. if (dwType == REG_SZ || dwType == REG_MULTI_SZ || dwType == REG_EXPAND_SZ) resVal = SAVE(C_string_to_Poly(taskData, (TCHAR*)keyValue, valSize / sizeof(TCHAR))); else resVal = SAVE(C_string_to_Poly(taskData, (char*)keyValue, valSize)); free(keyValue); } /* Create a pair containing the type and the value. */ resType = Make_fixed_precision(taskData, dwType); result = alloc_and_save(taskData, 2); DEREFHANDLE(result)->Set(0, resType->Word()); DEREFHANDLE(result)->Set(1, resVal->Word()); return result; } static Handle setRegistryKey(TaskData *taskData, Handle args, HKEY hkey) { TCHAR valName[MAX_PATH]; LONG lRes; PolyWord str = args->WordP()->Get(3); POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), valName, MAX_PATH); DWORD dwType = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2)); if (length > MAX_PATH) raise_syscall(taskData, "Value name too long", ERROR_BAD_LENGTH); // The value is binary. Strings will already have had a null added. if (IS_INT(str)) { byte b = (byte)UNTAGGED(str); // Single byte value. lRes = RegSetValueEx(hkey, valName, 0, dwType, &b, 1); } else { PolyStringObject *ps = (PolyStringObject*)str.AsObjPtr(); lRes = RegSetValueEx(hkey, valName, 0, dwType, (CONST BYTE *)ps->chars, (DWORD)ps->length); } if (lRes != ERROR_SUCCESS) raise_syscall(taskData, "RegSetValue failed", lRes); return Make_fixed_precision(taskData, 0); } // Enumerate a key or a value. Returns a string option containing NONE if // no key/value could be found or SOME s where s is the name of the key/value. static Handle enumerateRegistry(TaskData *taskData, Handle args, HKEY hkey, BOOL isKey) { DWORD num = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1)); LONG lRes; TCHAR keyName[MAX_PATH]; DWORD dwLength = sizeof(keyName)/sizeof(keyName[0]); Handle result, resVal; if (isKey) { FILETIME ftMod; lRes = RegEnumKeyEx(hkey, num, keyName, &dwLength, NULL, NULL, NULL, &ftMod); if (lRes != ERROR_SUCCESS && lRes != ERROR_NO_MORE_ITEMS) raise_syscall(taskData, "RegEnumKeyEx failed", lRes); } else { lRes = RegEnumValue(hkey, num, keyName, &dwLength, NULL, NULL, NULL, NULL); if (lRes != ERROR_SUCCESS && lRes != ERROR_NO_MORE_ITEMS) raise_syscall(taskData, "RegEnumValue failed", lRes); } if (lRes == ERROR_NO_MORE_ITEMS) return SAVE(NONE_VALUE); /* NONE. */ resVal = SAVE(C_string_to_Poly(taskData, keyName)); result = alloc_and_save(taskData, 1); DEREFHANDLE(result)->Set(0, resVal->Word()); return result; } struct _entrypts osSpecificEPT[] = { { "PolyGetOSType", (polyRTSFunction)&PolyGetOSType}, { "PolyOSSpecificGeneral", (polyRTSFunction)&PolyOSSpecificGeneral}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/xwindows.cpp b/libpolyml/xwindows.cpp index e931033f..f36eb408 100644 --- a/libpolyml/xwindows.cpp +++ b/libpolyml/xwindows.cpp @@ -1,9634 +1,9634 @@ /* 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(PolyObject *threadId, PolyWord params); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord 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"); 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; } // Test whether input is available and block if it is not. // N.B. There may be a GC while in here. // This was previously in basicio.cpp but has been moved here // since this is the only place it's used now. static void process_may_block(TaskData *taskData, int fd) { #ifdef __CYGWIN__ static struct timeval poll = {0,1}; #else static struct timeval poll = {0,0}; #endif fd_set read_fds; int selRes; while (1) { FD_ZERO(&read_fds); FD_SET(fd,&read_fds); /* If there is something there we can return. */ selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll); if (selRes > 0) return; /* Something waiting. */ else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr raise_syscall(taskData, "select failed", errno); WaitInputFD waiter(fd); processes->ThreadPauseForIO(taskData, &waiter); } } 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) { process_may_block(taskData, display->fd); } 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) { process_may_block(taskData, DEREFDISPLAYHANDLE(dsHandle)->display->fd); } 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(PolyObject *threadId, PolyWord params) +POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord params); + POLYEXTERNALSYMBOL POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord 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(PolyObject *threadId, PolyWord /*params*/) +POLYUNSIGNED PolyXWindowsGeneral(FirstArgument threadId, PolyWord /*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 diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml index e01a0d26..15960b20 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml @@ -1,500 +1,370 @@ (* Copyright (c) 2016-19 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 *) functor X86FOREIGNCALL( structure X86CODE: X86CODESIG structure X86OPTIMISE: sig type operation type code type operations = operation list type closureRef (* Optimise and code-generate. *) val generateCode: {code: code, ops: operations, labelCount: int, resultClosure: closureRef} -> unit structure Sharing: sig type operation = operation type code = code type closureRef = closureRef end end structure DEBUG: DEBUGSIG structure CODE_ARRAY: CODEARRAYSIG sharing X86CODE.Sharing = X86OPTIMISE.Sharing = CODE_ARRAY.Sharing ): FOREIGNCALLSIG = struct open X86CODE open Address open CODE_ARRAY (* Unix X64. The first six arguments are in rdi, rsi, rdx, rcx, r8, r9. The rest are on the stack. Windows X64. The first four arguments are in rcx, rdx, r8 and r9. The rest are on the stack. The caller must ensure the stack is aligned on 16-byte boundary and must allocate 32-byte save area for the register args. rbx, rbp, rdi, rsi, rsp, r12-r15 are saved by the called function. X86/32. Arguments are pushed to the stack. ebx, edi, esi, ebp and esp are saved by the called function. We use esi to hold the argument data pointer and edi to save the ML stack pointer Our ML conventions use eax, ebx for the first two arguments in X86/32, rax, ebx, r8, r9, r10 for the first five arguments in X86/64 and rax, rsi, r8, r9 and r10 for the first five arguments in X86/64-32 bit. *) val (polyWordOpSize, nativeWordOpSize) = case targetArch of Native32Bit => (OpSize32, OpSize32) | Native64Bit => (OpSize64, OpSize64) | ObjectId32Bit => (OpSize32, OpSize64) (* Ebx/Rbx is used for the second argument on the native architectures but is replaced by esi on the object ID arch because ebx is used as the global base register. *) val mlArg2Reg = case targetArch of ObjectId32Bit => esi | _ => ebx exception InternalError = Misc.InternalError fun opSizeToMove OpSize32 = Move32 | opSizeToMove OpSize64 = Move64 val pushR = PushToStack o RegisterArg fun moveRR{source, output, opSize} = Move{source=RegisterArg source, destination=RegisterArg output, moveSize=opSizeToMove opSize} fun loadMemory(reg, base, offset, opSize) = Move{source=MemoryArg{base=base, offset=offset, index=NoIndex}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} and storeMemory(reg, base, offset, opSize) = Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset, index=NoIndex}, moveSize=opSizeToMove opSize} val loadHeapMemory = case targetArch of ObjectId32Bit => ( fn (reg, base, offset, opSize) => Move{source=MemoryArg{base=ebx, offset=offset, index=Index4 base}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} ) | _ => loadMemory fun createProfileObject _ (*functionName*) = let (* The profile object is a single mutable with the F_bytes bit set. *) open Address val profileObject = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(profileObject, i-0w1, 0w0); clear (i-0w1)) val () = clear wordSize in toMachineWord profileObject end val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" datatype abi = X86_32 | X64Win | X64Unix local (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val getABICall: unit -> int = RunCall.rtsCallFast0 "PolyGetABI" in fun getABI() = case getABICall() of 0 => X86_32 | 1 => X64Unix | 2 => X64Win | n => raise InternalError ("Unknown ABI type " ^ Int.toString n) end - (* The RTS sets the exceptionPacket field to this at the start and then if - an exception is raised it stores the exception packet pointer there. *) - val noException = 1 - - (* Full RTS call version. An extra argument is passed that contains the thread ID. - This allows the taskData object to be found which is needed if the code allocates - any ML memory or raises an exception. It also saves the stack and heap pointers - in case of a GC. *) - fun rtsCallFull (functionName, nArgs (* Not counting the thread ID *), debugSwitches) = + (* This is now the standard entry call code. *) + datatype fastArgs = FastArgFixed | FastArgDouble | FastArgFloat + + + fun rtsCallFastGeneral (functionName, argFormats, (*resultFormat*) _, debugSwitches) = let val entryPointAddr = makeEntryPoint functionName (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val abi = getABI() - (* Branch to check for exception. *) - val exLabel = Label{labelNo=0} (* There's just one label in this function. *) - - (* Previously the ML stack pointer was saved in a callee-save register. This works - in almost all circumstances except when a call to the FFI code results in a callback - and the callback moves the ML stack. Instead the RTS callback handler adjusts the value - in memRegStackPtr and we reload the ML stack pointer from there. *) val entryPtrReg = if targetArch <> Native32Bit then r11 else ecx + val nArgs = List.length argFormats + local (* Compute stack space. The actual number of args passed is nArgs+1. *) val argSpace = case abi of - X64Unix => Int.max(0, nArgs+1-6)*8 - | X64Win => Int.max(0, nArgs+1-4)*8 - | X86_32 => (nArgs+1)*4 + X64Unix => Int.max(0, nArgs-6)*8 + | X64Win => Int.max(0, nArgs-4)*8 + | X86_32 => List.foldl(fn (FastArgDouble, n) => n+8 | (_, n) => n+4) 0 argFormats val align = argSpace mod 16 in (* Add sufficient space so that esp will be 16-byte aligned after we have pushed any arguments we need to push. *) val stackSpace = if align = 0 then memRegSize else memRegSize + 16 - align end - (* The RTS functions expect the real address of the thread Id. *) - fun loadThreadId toReg = - if targetArch <> ObjectId32Bit - then [loadMemory(toReg, ebp, memRegThreadSelf, nativeWordOpSize)] - else [loadMemory(toReg, ebp, memRegThreadSelf, polyWordOpSize), - LoadAddress{output=toReg, offset=0, base=SOME ebx, index=Index4 toReg, opSize=nativeWordOpSize}] + (* The number of ML arguments passed on the stack. *) + val mlArgsOnStack = Int.max(case abi of X86_32 => nArgs - 2 | _ => nArgs - 5, 0) val code = [ Move{source=AddressConstArg entryPointAddr, destination=RegisterArg entryPtrReg, moveSize=opSizeToMove polyWordOpSize}, (* Load the entry point ref. *) loadHeapMemory(entryPtrReg, entryPtrReg, 0, nativeWordOpSize)(* Load its value. *) ] @ ( (* Save heap ptr. This is in r15 in X86/64 *) if targetArch <> Native32Bit then [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] (* Save heap ptr *) else [] ) @ ( - if abi = X86_32 andalso nArgs >= 3 + if abi = X86_32 andalso nArgs >= 3 orelse abi = X64Win andalso nArgs >= 6 then [moveRR{source=esp, output=edi, opSize=nativeWordOpSize}] (* Needed if we have to load from the stack. *) else [] ) @ - [ - (* Have to save the stack pointer to the arg structure in case we need to scan the stack for a GC. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) - loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), (*moveRR{source=ebp, output=esp},*) (* Load the saved C stack pointer. *) - (* Set the stack pointer past the data on the stack. *) + loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), + (* Set the stack pointer past the data on the stack. For Windows/64 add in a 32 byte save area *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackSpace), opSize=nativeWordOpSize} ] @ ( case abi of (* Set the argument registers. *) - X64Unix => + X86_32 => let - fun pushArgs 0 = loadThreadId edi - | pushArgs 1 = moveRR{source=eax, output=esi, opSize=polyWordOpSize} :: pushArgs 0 - | pushArgs 2 = moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} :: pushArgs 1 - | pushArgs 3 = moveRR{source=r8, output=ecx, opSize=polyWordOpSize} :: pushArgs 2 - | pushArgs 4 = - (* Have to move r8 into rcx before we can move r9 into r8 *) - moveRR{source=r8, output=ecx, opSize=polyWordOpSize} :: - moveRR{source=r9, output=r8, opSize=polyWordOpSize} :: pushArgs 2 - | pushArgs 5 = - moveRR{source=r8, output=ecx, opSize=polyWordOpSize} :: moveRR{source=r9, output=r8, opSize=polyWordOpSize} :: - moveRR{source=r10, output=r9, opSize=polyWordOpSize} :: pushArgs 2 - | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" - + fun pushReg(reg, FastArgFixed) = [pushR reg] + | pushReg(reg, FastArgDouble) = + (* reg contains the address of the value. This must be unboxed onto the stack. *) + [ + FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=DoublePrecision}, + ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, + FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } + ] + | pushReg(reg, FastArgFloat) = + (* reg contains the address of the value. This must be unboxed onto the stack. *) + [ + FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=SinglePrecision}, + ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, + FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } + ] + + (* The stack arguments have to be copied first followed by the ebx and finally eax. *) + fun pushArgs (_, []) = [] + | pushArgs (_, [argType]) = pushReg(eax, argType) + | pushArgs (_, [arg2Type, arg1Type]) = pushReg(ebx, arg2Type) @ pushReg(eax, arg1Type) + | pushArgs (n, FastArgFixed :: argTypes) = + PushToStack(MemoryArg{base=edi, offset=(nArgs-n+1)* 4, index=NoIndex}) :: pushArgs(n-1, argTypes) + | pushArgs (n, argType :: argTypes) = + (* Use esi as a temporary register. *) + loadMemory(esi, edi, (nArgs-n+1)* 4, polyWordOpSize) :: pushReg(esi, argType) @ pushArgs(n-1, argTypes) in - pushArgs nArgs + pushArgs(nArgs, List.rev argFormats) end - + + | X64Unix => + ( + if List.all (fn FastArgFixed => true | _ => false) argFormats + then + let + fun pushArgs 0 = [] + | pushArgs 1 = [moveRR{source=eax, output=edi, opSize=polyWordOpSize}] + | pushArgs 2 = moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize} :: pushArgs 1 + | pushArgs 3 = moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: pushArgs 2 + | pushArgs 4 = moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: pushArgs 3 + | pushArgs 5 = + (* We have to move r8 into edx before we can move r10 into r8 *) + moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: + moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: + moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 + | pushArgs 6 = + (* We have to move r9 into edi before we can load r9 from the stack. *) + moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: + moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: + loadMemory(r9, edi, 8, polyWordOpSize) :: + moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 + | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" + in + pushArgs nArgs + end + else case argFormats of + [] => [] + | [FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed] => + (* Since mlArgs2Reg is esi on 32-in-64 this is redundant. *) + [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed, FastArgFixed] => + [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, + moveRR{source=r8, output=edx, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => + [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, + moveRR{source=r8, output=edx, opSize=polyWordOpSize}, moveRR{source=r9, output=ecx, opSize=polyWordOpSize} ] + (* One "double" argument. The value needs to be unboxed. *) + | [FastArgDouble] => [] (* Already in xmm0 *) + (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) + | [FastArgDouble, FastArgDouble] => [] + | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=nativeWordOpSize} ] + | [FastArgFloat] => [] (* Already in xmm0 *) + | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) + (* One float argument and one fixed. *) + | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edi, opSize=polyWordOpSize} ] + + | _ => raise InternalError "rtsCall: Abi/argument count not implemented" + + ) + | X64Win => - let - fun pushArgs 0 = loadThreadId ecx - | pushArgs 1 = moveRR{source=eax, output=edx, opSize=polyWordOpSize} :: pushArgs 0 - | pushArgs 2 = moveRR{source=mlArg2Reg, output=r8, opSize=polyWordOpSize} :: pushArgs 1 - | pushArgs 3 = moveRR{source=r8, output=r9, opSize=polyWordOpSize} :: pushArgs 2 - | pushArgs 4 = pushR r9 :: pushArgs 3 - | pushArgs 5 = pushR r10 :: pushArgs 4 - | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" - in - pushArgs nArgs - end - - | X86_32 => - let - (* Arguments have to be pushed in reverse order so that they appear correctly on the - final stack frame. *) - fun pushArgs 0 = [ PushToStack(MemoryArg{base=ebp, offset=memRegThreadSelf, index=NoIndex}) ] - | pushArgs 1 = pushR eax :: pushArgs 0 - | pushArgs 2 = pushR ebx :: pushArgs 1 - | pushArgs n = - PushToStack(MemoryArg{base=edi, offset=(nArgs-n+1)* 4, index=NoIndex}) :: pushArgs(n-1) - in - pushArgs nArgs - end + ( + if List.all (fn FastArgFixed => true | _ => false) argFormats + then + let + fun pushArgs 0 = [] + | pushArgs 1 = [moveRR{source=eax, output=ecx, opSize=polyWordOpSize}] + | pushArgs 2 = moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} :: pushArgs 1 + | pushArgs 3 = (* Already in r8 *) pushArgs 2 + | pushArgs 4 = (* Already in r9, and r8 *) pushArgs 2 + | pushArgs 5 = pushR r10 :: pushArgs 2 + | pushArgs 6 = PushToStack(MemoryArg{base=edi, offset=8, index=NoIndex}) :: pushArgs 5 + | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" + in + pushArgs nArgs + end + + else case argFormats of + [FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} ] + | [FastArgFixed, FastArgFixed, FastArgFixed] => + [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8. *) ] + | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => + [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8 and arg4 in r9. *) ] + | [FastArgDouble] => [ (* Already in xmm0 *) ] + (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) + | [FastArgDouble, FastArgDouble] => [ ] + (* X64 on both Windows and Unix take the first arg in xmm0. On Unix the integer argument is treated + as the first argument and goes into edi. On Windows it's treated as the second and goes into edx. + N.B. It's also the first argument in ML so is in rax. *) + | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edx, opSize=nativeWordOpSize} ] + | [FastArgFloat] => [] + | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) + | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize}] + + | _ => raise InternalError "rtsCall: Abi/argument count not implemented" + ) ) @ (* For Windows/64 add in a 32 byte save area ater we've pushed any arguments. *) (case abi of X64Win => [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg 32, opSize=nativeWordOpSize}] | _ => []) @ [ CallFunction(DirectReg entryPtrReg), (* Call the function *) loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) ] @ ( if targetArch <> Native32Bit then [loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] (* Copy back the heap ptr *) else [] ) @ - [ - ArithMemConst{opc=CMP, address={offset=memRegExceptionPacket, base=ebp, index=NoIndex}, source=noException, opSize=polyWordOpSize}, - ConditionalBranch{test=JNE, label=exLabel}, - (* Remove any arguments that have been passed on the stack. *) - ReturnFromFunction(Int.max(case abi of X86_32 => nArgs-2 | _ => nArgs-5, 0)), - JumpLabel exLabel, (* else raise the exception *) - loadMemory(eax, ebp, memRegExceptionPacket, polyWordOpSize), - RaiseException { workReg=ecx } - ] - - val profileObject = createProfileObject functionName - val newCode = codeCreate (functionName, profileObject, debugSwitches) - val closure = makeConstantClosure() - val () = X86OPTIMISE.generateCode{code=newCode, labelCount=1(*One label.*), ops=code, resultClosure=closure} - in - closureAsAddress closure - end - - (* This is a quicker version but can only be used if the RTS entry does - not allocated ML memory, raise an exception or need to suspend the thread. *) - datatype fastArgs = FastArgFixed | FastArgDouble | FastArgFloat - - - fun rtsCallFastGeneral (functionName, argFormats, (*resultFormat*) _, debugSwitches) = - let - val entryPointAddr = makeEntryPoint functionName - - (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) - val abi = getABI() - - val entryPtrReg = if targetArch <> Native32Bit then r11 else ecx - - val stackSpace = - case abi of - X64Unix => memRegSize - | X64Win => memRegSize + 32 (* Requires 32-byte save area. *) - | X86_32 => - let - (* GCC likes to keep the stack on a 16-byte alignment. *) - val argSpace = List.foldl(fn (FastArgDouble, n) => n+8 | (_, n) => n+4) 0 argFormats - val align = argSpace mod 16 - in - (* Add sufficient space so that esp will be 16-byte aligned *) - if align = 0 - then memRegSize - else memRegSize + 16 - align - end - - (* The number of ML arguments passed on the stack. *) - val mlArgsOnStack = - Int.max(case abi of X86_32 => List.length argFormats - 2 | _ => List.length argFormats - 5, 0) - - val code = - [ - Move{source=AddressConstArg entryPointAddr, destination=RegisterArg entryPtrReg, moveSize=opSizeToMove polyWordOpSize}, (* Load the entry point ref. *) - loadHeapMemory(entryPtrReg, entryPtrReg, 0, nativeWordOpSize)(* Load its value. *) - ] @ - ( - (* Save heap ptr. This is in r15 in X86/64 *) - if targetArch <> Native32Bit then [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] (* Save heap ptr *) - else [] - ) @ - ( - if abi = X86_32 andalso List.length argFormats >= 3 - then [moveRR{source=esp, output=edi, opSize=nativeWordOpSize}] (* Needed if we have to load from the stack. *) - else [] - ) @ - [ - storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) - loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), - (* Set the stack pointer past the data on the stack. For Windows/64 add in a 32 byte save area *) - ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackSpace), opSize=nativeWordOpSize} - ] @ - ( - case (abi, argFormats) of (* Set the argument registers. *) - (_, []) => [] - | (X64Unix, [FastArgFixed]) => [ moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] - | (X64Unix, [FastArgFixed, FastArgFixed]) => - (* Since mlArgs2Reg is esi on 32-in-64 this is redundant. *) - [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] - | (X64Unix, [FastArgFixed, FastArgFixed, FastArgFixed]) => - [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, - moveRR{source=r8, output=edx, opSize=polyWordOpSize} ] - | (X64Unix, [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed]) => - [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, - moveRR{source=r8, output=edx, opSize=polyWordOpSize}, moveRR{source=r9, output=ecx, opSize=polyWordOpSize} ] - | (X64Win, [FastArgFixed]) => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize} ] - | (X64Win, [FastArgFixed, FastArgFixed]) => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} ] - | (X64Win, [FastArgFixed, FastArgFixed, FastArgFixed]) => - [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8. *) ] - | (X64Win, [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed]) => - [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8 and arg4 in r9. *) ] - | (X86_32, [FastArgFixed]) => [ pushR eax ] - | (X86_32, [FastArgFixed, FastArgFixed]) => [ pushR mlArg2Reg, pushR eax ] - | (X86_32, [FastArgFixed, FastArgFixed, FastArgFixed]) => - [ - (* We need to move an argument from the ML stack. *) - loadMemory(edx, edi, 4, polyWordOpSize), pushR edx, pushR mlArg2Reg, pushR eax - ] - | (X86_32, [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed]) => - [ - (* We need to move an arguments from the ML stack. *) - loadMemory(edx, edi, 4, polyWordOpSize), pushR edx, - loadMemory(edx, edi, 8, polyWordOpSize), pushR edx, - pushR mlArg2Reg, pushR eax - ] - - (* One "double" argument. The value needs to be unboxed. *) - | (X86_32, [FastArgDouble]) => - (* eax contains the address of the value. This must be unboxed onto the stack. *) - [ - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=DoublePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } - ] - - | (_, [FastArgDouble]) => [ (* Already in xmm0 *) ] - - | (X86_32, [FastArgDouble, FastArgDouble]) => - (* eax and ebx contain the addresses of the values. They must be unboxed onto the stack. *) - [ - FPLoadFromMemory{address={base=ebx, offset=0, index=NoIndex}, precision=DoublePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true }, - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=DoublePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } - ] - (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) - | (_, [FastArgDouble, FastArgDouble]) => [ ] - - (* X64 on both Windows and Unix take the first arg in xmm0. On Unix the integer argument is treated - as the first argument and goes into edi. On Windows it's treated as the second and goes into edx. - N.B. It's also the first argument in ML so is in rax. *) - | (X64Unix, [FastArgDouble, FastArgFixed]) => [ moveRR{source=eax, output=edi, opSize=nativeWordOpSize} ] - | (X64Win, [FastArgDouble, FastArgFixed]) => [ moveRR{source=eax, output=edx, opSize=nativeWordOpSize} ] - | (X86_32, [FastArgDouble, FastArgFixed]) => - (* ebx must be pushed to the stack but eax must be unboxed.. *) - [ - pushR ebx, - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=DoublePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } - ] - - (* One "float" argument. The value needs to be untagged on X86/64 but unboxed on X86/32. *) - | (X86_32, [FastArgFloat]) => - (* eax contains the address of the value. This must be unboxed onto the stack. *) - [ - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=SinglePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } - ] - | (_, [FastArgFloat]) => [] - - (* Two float arguments. Untag them on X86/64 but unbox on X86/32 *) - | (X86_32, [FastArgFloat, FastArgFloat]) => - (* eax and ebx contain the addresses of the values. They must be unboxed onto the stack. *) - [ - FPLoadFromMemory{address={base=ebx, offset=0, index=NoIndex}, precision=SinglePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true }, - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=SinglePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } - ] - | (_, [FastArgFloat, FastArgFloat]) => [] (* Already in xmm0 and xmm1 *) - - (* One float argument and one fixed. *) - | (X64Unix, [FastArgFloat, FastArgFixed]) => [moveRR{source=mlArg2Reg, output=edi, opSize=polyWordOpSize} ] - | (X64Win, [FastArgFloat, FastArgFixed]) => [moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize}] - | (X86_32, [FastArgFloat, FastArgFixed]) => - (* ebx must be pushed to the stack but eax must be unboxed.. *) - [ - pushR ebx, - FPLoadFromMemory{address={base=eax, offset=0, index=NoIndex}, precision=SinglePrecision}, - ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, - FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } - ] - - | _ => raise InternalError "rtsCall: Abi/argument count not implemented" - ) @ - [ - CallFunction(DirectReg entryPtrReg), (* Call the function *) - loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) - ] @ - ( - if targetArch <> Native32Bit then [loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] (* Copy back the heap ptr *) - else [] - ) @ [ (* Since this is an ML function we need to remove any ML stack arguments. *) ReturnFromFunction mlArgsOnStack ] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} in closureAsAddress closure end fun rtsCallFast (functionName, nArgs, debugSwitches) = rtsCallFastGeneral (functionName, List.tabulate(nArgs, fn _ => FastArgFixed), FastArgFixed, debugSwitches) (* RTS call with one double-precision floating point argument and a floating point result. *) fun rtsCallFastRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with two double-precision floating point arguments and a floating point result. *) fun rtsCallFastRealRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastRealGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgFixed], FastArgDouble, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgDouble, debugSwitches) (* Operations on Real32.real values. *) fun rtsCallFastFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat], FastArgFloat, debugSwitches) fun rtsCallFastFloatFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFloat], FastArgFloat, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastFloatGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFixed], FastArgFloat, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgFloat, debugSwitches) end;