diff --git a/libpolyml/interpret.cpp b/libpolyml/interpret.cpp index f56b1531..f9c0fd51 100644 --- a/libpolyml/interpret.cpp +++ b/libpolyml/interpret.cpp @@ -1,2331 +1,2334 @@ /* 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. + Further development Copyright David C.J. Matthews 2015-18, 2020. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_MATH_H #include #endif #include // Currently just for isnan. #include "globals.h" #include "int_opcodes.h" #include "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" #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 Handle 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); // These aren't implemented in the interpreted version. virtual Handle EnterCallbackFunction(Handle func, Handle args) { ASSERT(0); return 0; } // 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; } + // The interpreted version does not need the code to have execute + // permission because it's not actually executed. + virtual bool CodeMustBeExecutable(void) { return false; } }; 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(); POLYUNSIGNED result = doCall(); *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS1: { callFastRts1 doCall = *(callFastRts1*)(*sp++).AsObjPtr(); intptr_t rtsArg1 = (*sp++).AsSigned(); POLYUNSIGNED result = doCall(rtsArg1); *(--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(); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2); *(--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(); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3); *(--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(); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4); *(--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(); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4, rtsArg5); *(--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; } 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); } Handle 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; } static Interpreter interpreterObject; MachineDependent *machineDependent = &interpreterObject; diff --git a/libpolyml/machine_dep.h b/libpolyml/machine_dep.h index 7198b96b..6e4fb036 100644 --- a/libpolyml/machine_dep.h +++ b/libpolyml/machine_dep.h @@ -1,62 +1,67 @@ /* Title: machine_dep.h - exports signature for machine_dep.c Copyright (c) 2000 Cambridge University Technical Services Limited + Further development Copyright 2020 David C. J. Matthews + This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. + 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 _MACHINE_DEP_H #define _MACHINE_DEP_H class ScanAddress; class TaskData; class SaveVecEntry; typedef SaveVecEntry *Handle; class StackSpace; // Machine architecture values. typedef enum { MA_Interpreted = 0, MA_I386, MA_X86_64, MA_X86_64_32 } Architectures; // Machine-dependent module. class MachineDependent { public: virtual ~MachineDependent() {} // Keep the compiler happy // Create the machine-specific task data object. virtual TaskData *CreateTaskData(void) = 0; virtual unsigned InitialStackSize(void) { return 128; } // Initial size of a stack // Must be > 40 (i.e. 2*min_stack_check) + base area in each stack frame /* ScanConstantsWithinCode - update addresses within a code segment.*/ virtual void ScanConstantsWithinCode(PolyObject *addr, PolyObject *oldAddr, POLYUNSIGNED length, ScanAddress *process) {} void ScanConstantsWithinCode(PolyObject *addr, ScanAddress *process) { ScanConstantsWithinCode(addr, addr, addr->Length(), process); } // Common case virtual void FlushInstructionCache(void *p, POLYUNSIGNED bytes) {} virtual Architectures MachineArchitecture(void) = 0; + + // The interpreted version does not need the code to have execute + // permission because it's not actually executed. + virtual bool CodeMustBeExecutable(void) { return true; } }; extern MachineDependent *machineDependent; #endif /* _MACHINE_DEP_H */ diff --git a/libpolyml/memmgr.cpp b/libpolyml/memmgr.cpp index 8ab4e5b0..0c5ea905 100644 --- a/libpolyml/memmgr.cpp +++ b/libpolyml/memmgr.cpp @@ -1,1375 +1,1377 @@ /* Title: memmgr.cpp Memory segment manager Copyright (c) 2006-7, 2011-12, 2016-18 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 #include #include #include "globals.h" #include "memmgr.h" #include "osmem.h" #include "scanaddrs.h" #include "bitmap.h" #include "mpoly.h" #include "diagnostics.h" #include "statistics.h" #include "processes.h" +#include "machine_dep.h" #ifdef POLYML32IN64 // This contains the address of the base of the heap. PolyWord *globalHeapBase, *globalCodeBase; #endif // heap resizing policy option requested on command line unsigned heapsizingOption = 0; MemSpace::MemSpace(OSMem *alloc): SpaceTree(true) { spaceType = ST_PERMANENT; isMutable = false; bottom = 0; top = 0; isCode = false; allocator = alloc; shadowSpace = 0; } MemSpace::~MemSpace() { if (allocator != 0 && bottom != 0) { if (isCode) allocator->FreeCodeArea(bottom, shadowSpace, (char*)top - (char*)bottom); else allocator->FreeDataArea(bottom, (char*)top - (char*)bottom); } } MarkableSpace::MarkableSpace(OSMem *alloc): MemSpace(alloc), spaceLock("Local space") { } LocalMemSpace::LocalMemSpace(OSMem *alloc): MarkableSpace(alloc) { spaceType = ST_LOCAL; upperAllocPtr = lowerAllocPtr = 0; for (unsigned i = 0; i < NSTARTS; i++) start[i] = 0; start_index = 0; i_marked = m_marked = updated = 0; allocationSpace = false; } bool LocalMemSpace::InitSpace(PolyWord *heapSpace, uintptr_t size, bool mut) { isMutable = mut; bottom = heapSpace; top = bottom + size; // Initialise all the fields. The partial GC in particular relies on this. upperAllocPtr = partialGCTop = fullGCRescanStart = fullGCLowerLimit = lowestWeak = top; lowerAllocPtr = partialGCScan = partialGCRootBase = partialGCRootTop = fullGCRescanEnd = highestWeak = bottom; #ifdef POLYML32IN64 // The address must be on an odd-word boundary so that after the length // word is put in the actual cell address is on an even-word boundary. lowerAllocPtr[0] = PolyWord::FromUnsigned(0); lowerAllocPtr = bottom + 1; #endif spaceOwner = 0; allocationSpace = false; // Bitmap for the space. return bitmap.Create(size); } MemMgr::MemMgr(): allocLock("Memmgr alloc"), codeBitmapLock("Code bitmap") { nextIndex = 0; reservedSpace = 0; nextAllocator = 0; defaultSpaceSize = 0; spaceBeforeMinorGC = 0; spaceForHeap = 0; currentAllocSpace = currentHeapSize = 0; defaultSpaceSize = 1024 * 1024 / sizeof(PolyWord); // 1Mbyte segments. spaceTree = new SpaceTreeTree; } MemMgr::~MemMgr() { delete(spaceTree); // Have to do this before we delete the spaces. for (std::vector::iterator i = pSpaces.begin(); i < pSpaces.end(); i++) delete(*i); for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) delete(*i); for (std::vector::iterator i = eSpaces.begin(); i < eSpaces.end(); i++) delete(*i); for (std::vector::iterator i = sSpaces.begin(); i < sSpaces.end(); i++) delete(*i); for (std::vector::iterator i = cSpaces.begin(); i < cSpaces.end(); i++) delete(*i); } bool MemMgr::Initialise() { #ifdef POLYML32IN64 // Allocate a single 16G area but with no access. void *heapBase; if (!osHeapAlloc.Initialise(false, (size_t)16 * 1024 * 1024 * 1024, &heapBase)) return false; globalHeapBase = (PolyWord*)heapBase; // Allocate a 4 gbyte area for the stacks. // It's important that the stack and code areas have addresses with // non-zero top 32-bits. if (!osStackAlloc.Initialise(false, (size_t)4 * 1024 * 1024 * 1024)) return false; // Allocate a 2G area for the code. void *codeBase; - if (!osCodeAlloc.Initialise(true, (size_t)2 * 1024 * 1024 * 1024, &codeBase)) + if (!osCodeAlloc.Initialise(machineDependent->CodeMustBeExecutable(), (size_t)2 * 1024 * 1024 * 1024, &codeBase)) return false; globalCodeBase = (PolyWord*)codeBase; return true; #else - return osHeapAlloc.Initialise(false) && osStackAlloc.Initialise(false) && osCodeAlloc.Initialise(true); + return osHeapAlloc.Initialise(false) && osStackAlloc.Initialise(false) && + osCodeAlloc.Initialise(machineDependent->CodeMustBeExecutable()); #endif } // Create and initialise a new local space and add it to the table. LocalMemSpace* MemMgr::NewLocalSpace(uintptr_t size, bool mut) { try { LocalMemSpace *space = new LocalMemSpace(&osHeapAlloc); // Before trying to allocate the heap temporarily allocate the // reserved space. This ensures that this much space will always // be available for C stacks and the C++ heap. void *reservation = 0; size_t rSpace = reservedSpace*sizeof(PolyWord); if (reservedSpace != 0) { reservation = osHeapAlloc.AllocateDataArea(rSpace); if (reservation == NULL) { // Insufficient space for the reservation. Can't allocate this local space. if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New local %smutable space: insufficient reservation space\n", mut ? "": "im"); delete space; return 0; } } // Allocate the heap itself. size_t iSpace = size * sizeof(PolyWord); PolyWord* heapSpace = (PolyWord*)osHeapAlloc.AllocateDataArea(iSpace); // The size may have been rounded up to a block boundary. size = iSpace / sizeof(PolyWord); bool success = heapSpace != 0 && space->InitSpace(heapSpace, size, mut) && AddLocalSpace(space); if (reservation != 0) osHeapAlloc.FreeDataArea(reservation, rSpace); if (success) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New local %smutable space %p, size=%luk words, bottom=%p, top=%p\n", mut ? "": "im", space, space->spaceSize()/1024, space->bottom, space->top); currentHeapSize += space->spaceSize(); globalStats.setSize(PSS_TOTAL_HEAP, currentHeapSize * sizeof(PolyWord)); return space; } // If something went wrong. delete space; if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New local %smutable space: insufficient space\n", mut ? "": "im"); return 0; } catch (std::bad_alloc&) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New local %smutable space: \"new\" failed\n", mut ? "": "im"); return 0; } } // Create a local space for initial allocation. LocalMemSpace *MemMgr::CreateAllocationSpace(uintptr_t size) { LocalMemSpace *result = NewLocalSpace(size, true); if (result) { result->allocationSpace = true; currentAllocSpace += result->spaceSize(); globalStats.incSize(PSS_ALLOCATION, result->spaceSize()*sizeof(PolyWord)); globalStats.incSize(PSS_ALLOCATION_FREE, result->freeSpace()*sizeof(PolyWord)); } return result; } // If an allocation space has a lot of data left in it after a GC, particularly // a single large object we should turn it into a local area. void MemMgr::ConvertAllocationSpaceToLocal(LocalMemSpace *space) { ASSERT(space->allocationSpace); space->allocationSpace = false; // Currently it is left as a mutable area but if the contents are all // immutable e.g. a large vector it could be better to turn it into an // immutable area. currentAllocSpace -= space->spaceSize(); } // Add a local memory space to the table. bool MemMgr::AddLocalSpace(LocalMemSpace *space) { // Add to the table. // Update the B-tree. try { AddTree(space); // The entries in the local table are ordered so that the copy phase of the full // GC simply has to copy to an entry earlier in the table. Immutable spaces come // first, followed by mutable spaces and finally allocation spaces. if (space->allocationSpace) lSpaces.push_back(space); // Just add at the end else if (space->isMutable) { // Add before the allocation spaces std::vector::iterator i = lSpaces.begin(); while (i != lSpaces.end() && ! (*i)->allocationSpace) i++; lSpaces.insert(i, space); } else { // Immutable space: Add before the mutable spaces std::vector::iterator i = lSpaces.begin(); while (i != lSpaces.end() && ! (*i)->isMutable) i++; lSpaces.insert(i, space); } } catch (std::bad_alloc&) { RemoveTree(space); return false; } return true; } // Create an entry for a permanent space. PermanentMemSpace* MemMgr::NewPermanentSpace(PolyWord *base, uintptr_t words, unsigned flags, unsigned index, unsigned hierarchy /*= 0*/) { try { PermanentMemSpace *space = new PermanentMemSpace(0/* Not freed */); space->bottom = base; space->topPointer = space->top = space->bottom + words; space->spaceType = ST_PERMANENT; space->isMutable = flags & MTF_WRITEABLE ? true : false; space->noOverwrite = flags & MTF_NO_OVERWRITE ? true : false; space->byteOnly = flags & MTF_BYTES ? true : false; space->isCode = flags & MTF_EXECUTABLE ? true : false; space->index = index; space->hierarchy = hierarchy; if (index >= nextIndex) nextIndex = index+1; // Extend the permanent memory table and add this space to it. try { AddTree(space); pSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); delete space; return 0; } return space; } catch (std::bad_alloc&) { return 0; } } PermanentMemSpace *MemMgr::AllocateNewPermanentSpace(uintptr_t byteSize, unsigned flags, unsigned index, unsigned hierarchy) { try { OSMem *alloc = flags & MTF_EXECUTABLE ? &osCodeAlloc : &osHeapAlloc; PermanentMemSpace *space = new PermanentMemSpace(alloc); size_t actualSize = byteSize; PolyWord* base; void* newShadow=0; if (flags & MTF_EXECUTABLE) base = (PolyWord*)alloc->AllocateCodeArea(actualSize, newShadow); else base = (PolyWord*)alloc->AllocateDataArea(actualSize); if (base == 0) { delete(space); return 0; } space->bottom = base; space->shadowSpace = (PolyWord*)newShadow; space->topPointer = space->top = space->bottom + actualSize/sizeof(PolyWord); space->spaceType = ST_PERMANENT; space->isMutable = flags & MTF_WRITEABLE ? true : false; space->noOverwrite = flags & MTF_NO_OVERWRITE ? true : false; space->byteOnly = flags & MTF_BYTES ? true : false; space->isCode = flags & MTF_EXECUTABLE ? true : false; space->index = index; space->hierarchy = hierarchy; if (index >= nextIndex) nextIndex = index + 1; // Extend the permanent memory table and add this space to it. try { AddTree(space); pSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); delete space; return 0; } return space; } catch (std::bad_alloc&) { return 0; } } bool MemMgr::CompletePermanentSpaceAllocation(PermanentMemSpace *space) { // Remove write access unless it is mutable. // Don't remove write access unless this is top-level. Share-data assumes only hierarchy 0 is write-protected. if (!space->isMutable && space->hierarchy == 0) { if (space->isCode) osCodeAlloc.DisableWriteForCode(space->bottom, space->shadowSpace, (char*)space->top - (char*)space->bottom); else osHeapAlloc.EnableWrite(false, space->bottom, (char*)space->top - (char*)space->bottom); } return true; } // Delete a local space and remove it from the table. void MemMgr::DeleteLocalSpace(std::vector::iterator &iter) { LocalMemSpace *sp = *iter; if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Deleted local %s space %p at %p size %zu\n", sp->spaceTypeString(), sp, sp->bottom, sp->spaceSize()); currentHeapSize -= sp->spaceSize(); globalStats.setSize(PSS_TOTAL_HEAP, currentHeapSize * sizeof(PolyWord)); if (sp->allocationSpace) currentAllocSpace -= sp->spaceSize(); RemoveTree(sp); delete(sp); iter = lSpaces.erase(iter); } // Remove local areas that are now empty after a GC. // It isn't clear if we always want to do this. void MemMgr::RemoveEmptyLocals() { for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); ) { LocalMemSpace *space = *i; if (space->isEmpty()) DeleteLocalSpace(i); else i++; } } // Create and initialise a new export space and add it to the table. PermanentMemSpace* MemMgr::NewExportSpace(uintptr_t size, bool mut, bool noOv, bool code) { try { OSMem *alloc = code ? &osCodeAlloc : &osHeapAlloc; PermanentMemSpace *space = new PermanentMemSpace(alloc); space->spaceType = ST_EXPORT; space->isMutable = mut; space->noOverwrite = noOv; space->isCode = code; space->index = nextIndex++; // Allocate the memory itself. size_t iSpace = size*sizeof(PolyWord); if (code) { void* shadow; space->bottom = (PolyWord*)alloc->AllocateCodeArea(iSpace, shadow); if (space->bottom != 0) space->shadowSpace = (PolyWord*)shadow; } else space->bottom = (PolyWord*)alloc->AllocateDataArea(iSpace); if (space->bottom == 0) { delete space; if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New export %smutable space: insufficient space\n", mut ? "" : "im"); return 0; } // The size may have been rounded up to a block boundary. size = iSpace/sizeof(PolyWord); space->top = space->bottom + size; space->topPointer = space->bottom; #ifdef POLYML32IN64 // The address must be on an odd-word boundary so that after the length // word is put in the actual cell address is on an even-word boundary. space->topPointer[0] = PolyWord::FromUnsigned(0); space->topPointer = space->bottom + 1; #endif if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New export %smutable %s%sspace %p, size=%luk words, bottom=%p, top=%p\n", mut ? "" : "im", noOv ? "no-overwrite " : "", code ? "code " : "", space, space->spaceSize() / 1024, space->bottom, space->top); // Add to the table. try { AddTree(space); eSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); delete space; if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New export %smutable space: Adding to tree failed\n", mut ? "" : "im"); return 0; } return space; } catch (std::bad_alloc&) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New export %smutable space: \"new\" failed\n", mut ? "" : "im"); return 0; } } void MemMgr::DeleteExportSpaces(void) { for (std::vector::iterator i = eSpaces.begin(); i < eSpaces.end(); i++) { PermanentMemSpace *space = *i; RemoveTree(space); delete(space); } eSpaces.clear(); } // If we have saved the state rather than exported a function we turn the exported // spaces into permanent ones, removing existing permanent spaces at the same or // lower level. bool MemMgr::PromoteExportSpaces(unsigned hierarchy) { // Save permanent spaces at a lower hierarchy. Others are converted into // local spaces. Most or all items will have been copied from these spaces // into an export space but there could be items reachable only from the stack. std::vector::iterator i = pSpaces.begin(); while (i != pSpaces.end()) { PermanentMemSpace *pSpace = *i; if (pSpace->hierarchy < hierarchy) i++; else { try { // Turn this into a local space or a code space // Remove this from the tree - AddLocalSpace will make an entry for the local version. RemoveTree(pSpace); if (pSpace->isCode) { // Enable write access. Permanent spaces are read-only. // osCodeAlloc.SetPermissions(pSpace->bottom, (char*)pSpace->top - (char*)pSpace->bottom, // PERMISSION_READ | PERMISSION_WRITE | PERMISSION_EXEC); CodeSpace *space = new CodeSpace(pSpace->bottom, pSpace->spaceSize(), &osCodeAlloc); if (! space->headerMap.Create(space->spaceSize())) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Unable to create header map for state space %p\n", pSpace); return false; } if (!AddCodeSpace(space)) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Unable to convert saved state space %p into code space\n", pSpace); return false; } if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Converted saved state space %p into code space %p\n", pSpace, space); // Set the bits in the header map. for (PolyWord *ptr = space->bottom; ptr < space->top; ) { PolyObject *obj = (PolyObject*)(ptr+1); // We may have forwarded this if this has been // copied to the exported area. Restore the original length word. if (obj->ContainsForwardingPtr()) { #ifdef POLYML32IN64 PolyObject *forwardedTo = obj; // This is relative to globalCodeBase not globalHeapBase while (forwardedTo->ContainsForwardingPtr()) forwardedTo = (PolyObject*)(globalCodeBase + ((forwardedTo->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); #else PolyObject *forwardedTo = obj->FollowForwardingChain(); #endif obj->SetLengthWord(forwardedTo->LengthWord()); } // Set the "start" bit if this is allocated. It will be a byte seg if not. if (obj->IsCodeObject()) space->headerMap.SetBit(ptr-space->bottom); ASSERT(!obj->IsClosureObject()); ptr += obj->Length() + 1; } } else { // Enable write access. Permanent spaces are read-only. // osHeapAlloc.SetPermissions(pSpace->bottom, (char*)pSpace->top - (char*)pSpace->bottom, // PERMISSION_READ | PERMISSION_WRITE); LocalMemSpace *space = new LocalMemSpace(&osHeapAlloc); space->top = pSpace->top; // Space is allocated in local areas from the top down. This area is full and // all data is in the old generation. The area can be recovered by a full GC. space->bottom = space->upperAllocPtr = space->lowerAllocPtr = space->fullGCLowerLimit = pSpace->bottom; space->isMutable = pSpace->isMutable; space->isCode = false; if (! space->bitmap.Create(space->top-space->bottom) || ! AddLocalSpace(space)) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Unable to convert saved state space %p into local space\n", pSpace); return false; } if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Converted saved state space %p into local %smutable space %p\n", pSpace, pSpace->isMutable ? "im": "", space); currentHeapSize += space->spaceSize(); globalStats.setSize(PSS_TOTAL_HEAP, currentHeapSize * sizeof(PolyWord)); } i = pSpaces.erase(i); } catch (std::bad_alloc&) { return false; } } } // Save newly exported spaces. for(std::vector::iterator j = eSpaces.begin(); j < eSpaces.end(); j++) { PermanentMemSpace *space = *j; space->hierarchy = hierarchy; // Set the hierarchy of the new spaces. space->spaceType = ST_PERMANENT; // Put a dummy object to fill up the unused space. if (space->topPointer != space->top) FillUnusedSpace(space->topPointer, space->top - space->topPointer); // Put in a dummy object to fill the rest of the space. pSpaces.push_back(space); } eSpaces.clear(); return true; } // Before we import a hierarchical saved state we need to turn any previously imported // spaces into local spaces. bool MemMgr::DemoteImportSpaces() { return PromoteExportSpaces(1); // Only truly permanent spaces are retained. } // Return the space for a given index PermanentMemSpace *MemMgr::SpaceForIndex(unsigned index) { for (std::vector::iterator i = pSpaces.begin(); i < pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->index == index) return space; } return NULL; } // In several places we assume that segments are filled with valid // objects. This fills unused memory with one or more "byte" objects. void MemMgr::FillUnusedSpace(PolyWord *base, uintptr_t words) { PolyWord *pDummy = base+1; while (words > 0) { #ifdef POLYML32IN64 // Make sure that any dummy object we insert is properly aligned. if (((uintptr_t)pDummy) & 4) { *pDummy++ = PolyWord::FromUnsigned(0); words--; continue; } #endif POLYUNSIGNED oSize; // If the space is larger than the maximum object size // we will need several objects. if (words > MAX_OBJECT_SIZE) oSize = MAX_OBJECT_SIZE; else oSize = (POLYUNSIGNED)(words-1); // Make this a byte object so it's always skipped. ((PolyObject*)pDummy)->SetLengthWord(oSize, F_BYTE_OBJ); words -= oSize+1; pDummy += oSize+1; } } // Allocate an area of the heap of at least minWords and at most maxWords. // This is used both when allocating single objects (when minWords and maxWords // are the same) and when allocating heap segments. If there is insufficient // space to satisfy the minimum it will return 0. PolyWord *MemMgr::AllocHeapSpace(uintptr_t minWords, uintptr_t &maxWords, bool doAllocation) { PLocker locker(&allocLock); // We try to distribute the allocations between the memory spaces // so that at the next GC we don't have all the most recent cells in // one space. The most recent cells will be more likely to survive a // GC so distibuting them improves the load balance for a multi-thread GC. nextAllocator++; if (nextAllocator > gMem.lSpaces.size()) nextAllocator = 0; unsigned j = nextAllocator; for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { if (j >= gMem.lSpaces.size()) j = 0; LocalMemSpace *space = gMem.lSpaces[j++]; if (space->allocationSpace) { uintptr_t available = space->freeSpace(); if (available > 0 && available >= minWords) { // Reduce the maximum value if we had less than that. if (available < maxWords) maxWords = available; #ifdef POLYML32IN64 // If necessary round down to an even boundary if (maxWords & 1) { maxWords--; space->lowerAllocPtr[maxWords] = PolyWord::FromUnsigned(0); } #endif PolyWord *result = space->lowerAllocPtr; // Return the address. if (doAllocation) space->lowerAllocPtr += maxWords; // Allocate it. #ifdef POLYML32IN64 ASSERT((uintptr_t)result & 4); // Must be odd-word aligned #endif return result; } } } // There isn't space in the existing areas - can we create a new area? // The reason we don't have enough space could simply be that we want to // allocate an object larger than the default space size. Try deleting // some other spaces to bring currentAllocSpace below spaceBeforeMinorGC - minWords. if (minWords > defaultSpaceSize && minWords < spaceBeforeMinorGC) RemoveExcessAllocation(spaceBeforeMinorGC - minWords); if (currentAllocSpace/* + minWords */ < spaceBeforeMinorGC) { // i.e. the current allocation space is less than the space allowed for the minor GC // but it may be that allocating this object will take us over the limit. We allow // that to happen so that we can successfully allocate very large objects even if // we have a new GC very shortly. uintptr_t spaceSize = defaultSpaceSize; #ifdef POLYML32IN64 // When we create the allocation space we take one word so that the first // length word is on an odd-word boundary. We need to allow for that otherwise // we may have available < minWords. if (minWords >= spaceSize) spaceSize = minWords+1; // If we really want a large space. #else if (minWords > spaceSize) spaceSize = minWords; // If we really want a large space. #endif LocalMemSpace *space = CreateAllocationSpace(spaceSize); if (space == 0) return 0; // Can't allocate it // Allocate our space in this new area. uintptr_t available = space->freeSpace(); ASSERT(available >= minWords); if (available < maxWords) { maxWords = available; #ifdef POLYML32IN64 // If necessary round down to an even boundary if (maxWords & 1) { maxWords--; space->lowerAllocPtr[maxWords] = PolyWord::FromUnsigned(0); } #endif } PolyWord *result = space->lowerAllocPtr; // Return the address. if (doAllocation) space->lowerAllocPtr += maxWords; // Allocate it. #ifdef POLYML32IN64 ASSERT((uintptr_t)result & 4); // Must be odd-word aligned #endif return result; } return 0; // There isn't space even for the minimum. } CodeSpace::CodeSpace(PolyWord *start, uintptr_t spaceSize, OSMem *alloc): MarkableSpace(alloc) { bottom = start; top = start+spaceSize; isMutable = true; // Make it mutable just in case. This will cause it to be scanned. isCode = true; spaceType = ST_CODE; #ifdef POLYML32IN64 // Dummy word so that the cell itself, after the length word, is on an 8-byte boundary. *start = PolyWord::FromUnsigned(0); largestFree = spaceSize - 2; firstFree = start+1; #else largestFree = spaceSize - 1; firstFree = start; #endif } CodeSpace *MemMgr::NewCodeSpace(uintptr_t size) { // Allocate a new area and add it at the end of the table. CodeSpace *allocSpace = 0; // Allocate a new mutable, code space. N.B. This may round up "actualSize". size_t actualSize = size * sizeof(PolyWord); void* shadow; PolyWord *mem = (PolyWord*)osCodeAlloc.AllocateCodeArea(actualSize, shadow); if (mem != 0) { try { allocSpace = new CodeSpace(mem, actualSize / sizeof(PolyWord), &osCodeAlloc); allocSpace->shadowSpace = (PolyWord*)shadow; if (!allocSpace->headerMap.Create(allocSpace->spaceSize())) { delete allocSpace; allocSpace = 0; } else if (!AddCodeSpace(allocSpace)) { delete allocSpace; allocSpace = 0; } else if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New code space %p allocated at %p size %lu\n", allocSpace, allocSpace->bottom, allocSpace->spaceSize()); // Put in a byte cell to mark the area as unallocated. FillUnusedSpace(allocSpace->firstFree, allocSpace->top- allocSpace->firstFree); } catch (std::bad_alloc&) { } if (allocSpace == 0) { osCodeAlloc.FreeCodeArea(mem, shadow, actualSize); mem = 0; } } return allocSpace; } // Allocate memory for a piece of code. This needs to be both mutable and executable, // at least for native code. The interpreted version need not (should not?) make the // area executable. It will not be executed until the mutable bit has been cleared. // Once code is allocated it is not GCed or moved. // initCell is a byte cell that is copied into the new code area. PolyObject* MemMgr::AllocCodeSpace(POLYUNSIGNED requiredSize) { PLocker locker(&codeSpaceLock); // Search the code spaces until we find a free area big enough. size_t i = 0; while (true) { if (i != cSpaces.size()) { CodeSpace *space = cSpaces[i]; if (space->largestFree >= requiredSize) { POLYUNSIGNED actualLargest = 0; while (space->firstFree < space->top) { PolyObject *obj = (PolyObject*)(space->firstFree+1); // Skip over allocated areas or free areas that are too small. if (obj->IsCodeObject() || obj->Length() < 8) space->firstFree += obj->Length()+1; else break; } PolyWord *pt = space->firstFree; while (pt < space->top) { PolyObject *obj = (PolyObject*)(pt+1); POLYUNSIGNED length = obj->Length(); if (obj->IsByteObject()) { if (length >= requiredSize) { // Free and large enough PolyWord *next = pt+requiredSize+1; POLYUNSIGNED spare = length - requiredSize; #ifdef POLYML32IN64 // Maintain alignment. if (((requiredSize + 1) & 1) && spare != 0) { *next++ = PolyWord::FromUnsigned(0); spare--; } #endif if (spare != 0) FillUnusedSpace(next, spare); space->isMutable = true; // Set this - it ensures the area is scanned on GC. space->headerMap.SetBit(pt-space->bottom); // Set the "header" bit // Set the length word of the code area and copy the byte cell in. // The code bit must be set before the lock is released to ensure // another thread doesn't reuse this. obj->SetLengthWord(requiredSize, F_CODE_OBJ|F_MUTABLE_BIT); return obj; } else if (length >= actualLargest) actualLargest = length+1; } pt += length+1; } // Reached the end without finding what we wanted. Update the largest size. space->largestFree = actualLargest; } i++; // Next area } else { // Allocate a new area and add it at the end of the table. uintptr_t spaceSize = requiredSize + 1; #ifdef POLYML32IN64 // We need to allow for the extra alignment word otherwise we // may allocate less than we need. spaceSize += 1; #endif CodeSpace *allocSpace = NewCodeSpace(spaceSize); if (allocSpace == 0) return 0; // Try a GC. globalStats.incSize(PSS_CODE_SPACE, allocSpace->spaceSize() * sizeof(PolyWord)); } } } // Remove code areas that are completely empty. This is probably better than waiting to reuse them. // It's particularly important if we reload a saved state because the code areas for old saved states // are made into local code areas just in case they are currently in use or reachable. void MemMgr::RemoveEmptyCodeAreas() { for (std::vector::iterator i = cSpaces.begin(); i != cSpaces.end(); ) { CodeSpace *space = *i; PolyObject *start = (PolyObject *)(space->bottom+1); if (start->IsByteObject() && start->Length() == space->spaceSize()-1) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Deleted code space %p at %p size %zu\n", space, space->bottom, space->spaceSize()); globalStats.decSize(PSS_CODE_SPACE, space->spaceSize() * sizeof(PolyWord)); // We have an empty cell that fills the whole space. RemoveTree(space); delete(space); i = cSpaces.erase(i); } else i++; } } // Add a code space to the tables. Used both for newly compiled code and also demoted saved spaces. bool MemMgr::AddCodeSpace(CodeSpace *space) { try { AddTree(space); cSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); return false; } return true; } // Check that we have sufficient space for an allocation to succeed. // Called from the GC to ensure that we will not get into an infinite // loop trying to allocate, failing and garbage-collecting again. bool MemMgr::CheckForAllocation(uintptr_t words) { uintptr_t allocated = 0; return AllocHeapSpace(words, allocated, false) != 0; } // Adjust the allocation area by removing free areas so that the total // size of the allocation area is less than the required value. This // is used after the quick GC and also if we need to allocate a large // object. void MemMgr::RemoveExcessAllocation(uintptr_t words) { // First remove any non-standard allocation areas. for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end();) { LocalMemSpace *space = *i; if (space->allocationSpace && space->isEmpty() && space->spaceSize() != defaultSpaceSize) DeleteLocalSpace(i); else i++; } for (std::vector::iterator i = lSpaces.begin(); currentAllocSpace > words && i < lSpaces.end(); ) { LocalMemSpace *space = *i; if (space->allocationSpace && space->isEmpty()) DeleteLocalSpace(i); else i++; } } // Return number of words free in all allocation spaces. uintptr_t MemMgr::GetFreeAllocSpace() { uintptr_t freeSpace = 0; PLocker lock(&allocLock); for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { LocalMemSpace *space = *i; if (space->allocationSpace) freeSpace += space->freeSpace(); } return freeSpace; } StackSpace *MemMgr::NewStackSpace(uintptr_t size) { PLocker lock(&stackSpaceLock); try { StackSpace *space = new StackSpace(&osStackAlloc); size_t iSpace = size*sizeof(PolyWord); space->bottom = (PolyWord*)osStackAlloc.AllocateDataArea(iSpace); if (space->bottom == 0) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New stack space: insufficient space\n"); delete space; return 0; } // The size may have been rounded up to a block boundary. size = iSpace/sizeof(PolyWord); space->top = space->bottom + size; space->spaceType = ST_STACK; space->isMutable = true; // Add the stack space to the tree. This ensures that operations such as // LocalSpaceForAddress will work for addresses within the stack. We can // get them in the RTS with functions such as quot_rem and exception stack. // It's not clear whether they really appear in the GC. try { AddTree(space); sSpaces.push_back(space); } catch (std::exception&) { RemoveTree(space); delete space; return 0; } if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New stack space %p allocated at %p size %lu\n", space, space->bottom, space->spaceSize()); globalStats.incSize(PSS_STACK_SPACE, space->spaceSize() * sizeof(PolyWord)); return space; } catch (std::bad_alloc&) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: New stack space: \"new\" failed\n"); return 0; } } // If checkmem is given write protect the immutable areas except during a GC. void MemMgr::ProtectImmutable(bool on) { if (debugOptions & DEBUG_CHECK_OBJECTS) { for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { LocalMemSpace *space = *i; if (!space->isMutable) { if (!space->isCode) osHeapAlloc.EnableWrite(!on, space->bottom, (char*)space->top - (char*)space->bottom); } } } } bool MemMgr::GrowOrShrinkStack(TaskData *taskData, uintptr_t newSize) { StackSpace *space = taskData->stack; size_t iSpace = newSize*sizeof(PolyWord); PolyWord *newSpace = (PolyWord*)osStackAlloc.AllocateDataArea(iSpace); if (newSpace == 0) { if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Unable to change size of stack %p from %lu to %lu: insufficient space\n", space, space->spaceSize(), newSize); return false; } // The size may have been rounded up to a block boundary. newSize = iSpace/sizeof(PolyWord); try { AddTree(space, newSpace, newSpace+newSize); } catch (std::bad_alloc&) { RemoveTree(space, newSpace, newSpace+newSize); delete space; return 0; } taskData->CopyStackFrame(space->stack(), space->spaceSize(), (StackObject*)newSpace, newSize); if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Size of stack %p changed from %lu to %lu at %p\n", space, space->spaceSize(), newSize, newSpace); globalStats.incSize(PSS_STACK_SPACE, (newSize - space->spaceSize()) * sizeof(PolyWord)); RemoveTree(space); // Remove it BEFORE freeing the space - another thread may allocate it PolyWord *oldBottom = space->bottom; size_t oldSize = (char*)space->top - (char*)space->bottom; space->bottom = newSpace; // Switch this before freeing - We could get a profile trap during the free space->top = newSpace+newSize; osStackAlloc.FreeDataArea(oldBottom, oldSize); return true; } // Delete a stack when a thread has finished. // This can be called by an ML thread so needs an interlock. bool MemMgr::DeleteStackSpace(StackSpace *space) { PLocker lock(&stackSpaceLock); for (std::vector::iterator i = sSpaces.begin(); i < sSpaces.end(); i++) { if (*i == space) { globalStats.decSize(PSS_STACK_SPACE, space->spaceSize() * sizeof(PolyWord)); RemoveTree(space); delete space; sSpaces.erase(i); if (debugOptions & DEBUG_MEMMGR) Log("MMGR: Deleted stack space %p at %p size %zu\n", space, space->bottom, space->spaceSize()); return true; } } ASSERT(false); // It should always be in the table. return false; } SpaceTreeTree::SpaceTreeTree(): SpaceTree(false) { for (unsigned i = 0; i < 256; i++) tree[i] = 0; } SpaceTreeTree::~SpaceTreeTree() { for (unsigned i = 0; i < 256; i++) { if (tree[i] && ! tree[i]->isSpace) delete(tree[i]); } } // Add and remove entries in the space tree. void MemMgr::AddTree(MemSpace *space, PolyWord *startS, PolyWord *endS) { // It isn't clear we need to lock here but it's probably sensible. PLocker lock(&spaceTreeLock); AddTreeRange(&spaceTree, space, (uintptr_t)startS, (uintptr_t)endS); } void MemMgr::RemoveTree(MemSpace *space, PolyWord *startS, PolyWord *endS) { PLocker lock(&spaceTreeLock); RemoveTreeRange(&spaceTree, space, (uintptr_t)startS, (uintptr_t)endS); } void MemMgr::AddTreeRange(SpaceTree **tt, MemSpace *space, uintptr_t startS, uintptr_t endS) { if (*tt == 0) *tt = new SpaceTreeTree; ASSERT(! (*tt)->isSpace); SpaceTreeTree *t = (SpaceTreeTree*)*tt; const unsigned shift = (sizeof(void*)-1) * 8; // Takes the high-order byte uintptr_t r = startS >> shift; ASSERT(r < 256); const uintptr_t s = endS == 0 ? 256 : endS >> shift; ASSERT(s >= r && s <= 256); if (r == s) // Wholly within this entry AddTreeRange(&(t->tree[r]), space, startS << 8, endS << 8); else { // Deal with any remainder at the start. if ((r << shift) != startS) { AddTreeRange(&(t->tree[r]), space, startS << 8, 0 /*End of range*/); r++; } // Whole entries. while (r < s) { ASSERT(t->tree[r] == 0); t->tree[r] = space; r++; } // Remainder at the end. if ((s << shift) != endS) AddTreeRange(&(t->tree[r]), space, 0, endS << 8); } } // Remove an entry from the tree for a range. Strictly speaking we don't need the // space argument here but it's useful as a check. // This may be called to remove a partially installed structure if we have // run out of space in AddTreeRange. void MemMgr::RemoveTreeRange(SpaceTree **tt, MemSpace *space, uintptr_t startS, uintptr_t endS) { SpaceTreeTree *t = (SpaceTreeTree*)*tt; if (t == 0) return; // This can only occur if we're recovering. ASSERT(! t->isSpace); const unsigned shift = (sizeof(void*)-1) * 8; uintptr_t r = startS >> shift; const uintptr_t s = endS == 0 ? 256 : endS >> shift; if (r == s) RemoveTreeRange(&(t->tree[r]), space, startS << 8, endS << 8); else { // Deal with any remainder at the start. if ((r << shift) != startS) { RemoveTreeRange(&(t->tree[r]), space, startS << 8, 0); r++; } // Whole entries. while (r < s) { ASSERT(t->tree[r] == space || t->tree[r] == 0 /* Recovery only */); t->tree[r] = 0; r++; } // Remainder at the end. if ((s << shift) != endS) RemoveTreeRange(&(t->tree[r]), space, 0, endS << 8); } // See if the whole vector is now empty. for (unsigned j = 0; j < 256; j++) { if (t->tree[j]) return; // It's not empty - we're done. } delete(t); *tt = 0; } uintptr_t MemMgr::AllocatedInAlloc() { uintptr_t inAlloc = 0; for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { LocalMemSpace *sp = *i; if (sp->allocationSpace) inAlloc += sp->allocatedSpace(); } return inAlloc; } // Report heap sizes and occupancy before and after GC void MemMgr::ReportHeapSizes(const char *phase) { uintptr_t alloc = 0, nonAlloc = 0, inAlloc = 0, inNonAlloc = 0; for (std::vector::iterator i = lSpaces.begin(); i < lSpaces.end(); i++) { LocalMemSpace *sp = *i; if (sp->allocationSpace) { alloc += sp->spaceSize(); inAlloc += sp->allocatedSpace(); } else { nonAlloc += sp->spaceSize(); inNonAlloc += sp->allocatedSpace(); } } Log("Heap: %s Major heap used ", phase); LogSize(inNonAlloc); Log(" of "); LogSize(nonAlloc); Log(" (%1.0f%%). Alloc space used ", (float)inNonAlloc / (float)nonAlloc * 100.0F); LogSize(inAlloc); Log(" of "); LogSize(alloc); Log(" (%1.0f%%). Total space ", (float)inAlloc / (float)alloc * 100.0F); LogSize(spaceForHeap); Log(" %1.0f%% full.\n", (float)(inAlloc + inNonAlloc) / (float)spaceForHeap * 100.0F); Log("Heap: Local spaces %" PRI_SIZET ", permanent spaces %" PRI_SIZET ", code spaces %" PRI_SIZET ", stack spaces %" PRI_SIZET "\n", lSpaces.size(), pSpaces.size(), cSpaces.size(), sSpaces.size()); uintptr_t cTotal = 0, cOccupied = 0; for (std::vector::iterator c = cSpaces.begin(); c != cSpaces.end(); c++) { cTotal += (*c)->spaceSize(); PolyWord *pt = (*c)->bottom; while (pt < (*c)->top) { pt++; PolyObject *obj = (PolyObject*)pt; if (obj->ContainsForwardingPtr()) { #ifdef POLYML32IN64 // This is relative to globalCodeBase not globalHeapBase while (obj->ContainsForwardingPtr()) obj = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); #else obj = obj->FollowForwardingChain(); #endif pt += obj->Length(); } else { if (obj->IsCodeObject()) cOccupied += obj->Length() + 1; pt += obj->Length(); } } } Log("Heap: Code area: total "); LogSize(cTotal); Log(" occupied: "); LogSize(cOccupied); Log("\n"); uintptr_t stackSpace = 0; for (std::vector::iterator s = sSpaces.begin(); s != sSpaces.end(); s++) { stackSpace += (*s)->spaceSize(); } Log("Heap: Stack area: total "); LogSize(stackSpace); Log("\n"); } // Profiling - Find a code object or return zero if not found. // This can be called on a "user" thread. PolyObject *MemMgr::FindCodeObject(const byte *addr) { MemSpace *space = SpaceForAddress(addr); if (space == 0) return 0; Bitmap *profMap = 0; if (! space->isCode) return 0; if (space->spaceType == ST_CODE) { CodeSpace *cSpace = (CodeSpace*)space; profMap = &cSpace->headerMap; } else if (space->spaceType == ST_PERMANENT) { PermanentMemSpace *pSpace = (PermanentMemSpace*)space; profMap = &pSpace->profileCode; } else return 0; // Must be in code or permanent code. // For the permanent areas the header maps are created and initialised on demand. if (! profMap->Created()) { PLocker lock(&codeBitmapLock); if (! profMap->Created()) // Second check now we've got the lock. { // Create the bitmap. If it failed just say "not in this area" if (! profMap->Create(space->spaceSize())) return 0; // Set the first bit before releasing the lock. profMap->SetBit(0); } } // A bit is set if it is a length word. while ((uintptr_t)addr & (sizeof(POLYUNSIGNED)-1)) addr--; // Make it word aligned PolyWord *wordAddr = (PolyWord*)addr; // Work back to find the first set bit before this. // Normally we will find one but if we're looking up a value that // is actually an integer it might be in a piece of code that is now free. uintptr_t bitOffset = profMap->FindLastSet(wordAddr - space->bottom); if (space->spaceType == ST_CODE) { PolyWord *ptr = space->bottom+bitOffset; if (ptr >= space->top) return 0; // This will find the last non-free code cell or the first cell. // Return zero if the value was not actually in the cell or it wasn't code. PolyObject *obj = (PolyObject*)(ptr+1); #ifdef POLYML32IN64 PolyObject *lastObj = obj; // This is relative to globalCodeBase not globalHeapBase. while (lastObj->ContainsForwardingPtr()) lastObj = (PolyObject*)(globalCodeBase + ((lastObj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); #else PolyObject *lastObj = obj->FollowForwardingChain(); #endif // We normally replace forwarding pointers but when scanning to update // addresses after a saved state we may not have yet done that. if (wordAddr > ptr && wordAddr < ptr + 1 + lastObj->Length() && lastObj->IsCodeObject()) return obj; else return 0; } // Permanent area - the bits are set on demand. // Now work forward, setting any bits if necessary. We don't need a lock // because this is monotonic. for (;;) { PolyWord *ptr = space->bottom+bitOffset; if (ptr >= space->top) return 0; PolyObject *obj = (PolyObject*)(ptr+1); ASSERT(obj->ContainsNormalLengthWord()); if (wordAddr > ptr && wordAddr < ptr + obj->Length()) return obj; bitOffset += obj->Length()+1; profMap->SetBit(bitOffset); } return 0; } // Remove profiling bitmaps from permanent areas to free up memory. void MemMgr::RemoveProfilingBitmaps() { for (std::vector::iterator i = pSpaces.begin(); i < pSpaces.end(); i++) (*i)->profileCode.Destroy(); } #ifdef POLYML32IN64DEBUG POLYOBJECTPTR PolyWord::AddressToObjectPtr(void *address) { ASSERT(address >= globalHeapBase); uintptr_t offset = (PolyWord*)address - globalHeapBase; ASSERT(offset <= 0x7fffffff); // Currently limited to 8Gbytes ASSERT((offset & 1) == 0); return (POLYOBJECTPTR)offset; } #endif MemMgr gMem; // The one and only memory manager object diff --git a/libpolyml/osmem.cpp b/libpolyml/osmem.cpp index 5bedb29e..827d8d46 100644 --- a/libpolyml/osmem.cpp +++ b/libpolyml/osmem.cpp @@ -1,457 +1,467 @@ /* Title: osomem.cpp - Interface to OS memory management Copyright (c) 2006, 2017-18, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_MMAN_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "osmem.h" #include "bitmap.h" #include "locking.h" // Linux prefers MAP_ANONYMOUS to MAP_ANON #ifndef MAP_ANON #ifdef MAP_ANONYMOUS #define MAP_ANON MAP_ANONYMOUS #endif #endif #ifdef POLYML32IN64 bool OSMem::Initialise(bool requiresExecute, size_t space /* = 0 */, void **pBase /* = 0 */) { + needExecute = requiresExecute; pageSize = PageSize(); memBase = (char*)ReserveHeap(space); if (memBase == 0) return 0; if (pBase != 0) *pBase = memBase; // Create a bitmap with a bit for each page. if (!pageMap.Create(space / pageSize)) return false; lastAllocated = space / pageSize; // Beyond the last page in the area // Set the last bit in the area so that we don't use it. // This is effectively a work-around for a problem with the heap. // If we have a zero-sized cell at the end of the memory its address is // going to be zero. This causes problems with forwarding pointers. // There may be better ways of doing this. pageMap.SetBit(space / pageSize - 1); return true; } void *OSMem::AllocateDataArea(size_t& space) { char *baseAddr; { PLocker l(&bitmapLock); uintptr_t pages = (space + pageSize - 1) / pageSize; // Round up to an integral number of pages. space = pages * pageSize; // Find some space while (pageMap.TestBit(lastAllocated - 1)) // Skip the wholly allocated area. lastAllocated--; uintptr_t free = pageMap.FindFree(0, lastAllocated, pages); if (free == lastAllocated) return 0; // Can't find the space. pageMap.SetBits(free, pages); // TODO: Do we need to zero this? It may have previously been set. baseAddr = memBase + free * pageSize; } return CommitPages(baseAddr, space, false); } bool OSMem::FreeDataArea(void *p, size_t space) { char *addr = (char*)p; uintptr_t offset = (addr - memBase) / pageSize; if (!UncommitPages(p, space)) return false; uintptr_t pages = space / pageSize; { PLocker l(&bitmapLock); pageMap.ClearBits(offset, pages); if (offset + pages > lastAllocated) // We allocate from the top down. lastAllocated = offset + pages; } return true; } void * OSMem::AllocateCodeArea(size_t& space, void*& shadowArea) { char* baseAddr; { PLocker l(&bitmapLock); uintptr_t pages = (space + pageSize - 1) / pageSize; // Round up to an integral number of pages. space = pages * pageSize; // Find some space while (pageMap.TestBit(lastAllocated - 1)) // Skip the wholly allocated area. lastAllocated--; uintptr_t free = pageMap.FindFree(0, lastAllocated, pages); if (free == lastAllocated) return 0; // Can't find the space. pageMap.SetBits(free, pages); // TODO: Do we need to zero this? It may have previously been set. baseAddr = memBase + free * pageSize; } - void *dataArea = CommitPages(baseAddr, space, true); + void *dataArea = CommitPages(baseAddr, space, needExecute); shadowArea = dataArea; return dataArea; } bool OSMem::FreeCodeArea(void* codeAddr, void* dataAddr, size_t space) { ASSERT(codeAddr == dataAddr); char* addr = (char*)codeAddr; uintptr_t offset = (addr - memBase) / pageSize; if (!UncommitPages(codeAddr, space)) return false; uintptr_t pages = space / pageSize; { PLocker l(&bitmapLock); pageMap.ClearBits(offset, pages); if (offset + pages > lastAllocated) // We allocate from the top down. lastAllocated = offset + pages; } return true; } #endif #if (defined(HAVE_MMAP) && defined(MAP_ANON)) // We don't use autoconf's test for mmap here because that tests for // file mapping. Instead the test simply tests for the presence of an mmap // function. // We also insist that the OS supports MAP_ANON or MAP_ANONYMOUS. Older // versions of Solaris required the use of /dev/zero instead. We don't // support that. #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif // How do we get the page size? #ifndef HAVE_GETPAGESIZE #ifdef _SC_PAGESIZE #define getpagesize() sysconf(_SC_PAGESIZE) #else // If this fails we're stuck #define getpagesize() PAGESIZE #endif #endif #ifdef SOLARIS #define FIXTYPE (caddr_t) #else #define FIXTYPE #endif #ifdef POLYML32IN64 // Unix-specific implementation of the subsidiary functions. size_t OSMem::PageSize() { return getpagesize(); } void *OSMem::ReserveHeap(size_t space) { return mmap(0, space, PROT_NONE, MAP_PRIVATE | MAP_ANON, -1, 0); } bool OSMem::UnreserveHeap(void *p, size_t space) { return munmap(FIXTYPE p, space) == 0; } void *OSMem::CommitPages(void *baseAddr, size_t space, bool allowExecute) { - if (mmap(baseAddr, space, allowExecute ? PROT_READ|PROT_WRITE|PROT_EXEC : PROT_READ|PROT_WRITE, - MAP_FIXED|MAP_PRIVATE|MAP_ANON, -1, 0) == MAP_FAILED) + int prot = PROT_READ | PROT_WRITE; + if (allowExecute) prot |= PROT_EXEC; + if (mmap(baseAddr, space, prot, MAP_FIXED|MAP_PRIVATE|MAP_ANON, -1, 0) == MAP_FAILED) return 0; msync(baseAddr, space, MS_SYNC|MS_INVALIDATE); return baseAddr; } bool OSMem::UncommitPages(void *p, size_t space) { // Remap the pages as new entries. This should remove the old versions. if (mmap(p, space, PROT_NONE, MAP_FIXED|MAP_PRIVATE|MAP_ANON, -1, 0) == MAP_FAILED) return false; msync(p, space, MS_SYNC|MS_INVALIDATE); return true; } bool OSMem::EnableWrite(bool enable, void* p, size_t space) { int res = mprotect(FIXTYPE p, space, enable ? PROT_READ|PROT_WRITE: PROT_READ); return res != -1; } bool OSMem::DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space) { - int res = mprotect(FIXTYPE codeAddr, space, PROT_READ|PROT_EXEC); + int prot = PROT_READ; + if (needExecute) prot |= PROT_EXEC; + int res = mprotect(FIXTYPE codeAddr, space, prot); return res != -1; } #else bool OSMem::Initialise(bool requiresExecute, size_t space /* = 0 */, void **pBase /* = 0 */) { + needExecute = requiresExecute; pageSize = getpagesize(); return true; } // Allocate space and return a pointer to it. The size is the minimum // size requested and it is updated with the actual space allocated. // Returns NULL if it cannot allocate the space. void *OSMem::AllocateDataArea(size_t &space) { // Round up to an integral number of pages. space = (space + pageSize-1) & ~(pageSize-1); int fd = -1; // This value is required by FreeBSD. Linux doesn't care void *result = mmap(0, space, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANON, fd, 0); // Convert MAP_FAILED (-1) into NULL if (result == MAP_FAILED) return 0; return result; } // Release the space previously allocated. This must free the whole of // the segment. The space must be the size actually allocated. bool OSMem::FreeDataArea(void *p, size_t space) { return munmap(FIXTYPE p, space) == 0; } bool OSMem::EnableWrite(bool enable, void* p, size_t space) { int res = mprotect(FIXTYPE p, space, enable ? PROT_READ|PROT_WRITE: PROT_READ); return res != -1; } void *OSMem::AllocateCodeArea(size_t &space, void*& shadowArea) { // Round up to an integral number of pages. space = (space + pageSize-1) & ~(pageSize-1); int fd = -1; // This value is required by FreeBSD. Linux doesn't care - void *result = mmap(0, space, PROT_READ|PROT_WRITE|PROT_EXEC, MAP_PRIVATE|MAP_ANON, fd, 0); + int prot = PROT_READ | PROT_WRITE; + if (needExecute) prot |= PROT_EXEC; + void *result = mmap(0, space, prot, MAP_PRIVATE|MAP_ANON, fd, 0); // Convert MAP_FAILED (-1) into NULL if (result == MAP_FAILED) return 0; shadowArea = result; return result; } bool OSMem::FreeCodeArea(void *codeArea, void *dataArea, size_t space) { ASSERT(codeArea == dataArea); return munmap(FIXTYPE codeArea, space) == 0; } bool OSMem::DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space) { - int res = mprotect(FIXTYPE codeAddr, space, PROT_READ|PROT_EXEC); + int prot = PROT_READ; + if (needExecute) prot |= PROT_EXEC; + int res = mprotect(FIXTYPE codeAddr, space, prot); return res != -1; } #endif #elif defined(_WIN32) // Use Windows memory management. #include #ifdef POLYML32IN64 // Windows-specific implementations of the subsidiary functions. size_t OSMem::PageSize() { // Get the page size and round up to that multiple. SYSTEM_INFO sysInfo; GetSystemInfo(&sysInfo); // Get the page size. Put it in a size_t variable otherwise the rounding // up of "space" may go wrong on 64-bits. return sysInfo.dwPageSize; } void *OSMem::ReserveHeap(size_t space) { void *memBase = VirtualAlloc(0, space, MEM_RESERVE, PAGE_NOACCESS); if (memBase == 0) return 0; // We need the heap to be such that the top 32-bits are non-zero. if ((uintptr_t)memBase >= ((uintptr_t)1 << 32)) return memBase; // Allocate again. void *newSpace = ReserveHeap(space); UnreserveHeap(memBase, space); // Free the old area that isn't suitable. // Return what we got, or zero if it failed. return newSpace; } bool OSMem::UnreserveHeap(void *p, size_t space) { return VirtualFree(p, 0, MEM_RELEASE) == TRUE; } void *OSMem::CommitPages(void *baseAddr, size_t space, bool allowExecute) { return VirtualAlloc(baseAddr, space, MEM_COMMIT, allowExecute ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE); } bool OSMem::UncommitPages(void *baseAddr, size_t space) { return VirtualFree(baseAddr, space, MEM_DECOMMIT) == TRUE; } bool OSMem::EnableWrite(bool enable, void* p, size_t space) { DWORD oldProtect; return VirtualProtect(p, space, enable ? PAGE_READWRITE : PAGE_READONLY, &oldProtect) == TRUE; } bool OSMem::DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space) { ASSERT(codeAddr == dataAddr); DWORD oldProtect; - return VirtualProtect(codeAddr, space, PAGE_EXECUTE_READ, &oldProtect) == TRUE; + return VirtualProtect(codeAddr, space, needExecute ? PAGE_EXECUTE_READ : PAGE_READONLY, &oldProtect) == TRUE; } #else bool OSMem::Initialise(bool requiresExecute, size_t space /* = 0 */, void **pBase /* = 0 */) { + needExecute = requiresExecute; // Get the page size and round up to that multiple. SYSTEM_INFO sysInfo; GetSystemInfo(&sysInfo); // Get the page size. Put it in a size_t variable otherwise the rounding // up of "space" may go wrong on 64-bits. pageSize = sysInfo.dwPageSize; return true; } // Allocate space and return a pointer to it. The size is the minimum // size requested and it is updated with the actual space allocated. // Returns NULL if it cannot allocate the space. void *OSMem::AllocateDataArea(size_t &space) { space = (space + pageSize - 1) & ~(pageSize - 1); DWORD options = MEM_RESERVE | MEM_COMMIT; return VirtualAlloc(0, space, options, PAGE_READWRITE); } // Release the space previously allocated. This must free the whole of // the segment. The space must be the size actually allocated. bool OSMem::FreeDataArea(void *p, size_t space) { return VirtualFree(p, 0, MEM_RELEASE) == TRUE; } // Adjust the permissions on a segment. This must apply to the // whole of a segment. bool OSMem::EnableWrite(bool enable, void* p, size_t space) { DWORD oldProtect; return VirtualProtect(p, space, enable ? PAGE_READWRITE: PAGE_READONLY, &oldProtect) == TRUE; } void* OSMem::AllocateCodeArea(size_t& space, void*& shadowArea) { space = (space + pageSize - 1) & ~(pageSize - 1); DWORD options = MEM_RESERVE | MEM_COMMIT; - void * dataAddr = VirtualAlloc(0, space, options, PAGE_EXECUTE_READWRITE); + void * dataAddr = VirtualAlloc(0, space, options, needExecute ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE); shadowArea = dataAddr; return dataAddr; } bool OSMem::FreeCodeArea(void* codeAddr, void* dataAddr, size_t space) { ASSERT(codeAddr == dataAddr); return VirtualFree(codeAddr, 0, MEM_RELEASE) == TRUE; } bool OSMem::DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space) { ASSERT(codeAddr == dataAddr); DWORD oldProtect; - return VirtualProtect(codeAddr, space, PAGE_EXECUTE_READ, &oldProtect) == TRUE; + return VirtualProtect(codeAddr, space, needExecute ? PAGE_EXECUTE_READ : PAGE_READONLY, &oldProtect) == TRUE; } #endif #else #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef POLYML32IN64 #error "32 bit in 64-bits requires either mmap or VirtualAlloc" #endif // Use calloc to allocate the memory. Using calloc ensures the memory is // zeroed and is compatible with the other allocators. void *OSMem::Allocate(size_t &bytes, unsigned permissions) { return calloc(bytes, 1); } bool OSMem::Free(void *p, size_t/*space*/) { free(p); return true; } // We can't do this if we don't have mprotect. bool OSMem::SetPermissions(void *p, size_t space, unsigned permissions) { return true; // Let's hope this is all right. } #endif diff --git a/libpolyml/osmem.h b/libpolyml/osmem.h index 636b5c51..b5a32231 100644 --- a/libpolyml/osmem.h +++ b/libpolyml/osmem.h @@ -1,95 +1,96 @@ /* Title: osomem.h - Interface to OS memory management Copyright (c) 2006, 2017-18, 2020 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifndef OS_MEM_H_INCLUDED #define OS_MEM_H_INCLUDED // We need size_t so include these two here. #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef POLYML32IN64 #include "bitmap.h" #include "locking.h" #endif // This class provides access to the memory management provided by the // operating system. It would be nice if we could always use malloc and // free for this but we need to have execute permission on the code // objects. class OSMem { public: OSMem() {} ~OSMem() {} bool Initialise(bool requiresExecute, size_t space = 0, void** pBase = 0); // Allocate space and return a pointer to it. The size is the minimum // size requested in bytes and it is updated with the actual space allocated. // Returns NULL if it cannot allocate the space. void *AllocateDataArea(size_t& bytes); // Release the space previously allocated. This must free the whole of // the segment. The space must be the size actually allocated. bool FreeDataArea(void* p, size_t space); // Enable/disable writing. This must apply to the whole of a segment. // Only for data areas. bool EnableWrite(bool enable, void* p, size_t space); // Allocate code area. Some systems will not allow both write and execute permissions // on the same page. On those systems we have to allocate two regions of shared memory, // one with read+execute permission and the other with read+write. void *AllocateCodeArea(size_t& bytes, void*& shadowArea); // Free the allocated areas. bool FreeCodeArea(void* codeAddr, void* dataAddr, size_t space); // Remove write access. This is used after the permanent code area has been created // either from importing a portable export file or copying the area in 32-in-64. bool DisableWriteForCode(void* codeAddr, void* dataAddr, size_t space); protected: size_t pageSize; + bool needExecute; #ifdef POLYML32IN64 size_t PageSize(); void* ReserveHeap(size_t space); bool UnreserveHeap(void* baseAddr, size_t space); void* CommitPages(void* baseAddr, size_t space, bool allowExecute); bool UncommitPages(void* baseAddr, size_t space); Bitmap pageMap; uintptr_t lastAllocated; char* memBase; PLock bitmapLock; #endif }; #endif