diff --git a/libpolyml/interpret.cpp b/libpolyml/interpret.cpp index 1c882c25..dfab70a9 100644 --- a/libpolyml/interpret.cpp +++ b/libpolyml/interpret.cpp @@ -1,2650 +1,2673 @@ /* Title: An interpreter for a compact instruction set. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited Further development Copyright David C.J. Matthews 2015-18. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_MATH_H #include #endif #include // Currently just for isnan. #include "globals.h" #include "int_opcodes.h" #include "machine_dep.h" #include "sys.h" #include "profiling.h" #include "arb.h" #include "reals.h" #include "processes.h" #include "run_time.h" #include "gc.h" #include "diagnostics.h" #include "polystring.h" #include "save_vec.h" #include "memmgr.h" #include "scanaddrs.h" #include "rtsentry.h" #if (SIZEOF_VOIDP == 8) #define IS64BITS 1 #endif #define arg1 (pc[0] + pc[1]*256) #define arg2 (pc[2] + pc[3]*256) const PolyWord True = TAGGED(1); const PolyWord False = TAGGED(0); const PolyWord Zero = TAGGED(0); #define CHECKED_REGS 2 #define UNCHECKED_REGS 0 #define EXTRA_STACK 0 // Don't need any extra - signals aren't handled on the Poly stack. /* the amount of ML stack space to reserve for registers, C exception handling etc. The compiler requires us to reserve 2 stack-frames worth (2 * 20 words) plus whatever we require for the register save area. We actually reserve slightly more than this. SPF 3/3/97 */ #define OVERFLOW_STACK_SIZE \ (50 + \ CHECKED_REGS + \ UNCHECKED_REGS + \ EXTRA_STACK) // This duplicates some code in reals.cpp but is now updated. #define DOUBLESIZE (sizeof(double)/sizeof(POLYUNSIGNED)) union realdb { double dble; POLYUNSIGNED puns[DOUBLESIZE]; }; #define LGWORDSIZE (sizeof(uintptr_t) / sizeof(PolyWord)) // We're using float for Real32 so it needs to be 32-bits. // Assume that's true for the moment. #if (SIZEOF_FLOAT != 4) #error "Float is not 32-bits. Please report this" #endif union flt { float fl; int32_t i; }; class IntTaskData: public TaskData { public: IntTaskData(): interrupt_requested(false), overflowPacket(0), dividePacket(0) {} virtual void GarbageCollect(ScanAddress *process); void ScanStackAddress(ScanAddress *process, PolyWord &val, StackSpace *stack); virtual void EnterPolyCode(); // Start running ML // Switch to Poly and return with the io function to call. int SwitchToPoly(); virtual void SetException(poly_exn *exc); virtual void InterruptCode(); // AddTimeProfileCount is used in time profiling. virtual bool AddTimeProfileCount(SIGNALCONTEXT *context); virtual void InitStackFrame(TaskData *newTask, Handle proc, Handle arg); // Increment or decrement the first word of the object pointed to by the // mutex argument and return the new value. virtual Handle AtomicIncrement(Handle mutexp); // Set a mutex to one. virtual void AtomicReset(Handle mutexp); // Return the minimum space occupied by the stack. Used when setting a limit. virtual uintptr_t currentStackSpace(void) const { return (this->stack->top - this->taskSp) + OVERFLOW_STACK_SIZE; } virtual void addProfileCount(POLYUNSIGNED words) { add_count(this, taskPc, words); } virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length); bool interrupt_requested; // Allocate memory on the heap. Returns with the address of the cell. Does not set the // length word or any of the data. PolyObject *allocateMemory(POLYUNSIGNED words, POLYCODEPTR &pc, PolyWord *&sp) { words++; // Add the size of the length word. // N.B. The allocation area may be empty so that both of these are zero. if (this->allocPointer >= this->allocLimit + words) { this->allocPointer -= words; return (PolyObject *)(this->allocPointer+1); } // Insufficient space. SaveInterpreterState(pc, sp); // Find some space to allocate in. Returns a pointer to the newly allocated space. // N.B. This may return zero if the heap is exhausted and it has set this // up for an exception. Generally it allocates by decrementing allocPointer // but if the required memory is large it may allocate in a separate area. PolyWord *space = processes->FindAllocationSpace(this, words, true); LoadInterpreterState(pc, sp); if (space == 0) return 0; return (PolyObject *)(space+1); } // Put a real result in a "box" PolyObject *boxDouble(double d, POLYCODEPTR &pc, PolyWord *&sp) { PolyObject *mem = this->allocateMemory(DOUBLESIZE, pc, sp); if (mem == 0) return 0; mem->SetLengthWord(DOUBLESIZE, F_BYTE_OBJ); union realdb uniondb; uniondb.dble = d; // Copy the words. Depending on the word length this may copy one or more words. for (unsigned i = 0; i < DOUBLESIZE; i++) mem->Set(i, PolyWord::FromUnsigned(uniondb.puns[i])); return mem; } // Extract a double value from a box. double unboxDouble(PolyWord p) { union realdb uniondb; for (unsigned i = 0; i < DOUBLESIZE; i++) uniondb.puns[i] = p.AsObjPtr()->Get(i).AsUnsigned(); return uniondb.dble; } // Largely copied from reals.cpp #if (SIZEOF_FLOAT < SIZEOF_POLYWORD) // Typically for 64-bit mode. Use a tagged representation. // The code-generator on the X86/64 assumes the float is in the // high order word. #define FLT_SHIFT ((SIZEOF_POLYWORD-SIZEOF_FLOAT)*8) float unboxFloat(PolyWord p) { union flt argx; argx.i = p.AsSigned() >> FLT_SHIFT; return argx.fl; } PolyObject *boxFloat(float f, POLYCODEPTR &pc, PolyWord *&sp) { union flt argx; argx.fl = f; PolyWord p = PolyWord::FromSigned(((POLYSIGNED)argx.i << FLT_SHIFT) + 1); return p.AsObjPtr(); // Temporarily cast it to this even though it isn't really } #else // Typically for 32-bit mode. Use a boxed representation. PolyObject *boxFloat(float f, POLYCODEPTR &pc, PolyWord *&sp) { PolyObject *mem = this->allocateMemory(1, pc, sp); if (mem == 0) return 0; mem->SetLengthWord(1, F_BYTE_OBJ); union flt argx; argx.fl = f; mem->Set(0, PolyWord::FromSigned(argx.i)); return mem; } // Extract a double value from a box. float unboxFloat(PolyWord p) { union flt argx; argx.i = (int32_t)p.AsObjPtr()->Get(0).AsSigned(); return argx.fl; } #endif // Update the copies in the task object void SaveInterpreterState(POLYCODEPTR pc, PolyWord *sp) { taskPc = pc; taskSp = sp; } // Update the local state void LoadInterpreterState(POLYCODEPTR &pc, PolyWord *&sp) { pc = taskPc; sp = taskSp; } POLYCODEPTR taskPc; /* Program counter. */ PolyWord *taskSp; /* Stack pointer. */ PolyWord *hr; PolyWord exception_arg; bool raiseException; PolyWord *sl; /* Stack limit register. */ PolyObject *overflowPacket, *dividePacket; }; // This lock is used to synchronise all atomic operations. // It is not needed in the X86 version because that can use a global // memory lock. static PLock mutexLock; // Special value for return address. #define SPECIAL_PC_END_THREAD TAGGED(1) class Interpreter : public MachineDependent { public: Interpreter() {} // Create a task data object. virtual TaskData *CreateTaskData(void) { return new IntTaskData(); } virtual Architectures MachineArchitecture(void) { return MA_Interpreted; } }; void IntTaskData::InitStackFrame(TaskData *parentTask, Handle proc, Handle arg) /* Initialise stack frame. */ { StackSpace *space = this->stack; StackObject *stack = (StackObject *)space->stack(); PolyObject *closure = DEREFWORDHANDLE(proc); uintptr_t stack_size = space->spaceSize(); this->taskPc = closure->Get(0).AsCodePtr(); this->exception_arg = TAGGED(0); /* Used for exception argument. */ this->taskSp = (PolyWord*)stack + stack_size; this->raiseException = false; /* Set up exception handler */ /* No previous handler so point it at itself. */ this->taskSp--; *(this->taskSp) = PolyWord::FromStackAddr(this->taskSp); *(--this->taskSp) = SPECIAL_PC_END_THREAD; /* Default return address. */ this->hr = this->taskSp; /* If this function takes an argument store it on the stack. */ if (arg != 0) *(--this->taskSp) = DEREFWORD(arg); *(--this->taskSp) = SPECIAL_PC_END_THREAD; /* Return address. */ *(--this->taskSp) = closure; /* Closure address */ // Make packets for exceptions. overflowPacket = makeExceptionPacket(parentTask, EXC_overflow); dividePacket = makeExceptionPacket(parentTask, EXC_divide); } extern "C" { typedef POLYUNSIGNED(*callFastRts0)(); typedef POLYUNSIGNED(*callFastRts1)(intptr_t); typedef POLYUNSIGNED(*callFastRts2)(intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts3)(intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts4)(intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts5)(intptr_t, intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFullRts0)(PolyObject *); typedef POLYUNSIGNED(*callFullRts1)(PolyObject *, intptr_t); typedef POLYUNSIGNED(*callFullRts2)(PolyObject *, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFullRts3)(PolyObject *, intptr_t, intptr_t, intptr_t); typedef double (*callRTSRtoR) (double); typedef double (*callRTSRRtoR) (double, double); typedef double (*callRTSGtoR) (intptr_t); typedef double (*callRTSRGtoR) (double, intptr_t); typedef float(*callRTSFtoF) (float); typedef float(*callRTSFFtoF) (float, float); typedef float(*callRTSGtoF) (intptr_t); typedef float(*callRTSFGtoF) (float, intptr_t); } void IntTaskData::InterruptCode() /* Stop the Poly code at a suitable place. */ /* We may get an asynchronous interrupt at any time. */ { IntTaskData *itd = (IntTaskData *)this; itd->interrupt_requested = true; } void IntTaskData::SetException(poly_exn *exc) /* Set up the stack of a process to raise an exception. */ { this->raiseException = true; *(--this->taskSp) = (PolyWord)exc; /* push exception data */ } int IntTaskData::SwitchToPoly() /* (Re)-enter the Poly code from C. */ { // These are temporary values used where one instruction jumps to // common code. POLYUNSIGNED tailCount; PolyWord *tailPtr; POLYUNSIGNED returnCount; POLYUNSIGNED storeWords; POLYUNSIGNED stackCheck; // Local values. These are copies of member variables but are used so frequently that // it is important that access should be fast. POLYCODEPTR pc; PolyWord *sp; double dv; LoadInterpreterState(pc, sp); sl = (PolyWord*)this->stack->stack() + OVERFLOW_STACK_SIZE; // We may have taken an interrupt which has set an exception. if (this->raiseException) goto RAISE_EXCEPTION; for(;;){ /* Each instruction */ // char buff[1000]; // sprintf(buff, "addr = %p sp=%p instr=%02x *sp=%p\n", pc, sp, *pc, (*sp).AsStackAddr()); // OutputDebugStringA(buff); switch(*pc++) { case INSTR_enter_int: pc++; /* Skip the argument. */ break; case INSTR_jump8false: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 1; break; } /* else - false - take the jump */ } case INSTR_jump8: pc += *pc + 1; break; case INSTR_jump16false: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 2; break; } /* else - false - take the jump */ } case INSTR_jump16: pc += arg1 + 2; break; case INSTR_jump32False: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 4; break; } /* else - false - take the jump */ } case INSTR_jump32: { // This is a 32-bit signed quantity on both 64-bits and 32-bits. POLYSIGNED offset = pc[3] & 0x80 ? -1 : 0; offset = (offset << 8) | pc[3]; offset = (offset << 8) | pc[2]; offset = (offset << 8) | pc[1]; offset = (offset << 8) | pc[0]; pc += offset + 4; break; } case INSTR_push_handler: /* Save the old handler value. */ *(--sp) = PolyWord::FromStackAddr(this->hr); /* Push old handler */ break; case INSTR_setHandler8: /* Set up a handler */ *(--sp) = PolyWord::FromCodePtr(pc + *pc + 1); /* Address of handler */ this->hr = sp; pc += 1; break; case INSTR_setHandler16: /* Set up a handler */ *(--sp) = PolyWord::FromCodePtr(pc + arg1 + 2); /* Address of handler */ this->hr = sp; pc += 2; break; case INSTR_setHandler32: /* Set up a handler */ { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); *(--sp) = PolyWord::FromCodePtr(pc + offset + 4); /* Address of handler */ this->hr = sp; pc += 4; break; } case INSTR_deleteHandler: /* Delete handler retaining the result. */ { PolyWord u = *sp++; sp = this->hr; sp++; // Remove handler entry point this->hr = (*sp).AsStackAddr(); // Restore old handler *sp = u; // Put back the result break; } case INSTR_case16: { // arg1 is the largest value that is in the range POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ if (u > arg1 || u < 0) pc += (arg1+2)*2; /* Out of range */ else { pc += 2; pc += /* Index */pc[u*2]+pc[u*2 + 1]*256; } break; } case INSTR_case32: { // arg1 is the number of cases i.e. one more than the largest value // This is followed by that number of 32-bit offsets. // If the value is out of range the default case is immediately after the table. POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ if (u >= arg1 || u < 0) pc += 2 + arg1 * 4; /* Out of range */ else { pc += 2; pc += /* Index */pc[u*4] + (pc[u*4+1] << 8) + (pc[u*4+2] << 16) + (pc[u*4+3] << 24); } break; } case INSTR_tail_3_b: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + *pc; goto TAIL_CALL; case INSTR_tail_3_2: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + 2; goto TAIL_CALL; case INSTR_tail_3_3: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + 3; goto TAIL_CALL; case INSTR_tail_4_b: tailCount = 4; tailPtr = sp + tailCount; sp = tailPtr + *pc; goto TAIL_CALL; case INSTR_tail_b_b: tailCount = *pc; tailPtr = sp + tailCount; sp = tailPtr + pc[1]; goto TAIL_CALL; case INSTR_tail: /* Tail recursive call. */ /* Move items up the stack. */ /* There may be an overlap if the function we are calling has more args than this one. */ tailCount = arg1; tailPtr = sp + tailCount; sp = tailPtr + arg2; TAIL_CALL: /* For general case. */ if (tailCount < 2) Crash("Invalid argument\n"); for (; tailCount > 0; tailCount--) *(--sp) = *(--tailPtr); pc = (*sp++).AsCodePtr(); /* Pop the original return address. */ /* And drop through. */ case INSTR_call_closure: /* Closure call. */ { POLYCODEPTR newPc = (*sp).AsObjPtr()->Get(0).AsCodePtr(); sp--; *sp = sp[1]; /* Move closure up. */ sp[1] = PolyWord::FromCodePtr(pc); /* Save return address. */ pc = newPc; /* Get entry point. */ this->taskPc = pc; // Update in case we're profiling break; } case INSTR_return_w: returnCount = arg1; /* Get no. of args to remove. */ RETURN: /* Common code for return. */ { PolyWord result = *sp++; /* Result */ sp++; /* Remove the link/closure */ pc = (*sp++).AsCodePtr(); /* Return address */ sp += returnCount; /* Add on number of args. */ if (pc == SPECIAL_PC_END_THREAD.AsCodePtr()) exitThread(this); // This thread is exiting. *(--sp) = result; /* Result */ this->taskPc = pc; // Update in case we're profiling } break; case INSTR_return_b: returnCount = *pc; goto RETURN; case INSTR_return_0: returnCount = 0; goto RETURN; case INSTR_return_1: returnCount = 1; goto RETURN; case INSTR_return_2: returnCount = 2; goto RETURN; case INSTR_return_3: returnCount = 3; goto RETURN; case INSTR_stackSize8: stackCheck = *pc++; goto STACKCHECK; case INSTR_stackSize16: { stackCheck = arg1; pc += 2; STACKCHECK: // Check there is space on the stack if (sp - stackCheck < sl) { uintptr_t min_size = (this->stack->top - (PolyWord*)sp) + OVERFLOW_STACK_SIZE + stackCheck; SaveInterpreterState(pc, sp); CheckAndGrowStack(this, min_size); LoadInterpreterState(pc, sp); sl = (PolyWord*)this->stack->stack() + OVERFLOW_STACK_SIZE; } // Also check for interrupts if (this->interrupt_requested) { // Check for interrupts this->interrupt_requested = false; SaveInterpreterState(pc, sp); return -1; } break; } case INSTR_pad: /* No-op */ break; case INSTR_raise_ex: { RAISE_EXCEPTION: this->raiseException = false; PolyException *exn = (PolyException*)((*sp).AsObjPtr()); this->exception_arg = exn; /* Get exception data */ sp = this->hr; if (*sp == SPECIAL_PC_END_THREAD) exitThread(this); // Default handler for thread. pc = (*sp++).AsCodePtr(); this->hr = (*sp++).AsStackAddr(); break; } case INSTR_get_store_w: // Get_store is now only used for mutually recursive closures. It allocates mutable store // initialised to zero. { storeWords = arg1; pc += 2; GET_STORE: PolyObject *p = this->allocateMemory(storeWords, pc, sp); if (p == 0) goto RAISE_EXCEPTION; p->SetLengthWord(storeWords, F_MUTABLE_BIT); for(; storeWords > 0; ) p->Set(--storeWords, TAGGED(0)); /* Must initialise store! */ *(--sp) = (PolyWord)p; break; } case INSTR_get_store_2: storeWords = 2; goto GET_STORE; case INSTR_get_store_3: storeWords = 3; goto GET_STORE; case INSTR_get_store_4: storeWords = 4; goto GET_STORE; case INSTR_get_store_b: storeWords = *pc; pc++; goto GET_STORE; case INSTR_tuple_w: { storeWords = arg1; pc += 2; TUPLE: /* Common code for tupling. */ PolyObject *p = this->allocateMemory(storeWords, pc, sp); if (p == 0) goto RAISE_EXCEPTION; // Exception p->SetLengthWord(storeWords, 0); for(; storeWords > 0; ) p->Set(--storeWords, *sp++); *(--sp) = (PolyWord)p; break; } case INSTR_tuple_2: storeWords = 2; goto TUPLE; case INSTR_tuple_3: storeWords = 3; goto TUPLE; case INSTR_tuple_4: storeWords = 4; goto TUPLE; case INSTR_tuple_b: storeWords = *pc; pc++; goto TUPLE; case INSTR_local_w: { PolyWord u = sp[arg1]; *(--sp) = u; pc += 2; break; } case INSTR_indirect_w: *sp = (*sp).AsObjPtr()->Get(arg1); pc += 2; break; case INSTR_move_to_vec_w: { PolyWord u = *sp++; (*sp).AsObjPtr()->Set(arg1, u); pc += 2; break; } case INSTR_set_stack_val_w: { PolyWord u = *sp++; sp[arg1-1] = u; pc += 2; break; } case INSTR_reset_w: sp += arg1; pc += 2; break; case INSTR_reset_r_w: { PolyWord u = *sp; sp += arg1; *sp = u; pc += 2; break; } case INSTR_constAddr8: *(--sp) = *(PolyWord*)(pc + pc[0] + 1); pc += 1; break; case INSTR_constAddr16: *(--sp) = *(PolyWord*)(pc + arg1 + 2); pc += 2; break; case INSTR_constAddr32: { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); *(--sp) = *(PolyWord*)(pc + offset + 4); pc += 4; break; } case INSTR_const_int_w: *(--sp) = TAGGED(arg1); pc += 2; break; case INSTR_jump_back8: pc -= *pc + 1; if (this->interrupt_requested) { // Check for interrupt in case we're in a loop this->interrupt_requested = false; SaveInterpreterState(pc, sp); return -1; } break; case INSTR_jump_back16: pc -= arg1 + 1; if (this->interrupt_requested) { // Check for interrupt in case we're in a loop this->interrupt_requested = false; SaveInterpreterState(pc, sp); return -1; } break; case INSTR_lock: { PolyObject *obj = (*sp).AsObjPtr(); obj->SetLengthWord(obj->LengthWord() & ~_OBJ_MUTABLE_BIT); break; } case INSTR_ldexc: *(--sp) = this->exception_arg; break; case INSTR_local_b: { PolyWord u = sp[*pc]; *(--sp) = u; pc += 1; break; } case INSTR_indirect_b: *sp = (*sp).AsObjPtr()->Get(*pc); pc += 1; break; case INSTR_move_to_vec_b: { PolyWord u = *sp++; (*sp).AsObjPtr()->Set(*pc, u); pc += 1; break; } case INSTR_set_stack_val_b: { PolyWord u = *sp++; sp[*pc-1] = u; pc += 1; break; } case INSTR_reset_b: sp += *pc; pc += 1; break; case INSTR_reset_r_b: { PolyWord u = *sp; sp += *pc; *sp = u; pc += 1; break; } case INSTR_const_int_b: *(--sp) = TAGGED(*pc); pc += 1; break; case INSTR_local_0: { PolyWord u = sp[0]; *(--sp) = u; break; } case INSTR_local_1: { PolyWord u = sp[1]; *(--sp) = u; break; } case INSTR_local_2: { PolyWord u = sp[2]; *(--sp) = u; break; } case INSTR_local_3: { PolyWord u = sp[3]; *(--sp) = u; break; } case INSTR_local_4: { PolyWord u = sp[4]; *(--sp) = u; break; } case INSTR_local_5: { PolyWord u = sp[5]; *(--sp) = u; break; } case INSTR_local_6: { PolyWord u = sp[6]; *(--sp) = u; break; } case INSTR_local_7: { PolyWord u = sp[7]; *(--sp) = u; break; } case INSTR_local_8: { PolyWord u = sp[8]; *(--sp) = u; break; } case INSTR_local_9: { PolyWord u = sp[9]; *(--sp) = u; break; } case INSTR_local_10: { PolyWord u = sp[10]; *(--sp) = u; break; } case INSTR_local_11: { PolyWord u = sp[11]; *(--sp) = u; break; } case INSTR_indirect_0: *sp = (*sp).AsObjPtr()->Get(0); break; case INSTR_indirect_1: *sp = (*sp).AsObjPtr()->Get(1); break; case INSTR_indirect_2: *sp = (*sp).AsObjPtr()->Get(2); break; case INSTR_indirect_3: *sp = (*sp).AsObjPtr()->Get(3); break; case INSTR_indirect_4: *sp = (*sp).AsObjPtr()->Get(4); break; case INSTR_indirect_5: *sp = (*sp).AsObjPtr()->Get(5); break; case INSTR_const_0: *(--sp) = Zero; break; case INSTR_const_1: *(--sp) = TAGGED(1); break; case INSTR_const_2: *(--sp) = TAGGED(2); break; case INSTR_const_3: *(--sp) = TAGGED(3); break; case INSTR_const_4: *(--sp) = TAGGED(4); break; case INSTR_const_10: *(--sp) = TAGGED(10); break; case INSTR_reset_r_1: { PolyWord u = *sp; sp += 1; *sp = u; break; } case INSTR_reset_r_2: { PolyWord u = *sp; sp += 2; *sp = u; break; } case INSTR_reset_r_3: { PolyWord u = *sp; sp += 3; *sp = u; break; } case INSTR_reset_1: sp += 1; break; case INSTR_reset_2: sp += 2; break; case INSTR_stack_container: { POLYUNSIGNED words = arg1; pc += 2; while (words-- > 0) *(--sp) = Zero; sp--; *sp = PolyWord::FromStackAddr(sp + 1); break; } case INSTR_tuple_container: /* Create a tuple from a container. */ { storeWords = arg1; PolyObject *t = this->allocateMemory(storeWords, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(storeWords, 0); for(; storeWords > 0; ) { storeWords--; t->Set(storeWords, (*sp).AsObjPtr()->Get(storeWords)); } *sp = t; pc += 2; break; } case INSTR_callFastRTS0: { callFastRts0 doCall = *(callFastRts0*)(*sp++).AsObjPtr(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS1: { callFastRts1 doCall = *(callFastRts1*)(*sp++).AsObjPtr(); intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS2: { callFastRts2 doCall = *(callFastRts2*)(*sp++).AsObjPtr(); intptr_t rtsArg2 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS3: { callFastRts3 doCall = *(callFastRts3*)(*sp++).AsObjPtr(); intptr_t rtsArg3 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg2 = (*sp++).AsSigned(); intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS4: { callFastRts4 doCall = *(callFastRts4*)(*sp++).AsObjPtr(); intptr_t rtsArg4 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg3 = (*sp++).AsSigned(); intptr_t rtsArg2 = (*sp++).AsSigned(); intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS5: { callFastRts5 doCall = *(callFastRts5*)(*sp++).AsObjPtr(); intptr_t rtsArg5 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg4 = (*sp++).AsSigned(); intptr_t rtsArg3 = (*sp++).AsSigned(); intptr_t rtsArg2 = (*sp++).AsSigned(); intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4, rtsArg5); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS0: { callFullRts0 doCall = *(callFullRts0*)(*sp++).AsObjPtr(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(this->threadObject); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp)= PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS1: { callFullRts1 doCall = *(callFullRts1*)(*sp++).AsObjPtr(); intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(this->threadObject, rtsArg1); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS2: { callFullRts2 doCall = *(callFullRts2*)(*sp++).AsObjPtr(); intptr_t rtsArg2 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(this->threadObject, rtsArg1, rtsArg2); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS3: { callFullRts3 doCall = *(callFullRts3*)(*sp++).AsObjPtr(); intptr_t rtsArg3 = (*sp++).AsSigned(); // Pop off the args, last arg first. intptr_t rtsArg2 = (*sp++).AsSigned(); intptr_t rtsArg1 = (*sp++).AsSigned(); this->raiseException = false; SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(this->threadObject, rtsArg1, rtsArg2, rtsArg3); LoadInterpreterState(pc, sp); // If this raised an exception if (this->raiseException) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRtoR: { // Floating point call. The call itself does not allocate but we // need to put the result into a "box". callRTSRtoR doCall = *(callRTSRtoR*)(*sp++).AsObjPtr(); PolyWord rtsArg1 = *sp++; double argument = unboxDouble(rtsArg1); // Allocate memory for the result. double result = doCall(argument); PolyObject *t = boxDouble(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case INSTR_callFastRRtoR: { // Floating point call. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. PolyWord rtsArg2 = *sp++; PolyWord rtsArg1 = *sp++; callRTSRRtoR doCall = (callRTSRRtoR)rtsCall.AsCodePtr(); double argument1 = unboxDouble(rtsArg1); double argument2 = unboxDouble(rtsArg2); // Allocate memory for the result. double result = doCall(argument1, argument2); PolyObject *t = boxDouble(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastGtoR: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSGtoR doCall = *(callRTSGtoR*)(*sp++).AsObjPtr(); intptr_t rtsArg1 = (*sp++).AsSigned(); // Allocate memory for the result. double result = doCall(rtsArg1); PolyObject *t = boxDouble(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case INSTR_callFastRGtoR: { // Call that takes a POLYUNSIGNED argument and returns a double. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. intptr_t rtsArg2 = (*sp++).AsSigned(); PolyWord rtsArg1 = *sp++; callRTSRGtoR doCall = (callRTSRGtoR)rtsCall.AsCodePtr(); double argument1 = unboxDouble(rtsArg1); // Allocate memory for the result. double result = doCall(argument1, rtsArg2); PolyObject *t = boxDouble(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastFtoF: { // Floating point call. The call itself does not allocate but we // need to put the result into a "box". PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. PolyWord rtsArg1 = *sp++; callRTSFtoF doCall = (callRTSFtoF)rtsCall.AsCodePtr(); float argument = unboxFloat(rtsArg1); // Allocate memory for the result. float result = doCall(argument); PolyObject *t = boxFloat(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastFFtoF: { // Floating point call. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. PolyWord rtsArg2 = *sp++; PolyWord rtsArg1 = *sp++; callRTSFFtoF doCall = (callRTSFFtoF)rtsCall.AsCodePtr(); float argument1 = unboxFloat(rtsArg1); float argument2 = unboxFloat(rtsArg2); // Allocate memory for the result. float result = doCall(argument1, argument2); PolyObject *t = boxFloat(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastGtoF: { // Call that takes a POLYUNSIGNED argument and returns a double. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. intptr_t rtsArg1 = (*sp++).AsSigned(); callRTSGtoF doCall = (callRTSGtoF)rtsCall.AsCodePtr(); // Allocate memory for the result. float result = doCall(rtsArg1); PolyObject *t = boxFloat(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_callFastFGtoF: { // Call that takes a POLYUNSIGNED argument and returns a double. PolyWord rtsCall = (*sp++).AsObjPtr()->Get(0); // Value holds address. intptr_t rtsArg2 = (*sp++).AsSigned(); PolyWord rtsArg1 = *sp++; callRTSFGtoF doCall = (callRTSFGtoF)rtsCall.AsCodePtr(); float argument1 = unboxFloat(rtsArg1); // Allocate memory for the result. float result = doCall(argument1, rtsArg2); PolyObject *t = boxFloat(result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = t; break; } case INSTR_notBoolean: *sp = ((*sp) == True) ? False : True; break; case INSTR_isTagged: *sp = (*sp).IsTagged() ? True : False; break; case INSTR_cellLength: /* Return the length word. */ *sp = TAGGED((*sp).AsObjPtr()->Length()); break; case INSTR_cellFlags: { PolyObject *p = (*sp).AsObjPtr(); POLYUNSIGNED f = (p->LengthWord()) >> OBJ_PRIVATE_FLAGS_SHIFT; *sp = TAGGED(f); break; } case INSTR_clearMutable: { PolyObject *obj = (*sp).AsObjPtr(); POLYUNSIGNED lengthW = obj->LengthWord(); /* Clear the mutable bit. */ obj->SetLengthWord(lengthW & ~_OBJ_MUTABLE_BIT); *sp = Zero; break; } case INSTR_stringLength: // Now replaced by loadUntagged *sp = TAGGED(((PolyStringObject*)(*sp).AsObjPtr())->length); break; case INSTR_atomicIncr: { PLocker l(&mutexLock); PolyObject *p = (*sp).AsObjPtr(); PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))+1); p->Set(0, newValue); *sp = newValue; break; } case INSTR_atomicDecr: { PLocker l(&mutexLock); PolyObject *p = (*sp).AsObjPtr(); PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))-1); p->Set(0, newValue); *sp = newValue; break; } case INSTR_atomicReset: { // This is needed in the interpreted version otherwise there // is a chance that we could set the value to zero while another // thread is between getting the old value and setting it to the new value. PLocker l(&mutexLock); PolyObject *p = (*sp).AsObjPtr(); p->Set(0, TAGGED(1)); // Set this to released. *sp = TAGGED(0); // Push the unit result break; } case INSTR_longWToTagged: { // Extract the first word and return it as a tagged value. This loses the top-bit POLYUNSIGNED wx = (*sp).AsObjPtr()->Get(0).AsUnsigned(); *sp = TAGGED(wx); break; } case INSTR_signedToLongW: { // Shift the tagged value to remove the tag and put it into the first word. // The original sign bit is copied in the shift. intptr_t wx = (*sp).UnTagged(); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(intptr_t*)t = wx; *sp = (PolyWord)t; break; } case INSTR_unsignedToLongW: { // As with the above except the value is treated as an unsigned // value and the top bit is zero. uintptr_t wx = (*sp).UnTaggedUnsigned(); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wx; *sp = (PolyWord)t; break; } case INSTR_realAbs: { PolyObject *t = this->boxDouble(fabs(unboxDouble(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_realNeg: { PolyObject *t = this->boxDouble(-(unboxDouble(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_floatAbs: { PolyObject *t = this->boxFloat(fabs(unboxFloat(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatNeg: { PolyObject *t = this->boxFloat(-(unboxFloat(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_fixedIntToReal: { POLYSIGNED u = UNTAGGED(*sp); PolyObject *t = this->boxDouble((double)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_fixedIntToFloat: { POLYSIGNED u = UNTAGGED(*sp); PolyObject *t = this->boxFloat((float)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatToReal: { float u = unboxFloat(*sp); PolyObject *t = this->boxDouble((double)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_equalWord: { PolyWord u = *sp++; *sp = u == (*sp) ? True : False; break; } case INSTR_lessSigned: { PolyWord u = *sp++; *sp = ((*sp).AsSigned() < u.AsSigned()) ? True : False; break; } case INSTR_lessUnsigned: { PolyWord u = *sp++; *sp = ((*sp).AsUnsigned() < u.AsUnsigned()) ? True : False; break; } case INSTR_lessEqSigned: { PolyWord u = *sp++; *sp = ((*sp).AsSigned() <= u.AsSigned()) ? True : False; break; } case INSTR_lessEqUnsigned: { PolyWord u = *sp++; *sp = ((*sp).AsUnsigned() <= u.AsUnsigned()) ? True : False; break; } case INSTR_greaterSigned: { PolyWord u = *sp++; *sp = ((*sp).AsSigned() > u.AsSigned()) ? True : False; break; } case INSTR_greaterUnsigned: { PolyWord u = *sp++; *sp = ((*sp).AsUnsigned() > u.AsUnsigned()) ? True : False; break; } case INSTR_greaterEqSigned: { PolyWord u = *sp++; *sp = ((*sp).AsSigned() >= u.AsSigned()) ? True : False; break; } case INSTR_greaterEqUnsigned: { PolyWord u = *sp++; *sp = ((*sp).AsUnsigned() >= u.AsUnsigned()) ? True : False; break; } case INSTR_fixedAdd: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(x) + UNTAGGED(y); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } break; } case INSTR_fixedSub: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(y) - UNTAGGED(x); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } break; } case INSTR_fixedMult: { POLYSIGNED x = UNTAGGED(*sp++); POLYSIGNED y = (*sp).AsSigned() - 1; // Just remove the tag POLYSIGNED t = x * y; if (x != 0 && t / x != y) { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } *sp = PolyWord::FromSigned(t+1); // Add back the tag break; } case INSTR_fixedQuot: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) / u); break; } case INSTR_fixedRem: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) % u); break; } case INSTR_wordAdd: { PolyWord u = *sp++; // Because we're not concerned with overflow we can just add the values and subtract the tag. *sp = PolyWord::FromUnsigned((*sp).AsUnsigned() + u.AsUnsigned() - TAGGED(0).AsUnsigned()); break; } case INSTR_wordSub: { PolyWord u = *sp++; *sp = PolyWord::FromUnsigned((*sp).AsUnsigned() - u.AsUnsigned() + TAGGED(0).AsUnsigned()); break; } case INSTR_wordMult: { PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) * UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordDiv: { POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); // Detection of zero is done in ML *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) / u); break; } case INSTR_wordMod: { POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) % u); break; } case INSTR_wordAnd: { PolyWord u = *sp++; // Since both of these should be tagged the tag bit will be preserved. *sp = PolyWord::FromUnsigned((*sp).AsUnsigned() & u.AsUnsigned()); break; } case INSTR_wordOr: { PolyWord u = *sp++; // Since both of these should be tagged the tag bit will be preserved. *sp = PolyWord::FromUnsigned((*sp).AsUnsigned() | u.AsUnsigned()); break; } case INSTR_wordXor: { PolyWord u = *sp++; // This will remove the tag bit so it has to be reinstated. *sp = PolyWord::FromUnsigned(((*sp).AsUnsigned() ^ u.AsUnsigned()) | TAGGED(0).AsUnsigned()); break; } case INSTR_wordShiftLeft: { // ML requires shifts greater than a word to return zero. // That's dealt with at the higher level. PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) << UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordShiftRLog: { PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) >> UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordShiftRArith: { PolyWord u = *sp++; // Strictly speaking, C does not require that this uses // arithmetic shifting so we really ought to set the // high-order bits explicitly. *sp = TAGGED(UNTAGGED(*sp) >> UNTAGGED(u)); break; } case INSTR_allocByteMem: { // Allocate byte segment. This does not need to be initialised. POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); PolyObject *t = this->allocateMemory(length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; // Exception t->SetLengthWord(length, (byte)flags); *sp = (PolyWord)t; break; } case INSTR_lgWordEqual: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = wx == wy ? True : False; break; } case INSTR_lgWordLess: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = (wy < wx) ? True : False; break; } case INSTR_lgWordLessEq: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = (wy <= wx) ? True : False; break; } case INSTR_lgWordGreater: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = (wy > wx) ? True : False; break; } case INSTR_lgWordGreaterEq: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); *sp = (wy >= wx) ? True : False; break; } case INSTR_lgWordAdd: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy+wx; *sp = (PolyWord)t; break; } case INSTR_lgWordSub: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy-wx; *sp = (PolyWord)t; break; } case INSTR_lgWordMult: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy*wx; *sp = (PolyWord)t; break; } case INSTR_lgWordDiv: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy/wx; *sp = (PolyWord)t; break; } case INSTR_lgWordMod: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy%wx; *sp = (PolyWord)t; break; } case INSTR_lgWordAnd: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy&wx; *sp = (PolyWord)t; break; } case INSTR_lgWordOr: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy|wx; *sp = (PolyWord)t; break; } case INSTR_lgWordXor: { uintptr_t wx = *(uintptr_t*)((*sp++).AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy^wx; *sp = (PolyWord)t; break; } case INSTR_lgWordShiftLeft: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy << wx; *sp = (PolyWord)t; break; } case INSTR_lgWordShiftRLog: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); uintptr_t wy = *(uintptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy >> wx; *sp = (PolyWord)t; break; } case INSTR_lgWordShiftRArith: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); intptr_t wy = *(intptr_t*)((*sp).AsObjPtr()); PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(intptr_t*)t = wy >> wx; *sp = (PolyWord)t; break; } case INSTR_realEqual: { double u = unboxDouble(*sp++); *sp = u == unboxDouble(*sp) ? True: False; break; } case INSTR_realLess: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) < u ? True: False; break; } case INSTR_realLessEq: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) <= u ? True: False; break; } case INSTR_realGreater: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) > u ? True: False; break; } case INSTR_realGreaterEq: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) >= u ? True: False; break; } case INSTR_realUnordered: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); *sp = (std::isnan(u) || std::isnan(v)) ? True : False; break; } case INSTR_realAdd: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject *t = this->boxDouble(v+u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_realSub: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject *t = this->boxDouble(v-u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_realMult: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject *t = this->boxDouble(v*u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_realDiv: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject *t = this->boxDouble(v/u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_floatEqual: { float u = unboxFloat(*sp++); *sp = u == unboxFloat(*sp) ? True : False; break; } case INSTR_floatLess: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) < u ? True : False; break; } case INSTR_floatLessEq: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) <= u ? True : False; break; } case INSTR_floatGreater: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) > u ? True : False; break; } case INSTR_floatGreaterEq: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) >= u ? True : False; break; } case INSTR_floatUnordered: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); *sp = (std::isnan(u) || std::isnan(v)) ? True : False; break; } case INSTR_floatAdd: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject *t = this->boxFloat(v + u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatSub: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject *t = this->boxFloat(v - u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatMult: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject *t = this->boxFloat(v*u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_floatDiv: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject *t = this->boxFloat(v / u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_realToFloat: { // Convert a double to a float. It's complicated because it depends on the rounding mode. int rMode = *pc++; int current = getrounding(); // If the rounding is 4 it means "use current rounding". // Don't call unboxDouble until we're set the rounding. GCC seems to convert it // before the actual float cast. if (rMode < 4) setrounding(rMode); double d = unboxDouble(*sp); float v = (float)d; // Convert with the appropriate rounding. setrounding(current); PolyObject *t = this->boxFloat(v, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = t; break; } case INSTR_realToInt: dv = unboxDouble(*sp); goto realtoint; case INSTR_floatToInt: dv = (double)unboxFloat(*sp); realtoint: { // Convert a double or a float to a tagged integer. int rMode = *pc++; // We mustn't try converting a value that will overflow the conversion // but we need to be careful that we don't raise overflow incorrectly due // to rounding. if (dv > (double)(MAXTAGGED + MAXTAGGED / 2) || dv < -(double)(MAXTAGGED + MAXTAGGED / 2)) { *(--sp) = overflowPacket; goto RAISE_EXCEPTION; } POLYSIGNED p; switch (rMode) { case POLY_ROUND_TONEAREST: p = (POLYSIGNED)round(dv); break; case POLY_ROUND_DOWNWARD: p = (POLYSIGNED)floor(dv); break; case POLY_ROUND_UPWARD: p = (POLYSIGNED)ceil(dv); break; case POLY_ROUND_TOZERO: default: // Truncation is the default for C. p = (POLYSIGNED)dv; } // Check that the value can be tagged. if (p > MAXTAGGED || p < -MAXTAGGED - 1) { *(--sp) = overflowPacket; goto RAISE_EXCEPTION; } *sp = TAGGED(p); break; } case INSTR_getThreadId: *(--sp) = (PolyWord)this->threadObject; break; case INSTR_allocWordMemory: { // Allocate word segment. This must be initialised. // We mustn't pop the initialiser until after any potential GC. POLYUNSIGNED length = UNTAGGED_UNSIGNED(sp[2]); PolyObject *t = this->allocateMemory(length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; PolyWord initialiser = *sp++; POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); t->SetLengthWord(length, (byte)flags); *sp = (PolyWord)t; // Have to initialise the data. for (; length > 0; ) t->Set(--length, initialiser); break; } case INSTR_alloc_ref: { // Allocate a single word mutable cell. This is more common than allocWordMemory on its own. PolyObject *t = this->allocateMemory(1, pc, sp); if (t == 0) goto RAISE_EXCEPTION; PolyWord initialiser = (*sp); t->SetLengthWord(1, F_MUTABLE_BIT); t->Set(0, initialiser); *sp = (PolyWord)t; break; } case INSTR_loadMLWord: { // The values on the stack are base, index and offset. POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).AsCodePtr() + offset); *sp = p->Get(index); break; } case INSTR_loadMLByte: { // The values on the stack are base and index. POLYUNSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = (*sp).AsCodePtr(); *sp = TAGGED(p[index]); // Have to tag the result break; } case INSTR_loadC8: { // This is similar to loadMLByte except that the base address is a boxed large-word. // Also the index is SIGNED. POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())); *sp = TAGGED(p[index]); // Have to tag the result break; } case INSTR_loadC16: { // This and the other loads are similar to loadMLWord with separate // index and offset values. POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; POLYUNSIGNED r = ((uint16_t*)p)[index]; *sp = TAGGED(r); break; } case INSTR_loadC32: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; uintptr_t r = ((uint32_t*)p)[index]; #ifdef IS64BITS // This is tagged in 64-bit mode *sp = TAGGED(r); #else // But boxed in 32-bit mode. PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = r; *sp = (PolyWord)t; #endif break; } #if (defined(IS64BITS)) case INSTR_loadC64: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; uintptr_t r = ((uint64_t*)p)[index]; // This must be boxed. PolyObject *t = this->allocateMemory(LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = r; *sp = (PolyWord)t; break; } #endif case INSTR_loadCFloat: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; double r = ((float*)p)[index]; // This must be boxed. PolyObject *t = this->boxDouble(r, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_loadCDouble: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; double r = ((double*)p)[index]; // This must be boxed. PolyObject *t = this->boxDouble(r, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case INSTR_loadUntagged: { // The values on the stack are base, index and offset. POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).AsCodePtr() + offset); *sp = TAGGED(p->Get(index).AsUnsigned()); break; } case INSTR_storeMLWord: { PolyWord toStore = *sp++; POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).AsCodePtr() + offset); p->Set(index, toStore); *sp = Zero; break; } case INSTR_storeMLByte: { POLYUNSIGNED toStore = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = (*sp).AsCodePtr(); p[index] = (byte)toStore; *sp = Zero; break; } case INSTR_storeC8: { // Similar to storeMLByte except that the base address is a boxed large-word. POLYUNSIGNED toStore = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())); p[index] = (byte)toStore; *sp = Zero; break; } case INSTR_storeC16: { uint16_t toStore = (uint16_t)UNTAGGED(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((uint16_t*)p)[index] = toStore; *sp = Zero; break; } case INSTR_storeC32: { #ifdef IS64BITS // This is a tagged value in 64-bit mode. uint32_t toStore = (uint32_t)UNTAGGED(*sp++); #else // but a boxed value in 32-bit mode. uint32_t toStore = (uint32_t)(*(uintptr_t*)((*sp++).AsObjPtr())); #endif POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((uint32_t*)p)[index] = toStore; *sp = Zero; break; } #if (defined(IS64BITS)) case INSTR_storeC64: { // This is a boxed value. uint64_t toStore = *(uintptr_t*)((*sp++).AsObjPtr()); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((uint64_t*)p)[index] = toStore; *sp = Zero; break; } #endif case INSTR_storeCFloat: { // This is a boxed value. float toStore = (float)unboxDouble(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((float*)p)[index] = toStore; *sp = Zero; break; } case INSTR_storeCDouble: { // This is a boxed value. double toStore = unboxDouble(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte **)((*sp).AsObjPtr())) + offset; ((double*)p)[index] = toStore; *sp = Zero; break; } case INSTR_storeUntagged: { PolyWord toStore = PolyWord::FromUnsigned(UNTAGGED_UNSIGNED(*sp++)); POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).AsCodePtr() + offset); p->Set(index, toStore); *sp = Zero; break; } case INSTR_blockMoveWord: { // The offsets are byte counts but the the indexes are in words. POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject *dest = (PolyObject*)((*sp++).AsCodePtr() + destOffset); POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED srcIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject *src = (PolyObject*)((*sp).AsCodePtr() + srcOffset); for (POLYUNSIGNED u = 0; u < length; u++) dest->Set(destIndex+u, src->Get(srcIndex+u)); *sp = Zero; break; } case INSTR_blockMoveByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR dest = (*sp++).AsCodePtr(); POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR src = (*sp).AsCodePtr(); memcpy(dest+destOffset, src+srcOffset, length); *sp = Zero; break; } case INSTR_blockEqualByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg2Ptr = (*sp++).AsCodePtr(); POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg1Ptr = (*sp).AsCodePtr(); *sp = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length) == 0 ? True : False; break; } case INSTR_blockCompareByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg2Ptr = (*sp++).AsCodePtr(); POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg1Ptr = (*sp).AsCodePtr(); int result = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length); *sp = result == 0 ? TAGGED(0) : result < 0 ? TAGGED(-1) : TAGGED(1); break; } case INSTR_allocCSpace: { // Allocate this on the C heap. POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); void* memory = malloc(length); *sp = Make_sysword(this, (uintptr_t)memory)->Word(); break; } case INSTR_freeCSpace: { // Both the address and the size are passed as arguments. //PolyWord size = *sp++; PolyWord addr = *sp; free(*(void**)(addr.AsObjPtr())); *sp = TAGGED(0); break; } default: Crash("Unknown instruction %x\n", pc[-1]); } /* switch */ } /* for */ return 0; } /* MD_switch_to_poly */ void IntTaskData::GarbageCollect(ScanAddress *process) { TaskData::GarbageCollect(process); overflowPacket = process->ScanObjectAddress(overflowPacket); dividePacket = process->ScanObjectAddress(dividePacket); if (stack != 0) { StackSpace *stackSpace = stack; PolyWord *stackPtr = this->taskSp; // The exception arg if any ScanStackAddress(process, this->exception_arg, stackSpace); // Now the values on the stack. for (PolyWord *q = stackPtr; q < stackSpace->top; q++) ScanStackAddress(process, *q, stackSpace); } } // Process a value within the stack. void IntTaskData::ScanStackAddress(ScanAddress *process, PolyWord &val, StackSpace *stack) { if (! val.IsDataPtr()) return; MemSpace *space = gMem.LocalSpaceForAddress(val.AsStackAddr()-1); if (space != 0) val = process->ScanObjectAddress(val.AsObjPtr()); } // Copy a stack void IntTaskData::CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) { /* Moves a stack, updating all references within the stack */ PolyWord *old_base = (PolyWord *)old_stack; PolyWord *new_base = (PolyWord*)new_stack; PolyWord *old_top = old_base + old_length; /* Calculate the offset of the new stack from the old. If the frame is being extended objects in the new frame will be further up the stack than in the old one. */ uintptr_t offset = new_base - old_base + new_length - old_length; PolyWord *oldSp = this->taskSp; this->taskSp = oldSp + offset; this->hr = this->hr + offset; /* Skip the unused part of the stack. */ uintptr_t i = oldSp - old_base; ASSERT(i <= old_length); i = old_length - i; PolyWord *old = oldSp; PolyWord *newp = this->taskSp; while (i--) { // ASSERT(old >= old_base && old < old_base+old_length); // ASSERT(newp >= new_base && newp < new_base+new_length); PolyWord old_word = *old++; if (old_word.IsTagged() || old_word.AsStackAddr() < old_base || old_word.AsStackAddr() >= old_top) *newp++ = old_word; else *newp++ = PolyWord::FromStackAddr(old_word.AsStackAddr() + offset); } ASSERT(old == ((PolyWord*)old_stack) + old_length); ASSERT(newp == ((PolyWord*)new_stack) + new_length); } void IntTaskData::EnterPolyCode() /* Called from "main" to enter the code. */ { Handle hOriginal = this->saveVec.mark(); // Set this up for the IO calls. while (1) { this->saveVec.reset(hOriginal); // Remove old RTS arguments and results. // Run the ML code and return with the function to call. this->inML = true; int ioFunction = SwitchToPoly(); this->inML = false; try { switch (ioFunction) { case -1: // We've been interrupted. This usually involves simulating a // stack overflow so we could come here because of a genuine // stack overflow. // Previously this code was executed on every RTS call but there // were problems on Mac OS X at least with contention on schedLock. // Process any asynchronous events i.e. interrupts or kill processes->ProcessAsynchRequests(this); // Release and re-acquire use of the ML memory to allow another thread // to GC. processes->ThreadReleaseMLMemory(this); processes->ThreadUseMLMemory(this); break; case -2: // A callback has returned. ASSERT(0); // Callbacks aren't implemented default: Crash("Unknown io operation %d\n", ioFunction); } } catch (IOException &) { } } } // As far as possible we want locking and unlocking an ML mutex to be fast so // we try to implement the code in the assembly code using appropriate // interlocked instructions. That does mean that if we need to lock and // unlock an ML mutex in this code we have to use the same, machine-dependent, // code to do it. These are defaults that are used where there is no // machine-specific code. static Handle ProcessAtomicIncrement(TaskData *taskData, Handle mutexp) { PLocker l(&mutexLock); PolyObject *p = DEREFHANDLE(mutexp); // A thread can only call this once so the values will be short PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))+1); p->Set(0, newValue); return taskData->saveVec.push(newValue); } // Release a mutex. We need to lock the mutex to ensure we don't // reset it in the time between one of atomic operations reading // and writing the mutex. static Handle ProcessAtomicReset(TaskData *taskData, Handle mutexp) { PLocker l(&mutexLock); DEREFHANDLE(mutexp)->Set(0, TAGGED(1)); // Set this to released. return taskData->saveVec.push(TAGGED(0)); // Push the unit result } Handle IntTaskData::AtomicIncrement(Handle mutexp) { return ProcessAtomicIncrement(this, mutexp); } void IntTaskData::AtomicReset(Handle mutexp) { (void)ProcessAtomicReset(this, mutexp); } bool IntTaskData::AddTimeProfileCount(SIGNALCONTEXT *context) { if (taskPc != 0) { // See if the PC we've got is an ML code address. MemSpace *space = gMem.SpaceForAddress(taskPc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { add_count(this, taskPc, 1); return true; } } return false; } extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedGetAbiList(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCreateCallback(FirstArgument threadId); } // FFI -#if (defined(HAVE_LIBFFI) && defined(HAVE_FFI_H)) +#if (1) // (defined(HAVE_LIBFFI) && defined(HAVE_FFI_H)) #ifdef HAVE_ERRNO_H #include #endif #include static struct _abiTable { const char* abiName; ffi_abi abiCode; } abiTable[] = { // Unfortunately the ABI entries are enums rather than #defines so we // can't test individual entries. #ifdef X86_WIN32 {"sysv", FFI_SYSV}, {"stdcall", FFI_STDCALL}, {"thiscall", FFI_THISCALL}, {"fastcall", FFI_FASTCALL}, {"ms_cdecl", FFI_MS_CDECL}, #elif defined(X86_WIN64) {"win64", FFI_WIN64}, #elif defined(X86_64) || (defined (__x86_64__) && defined (X86_DARWIN)) {"unix64", FFI_UNIX64}, #elif defined(X86_ANY) {"sysv", FFI_SYSV}, #endif { "default", FFI_DEFAULT_ABI} }; static Handle mkAbitab(TaskData* taskData, void*, char* p); static Handle toSysWord(TaskData* taskData, void* p) { return Make_sysword(taskData, (uintptr_t)p); } // Convert the Poly type info into ffi_type values. /* datatype cTypeForm = CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } */ static ffi_type* decodeType(PolyWord pType) { PolyWord typeForm = pType.AsObjPtr()->Get(2); PolyWord typeSize = pType.AsObjPtr()->Get(0); if (typeForm.IsDataPtr()) { // Struct size_t size = typeSize.UnTaggedUnsigned(); unsigned short align = (unsigned short)pType.AsObjPtr()->Get(1).UnTaggedUnsigned(); unsigned nElems = 0; for (PolyWord p = typeForm; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nElems++; size_t space = sizeof(ffi_type); // Add space for the elements plus one extra for the zero terminator. space += (nElems + 1) * sizeof(ffi_type*); ffi_type* result = (ffi_type*)calloc(1, space); // Raise an exception rather than returning zero. if (result == 0) return 0; ffi_type** elem = (ffi_type**)(result + 1); result->size = size; result->alignment = align; result->type = FFI_TYPE_STRUCT; result->elements = elem; if (elem != 0) { for (PolyWord p = typeForm; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; ffi_type* t = decodeType(e); if (t == 0) return 0; *elem++ = t; } *elem = 0; // Null terminator } } else { switch (typeForm.UnTaggedUnsigned()) { case 0: { // Floating point if (typeSize.UnTaggedUnsigned() == ffi_type_float.size) return &ffi_type_float; else if (typeSize.UnTaggedUnsigned() == ffi_type_double.size) return &ffi_type_double; ASSERT(0); } case 1: // FFI type poiner return &ffi_type_pointer; case 2: // Signed integer. { switch (typeSize.UnTaggedUnsigned()) { case 1: return &ffi_type_sint8; case 2: return &ffi_type_sint16; case 4: return &ffi_type_sint32; case 8: return &ffi_type_sint64; default: ASSERT(0); } } case 3: // Unsigned integer. { switch (typeSize.UnTaggedUnsigned()) { case 1: return &ffi_type_uint8; case 2: return &ffi_type_uint16; case 4: return &ffi_type_uint32; case 8: return &ffi_type_uint64; default: ASSERT(0); } } case 4: // Void return &ffi_type_void; } ASSERT(0); } return 0; } // Create a CIF. This contains all the types and some extra information. // The arguments are the raw ML values. That does make this dependent on the // representations used by the compiler. // This mallocs space for the CIF and the types. The space is never freed. // POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; ffi_abi abi = (ffi_abi)get_C_ushort(taskData, abiValue); try { unsigned nArgs = 0; for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nArgs++; // Allocate space for the cif followed by the argument type vector size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*); ffi_cif* cif = (ffi_cif*)malloc(space); if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type* rtype = decodeType(resultType); if (rtype == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type** atypes = (ffi_type**)(cif + 1); // Copy the arguments types. ffi_type** at = atypes; for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; ffi_type *atype = decodeType(e); if (atype == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); *at++ = atype; } ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes); if (status == FFI_BAD_TYPEDEF) raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif"); else if (status == FFI_BAD_ABI) raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif"); else if (status != FFI_OK) raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif"); result = toSysWord(taskData, cif); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Call a function. POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) { ffi_cif* cif = *(ffi_cif**)cifAddr.AsAddress(); void* f = *(void**)cFunAddr.AsAddress(); void* res = *(void**)resAddr.AsAddress(); - void** arg = *(void***)argVec.AsAddress(); - ffi_call(cif, FFI_FN(f), res, arg); + void* arg = *(void**)argVec.AsAddress(); + // Poly passes the arguments as values, effectively a single struct. + // Libffi wants a vector of addresses. + void** argVector = (void**)calloc(cif->nargs + 1, sizeof(void*)); + unsigned n = 0; + uintptr_t p = (uintptr_t)arg; + while (n < cif->nargs) + { + uintptr_t align = cif->arg_types[n]->alignment; + p = (p + align - 1) & (0-align); + argVector[n] = (void*)p; + p += cif->arg_types[n]->size; + n++; + } + // The result area we have provided is only as big as required. + // Libffi may need a larger area. + if (cif->rtype->size < FFI_SIZEOF_ARG) + { + char result[FFI_SIZEOF_ARG]; + ffi_call(cif, FFI_FN(f), &result, argVector); + if (cif->rtype->type != FFI_TYPE_VOID) + memcpy(res, result, cif->rtype->size); + } + else ffi_call(cif, FFI_FN(f), res, argVector); + free(argVector); return TAGGED(0).AsUnsigned(); } POLYUNSIGNED PolyInterpretedCreateCallback(FirstArgument threadId) { return TAGGED(0).AsUnsigned(); } #else // Libffi is not present. // A basic table so that the Foreign structure will compile static struct _abiTable { const char* abiName; int abiCode; } abiTable[] = { { "default", 0} }; // Don't raise an exception at this point so we can build calls. POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) { return TAGGED(0).AsUnsigned(); } POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) { TaskData* taskData = TaskData::FindTaskForId(threadId); raise_exception_string(taskData, EXC_foreign, "Foreign function calling is not available. Libffi is not installled."); return TAGGED(0).AsUnsigned(); } POLYUNSIGNED PolyInterpretedCreateCallback(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); raise_exception_string(taskData, EXC_foreign, "Foreign function calling is not available. Libffi is not installled."); return TAGGED(0).AsUnsigned(); } #endif // Construct an entry in the ABI table. static Handle mkAbitab(TaskData* taskData, void* arg, char* p) { struct _abiTable* ab = (struct _abiTable*)p; // Construct a pair of the string and the code Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName)); Handle code = Make_arbitrary_precision(taskData, ab->abiCode); Handle result = alloc_and_save(taskData, 2); result->WordP()->Set(0, name->Word()); result->WordP()->Set(1, code->Word()); return result; } // Get ABI list. This is called once only before the basis library is built. POLYUNSIGNED PolyInterpretedGetAbiList(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = makeList(taskData, sizeof(abiTable) / sizeof(abiTable[0]), (char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } static Interpreter interpreterObject; MachineDependent *machineDependent = &interpreterObject; // No machine-specific calls in the interpreter. struct _entrypts machineSpecificEPT[] = { { "PolyInterpretedGetAbiList", (polyRTSFunction)&PolyInterpretedGetAbiList }, { "PolyInterpretedCreateCIF", (polyRTSFunction)&PolyInterpretedCreateCIF }, { "PolyInterpretedCallFunction", (polyRTSFunction)&PolyInterpretedCallFunction }, { "PolyInterpretedCreateCallback", (polyRTSFunction)&PolyInterpretedCreateCallback }, { NULL, NULL} // End of list. };