diff --git a/libpolyml/arm64.cpp b/libpolyml/arm64.cpp index 30414887..9c59b393 100644 --- a/libpolyml/arm64.cpp +++ b/libpolyml/arm64.cpp @@ -1,825 +1,821 @@ /* Machine-dependent code for ARM64 Copyright David C.J. Matthews 2020-21. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ // Currently this is just copied from the interpreted version. #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif #include "globals.h" #include "machine_dep.h" #include "sys.h" #include "profiling.h" #include "arb.h" #include "processes.h" #include "run_time.h" #include "gc.h" #include "diagnostics.h" #include "polystring.h" #include "save_vec.h" #include "memmgr.h" #include "scanaddrs.h" #include "rtsentry.h" #include "bytecode.h" #include "int_opcodes.h" /* * ARM64 register use: * X0 First argument and return value * X1-X7 Second-eighth argument * X8 Indirect result (C), ML closure pointer on entry * X9-X15 Volatile scratch registers * X16-17 Intra-procedure-call (C). Only used for special cases in ML. * X18 Platform register. Not used in ML. * X19-X24 Non-volatile (C). Scratch registers (ML). * X25 ML Heap limit pointer * X26 ML assembly interface pointer. Non-volatile (C). * X27 ML Heap allocation pointer. Non-volatile (C). * X28 ML Stack pointer. Non-volatile (C). * X29 Frame pointer (C). Not used in ML * X30 Link register. Not used in ML. * X31 Stack pointer (C). Not used in ML. Also zero register. * * Floating point registers: * V0 First argument and return value * V1-V7 Second-eighth argument * V8-V15 Non volatile. Not currently used in ML. * V16-V31 Volatile. Not currently used in ML. * * The ML calling conventions generally follow the C ABI except that * all registers are volatile and X28 is used for the stack. */ /* the amount of ML stack space to reserve for registers, C exception handling etc. The compiler requires us to reserve 2 stack-frames worth (2 * 20 words). We actually reserve slightly more than this. */ // Arm64 instructions are all 32-bit values. typedef uint32_t* arm64CodePointer; #define OVERFLOW_STACK_SIZE 50 // X26 always points at this area when executing ML code. // The offsets are built into the assembly code and some are built into // the code generator so this must not be changed without checking these. typedef struct _AssemblyArgs { public: byte* enterInterpreter; // These are filled in with the functions. byte* heapOverFlowCall; byte* stackOverFlowCall; byte* stackOverFlowCallEx; byte* trapHandlerEntry; stackItem* handlerRegister; // Current exception handler stackItem* stackLimit; // Lower limit of stack stackItem exceptionPacket; // Set if there is an exception PolyWord threadId; // My thread id. Saves having to call into RTS for it. stackItem registers[25]; // Save/load area for registers X0-X25 inclusive double fpRegisters[8]; // Save/load area for floating point regs D0-D7 PolyWord* localMbottom; // Base of memory + 1 word PolyWord* localMpointer; // X27 Allocation ptr + 1 word stackItem* stackPtr; // X28 Current stack pointer arm64CodePointer linkRegister; // X30 - Link register (return address) arm64CodePointer entryPoint; // PC address to return to byte returnReason; // Reason for returning from ML - Set by assembly code. } AssemblyArgs; class Arm64TaskData: public TaskData, ByteCodeInterpreter { public: Arm64TaskData(); ~Arm64TaskData() {} unsigned allocReg; // The register to take the allocated space. POLYUNSIGNED allocWords; // The words to allocate. AssemblyArgs assemblyInterface; uint32_t saveRegisterMask; // Registers that need to be updated by a GC. virtual void GarbageCollect(ScanAddress *process); void ScanStackAddress(ScanAddress *process, stackItem& val, StackSpace *stack); virtual void EnterPolyCode(); // Start running ML virtual void SetException(poly_exn *exc) { assemblyInterface.exceptionPacket = (PolyWord)exc; } virtual void InterruptCode(); // AddTimeProfileCount is used in time profiling. virtual bool AddTimeProfileCount(SIGNALCONTEXT *context); virtual void InitStackFrame(TaskData *newTask, Handle proc); // Atomic exchange-and-add. Used in the process module to release a mutex and in the // interpreter. It needs to use the same instruction that compiled code uses. virtual POLYSIGNED AtomicExchAdd(PolyObject* mutexp, POLYSIGNED incr); // Set a mutex to zero. virtual void AtomicReset(PolyObject* mutexp); // Return the minimum space occupied by the stack. Used when setting a limit. // N.B. This is PolyWords not native words. virtual uintptr_t currentStackSpace(void) const { return (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE; } virtual void addProfileCount(POLYUNSIGNED words) { addSynchronousCount(interpreterPc, words); } virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length); //void HeapOverflowTrap(); void SetMemRegisters(); void SaveMemRegisters(); void HandleTrap(); // ByteCode overrides. The interpreter and native code states need to be in sync. // The interpreter is only used during the initial bootstrap. virtual void ClearExceptionPacket() { assemblyInterface.exceptionPacket = TAGGED(0); } virtual PolyWord GetExceptionPacket() { return assemblyInterface.exceptionPacket; } virtual stackItem* GetHandlerRegister() { return assemblyInterface.handlerRegister; } virtual void SetHandlerRegister(stackItem* hr) { assemblyInterface.handlerRegister = hr; } void Interpret(); void EndBootStrap() { mixedCode = true; } PLock interruptLock; virtual void HandleStackOverflow(uintptr_t space); }; class Arm64Dependent : public MachineDependent { public: Arm64Dependent() : mustInterpret(false) {} // Create a task data object. virtual TaskData* CreateTaskData(void) { return new Arm64TaskData(); } virtual Architectures MachineArchitecture(void); virtual void SetBootArchitecture(char arch, unsigned wordLength); // The ARM has separate instruction and data caches. virtual void FlushInstructionCache(void* p, POLYUNSIGNED bytes); // During the first bootstrap phase this is interpreted. bool mustInterpret; }; static Arm64Dependent arm64Dependent; MachineDependent* machineDependent = &arm64Dependent; Architectures Arm64Dependent::MachineArchitecture(void) { // During the first phase of the bootstrap we // compile the interpreted version. if (mustInterpret) return MA_Interpreted; return MA_Arm64; } // Values for the returnReason byte enum RETURN_REASON { RETURN_HEAP_OVERFLOW = 1, RETURN_STACK_OVERFLOW = 2, RETURN_STACK_OVERFLOWEX = 3, RETURN_ENTER_INTERPRETER = 4 }; extern "C" { // These are declared in the assembly code segment. void Arm64AsmEnterCompiledCode(void*); int Arm64AsmCallExtraRETURN_ENTER_INTERPRETER(void); int Arm64AsmCallExtraRETURN_HEAP_OVERFLOW(void); int Arm64AsmCallExtraRETURN_STACK_OVERFLOW(void); int Arm64AsmCallExtraRETURN_STACK_OVERFLOWEX(void); // This is declared here and called from the assembly code. // It avoids having a call to an external in the assembly code // which sometimes gives problems with position-indepent code. void Arm64TrapHandler(PolyWord threadId); }; Arm64TaskData::Arm64TaskData() : ByteCodeInterpreter(&assemblyInterface.stackPtr, &assemblyInterface.stackLimit), allocReg(0), allocWords(0), saveRegisterMask(0) { assemblyInterface.enterInterpreter = (byte*)Arm64AsmCallExtraRETURN_ENTER_INTERPRETER; assemblyInterface.heapOverFlowCall = (byte*)Arm64AsmCallExtraRETURN_HEAP_OVERFLOW; assemblyInterface.stackOverFlowCall = (byte*)Arm64AsmCallExtraRETURN_STACK_OVERFLOW; assemblyInterface.stackOverFlowCallEx = (byte*)Arm64AsmCallExtraRETURN_STACK_OVERFLOWEX; assemblyInterface.trapHandlerEntry = (byte*)Arm64TrapHandler; interpreterPc = 0; mixedCode = !arm64Dependent.mustInterpret; } void Arm64Dependent::SetBootArchitecture(char arch, unsigned wordLength) { if (arch == 'I') mustInterpret = true; else if (arch != 'A') Crash("Boot file has unexpected architecture code: %c", arch); } // The ARM has separate instruction and data caches so we must flush // the cache when creating or modifying code. void Arm64Dependent::FlushInstructionCache(void* p, POLYUNSIGNED bytes) { #ifdef _WIN32 ::FlushInstructionCache(GetCurrentProcess(), p, bytes); #elif defined (__GNUC__) __builtin___clear_cache(p, (char*)p + bytes); #elif (defined (__clang__) && defined (__APPLE__)) sys_icache_invalidate(p, bytes); #else #error "No code to flush the instruction cache." #endif } void Arm64TaskData::GarbageCollect(ScanAddress *process) { TaskData::GarbageCollect(process); ByteCodeInterpreter::GarbageCollect(process); if (assemblyInterface.exceptionPacket.w().IsDataPtr()) { PolyObject* obj = assemblyInterface.exceptionPacket.w().AsObjPtr(); obj = process->ScanObjectAddress(obj); assemblyInterface.exceptionPacket = (PolyWord)obj; } if (stack != 0) { stackItem*stackPtr = assemblyInterface.stackPtr; // Now the values on the stack. for (stackItem* q = stackPtr; q < (stackItem*)stack->top; q++) ScanStackAddress(process, *q, stack); } } // Process a value within the stack. void Arm64TaskData::ScanStackAddress(ScanAddress *process, stackItem& stackItem, StackSpace *stack) { // We may have return addresses on the stack which could look like // tagged values. Check whether the value is in the code area before // checking whether it is untagged. #ifdef POLYML32IN64 // In 32-in-64 return addresses always have the top 32 bits non-zero. if (stackItem.argValue < ((uintptr_t)1 << 32)) { // It's either a tagged integer or an object pointer. if (stackItem.w().IsDataPtr()) { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } } else { // Could be a code address or a stack address. MemSpace* space = gMem.SpaceForAddress(stackItem.codeAddr - 1); if (space == 0 || space->spaceType != ST_CODE) return; PolyObject* obj = gMem.FindCodeObject(stackItem.codeAddr); ASSERT(obj != 0); // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } #else // The -1 here is because we may have a zero-sized cell in the last // word of a space. MemSpace* space = gMem.SpaceForAddress(stackItem.codeAddr - 1); if (space == 0) return; // In particular we may have one of the assembly code addresses. if (space->spaceType == ST_CODE) { PolyObject* obj = gMem.FindCodeObject(stackItem.codeAddr); // If it is actually an integer it might be outside a valid code object. if (obj == 0) { ASSERT(stackItem.w().IsTagged()); // It must be an integer } else // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } else if (space->spaceType == ST_LOCAL && stackItem.w().IsDataPtr()) // Local values must be word addresses. { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } #endif } // Copy a stack void Arm64TaskData::CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) { #ifdef POLYML32IN64 old_length = old_length / 2; new_length = new_length / 2; #endif /* Moves a stack, updating all references within the stack */ stackItem*old_base = (stackItem*)old_stack; stackItem*new_base = (stackItem*)new_stack; stackItem*old_top = old_base + old_length; /* Calculate the offset of the new stack from the old. If the frame is being extended objects in the new frame will be further up the stack than in the old one. */ uintptr_t offset = new_base - old_base + new_length - old_length; stackItem *oldSp = assemblyInterface.stackPtr; assemblyInterface.stackPtr = oldSp + offset; assemblyInterface.handlerRegister = assemblyInterface.handlerRegister + offset; /* Skip the unused part of the stack. */ uintptr_t i = oldSp - old_base; ASSERT(i <= old_length); i = old_length - i; stackItem *old = oldSp; stackItem *newp = assemblyInterface.stackPtr; while (i--) { stackItem old_word = *old++; if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) old_word.stackAddr = old_word.stackAddr + offset; else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) { stackItem* addr = (stackItem*)old_word.w().AsStackAddr(); if (addr >= old_base && addr <= old_top) { addr += offset; old_word = PolyWord::FromStackAddr((PolyWord*)addr); } } *newp++ = old_word; } ASSERT(old == ((stackItem*)old_stack) + old_length); ASSERT(newp == ((stackItem*)new_stack) + new_length); } void Arm64TaskData::EnterPolyCode() /* Called from "main" to enter the code. */ { assemblyInterface.stackLimit = (stackItem*)((PolyWord*)this->stack->stack() + OVERFLOW_STACK_SIZE); if (arm64Dependent.mustInterpret) { PolyWord closure = assemblyInterface.registers[8]; *(--assemblyInterface.stackPtr) = closure; /* Closure address */ interpreterPc = *(POLYCODEPTR*)closure.AsObjPtr(); Interpret(); ASSERT(0); // Should never return } SetMemRegisters(); // Jump into the ML code. This code sets up the registers and puts the // address of the assemblyInterface into X26 Arm64AsmEnterCompiledCode(&assemblyInterface); // This should never return ASSERT(0); } void Arm64TaskData::Interpret() { while (true) { switch (RunInterpreter(this)) { case ReturnCall: // After the call there will be an enter-int instruction so that when this // returns we will re-enter the interpreter. The number of arguments for // this call is after that. while ((uintptr_t)interpreterPc & 3) { ASSERT(interpreterPc[0] == INSTR_no_op); interpreterPc++; } ASSERT(interpreterPc[0] == 0xe9); numTailArguments = interpreterPc[12]; case ReturnTailCall: { ClearExceptionPacket(); // Pop the closure. PolyWord closureWord = *assemblyInterface.stackPtr++; PolyObject* closure = closureWord.AsObjPtr(); arm64CodePointer cp = *(arm64CodePointer*)closure; if (cp[0] == 0xAA1E03E9 && cp[1] == 0xF9400350 && cp[2] == 0xD63F0200) { // If the code we're going to is interpreted push back the closure and // continue. interpreterPc = (POLYCODEPTR)cp; assemblyInterface.stackPtr--; HandleStackOverflow(128); // Make sure we have space since we're bypassing the check. continue; } assemblyInterface.registers[8] = closureWord; // Put closure in the closure reg. // Pop the return address. We may need to align this to a word boundary. POLYCODEPTR originalReturn = (POLYCODEPTR)((assemblyInterface.stackPtr++)->codeAddr); while ((uintptr_t)originalReturn & 3) { ASSERT(originalReturn[0] == INSTR_no_op); originalReturn++; } // Get the arguments into the correct registers. // Load the register arguments. The first 8 arguments go into X0-X7. // These will have been the first arguments to be pushed so will be // furthest away on the stack. // Note: we don't currently pass any arguments in the FP regs. for (unsigned i = 0; i < numTailArguments && i < 8; i++) assemblyInterface.registers[i] = assemblyInterface.stackPtr[numTailArguments - i - 1]; // If there are any more arguments these need to be shifted down the stack. while (numTailArguments > 8) { numTailArguments--; assemblyInterface.stackPtr[numTailArguments] = assemblyInterface.stackPtr[numTailArguments - 8]; } // Remove the register arguments assemblyInterface.stackPtr += numTailArguments > 8 ? 8 : numTailArguments; assemblyInterface.linkRegister = (arm64CodePointer)originalReturn; // Set the return address to caller assemblyInterface.entryPoint = *(arm64CodePointer*)closure; // Entry point to callee interpreterPc = 0; // No longer in the interpreter (See SaveMemRegs) return; } case ReturnReturn: { ClearExceptionPacket(); // Returning from an interpreted function. Normally we'll be returning to // interpreted code. if ((uintptr_t)interpreterPc & 3) // ARM64 addresses will always be 4-byte aligned. continue; arm64CodePointer cp = (arm64CodePointer)interpreterPc; if (cp[0] == 0xAA1E03E9 && cp[1] == 0xF9400350 && cp[2] == 0xD63F0200) continue; // Pop the value we're returning. Set the entry point to the code we're returning to. assemblyInterface.registers[0] = *assemblyInterface.stackPtr++; assemblyInterface.entryPoint = cp; interpreterPc = 0; // No longer in the interpreter (See SaveMemRegs) return; } } } } // Called from the assembly code as a result of a trap i.e. a request for // a GC or to extend the stack. void Arm64TrapHandler(PolyWord threadId) { Arm64TaskData* taskData = (Arm64TaskData*)TaskData::FindTaskForId(threadId); taskData->HandleTrap(); } void Arm64TaskData::HandleTrap() { SaveMemRegisters(); // Update globals from the memory registers. switch (this->assemblyInterface.returnReason) { case RETURN_HEAP_OVERFLOW: // The heap has overflowed. // The register mask is the word after the return. saveRegisterMask = *assemblyInterface.entryPoint++; ASSERT(0); // TODO //HeapOverflowTrap(); // Computes a value for allocWords only break; case RETURN_STACK_OVERFLOW: case RETURN_STACK_OVERFLOWEX: { // The register mask is the word after the return. saveRegisterMask = *assemblyInterface.entryPoint++; ASSERT(0); // TODO uintptr_t min_size = 0; // Size in PolyWords #if (0) if (assemblyInterface.returnReason == RETURN_STACK_OVERFLOW) { min_size = (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } else { // Stack limit overflow. If the required stack space is larger than // the fixed overflow size the code will calculate the limit in %EDI. stackItem* stackP = regDI().stackAddr; min_size = (this->stack->top - (PolyWord*)stackP) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } #endif HandleStackOverflow(min_size); break; } case RETURN_ENTER_INTERPRETER: { interpreterPc = (POLYCODEPTR)assemblyInterface.linkRegister; byte reasonCode = *interpreterPc++; // Sort out arguments. assemblyInterface.exceptionPacket = TAGGED(0); if (reasonCode == 0xff) { // Exception handler. - ASSERT(0); // Not used assemblyInterface.exceptionPacket = assemblyInterface.registers[0]; // Get the exception packet - // We're already in the exception handler but we still have to - // adjust the stack pointer and pop the current exception handler. - assemblyInterface.stackPtr = assemblyInterface.handlerRegister; - assemblyInterface.stackPtr++; - assemblyInterface.handlerRegister = (assemblyInterface.stackPtr++)[0].stackAddr; + // We need to leave the current handler in place. When we enter the interpreter it will + // check the exception packet and if it is non-null will raise it. } else if (reasonCode >= 128) { // Start of function. unsigned numArgs = reasonCode - 128; // We need the stack to contain: // The closure, the return address, the arguments. // The stack will currently contain the stack arguments. // Add space for the register arguments if (numArgs > 8) assemblyInterface.stackPtr -= 8; else assemblyInterface.stackPtr -= numArgs; // Move up any stack arguments. for (unsigned n = numArgs; n > 8; n--) { assemblyInterface.stackPtr[n - 8 - 1] = assemblyInterface.stackPtr[n - 1]; } // Store the register arguments for (unsigned n = 0; n < numArgs && n < 8; n++) assemblyInterface.stackPtr[numArgs - n - 1] = assemblyInterface.registers[n]; // Finally push the return address and closure pointer *(--assemblyInterface.stackPtr) = assemblyInterface.registers[9]; // Return address - value of X30 before enter-int *(--assemblyInterface.stackPtr) = assemblyInterface.registers[8]; // Closure } else { // Return from call. Push X0 *(--assemblyInterface.stackPtr) = assemblyInterface.registers[0]; } Interpret(); break; } default: Crash("Unknown return reason code %u", this->assemblyInterface.returnReason); } SetMemRegisters(); } void Arm64TaskData::HandleStackOverflow(uintptr_t space) { uintptr_t min_size = (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE + space; try { // The stack check has failed. This may either be because we really have // overflowed the stack or because the stack limit value has been adjusted // to result in a call here. CheckAndGrowStack(this, min_size); } catch (IOException&) { // We may get an exception while handling this if we run out of store } { PLocker l(&interruptLock); // Set the stack limit. This clears any interrupt and also sets the // correct value if we've grown the stack. assemblyInterface.stackLimit = (stackItem*)stack->bottom + OVERFLOW_STACK_SIZE; } try { processes->ProcessAsynchRequests(this); // Release and re-acquire use of the ML memory to allow another thread // to GC. processes->ThreadReleaseMLMemory(this); processes->ThreadUseMLMemory(this); } catch (IOException&) { } } void Arm64TaskData::InitStackFrame(TaskData* parentTask, Handle proc) /* Initialise stack frame. */ { StackSpace* space = this->stack; StackObject* stack = (StackObject*)space->stack(); uintptr_t stack_size = space->spaceSize() * sizeof(PolyWord) / sizeof(stackItem); assemblyInterface.stackPtr = (stackItem*)stack + stack_size; assemblyInterface.stackLimit = (stackItem*)space->bottom + OVERFLOW_STACK_SIZE; assemblyInterface.handlerRegister = assemblyInterface.stackPtr; // Store the argument and the closure. assemblyInterface.registers[8] = proc->Word(); // Closure assemblyInterface.registers[0] = TAGGED(0); // Argument assemblyInterface.linkRegister = 0; // We never return // Have to set the register mask in case we get a GC before the thread starts. saveRegisterMask = (1 << 8) | 1; // X8 and X0 } // This is called from a different thread so we have to be careful. void Arm64TaskData::InterruptCode() { PLocker l(&interruptLock); // Set the stack limit pointer to the top of the stack to cause // a trap when we next check for stack overflow. // We use a lock here to ensure that we always use the current value of the // stack. The thread we're interrupting could be growing the stack at this point. if (stack != 0) assemblyInterface.stackLimit = (stackItem*)(stack->top - 1); } // Called before entering ML code from the run-time system void Arm64TaskData::SetMemRegisters() { // Copy the current store limits into variables before we go into the assembly code. // If we haven't yet set the allocation area or we don't have enough we need // to create one (or a new one). if (allocPointer <= allocLimit + allocWords) { if (allocPointer < allocLimit) Crash("Bad length in heap overflow trap"); // Find some space to allocate in. Updates taskData->allocPointer and // returns a pointer to the newly allocated space (if allocWords != 0) PolyWord* space = processes->FindAllocationSpace(this, allocWords, true); if (space == 0) { // We will now raise an exception instead of returning. // Set allocWords to zero so we don't set the allocation register // since that could be holding the exception packet. allocWords = 0; } // Undo the allocation just now. allocPointer += allocWords; } if (this->allocWords != 0) { // If we have had a heap trap we actually do the allocation here. // We will have already garbage collected and recovered sufficient space. // This also happens if we have just trapped because of store profiling. allocPointer -= allocWords; // Now allocate // Set the allocation register to this area. N.B. This is an absolute address. #if (0) if (this->allocReg < 15) get_reg(this->allocReg)[0].codeAddr = (POLYCODEPTR)(this->allocPointer + 1); /* remember: it's off-by-one */ #endif allocWords = 0; } // If we have run out of store, either just above or while allocating in the RTS, // allocPointer and allocLimit will have been set to zero as part of the GC. We will // now be raising an exception which may free some store but we need to come back here // before we allocate anything. The compiled code uses unsigned arithmetic to check for // heap overflow but only after subtracting the space required. We need to make sure // that the values are still non-negative after substracting any object size. if (allocPointer == 0) allocPointer += MAX_OBJECT_SIZE; if (allocLimit == 0) allocLimit += MAX_OBJECT_SIZE; assemblyInterface.localMbottom = allocLimit + 1; assemblyInterface.localMpointer = allocPointer + 1; // If we are profiling store allocation we set mem_hl so that a trap // will be generated. if (profileMode == kProfileStoreAllocation) assemblyInterface.localMbottom = assemblyInterface.localMpointer; assemblyInterface.threadId = threadObject; } // This is called whenever we have returned from ML to C. void Arm64TaskData::SaveMemRegisters() { // The normal return is to the link register address. assemblyInterface.entryPoint = assemblyInterface.linkRegister; if (interpreterPc == 0) // Not if we're already in the interpreter allocPointer = assemblyInterface.localMpointer - 1; allocWords = 0; assemblyInterface.exceptionPacket = TAGGED(0); saveRegisterMask = 0; } // As far as possible we want locking and unlocking an ML mutex to be fast so // we try to implement the code in the assembly code using appropriate // interlocked instructions. That does mean that if we need to lock and // unlock an ML mutex in this code we have to use the same, machine-dependent, // code to do it. These are defaults that are used where there is no // machine-specific code. #if defined(_MSC_VER) // This saves having to define it in the MASM assembly code. static POLYSIGNED Arm64AsmAtomicExchangeAndAdd(PolyObject* mutexp, POLYSIGNED addend) { # if (SIZEOF_POLYWORD == 8) return InterlockedExchangeAdd64((LONG64*)mutexp, addend); # else return InterlockedExchangeAdd((LONG*)mutexp, addend); # endif } #else extern "C" { // This is only defined in the GAS assembly code POLYSIGNED Arm64AsmAtomicExchangeAndAdd(PolyObject*, POLYSIGNED); } #endif // Do the exchange-and-add POLYSIGNED Arm64TaskData::AtomicExchAdd(PolyObject* mutexp, POLYSIGNED incr) { return Arm64AsmAtomicExchangeAndAdd(mutexp, incr - TAGGED(0).AsSigned()/* Remove the tag */); } // Release a mutex. Because the atomic increment and decrement // use the hardware atomic load-and-add we can simply set this to zero. void Arm64TaskData::AtomicReset(PolyObject* mutexp) { mutexp->Set(0, TAGGED(0)); // Set this to released. } bool Arm64TaskData::AddTimeProfileCount(SIGNALCONTEXT *context) { if (interpreterPc != 0) { // See if the PC we've got is an ML code address. MemSpace *space = gMem.SpaceForAddress(interpreterPc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { incrementCountAsynch(interpreterPc); return true; } } return false; } extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedEnterIntMode(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyEndBootstrapMode(FirstArgument threadId, PolyWord function); } // Do we require EnterInt instructions and if so for which architecture? // 0 = > None; 1 => X86_32, 2 => X86_64. 3 => X86_32_in_64. 4 => ARM_64. POLYUNSIGNED PolyInterpretedEnterIntMode() { return TAGGED(4).AsUnsigned(); } // End the first stage of bootstrap mode and run a new function. // The first stage is always interpreted. Once that is complete every function will have // at least an executable "enter-interpreter" stub so it can be called as machine code. POLYUNSIGNED PolyEndBootstrapMode(FirstArgument threadId, PolyWord function) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle pushedFunction = taskData->saveVec.push(function); arm64Dependent.mustInterpret = false; ((Arm64TaskData*)taskData)->EndBootStrap(); taskData->InitStackFrame(taskData, pushedFunction); taskData->EnterPolyCode(); // Should never return. ASSERT(0); return TAGGED(0).AsUnsigned(); } // No machine-specific calls in the interpreter. struct _entrypts machineSpecificEPT[] = { { "PolyInterpretedEnterIntMode", (polyRTSFunction)&PolyInterpretedEnterIntMode }, { "PolyEndBootstrapMode", (polyRTSFunction)&PolyEndBootstrapMode }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/bytecode.cpp b/libpolyml/bytecode.cpp index 1ef21126..b7ad73a5 100644 --- a/libpolyml/bytecode.cpp +++ b/libpolyml/bytecode.cpp @@ -1,2615 +1,2631 @@ /* Title: An interpreter for a compact instruction set. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited Further development Copyright David C.J. Matthews 2015-18, 2020-21. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STRING_H #include #endif /* #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_MATH_H #include #endif */ #include // Currently just for isnan. #include "globals.h" #include "int_opcodes.h" #include "sys.h" #include "profiling.h" #include "arb.h" #include "reals.h" #include "run_time.h" #include "gc.h" #include "diagnostics.h" #include "polystring.h" #include "scanaddrs.h" #include "rtsentry.h" #include "bytecode.h" #if (SIZEOF_VOIDP == 8 && !defined(POLYML32IN64)) #define IS64BITS 1 #endif #define arg1 (pc[0] + pc[1]*256) #define arg2 (pc[2] + pc[3]*256) const PolyWord True = TAGGED(1); const PolyWord False = TAGGED(0); const PolyWord Zero = TAGGED(0); // This duplicates some code in reals.cpp but is now updated. #define DOUBLESIZE (sizeof(double)/sizeof(POLYUNSIGNED)) union realdb { double dble; POLYUNSIGNED puns[DOUBLESIZE]; }; #define LGWORDSIZE (sizeof(uintptr_t) / sizeof(PolyWord)) // We're using float for Real32 so it needs to be 32-bits. // Assume that's true for the moment. #if (SIZEOF_FLOAT != 4) #error "Float is not 32-bits. Please report this" #endif union flt { float fl; int32_t i; }; ByteCodeInterpreter::ByteCodeInterpreter(stackItem** spAddr, stackItem** slAddr) : mixedCode(false), stackPointerAddress(spAddr), stackLimitAddress(slAddr), overflowPacket(0), dividePacket(0) { #ifdef PROFILEOPCODES memset(frequency, 0, sizeof(frequency)); memset(arg1Value, 0, sizeof(arg1Value)); memset(arg2Value, 0, sizeof(arg2Value)); #endif } ByteCodeInterpreter::~ByteCodeInterpreter() { #ifdef PROFILEOPCODES OutputDebugStringA("Frequency\n"); for (unsigned i = 0; i < 256; i++) { if (frequency[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, frequency[i]); OutputDebugStringA(buffer); } } OutputDebugStringA("Arg1\n"); for (unsigned i = 0; i < 256; i++) { if (arg1Value[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, arg1Value[i]); OutputDebugStringA(buffer); } } OutputDebugStringA("Arg2\n"); for (unsigned i = 0; i < 256; i++) { if (arg2Value[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, arg2Value[i]); OutputDebugStringA(buffer); } } #endif } extern "C" { typedef POLYUNSIGNED(*callFastRts0)(); typedef POLYUNSIGNED(*callFastRts1)(intptr_t); typedef POLYUNSIGNED(*callFastRts2)(intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts3)(intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts4)(intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts5)(intptr_t, intptr_t, intptr_t, intptr_t, intptr_t); typedef double (*callRTSRtoR) (double); typedef double (*callRTSRRtoR) (double, double); typedef double (*callRTSGtoR) (intptr_t); typedef double (*callRTSRGtoR) (double, intptr_t); typedef float(*callRTSFtoF) (float); typedef float(*callRTSFFtoF) (float, float); typedef float(*callRTSGtoF) (intptr_t); typedef float(*callRTSFGtoF) (float, intptr_t); } // Allocate memory on the heap. Returns with the address of the cell. Does not set the // length word or any of the data. PolyObject* ByteCodeInterpreter::allocateMemory(TaskData * taskData, POLYUNSIGNED words, POLYCODEPTR& pc, stackItem*& sp) { words++; // Add the size of the length word. // N.B. The allocation area may be empty so that both of these are zero. if (taskData->allocPointer >= taskData->allocLimit + words + 1) { #ifdef POLYML32IN64 if (words & 1) words++; #endif taskData->allocPointer -= words; return (PolyObject*)(taskData->allocPointer + 1); } // Insufficient space. SaveInterpreterState(pc, sp); // Find some space to allocate in. Returns a pointer to the newly allocated space. // N.B. This may return zero if the heap is exhausted and it has set this // up for an exception. Generally it allocates by decrementing allocPointer // but if the required memory is large it may allocate in a separate area. PolyWord* space = processes->FindAllocationSpace(taskData, words, true); LoadInterpreterState(pc, sp); if (space == 0) return 0; return (PolyObject*)(space + 1); } // Put a real result in a "box" PolyObject* ByteCodeInterpreter::boxDouble(TaskData* taskData, double d, POLYCODEPTR& pc, stackItem*& sp) { PolyObject* mem = this->allocateMemory(taskData, DOUBLESIZE, pc, sp); if (mem == 0) return 0; mem->SetLengthWord(DOUBLESIZE, F_BYTE_OBJ); union realdb uniondb; uniondb.dble = d; // Copy the words. Depending on the word length this may copy one or more words. for (unsigned i = 0; i < DOUBLESIZE; i++) mem->Set(i, PolyWord::FromUnsigned(uniondb.puns[i])); return mem; } // Extract a double value from a box. double ByteCodeInterpreter::unboxDouble(PolyWord p) { union realdb uniondb; for (unsigned i = 0; i < DOUBLESIZE; i++) uniondb.puns[i] = p.AsObjPtr()->Get(i).AsUnsigned(); return uniondb.dble; } // Largely copied from reals.cpp #if (SIZEOF_FLOAT < SIZEOF_POLYWORD) // Typically for 64-bit mode. Use a tagged representation. // The code-generator on the X86/64 assumes the float is in the // high order word. #define FLT_SHIFT ((SIZEOF_POLYWORD-SIZEOF_FLOAT)*8) float ByteCodeInterpreter::unboxFloat(PolyWord p) { union flt argx; argx.i = p.AsSigned() >> FLT_SHIFT; return argx.fl; } PolyObject* ByteCodeInterpreter::boxFloat(TaskData* taskData, float f, POLYCODEPTR& pc, stackItem*& sp) { union flt argx; argx.fl = f; PolyWord p = PolyWord::FromSigned(((POLYSIGNED)argx.i << FLT_SHIFT) + 1); return p.AsObjPtr(); // Temporarily cast it to this even though it isn't really } #else // Typically for 32-bit mode. Use a boxed representation. PolyObject* ByteCodeInterpreter::boxFloat(TaskData* taskData, float f, POLYCODEPTR& pc, stackItem*& sp) { PolyObject* mem = this->allocateMemory(taskData, 1, pc, sp); if (mem == 0) return 0; mem->SetLengthWord(1, F_BYTE_OBJ); union flt argx; argx.fl = f; mem->Set(0, PolyWord::FromSigned(argx.i)); return mem; } // Extract a double value from a box. float ByteCodeInterpreter::unboxFloat(PolyWord p) { union flt argx; argx.i = (int32_t)p.AsObjPtr()->Get(0).AsSigned(); return argx.fl; } #endif enum ByteCodeInterpreter::_returnValue ByteCodeInterpreter::RunInterpreter(TaskData *taskData) /* (Re)-enter the Poly code from C. */ { // Make packets for exceptions. if (overflowPacket == 0) overflowPacket = makeExceptionPacket(taskData, EXC_overflow); if (dividePacket == 0) dividePacket = makeExceptionPacket(taskData, EXC_divide); // Local values. These are copies of member variables but are used so frequently that // it is important that access should be fast. POLYCODEPTR pc; stackItem*sp; LoadInterpreterState(pc, sp); // We may have taken an interrupt which has set an exception. if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; for(;;){ /* Each instruction */ #if (0) char buff[1000]; sprintf(buff, "addr = %p sp=%p instr=%02x *sp=%p\n", pc, sp, *pc, (*sp).stackAddr); OutputDebugStringA(buff); #endif // These are temporary values used where one instruction jumps to // common code. POLYUNSIGNED tailCount; stackItem* tailPtr; POLYUNSIGNED returnCount; POLYUNSIGNED storeWords; POLYUNSIGNED stackCheck; PolyObject *closure; double dv; #ifdef PROFILEOPCODES frequency[*pc]++; #endif switch(*pc++) { case INSTR_jump8false: { PolyWord u = *sp++; if (u == True) pc += 1; else pc += *pc + 1; break; } case INSTR_jump8: pc += *pc + 1; break; case INSTR_jump8True: { PolyWord u = *sp++; if (u == False) pc += 1; else pc += *pc + 1; break; } case INSTR_jump16True: // Invert the sense of the test and fall through. *sp = ((*sp).w() == True) ? False : True; case INSTR_jump16false: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 2; break; } /* else - false - take the jump */ } case INSTR_jump16: pc += arg1 + 2; break; case INSTR_push_handler: /* Save the old handler value. */ (*(--sp)).stackAddr = GetHandlerRegister(); /* Push old handler */ break; case INSTR_setHandler8: /* Set up a handler */ - (*(--sp)).codeAddr = pc + *pc + 1; /* Address of handler */ + { + POLYCODEPTR entry = pc + *pc + 1; // Address of handler + // This needs to be aligned for the ARM. This is only during development. + while (((uintptr_t)entry & 3) && entry[0] == INSTR_no_op) + entry++; + (--sp)->codeAddr = entry; SetHandlerRegister(sp); pc += 1; break; + } case INSTR_setHandler16: /* Set up a handler */ - (*(--sp)).codeAddr = pc + arg1 + 2; /* Address of handler */ + { + POLYCODEPTR entry = pc + arg1 + 2; + // This needs to be aligned for the ARM. This is only during development. + while (((uintptr_t)entry & 3) && entry[0] == INSTR_no_op) + entry++; + (--sp)->codeAddr = entry; SetHandlerRegister(sp); pc += 2; break; + } case INSTR_deleteHandler: /* Delete handler retaining the result. */ { stackItem u = *sp++; sp = GetHandlerRegister(); sp++; // Remove handler entry point SetHandlerRegister((*sp).stackAddr); // Restore old handler *sp = u; // Put back the result break; } case INSTR_case16: { // arg1 is the largest value that is in the range POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ if (u >= arg1 || u < 0) pc += 2 + arg1*2; /* Out of range */ else { pc += 2; pc += /* Index */pc[u*2]+pc[u*2 + 1]*256; } break; } case INSTR_tail_b_b: tailCount = *pc; tailPtr = sp + tailCount; sp = tailPtr + pc[1]; TAIL_CALL: /* For general case. */ if (tailCount < 2) Crash("Invalid argument\n"); numTailArguments = (unsigned)(tailCount - 2); for (; tailCount > 0; tailCount--) *(--sp) = *(--tailPtr); pc = (*sp++).codeAddr; /* Pop the original return address. */ closure = (*sp++).w().AsObjPtr(); if (mixedCode) { // Return to the caller in case the function we're calling is machine code. // The number of arguments we're passing is given in the tail-count. There's // no enter-int after this because we're not coming back. (--sp)->codeAddr = pc; *(--sp) = (PolyWord)closure; SaveInterpreterState(pc, sp); return ReturnTailCall; } goto CALL_CLOSURE; /* And drop through. */ case INSTR_call_closure: /* Closure call. */ { closure = (*sp++).w().AsObjPtr(); CALL_CLOSURE: (--sp)->codeAddr = pc; /* Save return address. */ *(--sp) = (PolyWord)closure; if (mixedCode) { SaveInterpreterState(pc, sp); return ReturnCall; // Caller must look at enter-int to determine number of args } pc = *(POLYCODEPTR*)closure; /* Get entry point. */ SaveInterpreterState(pc, sp); // Update in case we're profiling // Check that there at least 128 words on the stack stackCheck = 128; goto STACKCHECK; } case INSTR_callConstAddr8: closure = (*(PolyWord*)(pc + pc[0] + 1)).AsObjPtr(); pc += 1; goto CALL_CLOSURE; case INSTR_callConstAddr16: closure = (*(PolyWord*)(pc + arg1 + 2)).AsObjPtr(); pc += 2; goto CALL_CLOSURE; case INSTR_callConstAddr8_8: closure = ((PolyWord*)(pc + pc[0] + 2))[pc[1] + 3].AsObjPtr(); pc += 2; goto CALL_CLOSURE; case INSTR_callConstAddr8_0: closure = ((PolyWord*)(pc + pc[0] + 1))[3].AsObjPtr(); pc += 1; goto CALL_CLOSURE; case INSTR_callConstAddr8_1: closure = ((PolyWord*)(pc + pc[0] + 1))[4].AsObjPtr(); pc += 1; goto CALL_CLOSURE; case INSTR_callConstAddr16_8: closure = ((PolyWord*)(pc + arg1 + 3))[pc[2] + 3].AsObjPtr(); pc += 3; goto CALL_CLOSURE; case INSTR_callLocalB: { closure = (sp[*pc++]).w().AsObjPtr(); goto CALL_CLOSURE; } case INSTR_return_w: returnCount = arg1; /* Get no. of args to remove. */ RETURN: /* Common code for return. */ { stackItem result = *sp++; /* Result */ sp++; /* Remove the link/closure */ pc = (*sp++).codeAddr; /* Return address */ sp += returnCount; /* Add on number of args. */ *(--sp) = result; /* Result */ SaveInterpreterState(pc, sp); // Update in case we're profiling or if returning if (mixedCode) return ReturnReturn; } break; case INSTR_return_b: returnCount = *pc; goto RETURN; case INSTR_return_1: returnCount = 1; goto RETURN; case INSTR_return_2: returnCount = 2; goto RETURN; case INSTR_return_3: returnCount = 3; goto RETURN; case INSTR_stackSize16: { stackCheck = arg1; pc += 2; STACKCHECK: // Check stack space. This is combined with interrupts on the native code version. if (sp - stackCheck < *stackLimitAddress) { SaveInterpreterState(pc, sp); HandleStackOverflow(stackCheck); LoadInterpreterState(pc, sp); } break; } case INSTR_raise_ex: { { PolyException *exn = (PolyException*)((*sp).w().AsObjPtr()); taskData->SetException(exn); } RAISE_EXCEPTION: sp = GetHandlerRegister(); pc = (*sp++).codeAddr; // It is possible we could raise an exception to be // handled by native code but that does not currently happen // during the bootstrap. SetHandlerRegister((*sp++).stackAddr); break; } case INSTR_tuple_2: storeWords = 2; goto TUPLE; case INSTR_tuple_3: storeWords = 3; goto TUPLE; case INSTR_tuple_4: storeWords = 4; goto TUPLE; case INSTR_tuple_b: storeWords = *pc; pc++; goto TUPLE; case INSTR_closureB: storeWords = *pc++; goto CREATE_CLOSURE; break; case INSTR_local_w: { stackItem u = sp[arg1]; *(--sp) = u; pc += 2; break; } case INSTR_constAddr8: *(--sp) = *(PolyWord*)(pc + pc[0] + 1); pc += 1; break; case INSTR_constAddr16: *(--sp) = *(PolyWord*)(pc + arg1 + 2); pc += 2; break; case INSTR_constAddr8_8: *(--sp) = ((PolyWord*)(pc + pc[0]+ 2))[pc[1] + 3]; pc += 2; break; case INSTR_constAddr8_0: *(--sp) = ((PolyWord*)(pc + pc[0] + 1))[3]; pc += 1; break; case INSTR_constAddr8_1: *(--sp) = ((PolyWord*)(pc + pc[0] + 1))[4]; pc += 1; break; case INSTR_constAddr16_8: *(--sp) = ((PolyWord*)(pc + arg1 + 3))[pc[2] + 3]; pc += 3; break; case INSTR_const_int_w: *(--sp) = TAGGED(arg1); pc += 2; break; case INSTR_jump_back8: pc -= *pc + 1; // Check for interrupt in case we're in a loop if (sp < *stackLimitAddress) { SaveInterpreterState(pc, sp); HandleStackOverflow(0); LoadInterpreterState(pc, sp); } break; case INSTR_jump_back16: pc -= arg1 + 1; // Check for interrupt in case we're in a loop if (sp < *stackLimitAddress) { SaveInterpreterState(pc, sp); HandleStackOverflow(0); LoadInterpreterState(pc, sp); } break; case INSTR_lock: { PolyObject *obj = (*sp).w().AsObjPtr(); obj->SetLengthWord(obj->LengthWord() & ~_OBJ_MUTABLE_BIT); break; } case INSTR_ldexc: *(--sp) = GetExceptionPacket(); break; case INSTR_local_b: { stackItem u = sp[*pc]; *(--sp) = u; pc += 1; break; } case INSTR_indirect_b: *sp = (*sp).w().AsObjPtr()->Get(*pc); pc += 1; break; case INSTR_indirectLocalBB: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(*pc++); break; } case INSTR_indirectLocalB0: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(0); break; } case INSTR_indirect0Local0: { PolyWord u = sp[0]; *(--sp) = u.AsObjPtr()->Get(0); break; } case INSTR_indirectLocalB1: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(1); break; } case INSTR_moveToContainerB: { PolyWord u = *sp++; (*sp).stackAddr[*pc] = u; pc += 1; break; } case INSTR_moveToMutClosureB: { PolyWord u = *sp++; (*sp).w().AsObjPtr()->Set(*pc++ + sizeof(uintptr_t) / sizeof(PolyWord), u); break; } case INSTR_indirectContainerB: *sp = (*sp).stackAddr[*pc]; pc += 1; break; case INSTR_indirectClosureBB: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(*pc++ + sizeof(uintptr_t) / sizeof(PolyWord)); break; } case INSTR_indirectClosureB0: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord)); break; } case INSTR_indirectClosureB1: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord) + 1); break; } case INSTR_indirectClosureB2: { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord) + 2); break; } case INSTR_set_stack_val_b: { PolyWord u = *sp++; sp[*pc-1] = u; pc += 1; break; } case INSTR_reset_b: sp += *pc; pc += 1; break; case INSTR_reset_r_b: { PolyWord u = *sp; sp += *pc; *sp = u; pc += 1; break; } case INSTR_const_int_b: *(--sp) = TAGGED(*pc); pc += 1; break; case INSTR_local_0: { stackItem u = sp[0]; *(--sp) = u; break; } case INSTR_local_1: { stackItem u = sp[1]; *(--sp) = u; break; } case INSTR_local_2: { stackItem u = sp[2]; *(--sp) = u; break; } case INSTR_local_3: { stackItem u = sp[3]; *(--sp) = u; break; } case INSTR_local_4: { stackItem u = sp[4]; *(--sp) = u; break; } case INSTR_local_5: { stackItem u = sp[5]; *(--sp) = u; break; } case INSTR_local_6: { stackItem u = sp[6]; *(--sp) = u; break; } case INSTR_local_7: { stackItem u = sp[7]; *(--sp) = u; break; } case INSTR_local_8: { stackItem u = sp[8]; *(--sp) = u; break; } case INSTR_local_9: { stackItem u = sp[9]; *(--sp) = u; break; } case INSTR_local_10: { stackItem u = sp[10]; *(--sp) = u; break; } case INSTR_local_11: { stackItem u = sp[11]; *(--sp) = u; break; } case INSTR_local_12: { stackItem u = sp[12]; *(--sp) = u; break; } case INSTR_local_13: { stackItem u = sp[13]; *(--sp) = u; break; } case INSTR_local_14: { stackItem u = sp[14]; *(--sp) = u; break; } case INSTR_local_15: { stackItem u = sp[15]; *(--sp) = u; break; } case INSTR_indirect_0: *sp = (*sp).w().AsObjPtr()->Get(0); break; case INSTR_indirect_1: *sp = (*sp).w().AsObjPtr()->Get(1); break; case INSTR_indirect_2: *sp = (*sp).w().AsObjPtr()->Get(2); break; case INSTR_indirect_3: *sp = (*sp).w().AsObjPtr()->Get(3); break; case INSTR_indirect_4: *sp = (*sp).w().AsObjPtr()->Get(4); break; case INSTR_indirect_5: *sp = (*sp).w().AsObjPtr()->Get(5); break; case INSTR_const_0: *(--sp) = Zero; break; case INSTR_const_1: *(--sp) = TAGGED(1); break; case INSTR_const_2: *(--sp) = TAGGED(2); break; case INSTR_const_3: *(--sp) = TAGGED(3); break; case INSTR_const_4: *(--sp) = TAGGED(4); break; case INSTR_const_10: *(--sp) = TAGGED(10); break; case INSTR_reset_r_1: { PolyWord u = *sp; sp += 1; *sp = u; break; } case INSTR_reset_r_2: { PolyWord u = *sp; sp += 2; *sp = u; break; } case INSTR_reset_r_3: { PolyWord u = *sp; sp += 3; *sp = u; break; } case INSTR_reset_1: sp += 1; break; case INSTR_reset_2: sp += 2; break; case INSTR_stack_containerB: { POLYUNSIGNED words = *pc++; while (words-- > 0) *(--sp) = Zero; sp--; (*sp).stackAddr = sp + 1; break; } case INSTR_callFastRTS0: { callFastRts0 doCall = *(callFastRts0*)(*sp++).w().AsObjPtr(); ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS1: { callFastRts1 doCall = *(callFastRts1*)(*sp++).w().AsObjPtr(); intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS2: { callFastRts2 doCall = *(callFastRts2*)(*sp++).w().AsObjPtr(); intptr_t rtsArg2 = (*sp++).argValue; // Pop off the args, last arg first. intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS3: { callFastRts3 doCall = *(callFastRts3*)(*sp++).w().AsObjPtr(); intptr_t rtsArg3 = (*sp++).argValue; // Pop off the args, last arg first. intptr_t rtsArg2 = (*sp++).argValue; intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS4: { callFastRts4 doCall = *(callFastRts4*)(*sp++).w().AsObjPtr(); intptr_t rtsArg4 = (*sp++).argValue; // Pop off the args, last arg first. intptr_t rtsArg3 = (*sp++).argValue; intptr_t rtsArg2 = (*sp++).argValue; intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFastRTS5: { callFastRts5 doCall = *(callFastRts5*)(*sp++).w().AsObjPtr(); intptr_t rtsArg5 = (*sp++).argValue; // Pop off the args, last arg first. intptr_t rtsArg4 = (*sp++).argValue; intptr_t rtsArg3 = (*sp++).argValue; intptr_t rtsArg2 = (*sp++).argValue; intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4, rtsArg5); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_notBoolean: *sp = ((*sp).w() == True) ? False : True; break; case INSTR_isTagged: *sp = (*sp).w().IsTagged() ? True : False; break; case INSTR_cellLength: /* Return the length word. */ *sp = TAGGED((*sp).w().AsObjPtr()->Length()); break; case INSTR_cellFlags: { PolyObject *p = (*sp).w().AsObjPtr(); POLYUNSIGNED f = (p->LengthWord()) >> OBJ_PRIVATE_FLAGS_SHIFT; *sp = TAGGED(f); break; } case INSTR_clearMutable: { PolyObject *obj = (*sp).w().AsObjPtr(); POLYUNSIGNED lengthW = obj->LengthWord(); /* Clear the mutable bit. */ obj->SetLengthWord(lengthW & ~_OBJ_MUTABLE_BIT); *sp = Zero; break; } case INSTR_atomicIncr: { PolyObject* p = (*sp).w().AsObjPtr(); POLYUNSIGNED newValue = taskData->AtomicIncrement(p); *sp = PolyWord::FromUnsigned(newValue); break; } case INSTR_atomicDecr: { PolyObject *p = (*sp).w().AsObjPtr(); POLYUNSIGNED newValue = taskData->AtomicDecrement(p); *sp = PolyWord::FromUnsigned(newValue); break; } case INSTR_equalWord: { PolyWord u = *sp++; *sp = u == (*sp) ? True : False; break; } case INSTR_jumpNEqLocal: { // Compare a local with a constant and jump if not equal. PolyWord u = sp[pc[0]]; if (u.IsTagged() && u.UnTagged() == pc[1]) pc += 3; else pc += pc[2] + 3; break; } case INSTR_jumpNEqLocalInd: { // Test the union tag value in the first word of a tuple. PolyWord u = sp[pc[0]]; u = u.AsObjPtr()->Get(0); if (u.IsTagged() && u.UnTagged() == pc[1]) pc += 3; else pc += pc[2] + 3; break; } case INSTR_isTaggedLocalB: { PolyWord u = sp[*pc++]; *(--sp) = u.IsTagged() ? True : False; break; } case INSTR_jumpTaggedLocal: { PolyWord u = sp[*pc]; // Jump if the value is tagged. if (u.IsTagged()) pc += pc[1] + 2; else pc += 2; break; } case INSTR_lessSigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsSigned() < u.AsSigned()) ? True : False; break; } case INSTR_lessUnsigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsUnsigned() < u.AsUnsigned()) ? True : False; break; } case INSTR_lessEqSigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsSigned() <= u.AsSigned()) ? True : False; break; } case INSTR_lessEqUnsigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsUnsigned() <= u.AsUnsigned()) ? True : False; break; } case INSTR_greaterSigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsSigned() > u.AsSigned()) ? True : False; break; } case INSTR_greaterUnsigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsUnsigned() > u.AsUnsigned()) ? True : False; break; } case INSTR_greaterEqSigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsSigned() >= u.AsSigned()) ? True : False; break; } case INSTR_greaterEqUnsigned: { PolyWord u = *sp++; *sp = ((*sp).w().AsUnsigned() >= u.AsUnsigned()) ? True : False; break; } case INSTR_fixedAdd: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(x) + UNTAGGED(y); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { taskData->SetException((poly_exn*)overflowPacket); goto RAISE_EXCEPTION; } break; } case INSTR_fixedSub: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(y) - UNTAGGED(x); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { taskData->SetException((poly_exn*)overflowPacket); goto RAISE_EXCEPTION; } break; } case INSTR_fixedMult: { // There's no simple way to detect signed overflow in multiplication. // Unsigned multiplication is defined to wrap but signed is not and // GCC optimised away the previous test we had here. PolyWord x = *sp++; PolyWord y = (*sp); try { Handle mark = taskData->saveVec.mark(); SaveInterpreterState(pc, sp); Handle result = mult_longc(taskData, taskData->saveVec.push(x), taskData->saveVec.push(y)); LoadInterpreterState(pc, sp); *sp = result->Word(); taskData->saveVec.reset(mark); if ((*sp).w().IsDataPtr()) { taskData->SetException((poly_exn*)overflowPacket); goto RAISE_EXCEPTION; } } catch (IOException&) { // We could run out of store goto RAISE_EXCEPTION; } break; } case INSTR_fixedQuot: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) / u); break; } case INSTR_fixedRem: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) % u); break; } case INSTR_wordAdd: { PolyWord u = *sp++; // Because we're not concerned with overflow we can just add the values and subtract the tag. *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() + u.AsUnsigned() - TAGGED(0).AsUnsigned()); break; } case INSTR_wordSub: { PolyWord u = *sp++; *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() - u.AsUnsigned() + TAGGED(0).AsUnsigned()); break; } case INSTR_wordMult: { PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) * UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordDiv: { POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); // Detection of zero is done in ML *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) / u); break; } case INSTR_wordMod: { POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) % u); break; } case INSTR_wordAnd: { PolyWord u = *sp++; // Since both of these should be tagged the tag bit will be preserved. *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() & u.AsUnsigned()); break; } case INSTR_wordOr: { PolyWord u = *sp++; // Since both of these should be tagged the tag bit will be preserved. *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() | u.AsUnsigned()); break; } case INSTR_wordXor: { PolyWord u = *sp++; // This will remove the tag bit so it has to be reinstated. *sp = PolyWord::FromUnsigned(((*sp).w().AsUnsigned() ^ u.AsUnsigned()) | TAGGED(0).AsUnsigned()); break; } case INSTR_wordShiftLeft: { // ML requires shifts greater than a word to return zero. // That's dealt with at the higher level. PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) << UNTAGGED_UNSIGNED(u)); break; } case INSTR_wordShiftRLog: { PolyWord u = *sp++; *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) >> UNTAGGED_UNSIGNED(u)); break; } case INSTR_arbAdd: { PolyWord x = *sp++; PolyWord y = (*sp); if (x.IsTagged() && y.IsTagged()) { POLYSIGNED t = UNTAGGED(x) + UNTAGGED(y); if (t <= MAXTAGGED && t >= -MAXTAGGED - 1) { *sp = TAGGED(t); break; } } // One argument was untagged or there was an overflow try { Handle mark = taskData->saveVec.mark(); SaveInterpreterState(pc, sp); Handle result = add_longc(taskData, taskData->saveVec.push(x), taskData->saveVec.push(y)); LoadInterpreterState(pc, sp); *sp = result->Word(); taskData->saveVec.reset(mark); } catch (IOException&) { // We could run out of store goto RAISE_EXCEPTION; } break; } case INSTR_arbSubtract: { PolyWord x = *sp++; PolyWord y = (*sp); if (x.IsTagged() && y.IsTagged()) { POLYSIGNED t = UNTAGGED(y) - UNTAGGED(x); if (t <= MAXTAGGED && t >= -MAXTAGGED - 1) { *sp = TAGGED(t); break; } } // One argument was untagged or there was an overflow try { Handle mark = taskData->saveVec.mark(); SaveInterpreterState(pc, sp); Handle result = sub_longc(taskData, taskData->saveVec.push(x), taskData->saveVec.push(y)); LoadInterpreterState(pc, sp); *sp = result->Word(); taskData->saveVec.reset(mark); } catch (IOException&) { // We could run out of store goto RAISE_EXCEPTION; } break; } case INSTR_arbMultiply: { // See comment on fixedMultiply above PolyWord x = *sp++; PolyWord y = (*sp); try { Handle mark = taskData->saveVec.mark(); SaveInterpreterState(pc, sp); Handle result = mult_longc(taskData, taskData->saveVec.push(x), taskData->saveVec.push(y)); LoadInterpreterState(pc, sp); *sp = result->Word(); taskData->saveVec.reset(mark); } catch (IOException&) { // We could run out of store goto RAISE_EXCEPTION; } break; } case INSTR_allocByteMem: { // Allocate byte segment. This does not need to be initialised. POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); PolyObject *t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; // Exception t->SetLengthWord(length, (byte)flags); *sp = (PolyWord)t; break; } case INSTR_getThreadId: *(--sp) = (PolyWord)taskData->threadObject; break; case INSTR_allocWordMemory: { // Allocate word segment. This must be initialised. // We mustn't pop the initialiser until after any potential GC. POLYUNSIGNED length = UNTAGGED_UNSIGNED(sp[2]); PolyObject *t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; PolyWord initialiser = *sp++; POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); t->SetLengthWord(length, (byte)flags); *sp = (PolyWord)t; // Have to initialise the data. for (; length > 0; ) t->Set(--length, initialiser); break; } case INSTR_alloc_ref: { // Allocate a single word mutable cell. This is more common than allocWordMemory on its own. PolyObject *t = this->allocateMemory(taskData, 1, pc, sp); if (t == 0) goto RAISE_EXCEPTION; PolyWord initialiser = (*sp); t->SetLengthWord(1, F_MUTABLE_BIT); t->Set(0, initialiser); *sp = (PolyWord)t; break; } case INSTR_allocMutClosureB: { // Allocate memory for a mutable closure and copy in the code address. POLYUNSIGNED length = *pc++ + sizeof(uintptr_t) / sizeof(PolyWord); PolyObject* t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(length, F_CLOSURE_OBJ | F_MUTABLE_BIT); PolyObject* srcClosure = (*sp).w().AsObjPtr(); *(uintptr_t*)t = *(uintptr_t*)srcClosure; for (POLYUNSIGNED i = sizeof(uintptr_t) / sizeof(PolyWord); i < length; i++) t->Set(i, TAGGED(0)); *sp = (PolyWord)t; break; } case INSTR_loadMLWord: { POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); *sp = p->Get(index); break; } case INSTR_loadMLByte: { // The values on the stack are base and index. POLYUNSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = (*sp).w().AsCodePtr(); *sp = TAGGED(p[index]); // Have to tag the result break; } case INSTR_loadUntagged: { POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); *sp = TAGGED(p->Get(index).AsUnsigned()); break; } case INSTR_storeMLWord: { PolyWord toStore = *sp++; POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); p->Set(index, toStore); *sp = Zero; break; } case INSTR_storeMLByte: { POLYUNSIGNED toStore = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = (*sp).w().AsCodePtr(); p[index] = (byte)toStore; *sp = Zero; break; } case INSTR_storeUntagged: { PolyWord toStore = PolyWord::FromUnsigned(UNTAGGED_UNSIGNED(*sp++)); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); p->Set(index, toStore); *sp = Zero; break; } case INSTR_blockMoveWord: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject* dest = (PolyObject*)((*sp++).w().AsCodePtr()); POLYUNSIGNED srcIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject* src = (PolyObject*)((*sp).w().AsCodePtr()); for (POLYUNSIGNED u = 0; u < length; u++) dest->Set(destIndex + u, src->Get(srcIndex + u)); *sp = Zero; break; } case INSTR_blockMoveByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR dest = (*sp++).w().AsCodePtr(); POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR src = (*sp).w().AsCodePtr(); memcpy(dest+destOffset, src+srcOffset, length); *sp = Zero; break; } case INSTR_blockEqualByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg2Ptr = (*sp++).w().AsCodePtr(); POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg1Ptr = (*sp).w().AsCodePtr(); *sp = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length) == 0 ? True : False; break; } case INSTR_blockCompareByte: { POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg2Ptr = (*sp++).w().AsCodePtr(); POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); POLYCODEPTR arg1Ptr = (*sp).w().AsCodePtr(); int result = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length); *sp = result == 0 ? TAGGED(0) : result < 0 ? TAGGED(-1) : TAGGED(1); break; } case INSTR_escape: { switch (*pc++) { case EXTINSTR_callFastRRtoR: { // Floating point call. callRTSRRtoR doCall = *(callRTSRRtoR*)(*sp++).w().AsObjPtr(); PolyWord rtsArg2 = *sp++; PolyWord rtsArg1 = *sp++; double argument1 = unboxDouble(rtsArg1); double argument2 = unboxDouble(rtsArg2); // Allocate memory for the result. double result = doCall(argument1, argument2); PolyObject* t = boxDouble(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastRGtoR: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSRGtoR doCall = *(callRTSRGtoR*)(*sp++).w().AsObjPtr(); intptr_t rtsArg2 = (*sp++).w().AsSigned(); PolyWord rtsArg1 = *sp++; double argument1 = unboxDouble(rtsArg1); // Allocate memory for the result. double result = doCall(argument1, rtsArg2); PolyObject* t = boxDouble(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastGtoR: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSGtoR doCall = *(callRTSGtoR*)(*sp++).w().AsObjPtr(); intptr_t rtsArg1 = (*sp++).w().AsSigned(); // Allocate memory for the result. double result = doCall(rtsArg1); PolyObject* t = boxDouble(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastFtoF: { // Floating point call. The call itself does not allocate but we // need to put the result into a "box". callRTSFtoF doCall = *(callRTSFtoF*)(*sp++).w().AsObjPtr(); PolyWord rtsArg1 = *sp++; float argument = unboxFloat(rtsArg1); // Allocate memory for the result. float result = doCall(argument); PolyObject* t = boxFloat(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastFFtoF: { // Floating point call. callRTSFFtoF doCall = *(callRTSFFtoF*)(*sp++).w().AsObjPtr(); PolyWord rtsArg2 = *sp++; PolyWord rtsArg1 = *sp++; float argument1 = unboxFloat(rtsArg1); float argument2 = unboxFloat(rtsArg2); // Allocate memory for the result. float result = doCall(argument1, argument2); PolyObject* t = boxFloat(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastGtoF: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSGtoF doCall = *(callRTSGtoF*)(*sp++).w().AsObjPtr(); intptr_t rtsArg1 = (*sp++).w().AsSigned(); // Allocate memory for the result. float result = doCall(rtsArg1); PolyObject* t = boxFloat(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastFGtoF: { // Call that takes a POLYUNSIGNED argument and returns a double. callRTSFGtoF doCall = *(callRTSFGtoF*)(*sp++).w().AsObjPtr(); intptr_t rtsArg2 = (*sp++).w().AsSigned(); PolyWord rtsArg1 = *sp++; float argument1 = unboxFloat(rtsArg1); // Allocate memory for the result. float result = doCall(argument1, rtsArg2); PolyObject* t = boxFloat(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_callFastRtoR: { // Floating point call. The call itself does not allocate but we // need to put the result into a "box". callRTSRtoR doCall = *(callRTSRtoR*)(*sp++).w().AsObjPtr(); PolyWord rtsArg1 = *sp++; double argument = unboxDouble(rtsArg1); // Allocate memory for the result. double result = doCall(argument); PolyObject* t = boxDouble(taskData, result, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *(--sp) = (PolyWord)t; break; } case EXTINSTR_atomicExchAdd: { PolyWord u = *sp++; PolyObject* p = (*sp).w().AsObjPtr(); *sp = PolyWord::FromSigned(taskData->AtomicExchAdd(p, u.AsSigned())); break; } case EXTINSTR_atomicReset: { // This is needed in the interpreted version otherwise there // is a chance that we could set the value to zero while another // thread is between getting the old value and setting it to the new value. PolyObject* p = (*sp).w().AsObjPtr(); taskData->AtomicReset(p); *sp = TAGGED(0); // Push the unit result break; } case EXTINSTR_longWToTagged: { // Extract the first word and return it as a tagged value. This loses the top-bit POLYUNSIGNED wx = (*sp).w().AsObjPtr()->Get(0).AsUnsigned(); *sp = TAGGED(wx); break; } case EXTINSTR_signedToLongW: { // Shift the tagged value to remove the tag and put it into the first word. // The original sign bit is copied in the shift. intptr_t wx = (*sp).w().UnTagged(); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(intptr_t*)t = wx; *sp = (PolyWord)t; break; } case EXTINSTR_unsignedToLongW: { // As with the above except the value is treated as an unsigned // value and the top bit is zero. uintptr_t wx = (*sp).w().UnTaggedUnsigned(); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wx; *sp = (PolyWord)t; break; } case EXTINSTR_realAbs: { PolyObject* t = this->boxDouble(taskData, fabs(unboxDouble(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realNeg: { PolyObject* t = this->boxDouble(taskData, -(unboxDouble(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatAbs: { PolyObject* t = this->boxFloat(taskData, fabs(unboxFloat(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatNeg: { PolyObject* t = this->boxFloat(taskData, -(unboxFloat(*sp)), pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_fixedIntToReal: { POLYSIGNED u = UNTAGGED(*sp); PolyObject* t = this->boxDouble(taskData, (double)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_fixedIntToFloat: { POLYSIGNED u = UNTAGGED(*sp); PolyObject* t = this->boxFloat(taskData, (float)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatToReal: { float u = unboxFloat(*sp); PolyObject* t = this->boxDouble(taskData, (double)u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_wordShiftRArith: { PolyWord u = *sp++; // Strictly speaking, C does not require that this uses // arithmetic shifting so we really ought to set the // high-order bits explicitly. *sp = TAGGED(UNTAGGED(*sp) >> UNTAGGED(u)); break; } case EXTINSTR_lgWordEqual: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = wx == wy ? True : False; break; } case EXTINSTR_lgWordLess: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = (wy < wx) ? True : False; break; } case EXTINSTR_lgWordLessEq: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = (wy <= wx) ? True : False; break; } case EXTINSTR_lgWordGreater: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = (wy > wx) ? True : False; break; } case EXTINSTR_lgWordGreaterEq: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); *sp = (wy >= wx) ? True : False; break; } case EXTINSTR_lgWordAdd: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy + wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordSub: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy - wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordMult: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy * wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordDiv: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy / wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordMod: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy % wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordAnd: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy & wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordOr: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy | wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordXor: { uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy ^ wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordShiftLeft: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy << wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordShiftRLog: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = wy >> wx; *sp = (PolyWord)t; break; } case EXTINSTR_lgWordShiftRArith: { // The shift amount is a tagged word not a boxed large word POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); intptr_t wy = *(intptr_t*)((*sp).w().AsObjPtr()); PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(intptr_t*)t = wy >> wx; *sp = (PolyWord)t; break; } case EXTINSTR_realEqual: { double u = unboxDouble(*sp++); *sp = u == unboxDouble(*sp) ? True : False; break; } case EXTINSTR_realLess: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) < u ? True : False; break; } case EXTINSTR_realLessEq: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) <= u ? True : False; break; } case EXTINSTR_realGreater: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) > u ? True : False; break; } case EXTINSTR_realGreaterEq: { double u = unboxDouble(*sp++); *sp = unboxDouble(*sp) >= u ? True : False; break; } case EXTINSTR_realUnordered: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); *sp = (std::isnan(u) || std::isnan(v)) ? True : False; break; } case EXTINSTR_realAdd: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject* t = this->boxDouble(taskData, v + u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realSub: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject* t = this->boxDouble(taskData, v - u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realMult: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject* t = this->boxDouble(taskData, v * u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realDiv: { double u = unboxDouble(*sp++); double v = unboxDouble(*sp); PolyObject* t = this->boxDouble(taskData, v / u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatEqual: { float u = unboxFloat(*sp++); *sp = u == unboxFloat(*sp) ? True : False; break; } case EXTINSTR_floatLess: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) < u ? True : False; break; } case EXTINSTR_floatLessEq: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) <= u ? True : False; break; } case EXTINSTR_floatGreater: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) > u ? True : False; break; } case EXTINSTR_floatGreaterEq: { float u = unboxFloat(*sp++); *sp = unboxFloat(*sp) >= u ? True : False; break; } case EXTINSTR_floatUnordered: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); *sp = (std::isnan(u) || std::isnan(v)) ? True : False; break; } case EXTINSTR_floatAdd: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject* t = this->boxFloat(taskData, v + u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatSub: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject* t = this->boxFloat(taskData, v - u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatMult: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject* t = this->boxFloat(taskData, v * u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_floatDiv: { float u = unboxFloat(*sp++); float v = unboxFloat(*sp); PolyObject* t = this->boxFloat(taskData, v / u, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realToFloat: { // Convert a double to a float. It's complicated because it depends on the rounding mode. int rMode = *pc++; int current = getrounding(); // If the rounding is 4 it means "use current rounding". // Don't call unboxDouble until we're set the rounding. GCC seems to convert it // before the actual float cast. if (rMode < 4) setrounding(rMode); double d = unboxDouble(*sp); float v = (float)d; // Convert with the appropriate rounding. setrounding(current); PolyObject* t = this->boxFloat(taskData, v, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_realToInt: dv = unboxDouble(*sp); goto realtoint; case EXTINSTR_floatToInt: dv = (double)unboxFloat(*sp); realtoint: { // Convert a double or a float to a tagged integer. int rMode = *pc++; // We mustn't try converting a value that will overflow the conversion // but we need to be careful that we don't raise overflow incorrectly due // to rounding. if (dv > (double)(MAXTAGGED + MAXTAGGED / 2) || dv < -(double)(MAXTAGGED + MAXTAGGED / 2)) { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } POLYSIGNED p; switch (rMode) { case POLY_ROUND_TONEAREST: p = (POLYSIGNED)round(dv); break; case POLY_ROUND_DOWNWARD: p = (POLYSIGNED)floor(dv); break; case POLY_ROUND_UPWARD: p = (POLYSIGNED)ceil(dv); break; case POLY_ROUND_TOZERO: default: // Truncation is the default for C. p = (POLYSIGNED)dv; } // Check that the value can be tagged. if (p > MAXTAGGED || p < -MAXTAGGED - 1) { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } *sp = TAGGED(p); break; } case EXTINSTR_loadC8: { // This is similar to loadMLByte except that the base address is a boxed large-word. // Also the index is SIGNED. POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; *sp = TAGGED(p[index]); // Have to tag the result break; } case EXTINSTR_loadC16: { // This and the other loads are similar to loadMLWord with separate // index and offset values. POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; POLYUNSIGNED r = ((uint16_t*)p)[index]; *sp = TAGGED(r); break; } case EXTINSTR_loadC32: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; uintptr_t r = ((uint32_t*)p)[index]; #ifdef IS64BITS // This is tagged in 64-bit mode * sp = TAGGED(r); #else // But boxed in 32-bit mode. PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = r; *sp = (PolyWord)t; #endif break; } #if (defined(IS64BITS) || defined(POLYML32IN64)) case EXTINSTR_loadC64: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; uintptr_t r = ((uint64_t*)p)[index]; // This must be boxed. PolyObject* t = this->allocateMemory(taskData, LGWORDSIZE, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); *(uintptr_t*)t = r; *sp = (PolyWord)t; break; } #endif case EXTINSTR_loadCFloat: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; double r = ((float*)p)[index]; // This must be boxed. PolyObject* t = this->boxDouble(taskData, r, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_loadCDouble: { POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; double r = ((double*)p)[index]; // This must be boxed. PolyObject* t = this->boxDouble(taskData, r, pc, sp); if (t == 0) goto RAISE_EXCEPTION; *sp = (PolyWord)t; break; } case EXTINSTR_storeC8: { // Similar to storeMLByte except that the base address is a boxed large-word. POLYUNSIGNED toStore = UNTAGGED(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; p[index] = (byte)toStore; *sp = Zero; break; } case EXTINSTR_storeC16: { uint16_t toStore = (uint16_t)UNTAGGED(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((uint16_t*)p)[index] = toStore; *sp = Zero; break; } case EXTINSTR_storeC32: { #ifdef IS64BITS // This is a tagged value in 64-bit mode. uint32_t toStore = (uint32_t)UNTAGGED(*sp++); #else // but a boxed value in 32-bit mode. uint32_t toStore = (uint32_t)(*(uintptr_t*)((*sp++).w().AsObjPtr())); #endif POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((uint32_t*)p)[index] = toStore; *sp = Zero; break; } #if (defined(IS64BITS) || defined(POLYML32IN64)) case EXTINSTR_storeC64: { // This is a boxed value. uint64_t toStore = *(uintptr_t*)((*sp++).w().AsObjPtr()); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((uint64_t*)p)[index] = toStore; *sp = Zero; break; } #endif case EXTINSTR_storeCFloat: { // This is a boxed value. float toStore = (float)unboxDouble(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((float*)p)[index] = toStore; *sp = Zero; break; } case EXTINSTR_storeCDouble: { // This is a boxed value. double toStore = unboxDouble(*sp++); POLYSIGNED offset = UNTAGGED(*sp++); POLYSIGNED index = UNTAGGED(*sp++); POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; ((double*)p)[index] = toStore; *sp = Zero; break; } case EXTINSTR_jump32True: // Invert the sense of the test and fall through. *sp = ((*sp).w() == True) ? False : True; case EXTINSTR_jump32False: { PolyWord u = *sp++; /* Pop argument */ if (u == True) { pc += 4; break; } /* else - false - take the jump */ } case EXTINSTR_jump32: { // This is a 32-bit signed quantity on both 64-bits and 32-bits. POLYSIGNED offset = pc[3] & 0x80 ? -1 : 0; offset = (offset << 8) | pc[3]; offset = (offset << 8) | pc[2]; offset = (offset << 8) | pc[1]; offset = (offset << 8) | pc[0]; pc += offset + 4; break; } case EXTINSTR_setHandler32: /* Set up a handler */ { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); - (--sp)->codeAddr = pc + offset + 4; /* Address of handler */ + POLYCODEPTR entry = pc + offset + 4; // Address of handler + // This needs to be aligned for the ARM. This is only during development. + while (((uintptr_t)entry & 3) && entry[0] == INSTR_no_op) + entry++; + (--sp)->codeAddr = entry; SetHandlerRegister(sp); pc += 4; break; } case EXTINSTR_case32: { // arg1 is the number of cases i.e. one more than the largest value // This is followed by that number of 32-bit offsets. // If the value is out of range the default case is immediately after the table. POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ if (u >= arg1 || u < 0) pc += 2 + arg1 * 4; /* Out of range */ else { pc += 2; pc += /* Index */pc[u * 4] + (pc[u * 4 + 1] << 8) + (pc[u * 4 + 2] << 16) + (pc[u * 4 + 3] << 24); } break; } case EXTINSTR_tuple_w: { storeWords = arg1; pc += 2; TUPLE: /* Common code for tupling. */ PolyObject* p = this->allocateMemory(taskData, storeWords, pc, sp); if (p == 0) goto RAISE_EXCEPTION; // Exception p->SetLengthWord(storeWords, 0); for (; storeWords > 0; ) p->Set(--storeWords, *sp++); *(--sp) = (PolyWord)p; break; } case EXTINSTR_indirect_w: *sp = (*sp).w().AsObjPtr()->Get(arg1); pc += 2; break; case EXTINSTR_moveToContainerW: { PolyWord u = *sp++; (*sp).stackAddr[arg1] =u; pc += 2; break; } case EXTINSTR_moveToMutClosureW: { PolyWord u = *sp++; (*sp).w().AsObjPtr()->Set(arg1 + sizeof(uintptr_t)/sizeof(PolyWord), u); pc += 2; break; } case EXTINSTR_indirectContainerW: *sp = (*sp).stackAddr[arg1]; pc += 2; break; case EXTINSTR_indirectClosureW: *sp = (*sp).w().AsObjPtr()->Get(arg1+sizeof(uintptr_t)/sizeof(PolyWord)); pc += 2; break; case EXTINSTR_set_stack_val_w: { PolyWord u = *sp++; sp[arg1 - 1] = u; pc += 2; break; } case EXTINSTR_reset_w: sp += arg1; pc += 2; break; case EXTINSTR_reset_r_w: { PolyWord u = *sp; sp += arg1; *sp = u; pc += 2; break; } case EXTINSTR_stack_containerW: { POLYUNSIGNED words = arg1; pc += 2; while (words-- > 0) *(--sp) = Zero; sp--; (*sp).stackAddr = sp + 1; break; } case EXTINSTR_constAddr32: { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); *(--sp) = *(PolyWord*)(pc + offset + 4); pc += 4; break; } case EXTINSTR_constAddr32_16: { POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); POLYUNSIGNED cNum = pc[4] + (pc[5] << 8) + 3; offset += cNum * sizeof(PolyWord); *(--sp) = *(PolyWord*)(pc + offset + 6); pc += 6; break; } case EXTINSTR_allocCSpace: { // Allocate this on the C heap. POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); void* memory = malloc(length); *sp = Make_sysword(taskData, (uintptr_t)memory)->Word(); break; } case EXTINSTR_freeCSpace: { // Both the address and the size are passed as arguments. sp++; // Size PolyWord addr = *sp; free(*(void**)(addr.AsObjPtr())); *sp = TAGGED(0); break; } case EXTINSTR_tail: /* Tail recursive call. */ /* Move items up the stack. */ /* There may be an overlap if the function we are calling has more args than this one. */ tailCount = arg1; tailPtr = sp + tailCount; sp = tailPtr + arg2; goto TAIL_CALL; case EXTINSTR_allocMutClosureW: { // Allocate memory for a mutable closure and copy in the code address. POLYUNSIGNED length = arg1 + sizeof(uintptr_t) / sizeof(PolyWord); pc += 2; PolyObject* t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(length, F_CLOSURE_OBJ | F_MUTABLE_BIT); PolyObject* srcClosure = (*sp).w().AsObjPtr(); *(uintptr_t*)t = *(uintptr_t*)srcClosure; for (POLYUNSIGNED i = sizeof(uintptr_t) / sizeof(PolyWord); i < length; i++) t->Set(i, TAGGED(0)); *sp = (PolyWord)t; break; } case EXTINSTR_closureW: { storeWords = arg1; pc += 2; CREATE_CLOSURE: // Allocate a closure. storeWords is the number of non-locals. POLYUNSIGNED length = storeWords + sizeof(uintptr_t) / sizeof(PolyWord); PolyObject* t = this->allocateMemory(taskData, length, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(length, F_CLOSURE_OBJ); for (; storeWords > 0; ) t->Set(--storeWords + sizeof(uintptr_t) / sizeof(PolyWord), *sp++); PolyObject* srcClosure = (*sp).w().AsObjPtr(); *(uintptr_t*)t = *(uintptr_t*)srcClosure; *sp = (PolyWord)t; break; } default: Crash("Unknown extended instruction %x\n", pc[-1]); } break; } case INSTR_enterIntX86: // This is a no-op if we are already interpreting. pc += 3; break; case INSTR_enterIntArm64: pc += 12; break; case INSTR_no_op: // Only used for alignment for ARM64. break; default: Crash("Unknown instruction %x\n", pc[-1]); } /* switch */ } /* for */ return ReturnReturn; // Never actually reached } void ByteCodeInterpreter::GarbageCollect(ScanAddress* process) { if (overflowPacket != 0) overflowPacket = process->ScanObjectAddress(overflowPacket); if (dividePacket != 0) dividePacket = process->ScanObjectAddress(dividePacket); } extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedGetAbiList(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes); POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec); } // FFI #if (defined(HAVE_LIBFFI) && defined(HAVE_FFI_H)) #ifdef HAVE_ERRNO_H #include #endif #include static struct _abiTable { const char* abiName; ffi_abi abiCode; } abiTable[] = { // Unfortunately the ABI entries are enums rather than #defines so we // can't test individual entries. #ifdef X86_WIN32 {"sysv", FFI_SYSV}, {"stdcall", FFI_STDCALL}, {"thiscall", FFI_THISCALL}, {"fastcall", FFI_FASTCALL}, {"ms_cdecl", FFI_MS_CDECL}, #elif defined(X86_WIN64) {"win64", FFI_WIN64}, #elif defined(X86_64) || (defined (__x86_64__) && defined (X86_DARWIN)) {"unix64", FFI_UNIX64}, #elif defined(X86_ANY) {"sysv", FFI_SYSV}, #endif { "default", FFI_DEFAULT_ABI} }; static Handle mkAbitab(TaskData* taskData, void*, char* p); static Handle toSysWord(TaskData* taskData, void* p) { return Make_sysword(taskData, (uintptr_t)p); } // Convert the Poly type info into ffi_type values. /* datatype cTypeForm = CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } */ static ffi_type* decodeType(PolyWord pType) { PolyWord typeForm = pType.AsObjPtr()->Get(2); PolyWord typeSize = pType.AsObjPtr()->Get(0); if (typeForm.IsDataPtr()) { // Struct size_t size = typeSize.UnTaggedUnsigned(); unsigned short align = (unsigned short)pType.AsObjPtr()->Get(1).UnTaggedUnsigned(); unsigned nElems = 0; PolyWord listStart = typeForm.AsObjPtr()->Get(0); for (PolyWord p = listStart; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nElems++; size_t space = sizeof(ffi_type); // Add space for the elements plus one extra for the zero terminator. space += (nElems + 1) * sizeof(ffi_type*); ffi_type* result = (ffi_type*)calloc(1, space); // Raise an exception rather than returning zero. if (result == 0) return 0; ffi_type** elem = (ffi_type**)(result + 1); result->size = size; result->alignment = align; result->type = FFI_TYPE_STRUCT; result->elements = elem; if (elem != 0) { for (PolyWord p = listStart; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; ffi_type* t = decodeType(e); if (t == 0) return 0; *elem++ = t; } *elem = 0; // Null terminator } return result; } else { switch (typeForm.UnTaggedUnsigned()) { case 0: { // Floating point if (typeSize.UnTaggedUnsigned() == ffi_type_float.size) return &ffi_type_float; else if (typeSize.UnTaggedUnsigned() == ffi_type_double.size) return &ffi_type_double; ASSERT(0); } case 1: // FFI type poiner return &ffi_type_pointer; case 2: // Signed integer. { switch (typeSize.UnTaggedUnsigned()) { case 1: return &ffi_type_sint8; case 2: return &ffi_type_sint16; case 4: return &ffi_type_sint32; case 8: return &ffi_type_sint64; default: ASSERT(0); } } case 3: // Unsigned integer. { switch (typeSize.UnTaggedUnsigned()) { case 1: return &ffi_type_uint8; case 2: return &ffi_type_uint16; case 4: return &ffi_type_uint32; case 8: return &ffi_type_uint64; default: ASSERT(0); } } case 4: // Void return &ffi_type_void; } ASSERT(0); } return 0; } // Create a CIF. This contains all the types and some extra information. // The arguments are the raw ML values. That does make this dependent on the // representations used by the compiler. // This mallocs space for the CIF and the types. The space is never freed. // POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; ffi_abi abi = (ffi_abi)get_C_ushort(taskData, abiValue); try { unsigned nArgs = 0; for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nArgs++; // Allocate space for the cif followed by the argument type vector size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*); ffi_cif* cif = (ffi_cif*)malloc(space); if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type* rtype = decodeType(resultType); if (rtype == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type** atypes = (ffi_type**)(cif + 1); // Copy the arguments types. ffi_type** at = atypes; for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; ffi_type* atype = decodeType(e); if (atype == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); *at++ = atype; } ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes); if (status == FFI_BAD_TYPEDEF) raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif"); else if (status == FFI_BAD_ABI) raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif"); else if (status != FFI_OK) raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif"); result = toSysWord(taskData, cif); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Call a function. POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) { ffi_cif* cif = *(ffi_cif**)cifAddr.AsAddress(); void* f = *(void**)cFunAddr.AsAddress(); void* res = *(void**)resAddr.AsAddress(); void* arg = *(void**)argVec.AsAddress(); // Poly passes the arguments as values, effectively a single struct. // Libffi wants a vector of addresses. void** argVector = (void**)calloc(cif->nargs + 1, sizeof(void*)); unsigned n = 0; uintptr_t p = (uintptr_t)arg; while (n < cif->nargs) { uintptr_t align = cif->arg_types[n]->alignment; p = (p + align - 1) & (0 - align); argVector[n] = (void*)p; p += cif->arg_types[n]->size; n++; } // The result area we have provided is only as big as required. // Libffi may need a larger area. if (cif->rtype->size < FFI_SIZEOF_ARG) { char result[FFI_SIZEOF_ARG]; ffi_call(cif, FFI_FN(f), &result, argVector); if (cif->rtype->type != FFI_TYPE_VOID) memcpy(res, result, cif->rtype->size); } else ffi_call(cif, FFI_FN(f), res, argVector); free(argVector); return TAGGED(0).AsUnsigned(); } #else // Libffi is not present. // A basic table so that the Foreign structure will compile static struct _abiTable { const char* abiName; int abiCode; } abiTable[] = { { "default", 0} }; // Don't raise an exception at this point so we can build calls. POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) { return TAGGED(0).AsUnsigned(); } POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) { TaskData* taskData = TaskData::FindTaskForId(threadId); try { raise_exception_string(taskData, EXC_foreign, "Foreign function calling is not available. Libffi is not installled."); } catch (...) {} // Handle the IOException return TAGGED(0).AsUnsigned(); } #endif // Construct an entry in the ABI table. static Handle mkAbitab(TaskData* taskData, void* arg, char* p) { struct _abiTable* ab = (struct _abiTable*)p; // Construct a pair of the string and the code Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName)); Handle code = Make_arbitrary_precision(taskData, ab->abiCode); Handle result = alloc_and_save(taskData, 2); result->WordP()->Set(0, name->Word()); result->WordP()->Set(1, code->Word()); return result; } // Get ABI list. This is called once only before the basis library is built. POLYUNSIGNED PolyInterpretedGetAbiList(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = makeList(taskData, sizeof(abiTable) / sizeof(abiTable[0]), (char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } struct _entrypts byteCodeEPT[] = { { "PolyInterpretedGetAbiList", (polyRTSFunction)&PolyInterpretedGetAbiList }, { "PolyInterpretedCreateCIF", (polyRTSFunction)&PolyInterpretedCreateCIF }, { "PolyInterpretedCallFunction", (polyRTSFunction)&PolyInterpretedCallFunction }, { NULL, NULL} // End of list. }; diff --git a/mlsource/MLCompiler/CodeTree/Arm64Code/Arm64GenCode.sml b/mlsource/MLCompiler/CodeTree/Arm64Code/Arm64GenCode.sml index 9a378f54..e1266639 100644 --- a/mlsource/MLCompiler/CodeTree/Arm64Code/Arm64GenCode.sml +++ b/mlsource/MLCompiler/CodeTree/Arm64Code/Arm64GenCode.sml @@ -1,1332 +1,1347 @@ (* Copyright (c) 2021 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public Licence 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 Licence for more details. You should have received a copy of the GNU Lesser General Public Licence along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor Arm64GenCode ( structure FallBackCG: GENCODESIG and BackendTree: BackendIntermediateCodeSig and CodeArray: CODEARRAYSIG and Arm64Assembly: Arm64Assembly and Debug: DEBUG sharing FallBackCG.Sharing = BackendTree.Sharing = CodeArray.Sharing = Arm64Assembly.Sharing ) : GENCODESIG = struct open BackendTree CodeArray Arm64Assembly Address exception InternalError = Misc.InternalError (* tag a short constant *) fun tag c = 2 * c + 1 (* shift a short constant, but don't set tag bit *) fun semitag c = 2 * c + + (* Offsets in the assembly code interface pointed at by X26 + These are in units of 64-bits NOT bytes. *) + val heapOverflowCallOffset = 1 + and exceptionHandlerOffset = 5 + and stackLimitOffset = 6 + and exceptionPacketOffset = 7 + and threadIdOffset = 8 (* Remove items from the stack. If the second argument is true the value on the top of the stack has to be moved. TODO: This works only for offsets up to 256 words. *) fun resetStack(0, _, _) = () | resetStack(nItems, true, code) = ( genPopReg(X0, code); resetStack(nItems, false, code); genPushReg(X0, code) ) | resetStack(nItems, false, code) = genAddRegConstant({sReg=X_MLStackPtr, dReg=X_MLStackPtr, cValue=Word.toInt wordSize * nItems, shifted=false}, code) (* Load a constant and push it to the stack. *) fun pushConst(w, code) = if isShort w andalso toShort w < 0w32768 (* So tagged value will fit. *) then let val cVal = tag(Word.toInt(toShort w)) in genMoveShortConstToReg(X0, cVal, code); genPushReg(X0, code) end else (genLoadConstant(X0, w, code); genPushReg(X0, code)) (* Load a local value. TODO: the offset is limited to 12-bits. *) fun genLocal(offset, code) = (loadRegAligned({dest=X0, base=X_MLStackPtr, wordOffset=offset}, code); genPushReg(X0, code)) (* Load a value at an offset from the address on the top of the stack. TODO: the offset is limited to 12-bits. *) fun genIndirect(offset, code) = (genPopReg(X0, code); loadRegAligned({dest=X0, base=X0, wordOffset=offset}, code); genPushReg(X0, code)) fun toDo() = raise Fallback fun genOpcode _ = toDo() fun genContainer _ = toDo() fun createLabel _ = toDo() fun setLabel _ = toDo() fun genSetStackVal _ = toDo() fun putBranchInstruction _ = toDo() - fun genRaiseEx _ = toDo() fun genPushHandler _ = toDo() fun genLdexc _ = toDo() fun genCase _ = toDo() fun genTuple _ = toDo() fun genMoveToContainer _ = toDo() fun genEqualWordConst _ = toDo() fun genAllocMutableClosure _ = toDo() fun genMoveToMutClosure _ = toDo() fun genLock _ = toDo() fun genClosure _ = toDo() fun genIsTagged _ = toDo() fun genDoubleToFloat _ = toDo() fun genRealToInt _ = toDo() fun genFloatToInt _ = toDo() val opcode_notBoolean = 0 val opcode_cellLength = 0 and opcode_cellFlags = 0 and opcode_clearMutable = 0 and opcode_atomicExchAdd = 0 and opcode_atomicReset = 0 and opcode_longWToTagged = 0 and opcode_signedToLongW = 0 and opcode_unsignedToLongW = 0 and opcode_realAbs = 0 and opcode_realNeg = 0 and opcode_fixedIntToReal = 0 and opcode_fixedIntToFloat = 0 and opcode_floatToReal = 0 and opcode_floatAbs = 0 and opcode_floatNeg = 0 val opcode_equalWord = 0 and opcode_lessSigned = 0 and opcode_lessUnsigned = 0 and opcode_lessEqSigned = 0 and opcode_lessEqUnsigned = 0 and opcode_greaterSigned = 0 and opcode_greaterUnsigned = 0 and opcode_greaterEqSigned = 0 and opcode_greaterEqUnsigned = 0 val opcode_fixedAdd = 0 val opcode_fixedSub = 0 val opcode_fixedMult = 0 val opcode_fixedQuot = 0 val opcode_fixedRem = 0 val opcode_wordAdd = 0 val opcode_wordSub = 0 val opcode_wordMult = 0 val opcode_wordDiv = 0 val opcode_wordMod = 0 val opcode_wordAnd = 0 val opcode_wordOr = 0 val opcode_wordXor = 0 val opcode_wordShiftLeft = 0 val opcode_wordShiftRLog = 0 val opcode_wordShiftRArith = 0 val opcode_allocByteMem = 0 val opcode_lgWordEqual = 0 val opcode_lgWordLess = 0 val opcode_lgWordLessEq = 0 val opcode_lgWordGreater = 0 val opcode_lgWordGreaterEq = 0 val opcode_lgWordAdd = 0 val opcode_lgWordSub = 0 val opcode_lgWordMult = 0 val opcode_lgWordDiv = 0 val opcode_lgWordMod = 0 val opcode_lgWordAnd = 0 val opcode_lgWordOr = 0 val opcode_lgWordXor = 0 val opcode_lgWordShiftLeft = 0 val opcode_lgWordShiftRLog = 0 val opcode_lgWordShiftRArith = 0 val opcode_realEqual = 0 val opcode_realLess = 0 val opcode_realLessEq = 0 val opcode_realGreater = 0 val opcode_realGreaterEq = 0 val opcode_realUnordered = 0 val opcode_realAdd = 0 val opcode_realSub = 0 val opcode_realMult = 0 val opcode_realDiv = 0 val opcode_floatEqual = 0 val opcode_floatLess = 0 val opcode_floatLessEq = 0 val opcode_floatGreater = 0 val opcode_floatGreaterEq = 0 val opcode_floatUnordered = 0 val opcode_floatAdd = 0 val opcode_floatSub = 0 val opcode_floatMult = 0 val opcode_floatDiv = 0 val opcode_getThreadId = 0 val opcode_allocWordMemory = 0 val opcode_alloc_ref = 0 val opcode_loadMLWord = 0 val opcode_loadMLByte = 0 val opcode_loadC8 = 0 val opcode_loadC16 = 0 val opcode_loadC32 = 0 val opcode_loadC64 = 0 val opcode_loadCFloat = 0 val opcode_loadCDouble = 0 val opcode_loadUntagged = 0 val opcode_storeMLWord = 0 val opcode_storeMLByte = 0 val opcode_storeC8 = 0 val opcode_storeC16 = 0 val opcode_storeC32 = 0 val opcode_storeC64 = 0 val opcode_storeCFloat = 0 val opcode_storeCDouble = 0 val opcode_storeUntagged = 0 val opcode_blockMoveWord = 0 val opcode_blockMoveByte = 0 val opcode_blockEqualByte = 0 val opcode_blockCompareByte = 0 val opcode_deleteHandler = 0 val opcode_allocCSpace = 0 val opcode_freeCSpace = 0 val opcode_arbAdd = 0 val opcode_arbSubtract = 0 val opcode_arbMultiply = 0 val Jump = 0 val JumpBack = 0 val JumpFalse = 0 val JumpTrue = 0 val SetHandler = 0 val word0 = toMachineWord 0; val DummyValue : machineWord = word0; (* used as result of "raise e" etc. *) type caseForm = { cases : (backendIC * word) list, test : backendIC, caseType: caseType, default : backendIC } (* Where the result, if any, should go *) datatype whereto = NoResult (* discard result *) | ToStack (* Need a result but it can stay on the pseudo-stack *); (* Are we at the end of the function. *) datatype tail = EndOfProc | NotEnd (* Code generate a function or global declaration *) fun codegen (pt, cvec, resultClosure, numOfArgs, localCount, parameters) = let datatype decEntry = StackAddr of int | Empty val decVec = Array.array (localCount, Empty) (* Count of number of items on the stack. *) val realstackptr = ref 1 (* The closure ptr is already there *) (* Maximum size of the stack. *) val maxStack = ref 1 (* Push a value onto the stack. *) fun incsp () = ( realstackptr := !realstackptr + 1; if !realstackptr > !maxStack then maxStack := !realstackptr else () ) (* An entry has been removed from the stack. *) fun decsp () = realstackptr := !realstackptr - 1; fun pushLocalStackValue addr = ( genLocal(!realstackptr + addr, cvec); incsp() ) (* generates code from the tree *) fun gencde (pt : backendIC, whereto : whereto, tailKind : tail, loopAddr) : unit = let (* Save the stack pointer value here. We may want to reset the stack. *) val oldsp = !realstackptr; (* Operations on ML memory always have the base as an ML address. Word operations are always word aligned. The higher level will have extracted any constant offset and scaled it if necessary. That's helpful for the X86 but not for the interpreter. We have to turn them back into indexes. *) fun genMLAddress({base, index, offset}, scale) = ( gencde (base, ToStack, NotEnd, loopAddr); offset mod scale = 0 orelse raise InternalError "genMLAddress"; case (index, offset div scale) of (NONE, soffset) => (pushConst (toMachineWord soffset, cvec); incsp()) | (SOME indexVal, 0) => gencde (indexVal, ToStack, NotEnd, loopAddr) | (SOME indexVal, soffset) => ( gencde (indexVal, ToStack, NotEnd, loopAddr); pushConst (toMachineWord soffset, cvec); genOpcode(opcode_wordAdd, cvec) ) ) (* Load the address, index value and offset for non-byte operations. Because the offset has already been scaled by the size of the operand we have to load the index and offset separately. *) fun genCAddress{base, index, offset} = ( gencde (base, ToStack, NotEnd, loopAddr); case index of NONE => (pushConst (toMachineWord 0, cvec); incsp()) | SOME indexVal => gencde (indexVal, ToStack, NotEnd, loopAddr); pushConst (toMachineWord offset, cvec); incsp() ) val () = case pt of BICEval evl => genEval (evl, tailKind) | BICExtract ext => (* This may just be being used to discard a value which isn't used on this branch. *) if whereto = NoResult then () else ( case ext of BICLoadArgument locn => (* The register arguments appear in order on the stack, followed by the stack argumens in reverse order. *) if locn < 8 then pushLocalStackValue (locn+1) else pushLocalStackValue (numOfArgs-locn+8) | BICLoadLocal locn => ( case Array.sub (decVec, locn) of StackAddr n => pushLocalStackValue (~ n) | _ => (* Should be on the stack, not a function. *) raise InternalError "locaddr: bad stack address" ) | BICLoadClosure locn => ( pushLocalStackValue ~1; (* The closure itself. *) genIndirect(locn+1 (* The first word is the code *), cvec) ) | BICLoadRecursive => pushLocalStackValue ~1 (* The closure itself - first value on the stack. *) ) | BICField {base, offset} => (gencde (base, ToStack, NotEnd, loopAddr); genIndirect (offset, cvec)) | BICLoadContainer {base, offset} => (gencde (base, ToStack, NotEnd, loopAddr); genIndirect (offset, cvec)) | BICLambda lam => genProc (lam, false, fn () => ()) | BICConstnt(w, _) => (pushConst (w, cvec); incsp ()) | BICCond (testPart, thenPart, elsePart) => genCond (testPart, thenPart, elsePart, whereto, tailKind, loopAddr) | BICNewenv(decls, exp) => let (* Processes a list of entries. *) (* Mutually recursive declarations. May be either lambdas or constants. Recurse down the list pushing the addresses of the closure vectors, then unwind the recursion and fill them in. *) fun genMutualDecs [] = () | genMutualDecs ({lambda, addr, ...} :: otherDecs) = genProc (lambda, true, fn() => ( Array.update (decVec, addr, StackAddr (! realstackptr)); genMutualDecs (otherDecs) )) fun codeDecls(BICRecDecs dl) = genMutualDecs dl | codeDecls(BICDecContainer{size, addr}) = ( (* If this is a container we have to process it here otherwise it will be removed in the stack adjustment code. *) genContainer(size, cvec); (* Push the address of this container. *) realstackptr := !realstackptr + size + 1; (* Pushes N words plus the address. *) Array.update (decVec, addr, StackAddr(!realstackptr)) ) | codeDecls(BICDeclar{value, addr, ...}) = ( gencde (value, ToStack, NotEnd, loopAddr); Array.update (decVec, addr, StackAddr(!realstackptr)) ) | codeDecls(BICNullBinding exp) = gencde (exp, NoResult, NotEnd, loopAddr) in List.app codeDecls decls; gencde (exp, whereto, tailKind, loopAddr) end | BICBeginLoop {loop=body, arguments} => (* Execute the body which will contain at least one Loop instruction. There will also be path(s) which don't contain Loops and these will drop through. *) let val args = List.map #1 arguments (* Evaluate each of the arguments, pushing the result onto the stack. *) fun genLoopArg ({addr, value, ...}) = ( gencde (value, ToStack, NotEnd, loopAddr); Array.update (decVec, addr, StackAddr (!realstackptr)); !realstackptr (* Return the posn on the stack. *) ) val argIndexList = map genLoopArg args; val startSp = ! realstackptr; (* Remember the current top of stack. *) val startLoop = createLabel () val () = setLabel(startLoop, cvec) (* Start of loop *) in (* Process the body, passing the jump-back address down for the Loop instruction(s). *) gencde (body, whereto, tailKind, SOME(startLoop, startSp, argIndexList)) (* Leave the arguments on the stack. They can be cleared later if needed. *) end | BICLoop argList => (* Jump back to the enclosing BeginLoop. *) let val (startLoop, startSp, argIndexList) = case loopAddr of SOME l => l | NONE => raise InternalError "No BeginLoop for Loop instr" (* Evaluate the arguments. First push them to the stack because evaluating an argument may depend on the current value of others. Only when we've evaluated all of them can we overwrite the original argument positions. *) fun loadArgs ([], []) = !realstackptr - startSp (* The offset of all the args. *) | loadArgs (arg:: argList, _ :: argIndexList) = let (* Evaluate all the arguments. *) val () = gencde (arg, ToStack, NotEnd, NONE); val argOffset = loadArgs(argList, argIndexList); in genSetStackVal(argOffset, cvec); (* Copy the arg over. *) decsp(); (* The argument has now been popped. *) argOffset end | loadArgs _ = raise InternalError "loadArgs: Mismatched arguments"; val _: int = loadArgs(List.map #1 argList, argIndexList) in if !realstackptr <> startSp then resetStack (!realstackptr - startSp, false, cvec) (* Remove any local variables. *) else (); (* Jump back to the start of the loop. *) putBranchInstruction(JumpBack, startLoop, cvec) end | BICRaise exp => ( gencde (exp, ToStack, NotEnd, loopAddr); - genRaiseEx cvec + genPopReg(X0, cvec); + (* Copy the handler "register" into the stack pointer. Then + jump to the address in the first word. The second word is + the next handler. This is set up in the handler. We have a lot + more raises than handlers since most raises are exceptional conditions + such as overflow so it makes sense to minimise the code in each raise. *) + loadRegAligned({dest=X_MLStackPtr, base=X_MLAssemblyInt, wordOffset=exceptionHandlerOffset}, cvec); + loadRegAligned({dest=X1, base=X_MLStackPtr, wordOffset=0}, cvec); + genBranchRegister(X1, cvec) ) | BICHandle {exp, handler, exPacketAddr} => let (* Save old handler *) val () = genPushHandler cvec val () = incsp () val handlerLabel = createLabel() val () = putBranchInstruction (SetHandler, handlerLabel, cvec) val () = incsp() (* Code generate the body; "NotEnd" because we have to come back to remove the handler; "ToStack" because delHandler needs a result to carry down. *) val () = gencde (exp, ToStack, NotEnd, loopAddr) (* Now get out of the handler and restore the old one. *) val () = genOpcode(opcode_deleteHandler, cvec) val skipHandler = createLabel() val () = putBranchInstruction (Jump, skipHandler, cvec) val () = realstackptr := oldsp val () = setLabel (handlerLabel, cvec) (* Push the exception packet and set the address. *) val () = genLdexc cvec val () = incsp () val () = Array.update (decVec, exPacketAddr, StackAddr(!realstackptr)) val () = gencde (handler, ToStack, NotEnd, loopAddr) (* Have to remove the exception packet. *) val () = resetStack(1, true, cvec) val () = decsp() (* Finally fix-up the jump around the handler *) val () = setLabel (skipHandler, cvec) in () end | BICCase ({cases, test, default, firstIndex, ...}) => let val () = gencde (test, ToStack, NotEnd, loopAddr) (* Label to jump to at the end of each case. *) val exitJump = createLabel() val () = if firstIndex = 0w0 then () else ( (* Subtract lower limit. Don't check for overflow. Instead allow large value to wrap around and check in "case" instruction. *) pushConst(toMachineWord firstIndex, cvec); genOpcode(opcode_wordSub, cvec) ) (* Generate the case instruction followed by the table of jumps. *) val nCases = List.length cases val caseLabels = genCase (nCases, cvec) val () = decsp () (* The default case, if any, follows the case statement. *) (* If we have a jump to the default set it to jump here. *) local fun fixDefault(NONE, defCase) = setLabel(defCase, cvec) | fixDefault(SOME _, _) = () in val () = ListPair.appEq fixDefault (cases, caseLabels) end val () = gencde (default, whereto, tailKind, loopAddr); fun genCases(SOME body, label) = ( (* First exit from the previous case or the default if this is the first. *) putBranchInstruction(Jump, exitJump, cvec); (* Remove the result - the last case will leave it. *) case whereto of ToStack => decsp () | NoResult => (); (* Fix up the jump to come here. *) setLabel(label, cvec); gencde (body, whereto, tailKind, loopAddr) ) | genCases(NONE, _) = () val () = ListPair.appEq genCases (cases, caseLabels) (* Finally set the exit jump to come here. *) val () = setLabel (exitJump, cvec) in () end | BICTuple recList => let val size = List.length recList in (* Move the fields into the vector. *) List.app(fn v => gencde (v, ToStack, NotEnd, loopAddr)) recList; genTuple (size, cvec); realstackptr := !realstackptr - (size - 1) end | BICSetContainer{container, tuple, filter} => (* Copy the contents of a tuple into a container. If the tuple is a Tuple instruction we can avoid generating the tuple and then unpacking it and simply copy the fields that make up the tuple directly into the container. *) ( case tuple of BICTuple cl => (* Simply set the container from the values. *) let (* Load the address of the container. *) val _ = gencde (container, ToStack, NotEnd, loopAddr); fun setValues([], _, _) = () | setValues(v::tl, sourceOffset, destOffset) = if sourceOffset < BoolVector.length filter andalso BoolVector.sub(filter, sourceOffset) then ( gencde (v, ToStack, NotEnd, loopAddr); (* Move the entry into the container. This instruction pops the value to be moved but not the destination. *) genMoveToContainer(destOffset, cvec); decsp(); setValues(tl, sourceOffset+1, destOffset+1) ) else setValues(tl, sourceOffset+1, destOffset) in setValues(cl, 0, 0) (* The container address is still on the stack. *) end | _ => let (* General case. *) (* First the target tuple, then the container. *) val () = gencde (tuple, ToStack, NotEnd, loopAddr) val () = gencde (container, ToStack, NotEnd, loopAddr) val last = BoolVector.foldli(fn (i, true, _) => i | (_, false, n) => n) ~1 filter fun copy (sourceOffset, destOffset) = if BoolVector.sub(filter, sourceOffset) then ( (* Duplicate the tuple address . *) genLocal(1, cvec); genIndirect(sourceOffset, cvec); genMoveToContainer(destOffset, cvec); if sourceOffset = last then () else copy (sourceOffset+1, destOffset+1) ) else copy(sourceOffset+1, destOffset) in copy (0, 0) (* The container and tuple addresses are still on the stack. *) end ) | BICTagTest { test, tag, ... } => ( gencde (test, ToStack, NotEnd, loopAddr); genEqualWordConst(tag, cvec) ) | BICNullary {oper=BuiltIns.GetCurrentThreadId} => ( genOpcode(opcode_getThreadId, cvec); incsp() ) | BICNullary {oper=BuiltIns.CheckRTSException} => ( (* Do nothing. This is done in the RTS call. *) ) | BICNullary {oper=BuiltIns.CPUPause} => ( (* Do nothing. It's really only a hint. *) ) | BICUnary { oper, arg1 } => let open BuiltIns val () = gencde (arg1, ToStack, NotEnd, loopAddr) in case oper of NotBoolean => genOpcode(opcode_notBoolean, cvec) | IsTaggedValue => genIsTagged cvec | MemoryCellLength => genOpcode(opcode_cellLength, cvec) | MemoryCellFlags => genOpcode(opcode_cellFlags, cvec) | ClearMutableFlag => genOpcode(opcode_clearMutable, cvec) | AtomicReset => genOpcode(opcode_atomicReset, cvec) | LongWordToTagged => genOpcode(opcode_longWToTagged, cvec) | SignedToLongWord => genOpcode(opcode_signedToLongW, cvec) | UnsignedToLongWord => genOpcode(opcode_unsignedToLongW, cvec) | RealAbs PrecDouble => genOpcode(opcode_realAbs, cvec) | RealNeg PrecDouble => genOpcode(opcode_realNeg, cvec) | RealFixedInt PrecDouble => genOpcode(opcode_fixedIntToReal, cvec) | RealAbs PrecSingle => genOpcode(opcode_floatAbs, cvec) | RealNeg PrecSingle => genOpcode(opcode_floatNeg, cvec) | RealFixedInt PrecSingle => genOpcode(opcode_fixedIntToFloat, cvec) | FloatToDouble => genOpcode(opcode_floatToReal, cvec) | DoubleToFloat rnding => genDoubleToFloat(rnding, cvec) | RealToInt (PrecDouble, rnding) => genRealToInt(rnding, cvec) | RealToInt (PrecSingle, rnding) => genFloatToInt(rnding, cvec) | TouchAddress => resetStack(1, false, cvec) (* Discard this *) | AllocCStack => genOpcode(opcode_allocCSpace, cvec) end | BICBinary { oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1, arg2=BICConstnt(w, _) } => let val () = gencde (arg1, ToStack, NotEnd, loopAddr) in genEqualWordConst(toShort w, cvec) end | BICBinary { oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1=BICConstnt(w, _), arg2 } => let val () = gencde (arg2, ToStack, NotEnd, loopAddr) in genEqualWordConst(toShort w, cvec) end | BICBinary { oper, arg1, arg2 } => let open BuiltIns val () = gencde (arg1, ToStack, NotEnd, loopAddr) val () = gencde (arg2, ToStack, NotEnd, loopAddr) in case oper of WordComparison{test=TestEqual, ...} => genOpcode(opcode_equalWord, cvec) | WordComparison{test=TestLess, isSigned=true} => genOpcode(opcode_lessSigned, cvec) | WordComparison{test=TestLessEqual, isSigned=true} => genOpcode(opcode_lessEqSigned, cvec) | WordComparison{test=TestGreater, isSigned=true} => genOpcode(opcode_greaterSigned, cvec) | WordComparison{test=TestGreaterEqual, isSigned=true} => genOpcode(opcode_greaterEqSigned, cvec) | WordComparison{test=TestLess, isSigned=false} => genOpcode(opcode_lessUnsigned, cvec) | WordComparison{test=TestLessEqual, isSigned=false} => genOpcode(opcode_lessEqUnsigned, cvec) | WordComparison{test=TestGreater, isSigned=false} => genOpcode(opcode_greaterUnsigned, cvec) | WordComparison{test=TestGreaterEqual, isSigned=false} => genOpcode(opcode_greaterEqUnsigned, cvec) | WordComparison{test=TestUnordered, ...} => raise InternalError "WordComparison: TestUnordered" | PointerEq => genOpcode(opcode_equalWord, cvec) | FixedPrecisionArith ArithAdd => genOpcode(opcode_fixedAdd, cvec) | FixedPrecisionArith ArithSub => genOpcode(opcode_fixedSub, cvec) | FixedPrecisionArith ArithMult => genOpcode(opcode_fixedMult, cvec) | FixedPrecisionArith ArithQuot => genOpcode(opcode_fixedQuot, cvec) | FixedPrecisionArith ArithRem => genOpcode(opcode_fixedRem, cvec) | FixedPrecisionArith ArithDiv => raise InternalError "TODO: FixedPrecisionArith ArithDiv" | FixedPrecisionArith ArithMod => raise InternalError "TODO: FixedPrecisionArith ArithMod" | WordArith ArithAdd => genOpcode(opcode_wordAdd, cvec) | WordArith ArithSub => genOpcode(opcode_wordSub, cvec) | WordArith ArithMult => genOpcode(opcode_wordMult, cvec) | WordArith ArithDiv => genOpcode(opcode_wordDiv, cvec) | WordArith ArithMod => genOpcode(opcode_wordMod, cvec) | WordArith _ => raise InternalError "WordArith - unimplemented instruction" | WordLogical LogicalAnd => genOpcode(opcode_wordAnd, cvec) | WordLogical LogicalOr => genOpcode(opcode_wordOr, cvec) | WordLogical LogicalXor => genOpcode(opcode_wordXor, cvec) | WordShift ShiftLeft => genOpcode(opcode_wordShiftLeft, cvec) | WordShift ShiftRightLogical => genOpcode(opcode_wordShiftRLog, cvec) | WordShift ShiftRightArithmetic => genOpcode(opcode_wordShiftRArith, cvec) | AllocateByteMemory => genOpcode(opcode_allocByteMem, cvec) | LargeWordComparison TestEqual => genOpcode(opcode_lgWordEqual, cvec) | LargeWordComparison TestLess => genOpcode(opcode_lgWordLess, cvec) | LargeWordComparison TestLessEqual => genOpcode(opcode_lgWordLessEq, cvec) | LargeWordComparison TestGreater => genOpcode(opcode_lgWordGreater, cvec) | LargeWordComparison TestGreaterEqual => genOpcode(opcode_lgWordGreaterEq, cvec) | LargeWordComparison TestUnordered => raise InternalError "LargeWordComparison: TestUnordered" | LargeWordArith ArithAdd => genOpcode(opcode_lgWordAdd, cvec) | LargeWordArith ArithSub => genOpcode(opcode_lgWordSub, cvec) | LargeWordArith ArithMult => genOpcode(opcode_lgWordMult, cvec) | LargeWordArith ArithDiv => genOpcode(opcode_lgWordDiv, cvec) | LargeWordArith ArithMod => genOpcode(opcode_lgWordMod, cvec) | LargeWordArith _ => raise InternalError "LargeWordArith - unimplemented instruction" | LargeWordLogical LogicalAnd => genOpcode(opcode_lgWordAnd, cvec) | LargeWordLogical LogicalOr => genOpcode(opcode_lgWordOr, cvec) | LargeWordLogical LogicalXor => genOpcode(opcode_lgWordXor, cvec) | LargeWordShift ShiftLeft => genOpcode(opcode_lgWordShiftLeft, cvec) | LargeWordShift ShiftRightLogical => genOpcode(opcode_lgWordShiftRLog, cvec) | LargeWordShift ShiftRightArithmetic => genOpcode(opcode_lgWordShiftRArith, cvec) | RealComparison (TestEqual, PrecDouble) => genOpcode(opcode_realEqual, cvec) | RealComparison (TestLess, PrecDouble) => genOpcode(opcode_realLess, cvec) | RealComparison (TestLessEqual, PrecDouble) => genOpcode(opcode_realLessEq, cvec) | RealComparison (TestGreater, PrecDouble) => genOpcode(opcode_realGreater, cvec) | RealComparison (TestGreaterEqual, PrecDouble) => genOpcode(opcode_realGreaterEq, cvec) | RealComparison (TestUnordered, PrecDouble) => genOpcode(opcode_realUnordered, cvec) | RealComparison (TestEqual, PrecSingle) => genOpcode(opcode_floatEqual, cvec) | RealComparison (TestLess, PrecSingle) => genOpcode(opcode_floatLess, cvec) | RealComparison (TestLessEqual, PrecSingle) => genOpcode(opcode_floatLessEq, cvec) | RealComparison (TestGreater, PrecSingle) => genOpcode(opcode_floatGreater, cvec) | RealComparison (TestGreaterEqual, PrecSingle) => genOpcode(opcode_floatGreaterEq, cvec) | RealComparison (TestUnordered, PrecSingle) => genOpcode(opcode_floatUnordered, cvec) | RealArith (ArithAdd, PrecDouble) => genOpcode(opcode_realAdd, cvec) | RealArith (ArithSub, PrecDouble) => genOpcode(opcode_realSub, cvec) | RealArith (ArithMult, PrecDouble) => genOpcode(opcode_realMult, cvec) | RealArith (ArithDiv, PrecDouble) => genOpcode(opcode_realDiv, cvec) | RealArith (ArithAdd, PrecSingle) => genOpcode(opcode_floatAdd, cvec) | RealArith (ArithSub, PrecSingle) => genOpcode(opcode_floatSub, cvec) | RealArith (ArithMult, PrecSingle) => genOpcode(opcode_floatMult, cvec) | RealArith (ArithDiv, PrecSingle) => genOpcode(opcode_floatDiv, cvec) | RealArith _ => raise InternalError "RealArith - unimplemented instruction" | FreeCStack => genOpcode(opcode_freeCSpace, cvec) | AtomicExchangeAdd => genOpcode(opcode_atomicExchAdd, cvec) ; decsp() (* Removes one item from the stack. *) end | BICAllocateWordMemory {numWords as BICConstnt(length, _), flags as BICConstnt(flagByte, _), initial } => if isShort length andalso toShort length = 0w1 andalso isShort flagByte andalso toShort flagByte = 0wx40 then (* This is a very common case. *) ( gencde (initial, ToStack, NotEnd, loopAddr); genOpcode(opcode_alloc_ref, cvec) ) else let val () = gencde (numWords, ToStack, NotEnd, loopAddr) val () = gencde (flags, ToStack, NotEnd, loopAddr) val () = gencde (initial, ToStack, NotEnd, loopAddr) in genOpcode(opcode_allocWordMemory, cvec); decsp(); decsp() end | BICAllocateWordMemory { numWords, flags, initial } => let val () = gencde (numWords, ToStack, NotEnd, loopAddr) val () = gencde (flags, ToStack, NotEnd, loopAddr) val () = gencde (initial, ToStack, NotEnd, loopAddr) in genOpcode(opcode_allocWordMemory, cvec); decsp(); decsp() end | BICLoadOperation { kind=LoadStoreMLWord _, address={base, index=NONE, offset}} => ( (* If the index is a constant, frequently zero, we can use indirection. The offset is a byte count so has to be divided by the word size but it should always be an exact multiple. *) gencde (base, ToStack, NotEnd, loopAddr); offset mod Word.toInt wordSize = 0 orelse raise InternalError "gencde: BICLoadOperation - not word multiple"; genIndirect (offset div Word.toInt wordSize, cvec) ) | BICLoadOperation { kind=LoadStoreMLWord _, address} => ( genMLAddress(address, Word.toInt wordSize); genOpcode(opcode_loadMLWord, cvec); decsp() ) | BICLoadOperation { kind=LoadStoreMLByte _, address} => ( genMLAddress(address, 1); genOpcode(opcode_loadMLByte, cvec); decsp() ) | BICLoadOperation { kind=LoadStoreC8, address} => ( genCAddress address; genOpcode(opcode_loadC8, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC16, address} => ( genCAddress address; genOpcode(opcode_loadC16, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC32, address} => ( genCAddress address; genOpcode(opcode_loadC32, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreC64, address} => ( genCAddress address; genOpcode(opcode_loadC64, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreCFloat, address} => ( genCAddress address; genOpcode(opcode_loadCFloat, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreCDouble, address} => ( genCAddress address; genOpcode(opcode_loadCDouble, cvec); decsp(); decsp() ) | BICLoadOperation { kind=LoadStoreUntaggedUnsigned, address} => ( genMLAddress(address, Word.toInt wordSize); genOpcode(opcode_loadUntagged, cvec); decsp() ) | BICStoreOperation { kind=LoadStoreMLWord _, address, value } => ( genMLAddress(address, Word.toInt wordSize); gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeMLWord, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreMLByte _, address, value } => ( genMLAddress(address, 1); gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeMLByte, cvec); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC8, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC8, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC16, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC16, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC32, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC32, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreC64, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeC64, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreCFloat, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeCFloat, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreCDouble, address, value} => ( genCAddress address; gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeCDouble, cvec); decsp(); decsp(); decsp() ) | BICStoreOperation { kind=LoadStoreUntaggedUnsigned, address, value} => ( genMLAddress(address, Word.toInt wordSize); gencde (value, ToStack, NotEnd, loopAddr); genOpcode(opcode_storeUntagged, cvec); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpMove{isByteMove=true}, sourceLeft, destRight, length } => ( genMLAddress(sourceLeft, 1); genMLAddress(destRight, 1); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockMoveByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpMove{isByteMove=false}, sourceLeft, destRight, length } => ( genMLAddress(sourceLeft, Word.toInt wordSize); genMLAddress(destRight, Word.toInt wordSize); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockMoveWord, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpEqualByte, sourceLeft, destRight, length } => ( genMLAddress(sourceLeft, 1); genMLAddress(destRight, 1); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockEqualByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICBlockOperation { kind=BlockOpCompareByte, sourceLeft, destRight, length } => ( genMLAddress(sourceLeft, 1); genMLAddress(destRight, 1); gencde (length, ToStack, NotEnd, loopAddr); genOpcode(opcode_blockCompareByte, cvec); decsp(); decsp(); decsp(); decsp() ) | BICArbitrary { oper, arg1, arg2, ... } => let open BuiltIns val () = gencde (arg1, ToStack, NotEnd, loopAddr) val () = gencde (arg2, ToStack, NotEnd, loopAddr) in case oper of ArithAdd => genOpcode(opcode_arbAdd, cvec) | ArithSub => genOpcode(opcode_arbSubtract, cvec) | ArithMult => genOpcode(opcode_arbMultiply, cvec) | _ => raise InternalError "Unknown arbitrary precision operation"; decsp() (* Removes one item from the stack. *) end in (* body of gencde *) (* This ensures that there is precisely one item on the stack if whereto = ToStack and no items if whereto = NoResult. *) case whereto of ToStack => let val newsp = oldsp + 1; val adjustment = !realstackptr - newsp val () = if adjustment = 0 then () else if adjustment < ~1 then raise InternalError ("gencde: bad adjustment " ^ Int.toString adjustment) (* Hack for declarations that should push values, but don't *) else if adjustment = ~1 then pushConst (DummyValue, cvec) else resetStack (adjustment, true, cvec) in realstackptr := newsp end | NoResult => let val adjustment = !realstackptr - oldsp val () = if adjustment = 0 then () else if adjustment < 0 then raise InternalError ("gencde: bad adjustment " ^ Int.toString adjustment) else resetStack (adjustment, false, cvec) in realstackptr := oldsp end end (* gencde *) (* doNext is only used for mutually recursive functions where a function may not be able to fill in its closure if it does not have all the remaining declarations. *) (* TODO: This always creates the closure on the heap even when makeClosure is false. *) and genProc ({ closure=[], localCount, body, argTypes, name, ...}: bicLambdaForm, mutualDecs, doNext: unit -> unit) : unit = let (* Create a one word item for the closure. This is returned for recursive references and filled in with the address of the code when we've finished. *) val closure = makeConstantClosure() val newCode : code = codeCreate(name, parameters); (* Code-gen function. No non-local references. *) val () = codegen (body, newCode, closure, List.length argTypes, localCount, parameters); val () = pushConst(closureAsAddress closure, cvec); val () = incsp(); in if mutualDecs then doNext () else () end | genProc ({ localCount, body, name, argTypes, closure, ...}, mutualDecs, doNext) = let (* Full closure required. *) val resClosure = makeConstantClosure() val newCode = codeCreate (name, parameters) (* Code-gen function. *) val () = codegen (body, newCode, resClosure, List.length argTypes, localCount, parameters) val closureVars = List.length closure (* Size excluding the code address *) in if mutualDecs then let (* Have to make the closure now and fill it in later. *) val () = pushConst(toMachineWord resClosure, cvec) val () = genAllocMutableClosure(closureVars, cvec) val () = incsp () val entryAddr : int = !realstackptr val () = doNext () (* Any mutually recursive functions. *) (* Push the address of the vector - If we have processed other closures the vector will no longer be on the top of the stack. *) val () = pushLocalStackValue (~ entryAddr) (* Load items for the closure. *) fun loadItems ([], _) = () | loadItems (v :: vs, addr : int) = let (* Generate an item and move it into the clsoure *) val () = gencde (BICExtract v, ToStack, NotEnd, NONE) (* The closure "address" excludes the code address. *) val () = genMoveToMutClosure(addr, cvec) val () = decsp () in loadItems (vs, addr + 1) end val () = loadItems (closure, 0) val () = genLock cvec (* Lock it. *) (* Remove the extra reference. *) val () = resetStack (1, false, cvec) in realstackptr := !realstackptr - 1 end else let (* Put it on the stack. *) val () = pushConst (toMachineWord resClosure, cvec) val () = incsp () val () = List.app (fn pt => gencde (BICExtract pt, ToStack, NotEnd, NONE)) closure val () = genClosure (closureVars, cvec) in realstackptr := !realstackptr - closureVars end end and genCond (testCode, thenCode, elseCode, whereto, tailKind, loopAddr) = let (* andalso and orelse are turned into conditionals with constants. Convert this into a series of tests. *) fun genTest(BICConstnt(w, _), jumpOn, targetLabel) = let val cVal = case toShort w of 0w0 => false | 0w1 => true | _ => raise InternalError "genTest" in if cVal = jumpOn then putBranchInstruction (Jump, targetLabel, cvec) else () end | genTest(BICUnary { oper=BuiltIns.NotBoolean, arg1 }, jumpOn, targetLabel) = genTest(arg1, not jumpOn, targetLabel) | genTest(BICCond (testPart, thenPart, elsePart), jumpOn, targetLabel) = let val toElse = createLabel() and exitJump = createLabel() in genTest(testPart, false, toElse); genTest(thenPart, jumpOn, targetLabel); putBranchInstruction (Jump, exitJump, cvec); setLabel (toElse, cvec); genTest(elsePart, jumpOn, targetLabel); setLabel (exitJump, cvec) end | genTest(testCode, jumpOn, targetLabel) = ( gencde (testCode, ToStack, NotEnd, loopAddr); putBranchInstruction(if jumpOn then JumpTrue else JumpFalse, targetLabel, cvec); decsp() (* conditional branch pops a value. *) ) val toElse = createLabel() and exitJump = createLabel() val () = genTest(testCode, false, toElse) val () = gencde (thenCode, whereto, tailKind, loopAddr) (* Get rid of the result from the stack. If there is a result then the ``else-part'' will push it. *) val () = case whereto of ToStack => decsp () | NoResult => () val () = putBranchInstruction (Jump, exitJump, cvec) (* start of "else part" *) val () = setLabel (toElse, cvec) val () = gencde (elseCode, whereto, tailKind, loopAddr) val () = setLabel (exitJump, cvec) in () end (* genCond *) and genEval (eval, tailKind : tail) : unit = let val argList : backendIC list = List.map #1 (#argList eval) val argsToPass : int = List.length argList; (* Load arguments *) fun loadArgs [] = () | loadArgs (v :: vs) = let (* Push each expression onto the stack. *) val () = gencde(v, ToStack, NotEnd, NONE) in loadArgs vs end; (* Have to guarantee that the expression to return the function is evaluated before the arguments. *) (* Returns true if evaluating it later is safe. *) fun safeToLeave (BICConstnt _) = true | safeToLeave (BICLambda _) = true | safeToLeave (BICExtract _) = true | safeToLeave (BICField {base, ...}) = safeToLeave base | safeToLeave (BICLoadContainer {base, ...}) = safeToLeave base | safeToLeave _ = false val () = if (case argList of [] => true | _ => safeToLeave (#function eval)) then let (* Can load the args first. *) val () = loadArgs argList in gencde (#function eval, ToStack, NotEnd, NONE) end else let (* The expression for the function is too complicated to risk leaving. It might have a side-effect and we must ensure that any side-effects it has are done before the arguments are loaded. *) val () = gencde(#function eval, ToStack, NotEnd, NONE); val () = loadArgs(argList); (* Load the function again. *) val () = genLocal(argsToPass, cvec); in incsp () end in (* body of genEval *) case tailKind of NotEnd => (* Normal call. *) let val () = genPopReg(X8, cvec) (* Pop the closure pointer. *) (* We need to put the first 8 arguments into registers and leave the rest on the stack. *) fun loadArg(n, reg) = if argsToPass > n then loadRegAligned({dest=reg, base=X_MLStackPtr, wordOffset=argsToPass-n-1}, cvec) else () val () = loadArg(0, X0) val () = loadArg(1, X1) val () = loadArg(2, X2) val () = loadArg(3, X3) val () = loadArg(4, X4) val () = loadArg(5, X5) val () = loadArg(6, X6) val () = loadArg(7, X7) in loadRegAligned({dest=X9, base=X8, wordOffset=0}, cvec); (* Entry point *) genBranchAndLinkReg(X9, cvec); (* We have popped the closure pointer. The caller has popped the stack arguments and we have pushed the result value. The register arguments are still on the stack. *) genPushReg (X0, cvec); realstackptr := !realstackptr - Int.max(argsToPass-8, 0) (* Args popped by caller. *) end | EndOfProc => (* Tail recursive call. *) let val () = genPopReg(X8, cvec) (* Pop the closure pointer. *) val () = decsp() (* Get the return address into X30. *) val () = loadRegAligned({dest=X30, base=X_MLStackPtr, wordOffset= !realstackptr}, cvec) (* Load the register arguments *) fun loadArg(n, reg) = if argsToPass > n then loadRegAligned({dest=reg, base=X_MLStackPtr, wordOffset=argsToPass-n-1}, cvec) else () val () = loadArg(0, X0) val () = loadArg(1, X1) val () = loadArg(2, X2) val () = loadArg(3, X3) val () = loadArg(4, X4) val () = loadArg(5, X5) val () = loadArg(6, X6) val () = loadArg(7, X7) (* We need to move the stack arguments into the original argument area. *) (* This is the total number of words that this function is responsible for. It includes the stack arguments that the caller expects to be removed. *) val itemsOnStack = !realstackptr + 1 + numOfArgs (* Stack arguments are moved using X9. *) fun moveStackArg n = if n < 8 then () else let val () = loadArg(n, X9) val destOffset = itemsOnStack - (n-8) - 1 val () = storeRegAligned({dest=X9, base=X_MLStackPtr, wordOffset=destOffset}, cvec) in moveStackArg(n-1) end val () = moveStackArg (argsToPass-1) in resetStack(itemsOnStack - Int.max(argsToPass-8, 0), false, cvec); loadRegAligned({dest=X9, base=X8, wordOffset=0}, cvec); (* Entry point *) genBranchRegister(X9, cvec) (* Since we're not returning we can ignore the stack pointer value. *) end end (* Push the arguments passed in registers. *) val () = if numOfArgs >= 8 then genPushReg (X7, cvec) else () val () = if numOfArgs >= 7 then genPushReg (X6, cvec) else () val () = if numOfArgs >= 6 then genPushReg (X5, cvec) else () val () = if numOfArgs >= 5 then genPushReg (X4, cvec) else () val () = if numOfArgs >= 4 then genPushReg (X3, cvec) else () val () = if numOfArgs >= 3 then genPushReg (X2, cvec) else () val () = if numOfArgs >= 2 then genPushReg (X1, cvec) else () val () = if numOfArgs >= 1 then genPushReg (X0, cvec) else () val () = genPushReg (X30, cvec) val () = genPushReg (X8, cvec) (* Push closure pointer *) (* Generate the function. *) (* Assume we always want a result. There is otherwise a problem if the called routine returns a result of type void (i.e. no result) but the caller wants a result (e.g. the identity function). *) val () = gencde (pt, ToStack, EndOfProc, NONE) val () = genPopReg(X0, cvec) (* Value to return => pop into X0 *) val () = resetStack(1, false, cvec) (* Skip over the pushed closure *) val () = genPopReg(X30, cvec) (* Return address => pop into X30 *) val () = resetStack(numOfArgs, false, cvec) (* Remove the arguments *) val () = genReturnRegister(X30, cvec) (* Jump to X30 *) in (* body of codegen *) (* Having code-generated the body of the function, it is copied into a new data segment. *) generateCode{code = cvec, maxStack = !maxStack, resultClosure=resultClosure} end (* codegen *) fun gencodeLambda(lambda as { name, body, argTypes, localCount, ...}:bicLambdaForm, parameters, closure) = (let val debugSwitchLevel = Debug.getParameter Debug.compilerDebugTag parameters val _ = debugSwitchLevel <> 0 orelse raise Fallback (* make the code buffer for the new function. *) val newCode : code = codeCreate (name, parameters) (* This function must have no non-local references. *) in codegen (body, newCode, closure, List.length argTypes, localCount, parameters) end) handle Fallback => FallBackCG.gencodeLambda(lambda, parameters, closure) structure Foreign = FallBackCG.Foreign structure Sharing = struct open BackendTree.Sharing type closureRef = closureRef end end;