diff --git a/basis/Foreign.581.sml b/basis/Foreign.581.sml index 2cdfba5f..6b2fc9a2 100644 --- a/basis/Foreign.581.sml +++ b/basis/Foreign.581.sml @@ -1,23 +1,88 @@ (* Title: Foreign Function Interface: main part Author: David Matthews - Copyright David Matthews 2015-16, 2018 + Copyright David Matthews 2015-16, 2018, 2020 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(* A subset of the main Foreign structure for booting. We need + memoise in the interpreter. *) + structure Foreign = struct exception Foreign = RunCall.Foreign + + structure Memory :> + sig + eqtype volatileRef + val volatileRef: SysWord.word -> volatileRef + val setVolatileRef: volatileRef * SysWord.word -> unit + val getVolatileRef: volatileRef -> SysWord.word + + eqtype voidStar + (* Remember an address except across loads. *) + val memoise: ('a -> voidStar) ->'a -> unit -> voidStar + end + = + struct + open ForeignConstants + + (* Both volatileRef and SysWord.word are the ADDRESSes of the actual value. *) + type volatileRef = word ref + + val memMove: SysWord.word * SysWord.word * word * word* word -> unit = RunCall.moveBytes + + fun volatileRef init = + let + (* Allocate a single word marked as mutable, weak, no-overwrite, byte. *) + (* A weak byte cell is cleared to zero when it is read in either from the + executable or from a saved state. Using the no-overwrite bit ensures + that if it is contained in the executable it won't be changed by loading + a saved state but there's a problem if it is contained in a parent state. + Then loading a child state will clear it because we reload all the parents + when we load a child. *) + val v = RunCall.allocateWordMemory(sysWordSize div wordSize, 0wx69, 0w0) + (* Copy the SysWord into it. *) + val () = memMove(init, RunCall.unsafeCast v, 0w0, 0w0, sysWordSize) + in + v + end + + fun setVolatileRef(v, i) = memMove(i, RunCall.unsafeCast v, 0w0, 0w0, sysWordSize) + + fun getVolatileRef var = + let + (* Allocate a single word marked as mutable, byte. *) + val v = RunCall.allocateByteMemory(sysWordSize div wordSize, 0wx41) + val () = memMove(RunCall.unsafeCast var, v, 0w0, 0w0, sysWordSize) + val () = RunCall.clearMutableBit v + in + v + end + + type voidStar = SysWord.word + + fun 'a memoise(f: 'a -> voidStar) (a: 'a) : unit -> voidStar = + let + (* Initialise to zero. That means the function won't be + executed until we actually want the result. *) + val v = volatileRef 0w0 + in + (* If we've reloaded the volatile ref it will have been reset to zero. + We need to execute the function and set it. *) + fn () => (case getVolatileRef v of 0w0 => let val r = f a in setVolatileRef(v, r); r end | r => r) + end + end end; diff --git a/basis/ForeignConstants.581.sml b/basis/ForeignConstants.581.sml deleted file mode 100644 index 7cc051cf..00000000 --- a/basis/ForeignConstants.581.sml +++ /dev/null @@ -1,21 +0,0 @@ -(* - Title: Foreign Function Interface: constants - Author: David Matthews - Copyright David Matthews 2015, 2016-17 - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* This is defined separately so that the values are computed and - available as constants for the Foreign structure. *) diff --git a/libpolyml/bytecode.cpp b/libpolyml/bytecode.cpp index b65a1870..b05fbad3 100644 --- a/libpolyml/bytecode.cpp +++ b/libpolyml/bytecode.cpp @@ -1,2657 +1,2659 @@ /* 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. 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() : mixedCode(false), overflowPacket(0), dividePacket(0) { #ifdef PROFILEOPCODES memset(frequency, 0, sizeof(frequency)); memset(arg1Value, 0, sizeof(arg1Value)); memset(arg2Value, 0, sizeof(arg2Value)); #endif } ByteCodeInterpreter::~ByteCodeInterpreter() { #ifdef PROFILEOPCODES OutputDebugStringA("Frequency\n"); for (unsigned i = 0; i < 256; i++) { if (frequency[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, frequency[i]); OutputDebugStringA(buffer); } } OutputDebugStringA("Arg1\n"); for (unsigned i = 0; i < 256; i++) { if (arg1Value[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, arg1Value[i]); OutputDebugStringA(buffer); } } OutputDebugStringA("Arg2\n"); for (unsigned i = 0; i < 256; i++) { if (arg2Value[i] != 0) { char buffer[100]; sprintf(buffer, "%02X: %u\n", i, arg2Value[i]); OutputDebugStringA(buffer); } } #endif } extern "C" { typedef POLYUNSIGNED(*callFastRts0)(); typedef POLYUNSIGNED(*callFastRts1)(intptr_t); typedef POLYUNSIGNED(*callFastRts2)(intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts3)(intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts4)(intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFastRts5)(intptr_t, intptr_t, intptr_t, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFullRts0)(PolyObject *); typedef POLYUNSIGNED(*callFullRts1)(PolyObject *, intptr_t); typedef POLYUNSIGNED(*callFullRts2)(PolyObject *, intptr_t, intptr_t); typedef POLYUNSIGNED(*callFullRts3)(PolyObject *, intptr_t, intptr_t, intptr_t); typedef double (*callRTSRtoR) (double); typedef double (*callRTSRRtoR) (double, double); typedef double (*callRTSGtoR) (intptr_t); typedef double (*callRTSRGtoR) (double, intptr_t); typedef float(*callRTSFtoF) (float); typedef float(*callRTSFFtoF) (float, float); typedef float(*callRTSGtoF) (intptr_t); typedef float(*callRTSFGtoF) (float, intptr_t); } // 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 ASSERT(sp[0].argValue != 2); // 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 */ SetHandlerRegister(sp); pc += 1; break; case INSTR_setHandler16: /* Set up a handler */ (*(--sp)).codeAddr = pc + arg1 + 2; /* Address of handler */ 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_3_bLegacy: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + *pc; goto TAIL_CALL; case INSTR_tail_3_2Legacy: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + 2; goto TAIL_CALL; case INSTR_tail_3_3Legacy: tailCount = 3; tailPtr = sp + tailCount; sp = tailPtr + 3; goto TAIL_CALL; case INSTR_tail_4_bLegacy: tailCount = 4; tailPtr = sp + tailCount; sp = tailPtr + *pc; goto TAIL_CALL; case INSTR_tail_b_b: tailCount = *pc; tailPtr = sp + tailCount; sp = tailPtr + pc[1]; 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_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_0Legacy: returnCount = 0; goto RETURN; case INSTR_return_1: returnCount = 1; goto RETURN; case INSTR_return_2: returnCount = 2; goto RETURN; case INSTR_return_3: returnCount = 3; goto RETURN; case INSTR_stackSize8Legacy: stackCheck = *pc++; goto STACKCHECK; case INSTR_stackSize16: { stackCheck = arg1; pc += 2; STACKCHECK: // Check stackl space. This is combined with interrupts on the native code version. CheckStackAndInterrupt(stackCheck, 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_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 CheckStackAndInterrupt(0, pc, sp); break; case INSTR_jump_back16: pc -= arg1 + 1; // Check for interrupt in case we're in a loop CheckStackAndInterrupt(0, 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_tuple_containerLegacy: /* Create a tuple from a container. */ { storeWords = arg1; PolyObject *t = this->allocateMemory(taskData, storeWords, pc, sp); if (t == 0) goto RAISE_EXCEPTION; t->SetLengthWord(storeWords, 0); for(; storeWords > 0; ) { storeWords--; t->Set(storeWords, (*sp).stackAddr[storeWords]); } *sp = (PolyWord)t; pc += 2; 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_callFullRTS0: { callFullRts0 doCall = *(callFullRts0*)(*sp++).w().AsObjPtr(); ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(taskData->threadObject); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp)= PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS1: { callFullRts1 doCall = *(callFullRts1*)(*sp++).w().AsObjPtr(); intptr_t rtsArg1 = (*sp++).argValue; ClearExceptionPacket(); SaveInterpreterState(pc, sp); POLYUNSIGNED result = doCall(taskData->threadObject, rtsArg1); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS2: { callFullRts2 doCall = *(callFullRts2*)(*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(taskData->threadObject, rtsArg1, rtsArg2); LoadInterpreterState(pc, sp); // If this raised an exception if (GetExceptionPacket().IsDataPtr()) goto RAISE_EXCEPTION; *(--sp) = PolyWord::FromUnsigned(result); break; } case INSTR_callFullRTS3: { callFullRts3 doCall = *(callFullRts3*)(*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(taskData->threadObject, rtsArg1, rtsArg2, rtsArg3); 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: { SaveInterpreterState(pc, sp); 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_stringLength: // Now replaced by loadUntagged // *sp = TAGGED(((PolyStringObject*)(*sp).AsObjPtr())->length); // 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 { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } break; } case INSTR_fixedSub: { PolyWord x = *sp++; PolyWord y = (*sp); POLYSIGNED t = UNTAGGED(y) - UNTAGGED(x); if (t <= MAXTAGGED && t >= -MAXTAGGED-1) *sp = TAGGED(t); else { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } break; } case INSTR_fixedMult: { POLYSIGNED x = UNTAGGED(*sp++); POLYSIGNED y = (*sp).w().AsSigned() - 1; // Just remove the tag POLYSIGNED t = x * y; if (x != 0 && t / x != y) { *(--sp) = (PolyWord)overflowPacket; goto RAISE_EXCEPTION; } *sp = PolyWord::FromSigned(t+1); // Add back the tag break; } case INSTR_fixedQuot: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) / u); break; } case INSTR_fixedRem: { // Zero and overflow are checked for in ML. POLYSIGNED u = UNTAGGED(*sp++); PolyWord y = (*sp); *sp = TAGGED(UNTAGGED(y) % u); break; } case INSTR_wordAdd: { PolyWord u = *sp++; // Because we're not concerned with overflow we can just add the values and subtract the tag. *sp = PolyWord::FromUnsigned((*sp).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_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; *sp = (PolyWord)t; break; } case INSTR_loadMLWordLegacy: { // The values on the stack are base, index and offset. POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).w().AsCodePtr() + offset); *sp = p->Get(index); 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_loadUntaggedLegacy: { // The values on the stack are base, index and offset. POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).w().AsCodePtr() + offset); *sp = TAGGED(p->Get(index).AsUnsigned()); break; } case INSTR_loadUntagged: { POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); *sp = TAGGED(p->Get(index).AsUnsigned()); break; } case INSTR_storeMLWordLegacy: { PolyWord toStore = *sp++; POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).w().AsCodePtr() + offset); p->Set(index, toStore); *sp = Zero; 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_storeUntaggedLegacy: { PolyWord toStore = PolyWord::FromUnsigned(UNTAGGED_UNSIGNED(*sp++)); POLYUNSIGNED offset = UNTAGGED(*sp++); POLYUNSIGNED index = UNTAGGED(*sp++); PolyObject *p = (PolyObject*)((*sp).w().AsCodePtr() + offset); p->Set(index, 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_blockMoveWordLegacy: { // The offsets are byte counts but the the indexes are in words. POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED destIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject *dest = (PolyObject*)((*sp++).w().AsCodePtr() + destOffset); POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); POLYUNSIGNED srcIndex = UNTAGGED_UNSIGNED(*sp++); PolyObject *src = (PolyObject*)((*sp).w().AsCodePtr() + srcOffset); for (POLYUNSIGNED u = 0; u < length; u++) dest->Set(destIndex+u, src->Get(srcIndex+u)); *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; } // Backwards compatibility. // These are either used in the current compiler or compiled by it // while building the basis library. case EXTINSTR_stack_containerW: case EXTINSTR_reset_r_w: case EXTINSTR_tuple_w: case EXTINSTR_unsignedToLongW: case EXTINSTR_signedToLongW: case EXTINSTR_longWToTagged: case EXTINSTR_lgWordShiftLeft: case EXTINSTR_fixedIntToReal: case EXTINSTR_callFastRtoR: case EXTINSTR_realMult: case EXTINSTR_realDiv: case EXTINSTR_realNeg: case EXTINSTR_realAbs: case EXTINSTR_realToFloat: case EXTINSTR_floatDiv: case EXTINSTR_floatNeg: case EXTINSTR_floatAbs: case EXTINSTR_callFastFtoF: case EXTINSTR_floatMult: case EXTINSTR_callFastGtoR: case EXTINSTR_realUnordered: case EXTINSTR_realEqual: case EXTINSTR_lgWordEqual: case EXTINSTR_lgWordOr: case EXTINSTR_wordShiftRArith: case EXTINSTR_lgWordLess: // Back up and handle them as though they were escaped. pc--; 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_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 */ 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_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; *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; 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); - raise_exception_string(taskData, EXC_foreign, "Foreign function calling is not available. Libffi is not installled."); + 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(); } // No machine-specific calls in the interpreter. struct _entrypts byteCodeEPT[] = { { "PolyInterpretedGetAbiList", (polyRTSFunction)&PolyInterpretedGetAbiList }, { "PolyInterpretedCreateCIF", (polyRTSFunction)&PolyInterpretedCreateCIF }, { "PolyInterpretedCallFunction", (polyRTSFunction)&PolyInterpretedCallFunction }, { NULL, NULL} // End of list. }; diff --git a/libpolyml/elfexport.cpp b/libpolyml/elfexport.cpp index f5c5a025..e16c7971 100644 --- a/libpolyml/elfexport.cpp +++ b/libpolyml/elfexport.cpp @@ -1,787 +1,819 @@ /* Title: Write out a database as an ELF object file Author: David Matthews. Copyright (c) 2006-7, 2011, 2016-18, 2020 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR H 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 */ #include "config.h" #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STDDEF_H #include #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_TIME_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_ELF_H #include #elif defined(HAVE_ELF_ABI_H) #include #endif #ifdef HAVE_MACHINE_RELOC_H #include #ifndef EM_X86_64 #define EM_X86_64 EM_AMD64 #endif #if defined(HOSTARCHITECTURE_X86_64) #ifndef R_386_PC32 #define R_386_PC32 R_X86_64_PC32 #endif #ifndef R_386_32 #define R_386_32 R_X86_64_32 #endif #ifndef R_X86_64_64 #define R_X86_64_64 R_X86_64_64 #endif #endif /* HOSTARCHITECTURE_X86_64 */ #endif // Solaris seems to put processor-specific constants in separate files #ifdef HAVE_SYS_ELF_SPARC_H #include #endif #ifdef HAVE_SYS_ELF_386_H #include #endif #ifdef HAVE_SYS_ELF_AMD64_H #include #endif // Android has the ARM relocation symbol here #ifdef HAVE_ASM_ELF_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_SYS_UTSNAME_H #include #endif #include "globals.h" #include "diagnostics.h" #include "sys.h" #include "machine_dep.h" #include "gc.h" #include "mpoly.h" #include "scanaddrs.h" #include "elfexport.h" #include "run_time.h" #include "version.h" #include "polystring.h" #include "timing.h" #define sym_last_local_sym sym_data_section #if defined(HOSTARCHITECTURE_X86) # define HOST_E_MACHINE EM_386 # define HOST_DIRECT_DATA_RELOC R_386_32 # define HOST_DIRECT_FPTR_RELOC R_386_32 # define USE_RELA 0 #elif defined(HOSTARCHITECTURE_PPC) # define HOST_E_MACHINE EM_PPC # define HOST_DIRECT_DATA_RELOC R_PPC_ADDR32 # define HOST_DIRECT_FPTR_RELOC R_PPC_ADDR32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_PPC64) # define HOST_E_MACHINE EM_PPC64 # define HOST_DIRECT_DATA_RELOC R_PPC64_ADDR64 # define HOST_DIRECT_FPTR_RELOC R_PPC64_ADDR64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_S390) # define HOST_E_MACHINE EM_S390 # define HOST_DIRECT_DATA_RELOC R_390_32 # define HOST_DIRECT_FPTR_RELOC R_390_32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_S390X) # define HOST_E_MACHINE EM_S390 # define HOST_DIRECT_DATA_RELOC R_390_64 # define HOST_DIRECT_FPTR_RELOC R_390_64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_SH) # define HOST_E_MACHINE EM_SH # define HOST_DIRECT_DATA_RELOC R_SH_DIR32 # define HOST_DIRECT_FPTR_RELOC R_SH_DIR32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_SPARC) # define HOST_E_MACHINE EM_SPARC # define HOST_DIRECT_DATA_RELOC R_SPARC_32 # define HOST_DIRECT_FPTR_RELOC R_SPARC_32 # define USE_RELA 1 /* Sparc/Solaris, at least 2.8, requires ELF32_Rela relocations. For some reason, though, it adds the value in the location being relocated (as with ELF32_Rel relocations) as well as the addend. To be safe, whenever we use an ELF32_Rela relocation we always zero the location to be relocated. */ #elif defined(HOSTARCHITECTURE_SPARC64) # define HOST_E_MACHINE EM_SPARCV9 # define HOST_DIRECT_DATA_RELOC R_SPARC_64 # define HOST_DIRECT_FPTR_RELOC R_SPARC_64 /* Use the most relaxed memory model. At link time, the most restrictive one is chosen, so it does no harm to be as permissive as possible here. */ # define HOST_E_FLAGS EF_SPARCV9_RMO # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_X86_64) /* It seems Solaris/X86-64 only supports ELF64_Rela relocations. It appears that Linux will support either so we now use Rela on X86-64. */ # define HOST_E_MACHINE EM_X86_64 # define HOST_DIRECT_DATA_RELOC R_X86_64_64 # define HOST_DIRECT_FPTR_RELOC R_X86_64_64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_X32) # define HOST_E_MACHINE EM_X86_64 # define HOST_DIRECT_DATA_RELOC R_X86_64_32 # define HOST_DIRECT_FPTR_RELOC R_X86_64_32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_ARM) # ifndef EF_ARM_EABI_VER4 # define EF_ARM_EABI_VER4 0x04000000 # endif // When linking ARM binaries the linker checks the ABI version. We // need to set the version to the same as the libraries. // GCC currently uses version 4. # define HOST_E_MACHINE EM_ARM # define HOST_DIRECT_DATA_RELOC R_ARM_ABS32 # define HOST_DIRECT_FPTR_RELOC R_ARM_ABS32 # define USE_RELA 0 # define HOST_E_FLAGS EF_ARM_EABI_VER4 #elif defined(HOSTARCHITECTURE_HPPA) # if defined(__hpux) # define HOST_OSABI ELFOSABI_HPUX # elif defined(__NetBSD__) # define HOST_OSABI ELFOSABI_NETBSD # elif defined(__linux__) # define HOST_OSABI ELFOSABI_GNU # endif # define HOST_E_MACHINE EM_PARISC # define HOST_DIRECT_DATA_RELOC R_PARISC_DIR32 # define HOST_DIRECT_FPTR_RELOC R_PARISC_PLABEL32 # define HOST_E_FLAGS EFA_PARISC_1_0 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_IA64) # define HOST_E_MACHINE EM_IA_64 # define HOST_DIRECT_DATA_RELOC R_IA64_DIR64LSB # define HOST_DIRECT_FPTR_RELOC R_IA64_FPTR64LSB # define HOST_E_FLAGS EF_IA_64_ABI64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_AARCH64) # define HOST_E_MACHINE EM_AARCH64 # define HOST_DIRECT_DATA_RELOC R_AARCH64_ABS64 # define HOST_DIRECT_FPTR_RELOC R_AARCH64_ABS64 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_M68K) # define HOST_E_MACHINE EM_68K # define HOST_DIRECT_DATA_RELOC R_68K_32 # define HOST_DIRECT_FPTR_RELOC R_68K_32 # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_MIPS) # define HOST_E_MACHINE EM_MIPS # define HOST_DIRECT_DATA_RELOC R_MIPS_32 # define HOST_DIRECT_FPTR_RELOC R_MIPS_32 # ifdef __PIC__ # define HOST_E_FLAGS EF_MIPS_CPIC # endif # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_MIPS64) # define HOST_E_MACHINE EM_MIPS # define HOST_DIRECT_DATA_RELOC R_MIPS_64 # define HOST_DIRECT_FPTR_RELOC R_MIPS_64 # ifdef __PIC__ # define HOST_E_FLAGS (EF_MIPS_ARCH_64 | EF_MIPS_CPIC) # else # define HOST_E_FLAGS EF_MIPS_ARCH_64 # endif # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_ALPHA) # define HOST_E_MACHINE EM_ALPHA # define HOST_DIRECT_DATA_RELOC R_ALPHA_REFQUAD # define HOST_DIRECT_FPTR_RELOC R_ALPHA_REFQUAD # define USE_RELA 1 #elif defined(HOSTARCHITECTURE_RISCV32) || defined(HOSTARCHITECTURE_RISCV64) # define HOST_E_MACHINE EM_RISCV # if defined(HOSTARCHITECTURE_RISCV32) # define HOST_DIRECT_DATA_RELOC R_RISCV_32 # define HOST_DIRECT_FPTR_RELOC R_RISCV_32 # else # define HOST_DIRECT_DATA_RELOC R_RISCV_64 # define HOST_DIRECT_FPTR_RELOC R_RISCV_64 # endif # if defined(__riscv_float_abi_soft) # define HOST_E_FLAGS_FLOAT_ABI EF_RISCV_FLOAT_ABI_SOFT # elif defined(__riscv_float_abi_single) # define HOST_E_FLAGS_FLOAT_ABI EF_RISCV_FLOAT_ABI_SINGLE # elif defined(__riscv_float_abi_double) # define HOST_E_FLAGS_FLOAT_ABI EF_RISCV_FLOAT_ABI_DOUBLE # elif defined(__riscv_float_abi_quad) # define HOST_E_FLAGS_FLOAT_ABI EF_RISCV_FLOAT_ABI_QUAD # else # error "Unknown RISC-V float ABI" # endif # ifdef __riscv_32e # define HOST_E_FLAGS_RVE __riscv_32e # else # define HOST_E_FLAGS_RVE 0 # endif # define HOST_E_FLAGS (HOST_E_FLAGS_FLOAT_ABI | HOST_E_FLAGS_RVE) # define USE_RELA 1 #else # error "No support for exporting on this architecture" #endif // The first two symbols are special: // Zero is always special in ELF // 1 is used for the data section #define EXTRA_SYMBOLS 2 static unsigned AreaToSym(unsigned area) { return area+EXTRA_SYMBOLS; } // Section table entries enum { sect_initial = 0, sect_sectionnametable, sect_stringtable, // Data and relocation entries come in here. sect_data // Finally the symbol table }; // Add an external reference to the RTS void ELFExport::addExternalReference(void *relocAddr, const char *name, bool isFuncPtr) { externTable.makeEntry(name); // The symbol is added after the memory table entries and poly_exports writeRelocation(0, relocAddr, symbolNum++, isFuncPtr); } // Generate the address relative to the start of the segment. void ELFExport::setRelocationAddress(void *p, ElfXX_Addr *reloc) { unsigned area = findArea(p); POLYUNSIGNED offset = (char*)p - (char*)memTable[area].mtOriginalAddr; *reloc = offset; } /* Get the index corresponding to an address. */ PolyWord ELFExport::createRelocation(PolyWord p, void *relocAddr) { void *addr = p.AsAddress(); unsigned addrArea = findArea(addr); POLYUNSIGNED offset = (char*)addr - (char*)memTable[addrArea].mtOriginalAddr; return writeRelocation(offset, relocAddr, AreaToSym(addrArea), false); } PolyWord ELFExport::writeRelocation(POLYUNSIGNED offset, void *relocAddr, unsigned symbolNum, bool isFuncPtr) { #if USE_RELA ElfXX_Rela reloc; reloc.r_addend = offset; offset = 0; #else ElfXX_Rel reloc; #endif // Set the offset within the section we're scanning. setRelocationAddress(relocAddr, &reloc.r_offset); #ifdef HOSTARCHITECTURE_MIPS64 reloc.r_sym = symbolNum; reloc.r_ssym = 0; reloc.r_type = isFuncPtr ? HOST_DIRECT_FPTR_RELOC : HOST_DIRECT_DATA_RELOC; reloc.r_type2 = 0; reloc.r_type3 = 0; #else reloc.r_info = ELFXX_R_INFO(symbolNum, isFuncPtr ? HOST_DIRECT_FPTR_RELOC : HOST_DIRECT_DATA_RELOC); #endif fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; return PolyWord::FromUnsigned(offset); } /* This is called for each constant within the code. Print a relocation entry for the word and return a value that means that the offset is saved in original word. */ void ELFExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code) { #ifndef POLYML32IN64 PolyObject *p = GetConstantValue(addr, code); if (p == 0) return; void *a = p; unsigned aArea = findArea(a); // We don't need a relocation if this is relative to the current segment // since the relative address will already be right. if (code == PROCESS_RELOC_I386RELATIVE && aArea == findArea(addr)) return; // Set the value at the address to the offset relative to the symbol. POLYUNSIGNED offset = (char*)a - (char*)memTable[aArea].mtOriginalAddr; switch (code) { case PROCESS_RELOC_DIRECT: // 32 or 64 bit address of target { PolyWord r = createRelocation(p, addr); POLYUNSIGNED w = r.AsUnsigned(); for (unsigned i = 0; i < sizeof(PolyWord); i++) { addr[i] = (byte)(w & 0xff); w >>= 8; } } break; #if(defined(HOSTARCHITECTURE_X86) || defined(HOSTARCHITECTURE_X86_64) || \ defined(HOSTARCHITECTURE_X32)) #ifdef HOSTARCHITECTURE_X86 #define R_PC_RELATIVE R_386_PC32 #else #define R_PC_RELATIVE R_X86_64_PC32 #endif case PROCESS_RELOC_I386RELATIVE: // 32 bit relative address { #if USE_RELA ElfXX_Rela reloc; reloc.r_addend = offset; #else ElfXX_Rel reloc; #endif setRelocationAddress(addr, &reloc.r_offset); // We seem to need to subtract 4 bytes to get the correct offset in ELF offset -= 4; reloc.r_info = ELFXX_R_INFO(AreaToSym(aArea), R_PC_RELATIVE); #if USE_RELA // Clear the field. Even though it's not supposed to be used with Rela the // Linux linker at least seems to add the value in here sometimes. memset(addr, 0, 4); #else for (unsigned i = 0; i < 4; i++) { addr[i] = (byte)(offset & 0xff); offset >>= 8; } #endif fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; } break; #endif default: ASSERT(0); // Wrong type of relocation for this architecture. } #endif } unsigned long ELFExport::makeStringTableEntry(const char *str, ExportStringTable *stab) { if (str == NULL || str[0] == 0) return 0; // First entry is the null string. else return stab->makeEntry(str); } void ELFExport::writeSymbol(const char *symbolName, long value, long size, int binding, int sttype, int section) { ElfXX_Sym symbol; memset(&symbol, 0, sizeof(symbol)); // Zero unused fields symbol.st_name = makeStringTableEntry(symbolName, &symStrings); symbol.st_value = value; symbol.st_size = size; symbol.st_info = ELFXX_ST_INFO(binding, sttype); symbol.st_other = 0; symbol.st_shndx = section; fwrite(&symbol, sizeof(symbol), 1, exportFile); } // Set the file alignment. void ELFExport::alignFile(int align) { char pad[32] = {0}; // Maximum alignment int offset = ftell(exportFile); if ((offset % align) == 0) return; fwrite(&pad, align - (offset % align), 1, exportFile); } void ELFExport::createStructsRelocation(unsigned sym, size_t offset, size_t addend) { #if USE_RELA ElfXX_Rela reloc; reloc.r_addend = addend; #else ElfXX_Rel reloc; #endif reloc.r_offset = offset; #ifdef HOSTARCHITECTURE_MIPS64 reloc.r_sym = sym; reloc.r_ssym = 0; reloc.r_type = HOST_DIRECT_DATA_RELOC; reloc.r_type2 = 0; reloc.r_type3 = 0; #else reloc.r_info = ELFXX_R_INFO(sym, HOST_DIRECT_DATA_RELOC); #endif fwrite(&reloc, sizeof(reloc), 1, exportFile); relocationCount++; } void ELFExport::exportStore(void) { PolyWord *p; ElfXX_Ehdr fhdr; ElfXX_Shdr *sections = 0; #ifdef __linux__ unsigned extraSections = 1; // Extra section for .note.GNU-stack #else unsigned extraSections = 0; #endif - unsigned numSections = 6 + 2*memTableEntries /*- 1*/ + extraSections; - // The symbol table comes at the end. - unsigned sect_symtab = sect_data + 2*memTableEntries + 2/* - 1*/; - - unsigned i; + unsigned numSections = 0; + for (unsigned j = 0; j < memTableEntries; j++) + { + if ((memTable[j].mtFlags & (MTF_BYTES|MTF_WRITEABLE)) == MTF_BYTES) + numSections += 1; + else numSections += 2; + } + // The symbol table comes at the end. + unsigned sect_symtab = sect_data + numSections + 2; + numSections += 6 + extraSections; // External symbols start after the memory table entries and "poly_exports". symbolNum = EXTRA_SYMBOLS+memTableEntries+1; // Both the string tables have an initial null entry. symStrings.makeEntry(""); sectionStrings.makeEntry(""); // Write out initial values for the headers. These are overwritten at the end. // File header memset(&fhdr, 0, sizeof(fhdr)); fhdr.e_ident[EI_MAG0] = 0x7f; fhdr.e_ident[EI_MAG1] = 'E'; fhdr.e_ident[EI_MAG2] = 'L'; fhdr.e_ident[EI_MAG3] = 'F'; fhdr.e_ident[EI_CLASS] = ELFCLASSXX; // ELFCLASS32 or ELFCLASS64 fhdr.e_ident[EI_VERSION] = EV_CURRENT; #ifdef HOST_OSABI fhdr.e_ident[EI_OSABI] = HOST_OSABI; #endif { union { unsigned long wrd; char chrs[sizeof(unsigned long)]; } endian; endian.wrd = 1; if (endian.chrs[0] == 0) fhdr.e_ident[EI_DATA] = ELFDATA2MSB; // Big endian else fhdr.e_ident[EI_DATA] = ELFDATA2LSB; // Little endian } fhdr.e_type = ET_REL; // The machine needs to match the machine we're compiling for // even if this is actually portable code. fhdr.e_machine = HOST_E_MACHINE; #ifdef HOST_E_FLAGS fhdr.e_flags = HOST_E_FLAGS; #endif fhdr.e_version = EV_CURRENT; fhdr.e_shoff = sizeof(fhdr); // Offset to section header - immediately follows fhdr.e_ehsize = sizeof(fhdr); fhdr.e_shentsize = sizeof(ElfXX_Shdr); fhdr.e_shnum = numSections; fhdr.e_shstrndx = sect_sectionnametable; // Section name table section index; fwrite(&fhdr, sizeof(fhdr), 1, exportFile); // Write it for the moment. sections = new ElfXX_Shdr[numSections]; memset(sections, 0, sizeof(ElfXX_Shdr) * numSections); // Necessary? // Set up the section header but don't write it yet. // Section 0 - all zeros sections[sect_initial].sh_type = SHT_NULL; sections[sect_initial].sh_link = SHN_UNDEF; // Section name table. sections[sect_sectionnametable].sh_name = makeStringTableEntry(".shstrtab", §ionStrings); sections[sect_sectionnametable].sh_type = SHT_STRTAB; sections[sect_sectionnametable].sh_addralign = sizeof(char); // sections[sect_sectionnametable].sh_offset is set later // sections[sect_sectionnametable].sh_size is set later // Symbol name table. sections[sect_stringtable].sh_name = makeStringTableEntry(".strtab", §ionStrings); sections[sect_stringtable].sh_type = SHT_STRTAB; sections[sect_stringtable].sh_addralign = sizeof(char); // sections[sect_stringtable].sh_offset is set later // sections[sect_stringtable].sh_size is set later unsigned long dataName = makeStringTableEntry(".data", §ionStrings); unsigned long dataRelName = makeStringTableEntry(USE_RELA ? ".rela.data" : ".rel.data", §ionStrings); #ifndef CODEISNOTEXECUTABLE unsigned long textName = makeStringTableEntry(".text", §ionStrings); unsigned long textRelName = makeStringTableEntry(USE_RELA ? ".rela.text" : ".rel.text", §ionStrings); #endif // The Linux linker does not like relocations in the .rodata section and marks the executable // as containing text relocations. Putting the data in a .data.rel.ro section seems to work. - unsigned long rodataName = makeStringTableEntry(".data.rel.ro", §ionStrings); - unsigned long rodataRelName = makeStringTableEntry(USE_RELA ? ".rela.data.ro" : ".rel.data.ro", §ionStrings); + unsigned long relDataName = makeStringTableEntry(".data.rel.ro", §ionStrings); + unsigned long relDataRelName = makeStringTableEntry(USE_RELA ? ".rela.data.rel.ro" : ".rel.data.rel.ro", §ionStrings); + // Byte and other leaf data that do not require relocation can go in the .rodata section + unsigned long nRelDataName = makeStringTableEntry(".rodata", §ionStrings); // Main data sections. Each one has a relocation section. - for (i=0; i < memTableEntries; i++) + unsigned s = sect_data; + for (unsigned i=0; i < memTableEntries; i++) { - unsigned s = sect_data + i*2; sections[s].sh_addralign = 8; // 8-byte alignment sections[s].sh_type = SHT_PROGBITS; if (memTable[i].mtFlags & MTF_WRITEABLE) { // Mutable areas ASSERT(!(memTable[i].mtFlags & MTF_EXECUTABLE)); // Executable areas can't be writable. sections[s].sh_name = dataName; sections[s].sh_flags = SHF_WRITE | SHF_ALLOC; - sections[s+1].sh_name = dataRelName; // Name of relocation section + s++; + // Mutable byte areas can contain external references so need relocation + sections[s].sh_name = dataRelName; // Name of relocation section } #ifndef CODEISNOTEXECUTABLE // Not if we're building the interpreted version. else if (memTable[i].mtFlags & MTF_EXECUTABLE) { // Code areas are marked as executable. sections[s].sh_name = textName; sections[s].sh_flags = SHF_ALLOC | SHF_EXECINSTR; - sections[s+1].sh_name = textRelName; // Name of relocation section + s++; + sections[s].sh_name = textRelName; // Name of relocation section } #endif - else + else if (memTable[i].mtFlags & MTF_BYTES) { + // Data that does not require relocation. // Non-code immutable areas - sections[s].sh_name = rodataName; + sections[s].sh_name = nRelDataName; sections[s].sh_flags = SHF_ALLOC; - sections[s+1].sh_name = rodataRelName; // Name of relocation section + s++; + continue; // Skip the relocation section for this + } + else + { + // Non-code immutable areas + sections[s].sh_name = relDataName; + // The .data.rel.ro has to be writable in order to be relocated. + // It is set to read-only after relocation. + sections[s].sh_flags = SHF_WRITE | SHF_ALLOC; + s++; + sections[s].sh_name = relDataRelName; // Name of relocation section } // sections[s].sh_size is set later // sections[s].sh_offset is set later. // sections[s].sh_size is set later. // Relocation section - sections[s+1].sh_type = USE_RELA ? SHT_RELA : SHT_REL; // Contains relocation with/out explicit addends (ElfXX_Rel) - sections[s+1].sh_link = sect_symtab; // Index to symbol table - sections[s+1].sh_info = s; // Applies to the data section - sections[s+1].sh_addralign = sizeof(long); // Align to a word - sections[s+1].sh_entsize = USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel); + sections[s].sh_type = USE_RELA ? SHT_RELA : SHT_REL; // Contains relocation with/out explicit addends (ElfXX_Rel) + sections[s].sh_link = sect_symtab; // Index to symbol table + sections[s].sh_info = s-1; // Applies to the data section + sections[s].sh_addralign = sizeof(long); // Align to a word + sections[s].sh_entsize = USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel); + s++; // sections[s+1].sh_offset is set later. // sections[s+1].sh_size is set later. } // Table data - Poly tables that describe the memory layout. - unsigned sect_table_data = sect_data + 2*memTableEntries; + unsigned sect_table_data = s; sections[sect_table_data].sh_name = dataName; sections[sect_table_data].sh_type = SHT_PROGBITS; sections[sect_table_data].sh_flags = SHF_WRITE | SHF_ALLOC; sections[sect_table_data].sh_addralign = 8; // 8-byte alignment // Table relocation sections[sect_table_data+1].sh_name = dataRelName; sections[sect_table_data+1].sh_type = USE_RELA ? SHT_RELA : SHT_REL; // Contains relocation with/out explicit addends (ElfXX_Rel) sections[sect_table_data+1].sh_link = sect_symtab; // Index to symbol table sections[sect_table_data+1].sh_info = sect_table_data; // Applies to table section sections[sect_table_data+1].sh_addralign = sizeof(long); // Align to a word sections[sect_table_data+1].sh_entsize = USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel); // Symbol table. sections[sect_symtab].sh_name = makeStringTableEntry(".symtab", §ionStrings); sections[sect_symtab].sh_type = SHT_SYMTAB; sections[sect_symtab].sh_link = sect_stringtable; // String table to use sections[sect_symtab].sh_addralign = sizeof(long); // Align to a word sections[sect_symtab].sh_entsize = sizeof(ElfXX_Sym); // sections[sect_symtab].sh_info is set later // sections[sect_symtab].sh_size is set later // sections[sect_symtab].sh_offset is set later #ifdef __linux__ // Add a .note.GNU-stack section to indicate this does not require executable stack sections[numSections-1].sh_name = makeStringTableEntry(".note.GNU-stack", §ionStrings); sections[numSections - 1].sh_type = SHT_PROGBITS; #endif // Write the relocations. - - for (i = 0; i < memTableEntries; i++) + unsigned relocSection = sect_data; + for (unsigned i = 0; i < memTableEntries; i++) { - unsigned relocSection = sect_data + i*2 + 1; + relocSection++; + if ((memTable[i].mtFlags & (MTF_BYTES|MTF_WRITEABLE)) == MTF_BYTES) + continue; alignFile(sections[relocSection].sh_addralign); sections[relocSection].sh_offset = ftell(exportFile); relocationCount = 0; // Create the relocation table and turn all addresses into offsets. char *start = (char*)memTable[i].mtOriginalAddr; char *end = start + memTable[i].mtLength; for (p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); // Update any constants before processing the object // We need that for relative jumps/calls in X86/64. if (length != 0 && obj->IsCodeObject()) machineDependent->ScanConstantsWithinCode(obj, this); relocateObject(obj); p += length; } sections[relocSection].sh_size = relocationCount * (USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel)); + relocSection++; } // Relocations for "exports" and "memTable"; alignFile(sections[sect_table_data+1].sh_addralign); sections[sect_table_data+1].sh_offset = ftell(exportFile); relocationCount = 0; // TODO: This won't be needed if we put these in a separate section. POLYUNSIGNED areaSpace = 0; - for (i = 0; i < memTableEntries; i++) + for (unsigned i = 0; i < memTableEntries; i++) areaSpace += memTable[i].mtLength; // Address of "memTable" within "exports". We can't use createRelocation because // the position of the relocation is not in either the mutable or the immutable area. size_t memTableOffset = sizeof(exportDescription); // It follows immediately after this. createStructsRelocation(AreaToSym(memTableEntries), offsetof(exportDescription, memTable), memTableOffset); // Address of "rootFunction" within "exports" unsigned rootAddrArea = findArea(rootFunction); size_t rootOffset = (char*)rootFunction - (char*)memTable[rootAddrArea].mtOriginalAddr; createStructsRelocation(AreaToSym(rootAddrArea), offsetof(exportDescription, rootFunction), rootOffset); // Addresses of the areas within memtable. - for (i = 0; i < memTableEntries; i++) + for (unsigned i = 0; i < memTableEntries; i++) { createStructsRelocation(AreaToSym(i), sizeof(exportDescription) + i * sizeof(memoryTableEntry) + offsetof(memoryTableEntry, mtCurrentAddr), 0 /* No offset relative to base symbol*/); } sections[sect_table_data+1].sh_size = relocationCount * (USE_RELA ? sizeof(ElfXX_Rela) : sizeof(ElfXX_Rel)); // Now the symbol table. alignFile(sections[sect_symtab].sh_addralign); sections[sect_symtab].sh_offset = ftell(exportFile); writeSymbol("", 0, 0, 0, 0, 0); // Initial symbol // Write the local symbols first. writeSymbol("", 0, 0, STB_LOCAL, STT_SECTION, sect_data); // .data section // Create symbols for the address areas. AreaToSym assumes these come first. - for (i = 0; i < memTableEntries; i++) + s = sect_data; + for (unsigned i = 0; i < memTableEntries; i++) { - unsigned s = sect_data + i*2; char buff[50]; sprintf(buff, "area%1u", i); writeSymbol(buff, 0, 0, STB_LOCAL, STT_OBJECT, s); + if ((memTable[i].mtFlags & (MTF_BYTES|MTF_WRITEABLE)) == MTF_BYTES) + s += 1; + else s += 2; } // Global symbols - Exported symbol for table. writeSymbol("poly_exports", 0, sizeof(exportDescription)+sizeof(memoryTableEntry)*memTableEntries, STB_GLOBAL, STT_OBJECT, sect_table_data); // External references for (unsigned i = 0; i < externTable.stringSize; i += (unsigned)strlen(externTable.strings+i) + 1) writeSymbol(externTable.strings+i, 0, 0, STB_GLOBAL, STT_FUNC, SHN_UNDEF); sections[sect_symtab].sh_info = EXTRA_SYMBOLS+memTableEntries; // One more than last local sym sections[sect_symtab].sh_size = sizeof(ElfXX_Sym) * symbolNum; // Now the binary data. - for (i = 0; i < memTableEntries; i++) + unsigned dataSection = sect_data; + for (unsigned i = 0; i < memTableEntries; i++) { - unsigned dataSection = sect_data + i*2; sections[dataSection].sh_size = memTable[i].mtLength; alignFile(sections[dataSection].sh_addralign); sections[dataSection].sh_offset = ftell(exportFile); fwrite(memTable[i].mtOriginalAddr, 1, memTable[i].mtLength, exportFile); + if ((memTable[i].mtFlags & (MTF_BYTES|MTF_WRITEABLE)) == MTF_BYTES) + dataSection += 1; + else dataSection += 2; } exportDescription exports; memset(&exports, 0, sizeof(exports)); exports.structLength = sizeof(exportDescription); exports.memTableSize = sizeof(memoryTableEntry); exports.memTableEntries = memTableEntries; exports.memTable = USE_RELA ? 0 : (memoryTableEntry *)memTableOffset; // Set the value to be the offset relative to the base of the area. We have set a relocation // already which will add the base of the area. exports.rootFunction = USE_RELA ? 0 : (void*)rootOffset; exports.timeStamp = getBuildTime(); exports.architecture = machineDependent->MachineArchitecture(); exports.rtsVersion = POLY_version_number; #ifdef POLYML32IN64 exports.originalBaseAddr = globalHeapBase; #else exports.originalBaseAddr = 0; #endif // Set the address values to zero before we write. They will always // be relative to their base symbol. - for (i = 0; i < memTableEntries; i++) + for (unsigned i = 0; i < memTableEntries; i++) memTable[i].mtCurrentAddr = 0; // Now the binary data. alignFile(sections[sect_table_data].sh_addralign); sections[sect_table_data].sh_offset = ftell(exportFile); sections[sect_table_data].sh_size = sizeof(exportDescription) + memTableEntries*sizeof(memoryTableEntry); fwrite(&exports, sizeof(exports), 1, exportFile); fwrite(memTable, sizeof(memoryTableEntry), memTableEntries, exportFile); // The section name table sections[sect_sectionnametable].sh_offset = ftell(exportFile); fwrite(sectionStrings.strings, sectionStrings.stringSize, 1, exportFile); sections[sect_sectionnametable].sh_size = sectionStrings.stringSize; // The symbol name table sections[sect_stringtable].sh_offset = ftell(exportFile); fwrite(symStrings.strings, symStrings.stringSize, 1, exportFile); sections[sect_stringtable].sh_size = symStrings.stringSize; // Finally the section headers. alignFile(4); fhdr.e_shoff = ftell(exportFile); fwrite(sections, sizeof(ElfXX_Shdr) * numSections, 1, exportFile); // Rewind to rewrite the file header with the offset of the section headers. rewind(exportFile); fwrite(&fhdr, sizeof(fhdr), 1, exportFile); fclose(exportFile); exportFile = NULL; delete[]sections; } diff --git a/libpolyml/exporter.cpp b/libpolyml/exporter.cpp index d1278bab..96a1f056 100644 --- a/libpolyml/exporter.cpp +++ b/libpolyml/exporter.cpp @@ -1,929 +1,926 @@ /* Title: exporter.cpp - Export a function as an object or C file Copyright (c) 2006-7, 2015, 2016-20 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #if (defined(_WIN32)) #include #else #define _T(x) x #define _tcslen strlen #define _tcscmp strcmp #define _tcscat strcat #endif #include "exporter.h" #include "save_vec.h" #include "polystring.h" #include "run_time.h" #include "osmem.h" #include "scanaddrs.h" #include "gc.h" #include "machine_dep.h" #include "diagnostics.h" #include "memmgr.h" #include "processes.h" // For IO_SPACING #include "sys.h" // For EXC_Fail #include "rtsentry.h" #include "pexport.h" #ifdef HAVE_PECOFF #include "pecoffexport.h" #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) #include "elfexport.h" #elif defined(HAVE_MACH_O_RELOC_H) #include "machoexport.h" #endif #if (defined(_WIN32)) #define NOMEMORY ERROR_NOT_ENOUGH_MEMORY #define ERRORNUMBER _doserrno #else #define NOMEMORY ENOMEM #define ERRORNUMBER errno #endif extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root); POLYEXTERNALSYMBOL POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord root); } /* To export the function and everything reachable from it we need to copy all the objects into a new area. We leave tombstones in the original objects by overwriting the length word. That prevents us from copying an object twice and breaks loops. Once we've copied the objects we then have to go back over the memory and turn the tombstones back into length words. */ GraveYard::~GraveYard() { free(graves); } // Used to calculate the space required for the ordinary mutables // and the no-overwrite mutables. They are interspersed in local space. class MutSizes : public ScanAddress { public: MutSizes() : mutSize(0), noOverSize(0) {} virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; }// No Actually used virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord) { const POLYUNSIGNED words = OBJ_OBJECT_LENGTH(lengthWord) + 1; // Include length word if (OBJ_IS_NO_OVERWRITE(lengthWord)) noOverSize += words; else mutSize += words; } POLYUNSIGNED mutSize, noOverSize; }; CopyScan::CopyScan(unsigned h/*=0*/): hierarchy(h) { defaultImmSize = defaultMutSize = defaultCodeSize = defaultNoOverSize = 0; tombs = 0; graveYard = 0; } void CopyScan::initialise(bool isExport/*=true*/) { ASSERT(gMem.eSpaces.size() == 0); // Set the space sizes to a proportion of the space currently in use. // Computing these sizes is not obvious because CopyScan is used both // for export and for saved states. For saved states in particular we // want to use a smaller size because they are retained after we save // the state and if we have many child saved states it's important not // to waste memory. if (hierarchy == 0) { graveYard = new GraveYard[gMem.pSpaces.size()]; if (graveYard == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate graveyard, size: %lu.\n", gMem.pSpaces.size()); throw MemoryException(); } } for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->hierarchy >= hierarchy) { // Include this if we're exporting (hierarchy=0) or if we're saving a state // and will include this in the new state. size_t size = (space->top-space->bottom)/4; if (space->noOverwrite) defaultNoOverSize += size; else if (space->isMutable) defaultMutSize += size; else if (space->isCode) defaultCodeSize += size; else defaultImmSize += size; if (space->hierarchy == 0 && ! space->isMutable) { // We need a separate area for the tombstones because this is read-only graveYard[tombs].graves = (PolyWord*)calloc(space->spaceSize(), sizeof(PolyWord)); if (graveYard[tombs].graves == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate graveyard for permanent space, size: %lu.\n", space->spaceSize() * sizeof(PolyWord)); throw MemoryException(); } if (debugOptions & DEBUG_SAVING) Log("SAVE: Allocated graveyard for permanent space, %p size: %lu.\n", graveYard[tombs].graves, space->spaceSize() * sizeof(PolyWord)); graveYard[tombs].startAddr = space->bottom; graveYard[tombs].endAddr = space->top; tombs++; } } } for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; uintptr_t size = space->allocatedSpace(); // It looks as though the mutable size generally gets // overestimated while the immutable size is correct. if (space->isMutable) { MutSizes sizeMut; sizeMut.ScanAddressesInRegion(space->bottom, space->lowerAllocPtr); sizeMut.ScanAddressesInRegion(space->upperAllocPtr, space->top); defaultNoOverSize += sizeMut.noOverSize / 4; defaultMutSize += sizeMut.mutSize / 4; } else defaultImmSize += size/2; } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; uintptr_t size = space->spaceSize(); defaultCodeSize += size/2; } if (isExport) { // Minimum 1M words. if (defaultMutSize < 1024*1024) defaultMutSize = 1024*1024; if (defaultImmSize < 1024*1024) defaultImmSize = 1024*1024; if (defaultCodeSize < 1024*1024) defaultCodeSize = 1024*1024; #ifdef MACOSX // Limit the segment size for Mac OS X. The linker has a limit of 2^24 relocations // in a segment so this is a crude way of ensuring the limit isn't exceeded. // It's unlikely to be exceeded by the code itself. // Actually, from trial-and-error, the limit seems to be around 6M. if (defaultMutSize > 6 * 1024 * 1024) defaultMutSize = 6 * 1024 * 1024; if (defaultImmSize > 6 * 1024 * 1024) defaultImmSize = 6 * 1024 * 1024; #endif if (defaultNoOverSize < 4096) defaultNoOverSize = 4096; // Except for the no-overwrite area } else { // Much smaller minimum sizes for saved states. if (defaultMutSize < 1024) defaultMutSize = 1024; if (defaultImmSize < 4096) defaultImmSize = 4096; if (defaultCodeSize < 4096) defaultCodeSize = 4096; if (defaultNoOverSize < 4096) defaultNoOverSize = 4096; // Set maximum sizes as well. We may have insufficient contiguous space for // very large areas. if (defaultMutSize > 1024 * 1024) defaultMutSize = 1024 * 1024; if (defaultImmSize > 1024 * 1024) defaultImmSize = 1024 * 1024; if (defaultCodeSize > 1024 * 1024) defaultCodeSize = 1024 * 1024; if (defaultNoOverSize > 1024 * 1024) defaultNoOverSize = 1024 * 1024; } if (debugOptions & DEBUG_SAVING) Log("SAVE: Copyscan default sizes: Immutable: %" POLYUFMT ", Mutable: %" POLYUFMT ", Code: %" POLYUFMT ", No-overwrite %" POLYUFMT ".\n", defaultImmSize, defaultMutSize, defaultCodeSize, defaultNoOverSize); } CopyScan::~CopyScan() { gMem.DeleteExportSpaces(); if (graveYard) delete[](graveYard); } // This function is called for each address in an object // once it has been copied to its new location. We copy first // then scan to update the addresses. POLYUNSIGNED CopyScan::ScanAddressAt(PolyWord *pt) { PolyWord val = *pt; // Ignore integers. if (IS_INT(val) || val == PolyWord::FromUnsigned(0)) return 0; PolyObject *obj = val.AsObjPtr(); POLYUNSIGNED l = ScanAddress(&obj); *pt = obj; return l; } // This function is called for each address in an object // once it has been copied to its new location. We copy first // then scan to update the addresses. POLYUNSIGNED CopyScan::ScanAddress(PolyObject **pt) { PolyObject *obj = *pt; MemSpace *space = gMem.SpaceForObjectAddress(obj); ASSERT(space != 0); // We may sometimes get addresses that have already been updated // to point to the new area. e.g. (only?) in the case of constants // that have been updated in ScanConstantsWithinCode. if (space->spaceType == ST_EXPORT) return 0; // If this is at a lower level than the hierarchy we are saving // then leave it untouched. if (space->spaceType == ST_PERMANENT) { PermanentMemSpace *pmSpace = (PermanentMemSpace*)space; if (pmSpace->hierarchy < hierarchy) return 0; } // Have we already scanned this? if (obj->ContainsForwardingPtr()) { // Update the address to the new value. #ifdef POLYML32IN64 PolyObject *newAddr; if (space->isCode) newAddr = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else newAddr = obj->GetForwardingPtr(); #else PolyObject *newAddr = obj->GetForwardingPtr(); #endif *pt = newAddr; return 0; // No need to scan it again. } else if (space->spaceType == ST_PERMANENT) { // See if we have this in the grave-yard. for (unsigned i = 0; i < tombs; i++) { GraveYard *g = &graveYard[i]; if ((PolyWord*)obj >= g->startAddr && (PolyWord*)obj < g->endAddr) { PolyWord *tombAddr = g->graves + ((PolyWord*)obj - g->startAddr); PolyObject *tombObject = (PolyObject*)tombAddr; if (tombObject->ContainsForwardingPtr()) { #ifdef POLYML32IN64 PolyObject *newAddr; if (space->isCode) newAddr = (PolyObject*)(globalCodeBase + ((tombObject->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else newAddr = tombObject->GetForwardingPtr(); #else PolyObject *newAddr = tombObject->GetForwardingPtr(); #endif *pt = newAddr; return 0; } break; // No need to look further } } } // No, we need to copy it. ASSERT(space->spaceType == ST_LOCAL || space->spaceType == ST_PERMANENT || space->spaceType == ST_CODE); POLYUNSIGNED lengthWord = obj->LengthWord(); POLYUNSIGNED words = OBJ_OBJECT_LENGTH(lengthWord); PolyObject *newObj = 0; - PolyObject* writeAble = 0; + PolyObject* writAble = 0; bool isMutableObj = obj->IsMutable(); bool isNoOverwrite = false; - bool isByteObj = false; + bool isByteObj = obj->IsByteObject(); bool isCodeObj = false; if (isMutableObj) - { isNoOverwrite = obj->IsNoOverwriteObject(); - isByteObj = obj->IsByteObject(); - } else isCodeObj = obj->IsCodeObject(); // Allocate a new address for the object. for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { PermanentMemSpace *space = *i; if (isMutableObj == space->isMutable && isNoOverwrite == space->noOverwrite && isByteObj == space->byteOnly && isCodeObj == space->isCode) { ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom); size_t spaceLeft = space->top - space->topPointer; if (spaceLeft > words) { newObj = (PolyObject*)(space->topPointer + 1); - writeAble = space->writeAble(newObj); + writAble = space->writeAble(newObj); space->topPointer += words + 1; #ifdef POLYML32IN64 // Maintain the odd-word alignment of topPointer if ((words & 1) == 0 && space->topPointer < space->top) { *space->writeAble(space->topPointer) = PolyWord::FromUnsigned(0); space->topPointer++; } #endif break; } } } if (newObj == 0) { // Didn't find room in the existing spaces. Create a new space. uintptr_t spaceWords; if (isMutableObj) { if (isNoOverwrite) spaceWords = defaultNoOverSize; else spaceWords = defaultMutSize; } else { if (isCodeObj) spaceWords = defaultCodeSize; else spaceWords = defaultImmSize; } if (spaceWords <= words) spaceWords = words + 1; // Make sure there's space for this object. PermanentMemSpace *space = gMem.NewExportSpace(spaceWords, isMutableObj, isNoOverwrite, isCodeObj); if (isByteObj) space->byteOnly = true; if (space == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to allocate export space, size: %lu.\n", spaceWords); // Unable to allocate this. throw MemoryException(); } newObj = (PolyObject*)(space->topPointer + 1); - writeAble = space->writeAble(newObj); + writAble = space->writeAble(newObj); space->topPointer += words + 1; #ifdef POLYML32IN64 // Maintain the odd-word alignment of topPointer if ((words & 1) == 0 && space->topPointer < space->top) { *space->writeAble(space->topPointer) = PolyWord::FromUnsigned(0); space->topPointer++; } #endif ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom); } - writeAble->SetLengthWord(lengthWord); // copy length word + writAble->SetLengthWord(lengthWord); // copy length word if (hierarchy == 0 /* Exporting object module */ && isNoOverwrite && isMutableObj && !isByteObj) { // These are not exported. They are used for special values e.g. mutexes // that should be set to 0/nil/NONE at start-up. // Weak+No-overwrite byte objects are used for entry points and volatiles // in the foreign-function interface and have to be treated specially. // Note: this must not be done when exporting a saved state because the // copied version is used as the local data for the rest of the session. for (POLYUNSIGNED i = 0; i < words; i++) - writeAble->Set(i, TAGGED(0)); + writAble->Set(i, TAGGED(0)); } - else memcpy(writeAble, obj, words * sizeof(PolyWord)); + else memcpy(writAble, obj, words * sizeof(PolyWord)); if (space->spaceType == ST_PERMANENT && !space->isMutable && ((PermanentMemSpace*)space)->hierarchy == 0) { // The immutable permanent areas are read-only. unsigned m; for (m = 0; m < tombs; m++) { GraveYard *g = &graveYard[m]; if ((PolyWord*)obj >= g->startAddr && (PolyWord*)obj < g->endAddr) { PolyWord *tombAddr = g->graves + ((PolyWord*)obj - g->startAddr); PolyObject *tombObject = (PolyObject*)tombAddr; #ifdef POLYML32IN64 if (isCodeObj) { POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj - globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT); tombObject->SetLengthWord(ll); } else tombObject->SetForwardingPtr(newObj); #else tombObject->SetForwardingPtr(newObj); #endif break; // No need to look further } } ASSERT(m < tombs); // Should be there. } else if (isCodeObj) #ifdef POLYML32IN64 // If this is a code address we can't use the usual forwarding pointer format. // Instead we have to compute the offset relative to the base of the code. { POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj-globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT); gMem.SpaceForObjectAddress(obj)->writeAble(obj)->SetLengthWord(ll); } #else gMem.SpaceForObjectAddress(obj)->writeAble(obj)->SetForwardingPtr(newObj); #endif else obj->SetForwardingPtr(newObj); // Put forwarding pointer in old object. if (OBJ_IS_CODE_OBJECT(lengthWord)) { // We don't need to worry about flushing the instruction cache // since we're not going to execute this code here. // We do have to update any relative addresses within the code // to take account of its new position. We have to do that now // even though ScanAddressesInObject will do it again because this // is the only point where we have both the old and the new addresses. machineDependent->ScanConstantsWithinCode(newObj, obj, words, this); } *pt = newObj; // Update it to the newly copied object. return lengthWord; // This new object needs to be scanned. } // The address of code in the code area. We treat this as a normal heap cell. // We will probably need to copy this and to process addresses within it. POLYUNSIGNED CopyScan::ScanCodeAddressAt(PolyObject **pt) { POLYUNSIGNED lengthWord = ScanAddress(pt); if (lengthWord) ScanAddressesInObject(*pt, lengthWord); return 0; } PolyObject *CopyScan::ScanObjectAddress(PolyObject *base) { PolyWord val = base; // Scan this as an address. POLYUNSIGNED lengthWord = CopyScan::ScanAddressAt(&val); if (lengthWord) ScanAddressesInObject(val.AsObjPtr(), lengthWord); return val.AsObjPtr(); } #define MAX_EXTENSION 4 // The longest extension we may need to add is ".obj" // Convert the forwarding pointers in a region back into length words. // Generally if this object has a forwarding pointer that's // because we've moved it into the export region. We can, // though, get multiple levels of forwarding if there is an object // that has been shifted up by a garbage collection, leaving a forwarding // pointer and then that object has been moved to the export region. // We mustn't turn locally forwarded values back into ordinary objects // because they could contain addresses that are no longer valid. static POLYUNSIGNED GetObjLength(PolyObject *obj) { if (obj->ContainsForwardingPtr()) { PolyObject *forwardedTo; #ifdef POLYML32IN64 { MemSpace *space = gMem.SpaceForObjectAddress(obj); if (space->isCode) forwardedTo = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1)); else forwardedTo = obj->GetForwardingPtr(); } #else forwardedTo = obj->GetForwardingPtr(); #endif POLYUNSIGNED length = GetObjLength(forwardedTo); MemSpace *space = gMem.SpaceForObjectAddress(forwardedTo); if (space->spaceType == ST_EXPORT) gMem.SpaceForObjectAddress(obj)->writeAble(obj)->SetLengthWord(length); return length; } else { ASSERT(obj->ContainsNormalLengthWord()); return obj->LengthWord(); } } static void FixForwarding(PolyWord *pt, size_t space) { while (space) { pt++; PolyObject *obj = (PolyObject*)pt; #ifdef POLYML32IN64 if ((uintptr_t)obj & 4) { // Skip filler words needed to align to an even word space--; continue; // We've added 1 to pt so just loop. } #endif size_t length = OBJ_OBJECT_LENGTH(GetObjLength(obj)); pt += length; ASSERT(space > length); space -= length+1; } } class ExportRequest: public MainThreadRequest { public: ExportRequest(Handle root, Exporter *exp): MainThreadRequest(MTP_EXPORTING), exportRoot(root), exporter(exp) {} virtual void Perform() { exporter->RunExport(exportRoot->WordP()); } Handle exportRoot; Exporter *exporter; }; static void exporter(TaskData *taskData, Handle fileName, Handle root, const TCHAR *extension, Exporter *exports) { size_t extLen = _tcslen(extension); TempString fileNameBuff(Poly_string_to_T_alloc(fileName->Word(), extLen)); if (fileNameBuff == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY); size_t length = _tcslen(fileNameBuff); // Does it already have the extension? If not add it on. if (length < extLen || _tcscmp(fileNameBuff + length - extLen, extension) != 0) _tcscat(fileNameBuff, extension); #if (defined(_WIN32) && defined(UNICODE)) exports->exportFile = _wfopen(fileNameBuff, L"wb"); #else exports->exportFile = fopen(fileNameBuff, "wb"); #endif if (exports->exportFile == NULL) raise_syscall(taskData, "Cannot open export file", ERRORNUMBER); // Request a full GC to reduce the size of fix-ups. FullGC(taskData); // Request the main thread to do the export. ExportRequest request(root, exports); processes->MakeRootRequest(taskData, &request); if (exports->errorMessage) raise_fail(taskData, exports->errorMessage); } // This is called by the initial thread to actually do the export. void Exporter::RunExport(PolyObject *rootFunction) { Exporter *exports = this; PolyObject *copiedRoot = 0; CopyScan copyScan(hierarchy); try { copyScan.initialise(); // Copy the root and everything reachable from it into the temporary area. copiedRoot = copyScan.ScanObjectAddress(rootFunction); } catch (MemoryException &) { // If we ran out of memory. copiedRoot = 0; } // Fix the forwarding pointers. for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++) { LocalMemSpace *space = *i; // Local areas only have objects from the allocation pointer to the top. FixForwarding(space->bottom, space->lowerAllocPtr - space->bottom); FixForwarding(space->upperAllocPtr, space->top - space->upperAllocPtr); } for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. FixForwarding(space->bottom, space->top - space->bottom); } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { MemSpace *space = *i; // Code areas are filled with objects from the bottom. FixForwarding(space->bottom, space->top - space->bottom); } // Reraise the exception after cleaning up the forwarding pointers. if (copiedRoot == 0) { exports->errorMessage = "Insufficient Memory"; return; } // Copy the areas into the export object. size_t tableEntries = gMem.eSpaces.size(); unsigned memEntry = 0; if (hierarchy != 0) tableEntries += gMem.pSpaces.size(); exports->memTable = new memoryTableEntry[tableEntries]; // If we're constructing a module we need to include the global spaces. if (hierarchy != 0) { // Permanent spaces from the executable. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { PermanentMemSpace *space = *i; if (space->hierarchy < hierarchy) { memoryTableEntry *entry = &exports->memTable[memEntry++]; entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom; entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord); entry->mtIndex = space->index; entry->mtFlags = 0; if (space->isMutable) entry->mtFlags |= MTF_WRITEABLE; if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; } } newAreas = memEntry; } for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++) { memoryTableEntry *entry = &exports->memTable[memEntry++]; PermanentMemSpace *space = *i; entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom; entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord); entry->mtIndex = hierarchy == 0 ? memEntry-1 : space->index; entry->mtFlags = 0; if (space->isMutable) { entry->mtFlags = MTF_WRITEABLE; if (space->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE; } if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE; if (space->byteOnly) entry->mtFlags |= MTF_BYTES; } ASSERT(memEntry == tableEntries); exports->memTableEntries = memEntry; exports->rootFunction = copiedRoot; try { // This can raise MemoryException at least in PExport::exportStore. exports->exportStore(); } catch (MemoryException &) { exports->errorMessage = "Insufficient Memory"; } } // Functions called via the RTS call. Handle exportNative(TaskData *taskData, Handle args) { #ifdef HAVE_PECOFF // Windows including Cygwin #if (defined(_WIN32)) const TCHAR *extension = _T(".obj"); // Windows #else const char *extension = ".o"; // Cygwin #endif PECOFFExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) // Most Unix including Linux, FreeBSD and Solaris. const char *extension = ".o"; ELFExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #elif defined(HAVE_MACH_O_RELOC_H) // Mac OS-X const char *extension = ".o"; MachoExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports); #else raise_exception_string (taskData, EXC_Fail, "Native export not available for this platform"); #endif return taskData->saveVec.push(TAGGED(0)); } Handle exportPortable(TaskData *taskData, Handle args) { PExport exports; exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)), taskData->saveVec.push(args->WordP()->Get(1)), _T(".txt"), &exports); return taskData->saveVec.push(TAGGED(0)); } POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedName = taskData->saveVec.push(fileName); Handle pushedRoot = taskData->saveVec.push(root); try { #ifdef HAVE_PECOFF // Windows including Cygwin #if (defined(_WIN32)) const TCHAR *extension = _T(".obj"); // Windows #else const char *extension = ".o"; // Cygwin #endif PECOFFExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H) // Most Unix including Linux, FreeBSD and Solaris. const char *extension = ".o"; ELFExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #elif defined(HAVE_MACH_O_RELOC_H) // Mac OS-X const char *extension = ".o"; MachoExport exports; exporter(taskData, pushedName, pushedRoot, extension, &exports); #else raise_exception_string (taskData, EXC_Fail, "Native export not available for this platform"); #endif } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Returns unit } POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord root) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedName = taskData->saveVec.push(fileName); Handle pushedRoot = taskData->saveVec.push(root); try { PExport exports; exporter(taskData, pushedName, pushedRoot, _T(".txt"), &exports); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); // Returns unit } // Helper functions for exporting. We need to produce relocation information // and this code is common to every method. Exporter::Exporter(unsigned int h): exportFile(NULL), errorMessage(0), hierarchy(h), memTable(0), newAreas(0) { } Exporter::~Exporter() { delete[](memTable); if (exportFile) fclose(exportFile); } void Exporter::relocateValue(PolyWord *pt) { #ifndef POLYML32IN64 PolyWord q = *pt; if (IS_INT(q) || q == PolyWord::FromUnsigned(0)) {} else createRelocation(pt); #endif } void Exporter::createRelocation(PolyWord* pt) { *gMem.SpaceForAddress(pt)->writeAble(pt) = createRelocation(*pt, pt); } // Check through the areas to see where the address is. It must be // in one of them. unsigned Exporter::findArea(void *p) { for (unsigned i = 0; i < memTableEntries; i++) { if (p > memTable[i].mtOriginalAddr && p <= (char*)memTable[i].mtOriginalAddr + memTable[i].mtLength) return i; } { ASSERT(0); } return 0; } void Exporter::relocateObject(PolyObject *p) { if (p->IsByteObject()) { if (p->IsMutable() && p->IsWeakRefObject()) { // Weak mutable byte refs are used for external references and // also in the FFI for non-persistent values. bool isFuncPtr = true; const char *entryName = getEntryPointName(p, &isFuncPtr); if (entryName != 0) addExternalReference(p, entryName, isFuncPtr); // Clear the first word of the data. ASSERT(p->Length() >= sizeof(uintptr_t)/sizeof(PolyWord)); *(uintptr_t*)p = 0; } } else if (p->IsCodeObject()) { POLYUNSIGNED constCount; PolyWord *cp; ASSERT(! p->IsMutable() ); p->GetConstSegmentForCode(cp, constCount); /* Now the constants. */ for (POLYUNSIGNED i = 0; i < constCount; i++) relocateValue(&(cp[i])); } else // Closure and ordinary objects { POLYUNSIGNED length = p->Length(); for (POLYUNSIGNED i = 0; i < length; i++) relocateValue(p->Offset(i)); } } ExportStringTable::ExportStringTable(): strings(0), stringSize(0), stringAvailable(0) { } ExportStringTable::~ExportStringTable() { free(strings); } // Add a string to the string table, growing it if necessary. unsigned long ExportStringTable::makeEntry(const char *str) { unsigned len = (unsigned)strlen(str); unsigned long entry = stringSize; if (stringSize + len + 1 > stringAvailable) { stringAvailable = stringAvailable+stringAvailable/2; if (stringAvailable < stringSize + len + 1) stringAvailable = stringSize + len + 1 + 500; char* newStrings = (char*)realloc(strings, stringAvailable); if (newStrings == 0) { if (debugOptions & DEBUG_SAVING) Log("SAVE: Unable to realloc string table, size: %lu.\n", stringAvailable); throw MemoryException(); } else strings = newStrings; } strcpy(strings + stringSize, str); stringSize += len + 1; return entry; } struct _entrypts exporterEPT[] = { { "PolyExport", (polyRTSFunction)&PolyExport}, { "PolyExportPortable", (polyRTSFunction)&PolyExportPortable}, { NULL, NULL} // End of list. }; diff --git a/libpolyml/globals.h b/libpolyml/globals.h index ed6e7f8c..63e0f8e1 100644 --- a/libpolyml/globals.h +++ b/libpolyml/globals.h @@ -1,428 +1,436 @@ /* Title: Globals for the system. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright David C. J. Matthews 2017-20 Copyright (c) 2000-7 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifndef _GLOBALS_H #define _GLOBALS_H /* Poly words, pointers and cells (objects). The garbage collector needs to be able to distinguish different uses of a memory word. We need to be able find which words are pointers to other objects and which are simple integers. The simple distinction is between integers, which are tagged by having the bottom bit set, and Addresses which are word aligned (bottom 2 bits zero on a 32 bit machine, bottom 3 bits on a 64 bit machine, bottom bit in 32-in-64). Addresses always point to the start of cells. The preceding word of a cell is the length word. This contains the length of the cell in words in the low-order 3 (7 in native 64-bits) bytes and a flag byte in the top byte. The flags give information about the type of the object. The length word is also used by the garbage collector and other object processors. */ #if HAVE_STDINT_H # include #endif #if HAVE_INTTYPES_H # ifndef __STDC_FORMAT_MACROS # define __STDC_FORMAT_MACROS # endif # include #elif (defined(_MSC_VER) && (_MSC_VER >= 1900)) // In VS 2015 and later we need to use # include #endif #ifdef HAVE_STDDEF_H # include #endif #define POLY_TAGSHIFT 1 #if (defined(_WIN32)) # include #endif #ifdef POLYML32IN64 typedef int32_t POLYSIGNED; typedef uint32_t POLYUNSIGNED; #define SIZEOF_POLYWORD 4 #else typedef intptr_t POLYSIGNED; typedef uintptr_t POLYUNSIGNED; #define SIZEOF_POLYWORD SIZEOF_VOIDP #endif // libpolyml uses printf-style I/O instead of C++ standard IOstreams, // so we need specifier to format POLYUNSIGNED/POLYSIGNED values. #ifdef POLYML32IN64 #if (defined(PRIu32)) # define POLYUFMT PRIu32 # define POLYSFMT PRId32 #elif (defined(_MSC_VER)) # define POLYUFMT "lu" # define POLYSFMT "ld" #else # define POLYUFMT "u" # define POLYSFMT "d" #endif #elif (defined(PRIuPTR)) # define POLYUFMT PRIuPTR # define POLYSFMT PRIdPTR #elif (defined(_MSC_VER) && (SIZEOF_POLYWORD == 8)) # define POLYUFMT "llu" # define POLYSFMT "lld" #else # define POLYUFMT "lu" // as before. Cross your fingers. # define POLYSFMT "ld" // idem. #endif // We can use the C99 %zu in most cases except MingW since it uses // the old msvcrt and that only supports C89. #if (defined(_WIN32) && (! defined(_MSC_VER) || _MSC_VER < 1800)) # if (SIZEOF_VOIDP == 8) # define PRI_SIZET PRIu64 # else # define PRI_SIZET PRIu32 # endif #else # define PRI_SIZET "zu" #endif typedef unsigned char byte; class PolyObject; typedef PolyObject *POLYOBJPTR; #ifdef POLYML32IN64 class PolyWord; extern PolyWord *globalHeapBase, *globalCodeBase; typedef uint32_t POLYOBJECTPTR; // This is an index into globalHeapBase // If a 64-bit value if in the range of the object pointers. inline bool IsHeapAddress(void *addr) { return (uintptr_t)addr <= 0xffffffff; } #else typedef POLYOBJPTR POLYOBJECTPTR; inline bool IsHeapAddress(void *) { return true; } #endif typedef byte *POLYCODEPTR; class PolyWord { public: // Initialise to TAGGED(0). This is very rarely used. PolyWord() { contents.unsignedInt = 1; } // Integers need to be tagged. static PolyWord TaggedInt(POLYSIGNED s) { return PolyWord((s << POLY_TAGSHIFT) | (POLYSIGNED)0x01); } static PolyWord TaggedUnsigned(POLYUNSIGNED u) { return PolyWord((u << POLY_TAGSHIFT) | 0x01); } static PolyWord FromStackAddr(PolyWord *sp) { return PolyWord(sp); } static PolyWord FromCodePtr(POLYCODEPTR p) { return PolyWord(p); } // Tests for the various cases. bool IsTagged(void) const { return (contents.unsignedInt & 1) != 0; } #ifndef POLYML32IN64 // In native 32-bit and 64-bit addresses are on word boundaries bool IsDataPtr(void) const { return (contents.unsignedInt & (sizeof(PolyWord) - 1)) == 0; } #else // In 32-in-64 addresses are anything that isn't tagged. bool IsDataPtr(void) const { return (contents.unsignedInt & 1) == 0; } #ifdef POLYML32IN64DEBUG static POLYOBJECTPTR AddressToObjectPtr(void *address); #else static POLYOBJECTPTR AddressToObjectPtr(void *address) { return (POLYOBJECTPTR)((PolyWord*)address - globalHeapBase); } #endif #endif // Extract the various cases. POLYSIGNED UnTagged(void) const { return contents.signedInt >> POLY_TAGSHIFT; } POLYUNSIGNED UnTaggedUnsigned(void) const { return contents.unsignedInt >> POLY_TAGSHIFT; } #ifdef POLYML32IN64 PolyWord(POLYOBJPTR p) { contents.objectPtr = AddressToObjectPtr(p); } PolyWord *AsStackAddr(PolyWord *base = globalHeapBase) const { return base + contents.objectPtr; } POLYOBJPTR AsObjPtr(PolyWord *base = globalHeapBase) const { return (POLYOBJPTR)AsStackAddr(base); } #else // An object pointer can become a word directly. PolyWord(POLYOBJPTR p) { contents.objectPtr = p; } POLYOBJPTR AsObjPtr(PolyWord *base = 0) const { return contents.objectPtr; } PolyWord *AsStackAddr(PolyWord *base=0) const { return (PolyWord *)contents.objectPtr; } #endif POLYCODEPTR AsCodePtr(void) const { return (POLYCODEPTR)AsObjPtr(); } void *AsAddress(void)const { return AsCodePtr(); } // There are a few cases where we need to store and extract untagged values static PolyWord FromUnsigned(POLYUNSIGNED u) { return PolyWord(u); } static PolyWord FromSigned(POLYSIGNED s) { return PolyWord(s); } POLYUNSIGNED AsUnsigned(void) const { return contents.unsignedInt; } POLYSIGNED AsSigned(void) const { return contents.signedInt; } protected: PolyWord(POLYSIGNED s) { contents.signedInt = s; } PolyWord(POLYUNSIGNED u) { contents.unsignedInt = u; } public: bool operator == (PolyWord b) const { return contents.unsignedInt == b.contents.unsignedInt; } bool operator != (PolyWord b) const { return contents.unsignedInt != b.contents.unsignedInt; } protected: #ifdef POLYML32IN64 PolyWord(PolyWord *sp) { contents.objectPtr = AddressToObjectPtr(sp); } PolyWord(POLYCODEPTR p) { contents.objectPtr = AddressToObjectPtr(p); } #else PolyWord(PolyWord *sp) { contents.objectPtr = (PolyObject*)sp; } PolyWord(POLYCODEPTR p) { contents.objectPtr = (PolyObject*)p; } #endif union { POLYSIGNED signedInt; // A tagged integer - lowest bit set POLYUNSIGNED unsignedInt; // A tagged integer - lowest bit set POLYOBJECTPTR objectPtr; // Object pointer - lowest bit clear. } contents; }; //typedef PolyWord POLYWORD; inline bool OBJ_IS_AN_INTEGER(const PolyWord & a) { return a.IsTagged(); } inline bool OBJ_IS_DATAPTR(const PolyWord & a) { return a.IsDataPtr(); } // The maximum tagged signed number is one less than 0x80 shifted into the top byte then shifted down // by the tag shift. #define MAXTAGGED (((POLYSIGNED)0x80 << (POLYSIGNED)(8*(sizeof(PolyWord)-1) -POLY_TAGSHIFT)) -1) inline PolyWord TAGGED(POLYSIGNED a) { return PolyWord::TaggedInt(a); } inline POLYSIGNED UNTAGGED(PolyWord a) { return a.UnTagged(); } inline POLYUNSIGNED UNTAGGED_UNSIGNED(PolyWord a) { return a.UnTaggedUnsigned(); } #define IS_INT(x) ((x).IsTagged()) /* length word flags */ #define OBJ_PRIVATE_FLAGS_SHIFT (8 * (sizeof(PolyWord) - 1)) #define _TOP_BYTE(x) ((POLYUNSIGNED)(x) << OBJ_PRIVATE_FLAGS_SHIFT) // Bottom two bits define the content format. // Zero bits mean ordinary word object containing addresses or tagged integers. #define F_BYTE_OBJ 0x01 /* byte object (contains no pointers) */ #define F_CODE_OBJ 0x02 /* code object (mixed bytes and words) */ #define F_CLOSURE_OBJ 0x03 /* closure (32-in-64 only). First word is code addr. */ #define F_GC_MARK 0x04 // Used during the GC marking phase #define F_NO_OVERWRITE 0x08 /* don't overwrite when loading - mutables only. */ // This bit is overloaded and has different meanings depending on what other bits are set. // For byte objects it is the sign bit for arbitrary precision ints. // For other data it indicates either that the object is a profile block or contains // information for allocation profiling. #define F_NEGATIVE_BIT 0x10 // Sign bit for arbitrary precision ints (byte segs only) #define F_PROFILE_BIT 0x10 // Object has a profile pointer (word segs only) #define F_WEAK_BIT 0x20 /* object contains weak references to option values. */ // The Weak bit is only used on mutables. The data sharing (sharedata.cpp) uses this with // immutables to indicate that the length field is being used to store the "depth". #define F_MUTABLE_BIT 0x40 /* object is mutable */ #define F_TOMBSTONE_BIT 0x80 // Object is a forwarding pointer #define F_PRIVATE_FLAGS_MASK 0xFF // Shifted bits #define _OBJ_BYTE_OBJ _TOP_BYTE(F_BYTE_OBJ) /* byte object (contains no pointers) */ #define _OBJ_CODE_OBJ _TOP_BYTE(F_CODE_OBJ) /* code object (mixed bytes and words) */ #define _OBJ_CLOSURE_OBJ _TOP_BYTE(F_CLOSURE_OBJ) // closure (32-in-64 only). First word is code addr. #define _OBJ_GC_MARK _TOP_BYTE(F_GC_MARK) // Mark bit #define _OBJ_NO_OVERWRITE _TOP_BYTE(F_NO_OVERWRITE) /* don't overwrite when loading - mutables only. */ #define _OBJ_NEGATIVE_BIT _TOP_BYTE(F_NEGATIVE_BIT) /* sign bit for arbitrary precision ints */ #define _OBJ_PROFILE_BIT _TOP_BYTE(F_PROFILE_BIT) /* sign bit for arbitrary precision ints */ #define _OBJ_WEAK_BIT _TOP_BYTE(F_WEAK_BIT) #define _OBJ_MUTABLE_BIT _TOP_BYTE(F_MUTABLE_BIT) /* object is mutable */ #define _OBJ_TOMBSTONE_BIT _TOP_BYTE(F_TOMBSTONE_BIT) // object is a tombstone. #define _OBJ_PRIVATE_FLAGS_MASK _TOP_BYTE(F_PRIVATE_FLAGS_MASK) #define _OBJ_PRIVATE_LENGTH_MASK ((-1) ^ _OBJ_PRIVATE_FLAGS_MASK) #define MAX_OBJECT_SIZE _OBJ_PRIVATE_LENGTH_MASK // inline bool OBJ_IS_LENGTH(POLYUNSIGNED L) { return ((L & _OBJ_TOMBSTONE_BIT) == 0); } /* these should only be applied to proper length words */ /* discards GC flag, mutable bit and weak bit. */ inline byte GetTypeBits(POLYUNSIGNED L) { return (byte)(L >> OBJ_PRIVATE_FLAGS_SHIFT) & 0x03; } inline POLYUNSIGNED OBJ_OBJECT_LENGTH(POLYUNSIGNED L) { return L & _OBJ_PRIVATE_LENGTH_MASK; } inline bool OBJ_IS_BYTE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_BYTE_OBJ); } inline bool OBJ_IS_CODE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_CODE_OBJ); } inline bool OBJ_IS_CLOSURE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_CLOSURE_OBJ); } inline bool OBJ_IS_NO_OVERWRITE(POLYUNSIGNED L) { return ((L & _OBJ_NO_OVERWRITE) != 0); } inline bool OBJ_IS_NEGATIVE(POLYUNSIGNED L) { return ((L & _OBJ_NEGATIVE_BIT) != 0); } inline bool OBJ_HAS_PROFILE(POLYUNSIGNED L) { return ((L & _OBJ_PROFILE_BIT) != 0); } inline bool OBJ_IS_MUTABLE_OBJECT(POLYUNSIGNED L) { return ((L & _OBJ_MUTABLE_BIT) != 0); } inline bool OBJ_IS_WEAKREF_OBJECT(POLYUNSIGNED L) { return ((L & _OBJ_WEAK_BIT) != 0); } /* Don't need to worry about whether shift is signed, because OBJ_PRIVATE_USER_FLAGS_MASK removes the sign bit. We don't want the GC bit (which should be 0) anyway. */ #define OBJ_PRIVATE_USER_FLAGS_MASK _TOP_BYTE(0x7F) #define OBJ_IS_WORD_OBJECT(L) (GetTypeBits(L) == 0) /* case 2 - forwarding pointer */ inline bool OBJ_IS_POINTER(POLYUNSIGNED L) { return (L & _OBJ_TOMBSTONE_BIT) != 0; } #ifdef POLYML32IN64 inline PolyObject *OBJ_GET_POINTER(POLYUNSIGNED L) { return (PolyObject*)(globalHeapBase + ((L & ~_OBJ_TOMBSTONE_BIT) << 1)); } inline POLYUNSIGNED OBJ_SET_POINTER(PolyObject *pt) { return PolyWord::AddressToObjectPtr(pt) >> 1 | _OBJ_TOMBSTONE_BIT; } #else inline PolyObject *OBJ_GET_POINTER(POLYUNSIGNED L) { return (PolyObject*)(( L & ~_OBJ_TOMBSTONE_BIT) <<2); } inline POLYUNSIGNED OBJ_SET_POINTER(PolyObject *pt) { return ((POLYUNSIGNED)pt >> 2) | _OBJ_TOMBSTONE_BIT; } #endif // An object i.e. a piece of allocated memory in the heap. In the simplest case this is a // tuple, a list cons cell, a string or a ref. Every object has a length word in the word before // where its address points. The top byte of this contains flags. class PolyObject { public: byte *AsBytePtr(void)const { return (byte*)this; } PolyWord *AsWordPtr(void)const { return (PolyWord*)this; } POLYUNSIGNED LengthWord(void)const { return ((PolyWord*)this)[-1].AsUnsigned(); } POLYUNSIGNED Length(void)const { return OBJ_OBJECT_LENGTH(LengthWord()); } // Get and set a word PolyWord Get(POLYUNSIGNED i) const { return ((PolyWord*)this)[i]; } void Set(POLYUNSIGNED i, PolyWord v) { ((PolyWord*)this)[i] = v; } PolyWord *Offset(POLYUNSIGNED i) const { return ((PolyWord*)this)+i; } // Create a length word from a length and the flags in the top byte. void SetLengthWord(POLYUNSIGNED l, byte f) { ((POLYUNSIGNED*)this)[-1] = l | ((POLYUNSIGNED)f << OBJ_PRIVATE_FLAGS_SHIFT); } void SetLengthWord(POLYUNSIGNED l) { ((PolyWord*)this)[-1] = PolyWord::FromUnsigned(l); } bool IsByteObject(void) const { return OBJ_IS_BYTE_OBJECT(LengthWord()); } bool IsCodeObject(void) const { return OBJ_IS_CODE_OBJECT(LengthWord()); } bool IsClosureObject(void) const { return OBJ_IS_CLOSURE_OBJECT(LengthWord()); } bool IsWordObject(void) const { return OBJ_IS_WORD_OBJECT(LengthWord()); } bool IsMutable(void) const { return OBJ_IS_MUTABLE_OBJECT(LengthWord()); } bool IsWeakRefObject(void) const { return OBJ_IS_WEAKREF_OBJECT(LengthWord()); } bool IsNoOverwriteObject(void) const { return OBJ_IS_NO_OVERWRITE(LengthWord()); } bool ContainsForwardingPtr(void) const { return OBJ_IS_POINTER(LengthWord()); } PolyObject *GetForwardingPtr(void) const { return OBJ_GET_POINTER(LengthWord()); } void SetForwardingPtr(PolyObject *newp) { ((PolyWord*)this)[-1] = PolyWord::FromUnsigned(OBJ_SET_POINTER(newp)); } bool ContainsNormalLengthWord(void) const { return OBJ_IS_LENGTH(LengthWord()); } // Find the start of the constant section for a piece of code. // The first of these is really only needed because we may have objects whose length // words have been overwritten. void GetConstSegmentForCode(POLYUNSIGNED obj_length, PolyWord * &cp, POLYUNSIGNED &count) const { PolyWord *last_word = Offset(obj_length - 1); // Last word in the code - count = last_word->AsUnsigned(); // This is the number of consts - cp = last_word - count; + if (last_word->AsSigned() < 0) + { + cp = last_word + 1 + last_word->AsSigned() / sizeof(PolyWord); + count = cp[-1].AsUnsigned(); + } + else + { + count = last_word->AsUnsigned(); // This is the number of consts + cp = last_word - count; + } } void GetConstSegmentForCode(PolyWord * &cp, POLYUNSIGNED &count) const { GetConstSegmentForCode(Length(), cp, count); } PolyWord *ConstPtrForCode(void) const { PolyWord *cp; POLYUNSIGNED count; GetConstSegmentForCode(cp, count); return cp; } // Follow a chain of forwarding pointers PolyObject *FollowForwardingChain(void) { if (ContainsForwardingPtr()) return GetForwardingPtr()->FollowForwardingChain(); else return this; } }; // Stacks are native-words size even in 32-in-64. union stackItem { stackItem(PolyWord v) { argValue = v.AsUnsigned(); } stackItem() { argValue = TAGGED(0).AsUnsigned(); } // These return the low order word. PolyWord w()const { return PolyWord::FromUnsigned((POLYUNSIGNED)argValue); } operator PolyWord () { return PolyWord::FromUnsigned((POLYUNSIGNED)argValue); } POLYCODEPTR codeAddr; // Return addresses stackItem* stackAddr; // Stack addresses uintptr_t argValue; // Treat an address as an int }; /* There was a problem with version 2.95 on Sparc/Solaris at least. The PolyObject class has no members so classes derived from it e.g. ML_Cons_Cell should begin at the beginning of the object. Later versions of GCC get this right. */ #if defined(__GNUC__) && (__GNUC__ <= 2) #error Poly/ML requires GCC version 3 or newer #endif inline POLYUNSIGNED GetLengthWord(PolyWord p) { return p.AsObjPtr()->LengthWord(); } // Get the length of an object. inline POLYUNSIGNED OBJECT_LENGTH(PolyWord p) { return OBJ_OBJECT_LENGTH(GetLengthWord(p)); } // A list cell. This can be passed to or returned from certain RTS functions. class ML_Cons_Cell: public PolyObject { public: PolyWord h; PolyWord t; #define ListNull (TAGGED(0)) static bool IsNull(PolyWord p) { return p == ListNull; } }; /* An exception packet. This contains an identifier (either a tagged integer for RTS exceptions or the address of a mutable for those created within ML), a string name for printing and an exception argument value. */ class PolyException: public PolyObject { public: PolyWord ex_id; /* Exc identifier */ PolyWord ex_name;/* Exc name */ PolyWord arg; /* Exc arguments */ PolyWord ex_location; // Location of "raise". Always zero for RTS exceptions. }; typedef PolyException poly_exn; /* Macro to round a number of bytes up to a number of words. */ #define WORDS(s) ((s+sizeof(PolyWord)-1)/sizeof(PolyWord)) /********************************************************************** * * Representation of option type. * **********************************************************************/ #define NONE_VALUE (TAGGED(0)) /* SOME x is represented by a single word cell containing x. */ #if (defined(_WIN32)) /* Windows doesn't include 0x in %p format. */ #define ZERO_X "0x" #else #define ZERO_X "" #endif #endif diff --git a/libpolyml/pexport.cpp b/libpolyml/pexport.cpp index 3f8f3461..c45db4d6 100644 --- a/libpolyml/pexport.cpp +++ b/libpolyml/pexport.cpp @@ -1,905 +1,913 @@ /* Title: Export and import memory in a portable format Author: David C. J. Matthews. Copyright (c) 2006-7, 2015-8, 2020 David C. J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR H PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "pexport.h" #include "machine_dep.h" #include "scanaddrs.h" #include "run_time.h" #include "../polyexports.h" #include "version.h" #include "sys.h" #include "polystring.h" #include "memmgr.h" #include "rtsentry.h" #include "mpoly.h" // For polyStderr /* This file contains the code both to export the file and to import it in a new session. */ PExport::PExport() { } PExport::~PExport() { } // Get the index corresponding to an address. size_t PExport::getIndex(PolyObject *p) { // Binary chop to find the index from the address. size_t lower = 0, upper = pMap.size(); while (1) { ASSERT(lower < upper); size_t middle = (lower+upper)/2; ASSERT(middle < pMap.size()); if (p < pMap[middle]) { // Use lower to middle upper = middle; } else if (p > pMap[middle]) { // Use middle+1 to upper lower = middle+1; } else // Found it return middle; } } /* Get the index corresponding to an address. */ void PExport::printAddress(void *p) { fprintf(exportFile, "@%" PRI_SIZET "", getIndex((PolyObject*)p)); } void PExport::printValue(PolyWord q) { if (IS_INT(q) || q == PolyWord::FromUnsigned(0)) fprintf(exportFile, "%" POLYSFMT, UNTAGGED(q)); else printAddress(q.AsAddress()); } void PExport::printObject(PolyObject *p) { POLYUNSIGNED length = p->Length(); POLYUNSIGNED i; size_t myIndex = getIndex(p); fprintf(exportFile, "%" PRI_SIZET ":", myIndex); if (p->IsMutable()) putc('M', exportFile); if (OBJ_IS_NEGATIVE(p->LengthWord())) putc('N', exportFile); if (OBJ_IS_WEAKREF_OBJECT(p->LengthWord())) putc('W', exportFile); if (OBJ_IS_NO_OVERWRITE(p->LengthWord())) putc('V', exportFile); if (p->IsByteObject()) { if (p->IsMutable() && p->IsWeakRefObject() && p->Length() >= sizeof(uintptr_t) / sizeof(PolyWord)) { // This is either an entry point or a weak ref used in the FFI. // Clear the first word if (p->Length() == sizeof(uintptr_t)/sizeof(PolyWord)) putc('K', exportFile); // Weak ref else if (p->Length() > sizeof(uintptr_t) / sizeof(PolyWord)) { // Entry point - C null-terminated string. putc('E', exportFile); const char* name = (char*)p + sizeof(uintptr_t); fprintf(exportFile, "%" PRI_SIZET "|%s", strlen(name), name); *(uintptr_t*)p = 0; // Entry point } } else { /* May be a string, a long format arbitrary precision number or a real number. */ PolyStringObject* ps = (PolyStringObject*)p; /* This is not infallible but it seems to be good enough to detect the strings. */ POLYUNSIGNED bytes = length * sizeof(PolyWord); if (length >= 2 && ps->length <= bytes - sizeof(POLYUNSIGNED) && ps->length > bytes - 2 * sizeof(POLYUNSIGNED)) { /* Looks like a string. */ fprintf(exportFile, "S%" POLYUFMT "|", ps->length); for (unsigned i = 0; i < ps->length; i++) { char ch = ps->chars[i]; fprintf(exportFile, "%02x", ch & 0xff); } } else { /* Not a string. May be an arbitrary precision integer. If the source and destination word lengths differ we could find that some long-format arbitrary precision numbers could be represented in the tagged short form or vice-versa. The former case might give rise to errors because when comparing two arbitrary precision numbers for equality we assume that they are not equal if they have different representation. The latter case could be a problem because we wouldn't know whether to convert the tagged form to long form, which would be correct if the value has type "int" or to truncate it which would be correct for "word". It could also be a real number but that doesn't matter if we recompile everything on the new machine. */ byte* u = (byte*)p; putc('B', exportFile); fprintf(exportFile, "%" PRI_SIZET "|", length * sizeof(PolyWord)); for (unsigned i = 0; i < (unsigned)(length * sizeof(PolyWord)); i++) { fprintf(exportFile, "%02x", u[i]); } } } } else if (p->IsCodeObject()) { - POLYUNSIGNED constCount, i; + POLYUNSIGNED constCount; PolyWord *cp; ASSERT(! p->IsMutable() ); /* Work out the number of bytes in the code and the number of constants. */ p->GetConstSegmentForCode(cp, constCount); /* The byte count is the length of the segment minus the number of constants minus one for the constant count. It includes the marker word, byte count, profile count and, on the X86/64 at least, any non-address constants. These are actually word values. */ + PolyWord* last_word = p->Offset(length - 1); POLYUNSIGNED byteCount = (length - constCount - 1) * sizeof(PolyWord); - fprintf(exportFile, "D%" POLYUFMT ",%" POLYUFMT "|", constCount, byteCount); + if (last_word->AsSigned() < 0) + { + byteCount -= sizeof(PolyWord); + fprintf(exportFile, "F%" POLYUFMT ",%" POLYUFMT "|", constCount, byteCount); + } + else + { + // Old format + fprintf(exportFile, "D%" POLYUFMT ",%" POLYUFMT "|", constCount, byteCount); + } // First the code. byte *u = (byte*)p; - for (i = 0; i < byteCount; i++) + for (POLYUNSIGNED i = 0; i < byteCount; i++) fprintf(exportFile, "%02x", u[i]); putc('|', exportFile); // Now the constants. - for (i = 0; i < constCount; i++) + for (POLYUNSIGNED i = 0; i < constCount; i++) { printValue(cp[i]); if (i < constCount-1) putc(',', exportFile); } putc('|', exportFile); // Finally any constants in the code object. machineDependent->ScanConstantsWithinCode(p, this); } else // Ordinary objects, essentially tuples, or closures. { if (p->IsClosureObject()) { POLYUNSIGNED nItems = length - sizeof(PolyObject*) / sizeof(PolyWord) + 1; fprintf(exportFile, "C%" POLYUFMT "|", nItems); // Number of items } else fprintf(exportFile, "O%" POLYUFMT "|", length); if (p->IsClosureObject()) { // The first word is always a code address. printAddress(*(PolyObject**)p); i = sizeof(PolyObject*)/sizeof(PolyWord); if (i < length) putc(',', exportFile); } else i = 0; while (i < length) { printValue(p->Get(i)); if (i < length-1) putc(',', exportFile); i++; } } fprintf(exportFile, "\n"); } /* This is called for each constant within the code. Print a relocation entry for the word and return a value that means that the offset is saved in original word. */ void PExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code) { PolyObject *p = GetConstantValue(addr, code); if (p == 0) return; // Don't put in tagged constants // Put in the byte offset and the relocation type code. POLYUNSIGNED offset = (POLYUNSIGNED)(addr - (byte*)base); ASSERT (offset < base->Length() * sizeof(POLYUNSIGNED)); fprintf(exportFile, "%" POLYUFMT ",%d,", (POLYUNSIGNED)(addr - (byte*)base), code); printAddress(p); // The value to plug in. fprintf(exportFile, " "); } void PExport::exportStore(void) { // We want the entries in pMap to be in ascending // order of address to make searching easy so we need to process the areas // in order of increasing address, which may not be the order in memTable. std::vector indexOrder; indexOrder.reserve(memTableEntries); for (size_t i = 0; i < memTableEntries; i++) { std::vector::iterator it; for (it = indexOrder.begin(); it != indexOrder.end(); it++) { if (memTable[*it].mtOriginalAddr >= memTable[i].mtOriginalAddr) break; } indexOrder.insert(it, i); } // Process the area in order of ascending address. for (std::vector::iterator i = indexOrder.begin(); i != indexOrder.end(); i++) { size_t index = *i; char *start = (char*)memTable[index].mtOriginalAddr; char *end = start + memTable[index].mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); pMap.push_back(obj); p += length; } } /* Start writing the information. */ fprintf(exportFile, "Objects\t%" PRI_SIZET "\n", pMap.size()); char arch = '?'; switch (machineDependent->MachineArchitecture()) { case MA_Interpreted: arch = 'I'; break; case MA_I386: case MA_X86_64: case MA_X86_64_32: arch = 'X'; break; } fprintf(exportFile, "Root\t%" PRI_SIZET " %c %u\n", getIndex(rootFunction), arch, (unsigned)sizeof(PolyWord)); // Generate each of the areas. for (size_t i = 0; i < memTableEntries; i++) { char *start = (char*)memTable[i].mtOriginalAddr; char *end = start + memTable[i].mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); #ifdef POLYML32IN64 // We may have filler cells to get the alignment right. // We mustn't try to print them. if (((uintptr_t)obj & 4) != 0 && length == 0) continue; #endif printObject(obj); p += length; } } fclose(exportFile); exportFile = NULL; } /* Import a portable export file and load it into memory. Creates "permanent" address entries in the global memory table. */ class SpaceAlloc { public: SpaceAlloc(unsigned *indexCtr, unsigned perms, POLYUNSIGNED def); PolyObject *NewObj(POLYUNSIGNED objWords); size_t defaultSize; PermanentMemSpace *memSpace; size_t used; unsigned permissions; unsigned *spaceIndexCtr; }; SpaceAlloc::SpaceAlloc(unsigned *indexCtr, unsigned perms, POLYUNSIGNED def) { permissions = perms; defaultSize = def; memSpace = 0; used = 0; spaceIndexCtr = indexCtr; } // Allocate a new object. May create a new space and add the old one to the permanent // memory table if this is exhausted. #ifndef POLYML32IN64 PolyObject *SpaceAlloc::NewObj(POLYUNSIGNED objWords) { if (memSpace == 0 || memSpace->spaceSize() - used <= objWords) { // Need some more space. size_t size = defaultSize; if (size <= objWords) size = objWords+1; memSpace = gMem.AllocateNewPermanentSpace(size * sizeof(PolyWord), permissions, *spaceIndexCtr); (*spaceIndexCtr)++; // The memory is writable until CompletePermanentSpaceAllocation is called if (memSpace == 0) { fprintf(polyStderr, "Unable to allocate memory\n"); return 0; } used = 0; } ASSERT(memSpace->spaceSize() - used > objWords); PolyObject *newObj = (PolyObject*)(memSpace->bottom + used+1); used += objWords+1; return newObj; } #else // With 32in64 we need to allocate on 8-byte boundaries. PolyObject *SpaceAlloc::NewObj(POLYUNSIGNED objWords) { size_t rounded = objWords; if ((objWords & 1) == 0) rounded++; if (memSpace == 0 || memSpace->spaceSize() - used <= rounded) { // Need some more space. size_t size = defaultSize; if (size <= rounded) size = rounded + 1; memSpace = gMem.AllocateNewPermanentSpace(size * sizeof(PolyWord), permissions, *spaceIndexCtr); (*spaceIndexCtr)++; // The memory is writable until CompletePermanentSpaceAllocation is called if (memSpace == 0) { fprintf(stderr, "Unable to allocate memory\n"); return 0; } memSpace->writeAble(memSpace->bottom)[0] = PolyWord::FromUnsigned(0); used = 1; } PolyObject *newObj = (PolyObject*)(memSpace->bottom + used + 1); if (rounded != objWords) memSpace->writeAble(newObj)->Set(objWords, PolyWord::FromUnsigned(0)); used += rounded + 1; ASSERT(((uintptr_t)newObj & 0x7) == 0); return newObj; } #endif class PImport { public: PImport(); ~PImport(); bool DoImport(void); FILE *f; PolyObject *Root(void) { return objMap[nRoot]; } private: bool ReadValue(PolyObject *p, POLYUNSIGNED i); bool GetValue(PolyWord *result); POLYUNSIGNED nObjects, nRoot; PolyObject **objMap; unsigned spaceIndex; SpaceAlloc mutSpace, immutSpace, codeSpace; }; PImport::PImport(): mutSpace(&spaceIndex, MTF_WRITEABLE, 1024*1024), immutSpace(&spaceIndex, 0, 1024*1024), codeSpace(&spaceIndex, MTF_EXECUTABLE, 1024 * 1024) { f = NULL; objMap = 0; spaceIndex = 1; } PImport::~PImport() { if (f) fclose(f); free(objMap); } bool PImport::GetValue(PolyWord *result) { int ch = getc(f); if (ch == '@') { /* Address of an object. */ POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); *result = objMap[obj]; } else if ((ch >= '0' && ch <= '9') || ch == '-') { /* Tagged integer. */ POLYSIGNED j; ungetc(ch, f); fscanf(f, "%" POLYSFMT, &j); /* The assertion may be false if we are porting to a machine with a shorter tagged representation. */ ASSERT(j >= -MAXTAGGED-1 && j <= MAXTAGGED); *result = TAGGED(j); } else { fprintf(polyStderr, "Unexpected character in stream"); return false; } return true; } /* Read a value and store it at the specified word. */ bool PImport::ReadValue(PolyObject *p, POLYUNSIGNED i) { PolyWord result = TAGGED(0); if (GetValue(&result)) { p->Set(i, result); return true; } else return false; } bool PImport::DoImport() { int ch; POLYUNSIGNED objNo; ASSERT(gMem.pSpaces.size() == 0); ASSERT(gMem.eSpaces.size() == 0); ch = getc(f); ASSERT(ch == 'O'); /* Number of objects. */ while (getc(f) != '\t') ; fscanf(f, "%" POLYUFMT, &nObjects); /* Create a mapping table. */ objMap = (PolyObject**)calloc(nObjects, sizeof(PolyObject*)); if (objMap == 0) { fprintf(polyStderr, "Unable to allocate memory\n"); return false; } do { ch = getc(f); } while (ch == '\n'); ASSERT(ch == 'R'); /* Root object number. */ while (getc(f) != '\t') ; fscanf(f, "%" POLYUFMT, &nRoot); do { ch = getc(f); } while (ch == ' ' || ch == '\t'); // Older versions did not have the architecture and word length. if (ch != '\r' && ch != '\n') { unsigned wordLength; while (ch == ' ' || ch == '\t') ch = getc(f); char arch = ch; ch = getc(f); fscanf(f, "%u", &wordLength); // If we're booting a native code version from interpreted // code we have to interpret. machineDependent->SetBootArchitecture(arch, wordLength); } /* Now the objects themselves. */ while (1) { unsigned objBits = 0; POLYUNSIGNED nWords, nBytes; do { ch = getc(f); } while (ch == '\r' || ch == '\n'); if (ch == EOF) break; ungetc(ch, f); fscanf(f, "%" POLYUFMT, &objNo); ch = getc(f); ASSERT(ch == ':'); ASSERT(objNo < nObjects); /* Modifiers, MNVW. */ do { ch = getc(f); if (ch == 'M') objBits |= F_MUTABLE_BIT; else if (ch == 'N') objBits |= F_NEGATIVE_BIT; if (ch == 'V') objBits |= F_NO_OVERWRITE; if (ch == 'W') objBits |= F_WEAK_BIT; } while (ch == 'M' || ch == 'N' || ch == 'V' || ch == 'W'); /* Object type. */ switch (ch) { case 'O': /* Simple object. */ fscanf(f, "%" POLYUFMT, &nWords); break; case 'B': /* Byte segment. */ objBits |= F_BYTE_OBJ; fscanf(f, "%" POLYUFMT, &nBytes); /* Round up to appropriate number of words. */ nWords = (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord); break; case 'S': /* String. */ objBits |= F_BYTE_OBJ; /* The length is the number of characters. */ fscanf(f, "%" POLYUFMT, &nBytes); /* Round up to appropriate number of words. Need to add one PolyWord for the length PolyWord. */ nWords = (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord) + 1; break; - case 'D': /* Code segment (new form). */ + case 'D': // Code segment. + case 'F': objBits |= F_CODE_OBJ; /* Read the number of bytes of code and the number of words for constants. */ fscanf(f, "%" POLYUFMT ",%" POLYUFMT, &nWords, &nBytes); - nWords += ch == 'C' ? 4 : 1; /* Add words for extras. */ + nWords += ch == 'F' ? 2 : 1; // Add one or two words for no of consts + offset. /* Add in the size of the code itself. */ nWords += (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord); break; case 'C': // Closure objBits |= F_CLOSURE_OBJ; fscanf(f, "%" POLYUFMT, &nWords); // This is the number of items. nWords += sizeof(PolyObject*) / sizeof(PolyWord) - 1; break; case 'L': // Legacy closure objBits |= F_CLOSURE_OBJ; fscanf(f, "%" POLYUFMT, &nWords); // This was the number of words. break; case 'K': // Single weak reference nWords = sizeof(uintptr_t)/sizeof(PolyWord); objBits |= F_BYTE_OBJ; break; case 'E': // Entry point - address followed by string objBits |= F_BYTE_OBJ; // The length is the length of the string but it must be null-terminated fscanf(f, "%" POLYUFMT, &nBytes); // Add one uintptr_t plus one plus padding to an integral number of words. nWords = (nBytes + sizeof(uintptr_t) + sizeof(PolyWord)) / sizeof(PolyWord); break; default: fprintf(polyStderr, "Invalid object type\n"); return false; } SpaceAlloc* alloc; if (objBits & F_MUTABLE_BIT) alloc = &mutSpace; else if ((objBits & 3) == F_CODE_OBJ) alloc = &codeSpace; else alloc = &immutSpace; PolyObject* p = alloc->NewObj(nWords); if (p == 0) return false; objMap[objNo] = p; /* Put in length PolyWord and flag bits. */ alloc->memSpace->writeAble(p)->SetLengthWord(nWords, objBits); /* Skip the object contents. */ while (getc(f) != '\n') ; } /* Second pass - fill in the contents. */ fseek(f, 0, SEEK_SET); /* Skip the information at the start. */ ch = getc(f); ASSERT(ch == 'O'); /* Number of objects. */ while (getc(f) != '\n'); ch = getc(f); ASSERT(ch == 'R'); /* Root object number. */ while (getc(f) != '\n') ; while (1) { if (feof(f)) break; fscanf(f, "%" POLYUFMT, &objNo); if (feof(f)) break; ch = getc(f); ASSERT(ch == ':'); ASSERT(objNo < nObjects); PolyObject * p = objMap[objNo]; /* Modifiers, M or N. */ do { ch = getc(f); } while (ch == 'M' || ch == 'N' || ch == 'V' || ch == 'W'); /* Object type. */ switch (ch) { case 'O': /* Simple object. */ case 'C': // Closure case 'L': // Legacy closure { POLYUNSIGNED nWords; bool isClosure = ch == 'C' || ch == 'L'; fscanf(f, "%" POLYUFMT, &nWords); if (ch == 'C') nWords += sizeof(PolyObject*) / sizeof(PolyWord) - 1; ch = getc(f); ASSERT(ch == '|'); ASSERT(nWords == p->Length()); POLYUNSIGNED i = 0; if (isClosure) { int ch = getc(f); // This should be an address if (ch != '@') return false; POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); *(PolyObject**)p = objMap[obj]; ch = getc(f); i = sizeof(PolyObject*) / sizeof(PolyWord); } while (i < nWords) { if (!ReadValue(p, i)) return false; ch = getc(f); ASSERT((ch == ',' && i < nWords - 1) || (ch == '\n' && i == nWords - 1)); i++; } break; } case 'B': /* Byte segment. */ { byte *u = (byte*)p; POLYUNSIGNED nBytes; fscanf(f, "%" POLYUFMT, &nBytes); ch = getc(f); ASSERT(ch == '|'); for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); u[i] = n; } ch = getc(f); ASSERT(ch == '\n'); // Legacy: If this is an entry point object set its value. if (p->IsMutable() && p->IsWeakRefObject() && p->Length() > sizeof(uintptr_t)/sizeof(PolyWord)) { bool loadEntryPt = setEntryPoint(p); ASSERT(loadEntryPt); } break; } case 'S': /* String. */ { PolyStringObject * ps = (PolyStringObject *)p; /* The length is the number of characters. */ POLYUNSIGNED nBytes; fscanf(f, "%" POLYUFMT, &nBytes); ch = getc(f); ASSERT(ch == '|'); ps->length = nBytes; for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); ps->chars[i] = n; } ch = getc(f); ASSERT(ch == '\n'); break; } case 'D': + case 'F': { - bool oldForm = ch == 'C'; + bool newForm = ch == 'F'; POLYUNSIGNED length = p->Length(); POLYUNSIGNED nWords, nBytes; MemSpace* space = gMem.SpaceForObjectAddress(p); PolyObject *wr = space->writeAble(p); byte* u = (byte*)wr; /* Read the number of bytes of code and the number of words for constants. */ fscanf(f, "%" POLYUFMT ",%" POLYUFMT, &nWords, &nBytes); /* Read the code. */ ch = getc(f); ASSERT(ch == '|'); for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); u[i] = n; } ch = getc(f); ASSERT(ch == '|'); - /* Set the constant count. */ - wr->Set(length-1, PolyWord::FromUnsigned(nWords)); - if (oldForm) + if (newForm) { - wr->Set(length-1-nWords-1, PolyWord::FromUnsigned(0)); /* Profile count. */ - wr->Set(length-1-nWords-3, PolyWord::FromUnsigned(0)); /* Marker word. */ - wr->Set(length-1-nWords-2, PolyWord::FromUnsigned((length-1-nWords-2)*sizeof(PolyWord))); - /* Check - the code should end at the marker word. */ - ASSERT(nBytes == ((length-1-nWords-3)*sizeof(PolyWord))); + wr->Set(length - nWords - 2, PolyWord::FromUnsigned(nWords)); + wr->Set(length - 1, PolyWord::FromSigned((0-nWords-1)*sizeof(PolyWord))); } + else wr->Set(length-1, PolyWord::FromUnsigned(nWords)); /* Read in the constants. */ for (POLYUNSIGNED i = 0; i < nWords; i++) { if (! ReadValue(wr, i+length-nWords-1)) return false; ch = getc(f); ASSERT((ch == ',' && i < nWords-1) || ((ch == '\n' || ch == '|') && i == nWords-1)); } // Read in any constants in the code. if (ch == '|') { ch = getc(f); while (ch != '\n') { ungetc(ch, f); POLYUNSIGNED offset; int code; fscanf(f, "%" POLYUFMT ",%d", &offset, &code); ch = getc(f); ASSERT(ch == ','); // This should be an address. ch = getc(f); if (ch == '@') { POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); PolyObject *addr = objMap[obj]; byte *toPatch = (byte*)p + offset; // Pass the execute address here. ScanAddress::SetConstantValue(toPatch, addr, (ScanRelocationKind)code); } else { // Previously we also included tagged constants but they are // already in the code. ungetc(ch, f); PolyWord w; if (!GetValue(&w)) return false; } do ch = getc(f); while (ch == ' '); } } // Clear the mutable bit wr->SetLengthWord(p->Length(), F_CODE_OBJ); break; } case 'K': // Weak reference - must be zeroed *(uintptr_t*)p = 0; break; case 'E': // Entry point - address followed by string { // The length is the number of characters. *(uintptr_t*)p = 0; char* b = (char*)p + sizeof(uintptr_t); POLYUNSIGNED nBytes; fscanf(f, "%" POLYUFMT, &nBytes); ch = getc(f); ASSERT(ch == '|'); for (POLYUNSIGNED i = 0; i < nBytes; i++) { ch = getc(f); *b++ = ch; } *b = 0; ch = getc(f); ASSERT(ch == '\n'); bool loadEntryPt = setEntryPoint(p); ASSERT(loadEntryPt); break; } default: fprintf(polyStderr, "Invalid object type\n"); return false; } } // Now remove write access from immutable spaces. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) gMem.CompletePermanentSpaceAllocation(*i); return true; } // Import a file in the portable format and return a pointer to the root object. PolyObject *ImportPortable(const TCHAR *fileName) { PImport pImport; #if (defined(_WIN32) && defined(UNICODE)) pImport.f = _wfopen(fileName, L"r"); if (pImport.f == 0) { fprintf(polyStderr, "Unable to open file: %S\n", fileName); return 0; } #else pImport.f = fopen(fileName, "r"); if (pImport.f == 0) { fprintf(polyStderr, "Unable to open file: %s\n", fileName); return 0; } #endif if (pImport.DoImport()) return pImport.Root(); else return 0; } diff --git a/libpolyml/profiling.cpp b/libpolyml/profiling.cpp index 4030c486..2881ae55 100644 --- a/libpolyml/profiling.cpp +++ b/libpolyml/profiling.cpp @@ -1,621 +1,621 @@ /* Title: Profiling Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited Further development copyright (c) David C.J. Matthews 2011, 2015, 2020 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #include "globals.h" #include "arb.h" #include "processes.h" #include "polystring.h" #include "profiling.h" #include "save_vec.h" #include "rts_module.h" #include "memmgr.h" #include "scanaddrs.h" #include "locking.h" #include "run_time.h" #include "sys.h" #include "rtsentry.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode); } static long mainThreadCounts[MTP_MAXENTRY]; static const char* const mainThreadText[MTP_MAXENTRY] = { "UNKNOWN", "GARBAGE COLLECTION (sharing phase)", "GARBAGE COLLECTION (mark phase)", "GARBAGE COLLECTION (copy phase)", "GARBAGE COLLECTION (update phase)", "GARBAGE COLLECTION (minor collection)", "Common data sharing", "Exporting", "Saving state", "Loading saved state", "Profiling", "Setting signal handler", "Cygwin spawn", "Storing module", "Loading module" }; // Entries for store profiling enum _extraStore { EST_CODE = 0, EST_STRING, EST_BYTE, EST_WORD, EST_MUTABLE, EST_MUTABLEBYTE, EST_MAX_ENTRY }; static POLYUNSIGNED extraStoreCounts[EST_MAX_ENTRY]; static const char * const extraStoreText[EST_MAX_ENTRY] = { "Function code", "Strings", "Byte data (long precision ints etc)", "Unidentified word data", "Unidentified mutable data", "Mutable byte data (profiling counts)" }; // Poly strings for "standard" counts. These are generated from the C strings // above the first time profiling is activated. static PolyWord psRTSString[MTP_MAXENTRY], psExtraStrings[EST_MAX_ENTRY], psGCTotal; ProfileMode profileMode; // If we are just profiling a single thread, this is the thread data. static TaskData *singleThreadProfile = 0; // The queue is processed every 400ms and an entry can be // added every ms of CPU time by each thread. #define PCQUEUESIZE 4000 static long queuePtr = 0; static POLYCODEPTR pcQueue[PCQUEUESIZE]; // Increment, returning the original value. static int incrAtomically(long & p) { #if (defined(HAVE_SYNC_FETCH)) return __sync_fetch_and_add(&p, 1); #elif (defined(_WIN32)) long newValue = InterlockedIncrement(&p); return newValue - 1; #else return p++; #endif } // Decrement and return new value. static int decrAtomically(long & p) { #if (defined(HAVE_SYNC_FETCH)) return __sync_sub_and_fetch(&p, 1); #elif (defined(_WIN32)) return InterlockedDecrement(&p); #else return --p; #endif } typedef struct _PROFENTRY { POLYUNSIGNED count; PolyWord functionName; struct _PROFENTRY *nextEntry; } PROFENTRY, *PPROFENTRY; class ProfileRequest: public MainThreadRequest { public: ProfileRequest(unsigned prof, TaskData *pTask): MainThreadRequest(MTP_PROFILING), mode(prof), pCallingThread(pTask), pTab(0), errorMessage(0) {} ~ProfileRequest(); virtual void Perform(); Handle extractAsList(TaskData *taskData); private: void getResults(void); void getProfileResults(PolyWord *bottom, PolyWord *top); PPROFENTRY newProfileEntry(void); private: unsigned mode; TaskData *pCallingThread; PPROFENTRY pTab; public: const char *errorMessage; }; ProfileRequest::~ProfileRequest() { PPROFENTRY p = pTab; while (p != 0) { PPROFENTRY toFree = p; p = p->nextEntry; free(toFree); } } // Lock to serialise updates of counts. Only used during update. // Not required when we print the counts since there's only one thread // running then. static PLock countLock; // Get the profile object associated with a piece of code. Returns null if // there isn't one, in particular if this is in the old format. static PolyObject *getProfileObjectForCode(PolyObject *code) { ASSERT(code->IsCodeObject()); PolyWord *consts; POLYUNSIGNED constCount; code->GetConstSegmentForCode(consts, constCount); - if (constCount < 3 || ! consts[2].IsDataPtr()) return 0; - PolyObject *profObject = consts[2].AsObjPtr(); + if (constCount < 2 || consts[1].AsUnsigned() == 0 || ! consts[1].IsDataPtr()) return 0; + PolyObject *profObject = consts[1].AsObjPtr(); if (profObject->IsMutable() && profObject->IsByteObject() && profObject->Length() == 1) return profObject; else return 0; } // Adds incr to the profile count for the function pointed at by // pc or by one of its callers. void addSynchronousCount(POLYCODEPTR fpc, POLYUNSIGNED incr) { // Check that the pc value is within the heap. It could be // in the assembly code. PolyObject *codeObj = gMem.FindCodeObject(fpc); if (codeObj) { PolyObject *profObject = getProfileObjectForCode(codeObj); PLocker locker(&countLock); if (profObject) profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + incr)); return; } // Didn't find it. { PLocker locker(&countLock); incrAtomically(mainThreadCounts[MTP_USER_CODE]); } } // newProfileEntry - Make a new entry in the list PPROFENTRY ProfileRequest::newProfileEntry(void) { PPROFENTRY newEntry = (PPROFENTRY)malloc(sizeof(PROFENTRY)); if (newEntry == 0) { errorMessage = "Insufficient memory"; return 0; } newEntry->nextEntry = pTab; pTab = newEntry; return newEntry; } // We don't use ScanAddress here because we're only interested in the // objects themselves not the addresses in them. // We have to build the list of results in C memory rather than directly in // ML memory because we can't allocate in ML memory in the root thread. void ProfileRequest::getProfileResults(PolyWord *bottom, PolyWord *top) { PolyWord *ptr = bottom; while (ptr < top) { ptr++; // Skip the length word PolyObject *obj = (PolyObject*)ptr; if (obj->ContainsForwardingPtr()) { // This used to be necessary when code objects were held in the // general heap. Now that we only ever scan code and permanent // areas it's probably not needed. while (obj->ContainsForwardingPtr()) obj = obj->GetForwardingPtr(); ASSERT(obj->ContainsNormalLengthWord()); ptr += obj->Length(); } else { ASSERT(obj->ContainsNormalLengthWord()); if (obj->IsCodeObject()) { PolyWord *firstConstant = obj->ConstPtrForCode(); PolyWord name = firstConstant[0]; PolyObject *profCount = getProfileObjectForCode(obj); if (profCount) { POLYUNSIGNED count = profCount->Get(0).AsUnsigned(); if (count != 0) { if (name != TAGGED(0)) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; pEnt->count = count; pEnt->functionName = name; } profCount->Set(0, PolyWord::FromUnsigned(0)); } } } /* code object */ ptr += obj->Length(); } /* else */ } /* while */ } void ProfileRequest::getResults(void) // Print profiling information and reset profile counts. { for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) { MemSpace *space = *i; // Permanent areas are filled with objects from the bottom. getProfileResults(space->bottom, space->top); // Bottom to top } for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++) { CodeSpace *space = *i; getProfileResults(space->bottom, space->top); } { POLYUNSIGNED gc_count = mainThreadCounts[MTP_GCPHASESHARING]+ mainThreadCounts[MTP_GCPHASEMARK]+ mainThreadCounts[MTP_GCPHASECOMPACT] + mainThreadCounts[MTP_GCPHASEUPDATE] + mainThreadCounts[MTP_GCQUICK]; if (gc_count) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = gc_count; pEnt->functionName = psGCTotal; } } for (unsigned k = 0; k < MTP_MAXENTRY; k++) { if (mainThreadCounts[k]) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = mainThreadCounts[k]; pEnt->functionName = psRTSString[k]; mainThreadCounts[k] = 0; } } for (unsigned l = 0; l < EST_MAX_ENTRY; l++) { if (extraStoreCounts[l]) { PPROFENTRY pEnt = newProfileEntry(); if (pEnt == 0) return; // Report insufficient memory? pEnt->count = extraStoreCounts[l]; pEnt->functionName = psExtraStrings[l]; extraStoreCounts[l] = 0; } } } // Extract the accumulated results as an ML list of pairs of the count and the string. Handle ProfileRequest::extractAsList(TaskData *taskData) { Handle saved = taskData->saveVec.mark(); Handle list = taskData->saveVec.push(ListNull); for (PPROFENTRY p = pTab; p != 0; p = p->nextEntry) { Handle pair = alloc_and_save(taskData, 2); Handle countValue = Make_arbitrary_precision(taskData, p->count); pair->WordP()->Set(0, countValue->Word()); pair->WordP()->Set(1, p->functionName); Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell) / sizeof(PolyWord)); DEREFLISTHANDLE(next)->h = pair->Word(); DEREFLISTHANDLE(next)->t =list->Word(); taskData->saveVec.reset(saved); list = taskData->saveVec.push(next->Word()); } return list; } // We have had an asynchronous interrupt and found a potential PC but // we're in a signal handler. void incrementCountAsynch(POLYCODEPTR pc) { int q = incrAtomically(queuePtr); if (q < PCQUEUESIZE) pcQueue[q] = pc; } // Called by the main thread to process the queue of PC values void processProfileQueue() { if (queuePtr == 0) return; while (1) { int q = queuePtr; if (q >= PCQUEUESIZE) incrAtomically(mainThreadCounts[MTP_USER_CODE]); else addSynchronousCount(pcQueue[q], 1); if (decrAtomically(queuePtr) == 0) break; } } // Handle a SIGVTALRM or the simulated equivalent in Windows. This may be called // at any time so we have to be careful. In particular in Linux this may be // executed by a thread while holding a mutex so we must not do anything, such // calling malloc, that could require locking. void handleProfileTrap(TaskData *taskData, SIGNALCONTEXT *context) { if (singleThreadProfile != 0 && singleThreadProfile != taskData) return; /* If we are in the garbage-collector add the count to "gc_count" otherwise try to find out where we are. */ if (mainThreadPhase == MTP_USER_CODE) { if (taskData == 0 || ! taskData->AddTimeProfileCount(context)) incrAtomically(mainThreadCounts[MTP_USER_CODE]); // On Mac OS X all virtual timer interrupts seem to be directed to the root thread // so all the counts will be "unknown". } else incrAtomically(mainThreadCounts[mainThreadPhase]); } // Called from the GC when allocation profiling is on. void AddObjectProfile(PolyObject *obj) { ASSERT(obj->ContainsNormalLengthWord()); POLYUNSIGNED length = obj->Length(); if (obj->IsWordObject() && OBJ_HAS_PROFILE(obj->LengthWord())) { // It has a profile pointer. The last word should point to the // closure or code of the allocating function. Add the size of this to the count. ASSERT(length != 0); PolyWord profWord = obj->Get(length-1); ASSERT(profWord.IsDataPtr()); PolyObject *profObject = profWord.AsObjPtr(); ASSERT(profObject->IsMutable() && profObject->IsByteObject() && profObject->Length() == 1); profObject->Set(0, PolyWord::FromUnsigned(profObject->Get(0).AsUnsigned() + length + 1)); } // If it doesn't have a profile pointer add it to the appropriate count. else if (obj->IsMutable()) { if (obj->IsByteObject()) extraStoreCounts[EST_MUTABLEBYTE] += length+1; else extraStoreCounts[EST_MUTABLE] += length+1; } else if (obj->IsCodeObject()) extraStoreCounts[EST_CODE] += length+1; else if (obj->IsClosureObject()) { ASSERT(0); } else if (obj->IsByteObject()) { // Try to separate strings from other byte data. This is only // approximate. if (OBJ_IS_NEGATIVE(obj->LengthWord())) extraStoreCounts[EST_BYTE] += length+1; else { PolyStringObject *possString = (PolyStringObject*)obj; POLYUNSIGNED bytes = length * sizeof(PolyWord); // If the length of the string as given in the first word is sufficient // to fit in the exact number of words then it's probably a string. if (length >= 2 && possString->length <= bytes - sizeof(POLYUNSIGNED) && possString->length > bytes - 2 * sizeof(POLYUNSIGNED)) extraStoreCounts[EST_STRING] += length+1; else { extraStoreCounts[EST_BYTE] += length+1; } } } else extraStoreCounts[EST_WORD] += length+1; } // Called from ML to control profiling. static Handle profilerc(TaskData *taskData, Handle mode_handle) /* Profiler - generates statistical profiles of the code. The parameter is an integer which determines the value to be profiled. When profiler is called it always resets the profiling and prints out any values which have been accumulated. If the parameter is 0 this is all it does, if the parameter is 1 then it produces time profiling, if the parameter is 2 it produces store profiling. 3 - arbitrary precision emulation traps. */ { unsigned mode = get_C_unsigned(taskData, mode_handle->Word()); { // Create any strings we need. We only need to do this once but // it must be done by a non-root thread since it needs a taskData object. // Don't bother locking. At worst we'll create some garbage. for (unsigned k = 0; k < MTP_MAXENTRY; k++) { if (psRTSString[k] == TAGGED(0)) psRTSString[k] = C_string_to_Poly(taskData, mainThreadText[k]); } for (unsigned k = 0; k < EST_MAX_ENTRY; k++) { if (psExtraStrings[k] == TAGGED(0)) psExtraStrings[k] = C_string_to_Poly(taskData, extraStoreText[k]); } if (psGCTotal == TAGGED(0)) psGCTotal = C_string_to_Poly(taskData, "GARBAGE COLLECTION (total)"); } // All these actions are performed by the root thread. Only profile // printing needs to be performed with all the threads stopped but it's // simpler to serialise all requests. ProfileRequest request(mode, taskData); processes->MakeRootRequest(taskData, &request); if (request.errorMessage != 0) raise_exception_string(taskData, EXC_Fail, request.errorMessage); return request.extractAsList(taskData); } POLYUNSIGNED PolyProfiling(FirstArgument threadId, PolyWord mode) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedMode = taskData->saveVec.push(mode); Handle result = 0; try { result = profilerc(taskData, pushedMode); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // This is called from the root thread when all the ML threads have been paused. void ProfileRequest::Perform() { if (mode != kProfileOff && profileMode != kProfileOff) { // Profiling must be stopped first. errorMessage = "Profiling is currently active"; return; } singleThreadProfile = 0; // Unless kProfileTimeThread is given this should be 0 switch (mode) { case kProfileOff: // Turn off old profiling mechanism and print out accumulated results profileMode = kProfileOff; processes->StopProfiling(); getResults(); // Remove all the bitmaps to free up memory gMem.RemoveProfilingBitmaps(); break; case kProfileTimeThread: singleThreadProfile = pCallingThread; // And drop through to kProfileTime case kProfileTime: profileMode = kProfileTime; processes->StartProfiling(); break; case kProfileStoreAllocation: profileMode = kProfileStoreAllocation; break; case kProfileEmulation: profileMode = kProfileEmulation; break; case kProfileLiveData: profileMode = kProfileLiveData; break; case kProfileLiveMutables: profileMode = kProfileLiveMutables; break; case kProfileMutexContention: profileMode = kProfileMutexContention; break; default: /* do nothing */ break; } } struct _entrypts profilingEPT[] = { // Profiling { "PolyProfiling", (polyRTSFunction)&PolyProfiling}, { NULL, NULL} // End of list. }; class Profiling: public RtsModule { public: virtual void Init(void); virtual void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static Profiling profileModule; void Profiling::Init(void) { // Reset profiling counts. profileMode = kProfileOff; for (unsigned k = 0; k < MTP_MAXENTRY; k++) mainThreadCounts[k] = 0; } void Profiling::GarbageCollect(ScanAddress *process) { // Process any strings in the table. for (unsigned k = 0; k < MTP_MAXENTRY; k++) process->ScanRuntimeWord(&psRTSString[k]); for (unsigned k = 0; k < EST_MAX_ENTRY; k++) process->ScanRuntimeWord(&psExtraStrings[k]); process->ScanRuntimeWord(&psGCTotal); } diff --git a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML index 8579b22c..4fa4fdd8 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTCODECONS.ML @@ -1,1742 +1,1743 @@ (* Copyright (c) 2015-18, 2020 David C.J. Matthews Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) functor INTCODECONS ( structure DEBUG: DEBUG structure PRETTY: PRETTYSIG ) : INTCODECONSSIG = struct open CODE_ARRAY open DEBUG open Address open Misc infix 5 << <<+ <<- >> >>+ >>- ~>> ~>>+ ~>>- (* Shift operators *) infix 3 andb orb xorb andbL orbL xorbL andb8 orb8 xorb8 val op << = Word.<< and op >> = Word.>> and op ~>> = Word.~>> val wordToWord8 = Word8.fromLargeWord o Word.toLargeWord and word8ToWord = Word.fromLargeWord o Word8.toLargeWord (* Typically the compiler is built on a little-endian machine but it could be run on a machine with either endian-ness. We have to find out the endian-ness when we run. There are separate versions of the compiler for 32-bit and 64-bit so that can be a constant. *) local val isBigEndian: unit -> bool = RunCall.rtsCallFast1 "PolyIsBigEndian" in val isBigEndian = isBigEndian() end val opcode_jump = 0wx02 (* 8-bit unsigned jump forward. *) and opcode_jumpFalse = 0wx03 (* Test top of stack. Take 8-bit unsigned jump if false. *) and opcode_loadMLWord = 0wx04 and opcode_storeMLWord = 0wx05 and opcode_alloc_ref = 0wx06 and opcode_blockMoveWord = 0wx07 and opcode_loadUntagged = 0wx08 and opcode_storeUntagged = 0wx09 and opcode_case16 = 0wx0a and opcode_callClosure = 0wx0c and opcode_returnW = 0wx0d and opcode_containerB = 0wx0e and opcode_raiseEx = 0wx10 and opcode_callConstAddr16 = 0wx11 and opcode_callConstAddr8 = 0wx12 and opcode_localW = 0wx13 and opcode_callLocalB = 0wx16 and opcode_constAddr16 = 0wx1a and opcode_constIntW = 0wx1b and opcode_jumpBack8 = 0wx1e (* 8-bit unsigned jump backwards - relative to end of instr. *) and opcode_returnB = 0wx1f and opcode_jumpBack16 = 0wx20 (* 16-bit unsigned jump backwards - relative to end of instr. *) and opcode_indirectLocalBB = 0wx21 and opcode_localB = 0wx22 and opcode_indirectB = 0wx23 and opcode_moveToContainerB = 0wx24 and opcode_setStackValB = 0wx25 and opcode_resetB = 0wx26 and opcode_resetRB = 0wx27 and opcode_constIntB = 0wx28 and opcode_local_0 = 0wx29 and opcode_local_1 = 0wx2a and opcode_local_2 = 0wx2b and opcode_local_3 = 0wx2c and opcode_local_4 = 0wx2d and opcode_local_5 = 0wx2e and opcode_local_6 = 0wx2f and opcode_local_7 = 0wx30 and opcode_local_8 = 0wx31 and opcode_local_9 = 0wx32 and opcode_local_10 = 0wx33 and opcode_local_11 = 0wx34 and opcode_indirect_0 = 0wx35 and opcode_indirect_1 = 0wx36 and opcode_indirect_2 = 0wx37 and opcode_indirect_3 = 0wx38 and opcode_indirect_4 = 0wx39 and opcode_indirect_5 = 0wx3a and opcode_const_0 = 0wx3b and opcode_const_1 = 0wx3c and opcode_const_2 = 0wx3d and opcode_const_3 = 0wx3e and opcode_const_4 = 0wx3f and opcode_const_10 = 0wx40 and opcode_return_1 = 0wx42 and opcode_return_2 = 0wx43 and opcode_return_3 = 0wx44 and opcode_local_12 = 0wx45 and opcode_jumpTrue = 0wx46 and opcode_jump16True = 0wx47 and opcode_local_13 = 0wx49 and opcode_local_14 = 0wx4a and opcode_local_15 = 0wx4b and opcode_reset_1 = 0wx50 and opcode_reset_2 = 0wx51 and opcode_indirectClosureBB = 0wx54 and opcode_resetR_1 = 0wx64 and opcode_resetR_2 = 0wx65 and opcode_resetR_3 = 0wx66 and opcode_tupleB = 0wx68 and opcode_tuple_2 = 0wx69 and opcode_tuple_3 = 0wx6a and opcode_tuple_4 = 0wx6b and opcode_lock = 0wx6c and opcode_ldexc = 0wx6d and opcode_indirectContainerB= 0wx74 and opcode_moveToMutClosureB = 0wx75 and opcode_allocMutClosureB = 0wx76 and opcode_indirectClosureB0 = 0wx77 and opcode_pushHandler = 0wx78 and opcode_indirectClosureB1 = 0wx7a and opcode_tailbb = 0wx7b and opcode_indirectClosureB2 = 0wx7c and opcode_setHandler = 0wx81 and opcode_callFastRTS0 = 0wx83 and opcode_callFastRTS1 = 0wx84 and opcode_callFastRTS2 = 0wx85 and opcode_callFastRTS3 = 0wx86 and opcode_callFastRTS4 = 0wx87 and opcode_callFastRTS5 = 0wx88 (*and opcode_callFullRTS0 = 0wx89 (* Legacy *) and opcode_callFullRTS1 = 0wx8a and opcode_callFullRTS2 = 0wx8b and opcode_callFullRTS3 = 0wx8c and opcode_callFullRTS4 = 0wx8d and opcode_callFullRTS5 = 0wx8e*) and opcode_notBoolean = 0wx91 and opcode_isTagged = 0wx92 and opcode_cellLength = 0wx93 and opcode_cellFlags = 0wx94 and opcode_clearMutable = 0wx95 and opcode_atomicIncr = 0wx97 and opcode_atomicDecr = 0wx98 and opcode_equalWord = 0wxa0 and opcode_lessSigned = 0wxa2 and opcode_lessUnsigned = 0wxa3 and opcode_lessEqSigned = 0wxa4 and opcode_lessEqUnsigned = 0wxa5 and opcode_greaterSigned = 0wxa6 and opcode_greaterUnsigned = 0wxa7 and opcode_greaterEqSigned = 0wxa8 and opcode_greaterEqUnsigned = 0wxa9 and opcode_fixedAdd = 0wxaa and opcode_fixedSub = 0wxab and opcode_fixedMult = 0wxac and opcode_fixedQuot = 0wxad and opcode_fixedRem = 0wxae and opcode_wordAdd = 0wxb1 and opcode_wordSub = 0wxb2 and opcode_wordMult = 0wxb3 and opcode_wordDiv = 0wxb4 and opcode_wordMod = 0wxb5 and opcode_wordAnd = 0wxb7 and opcode_wordOr = 0wxb8 and opcode_wordXor = 0wxb9 and opcode_wordShiftLeft = 0wxba and opcode_wordShiftRLog = 0wxbb and opcode_allocByteMem = 0wxbd and opcode_indirectLocalB1 = 0wxc1 and opcode_isTaggedLocalB = 0wxc2 and opcode_jumpNEqLocalInd = 0wxc3 and opcode_jumpTaggedLocal = 0wxc4 and opcode_jumpNEqLocal = 0wxc5 and opcode_indirect0Local0 = 0wxc6 and opcode_indirectLocalB0 = 0wxc7 and opcode_closureB = 0wxd0 and opcode_getThreadId = 0wxd9 and opcode_allocWordMemory = 0wxda and opcode_loadMLByte = 0wxdc and opcode_storeMLByte = 0wxe4 and opcode_blockMoveByte = 0wxec and opcode_blockEqualByte = 0wxed and opcode_blockCompareByte = 0wxee and opcode_deleteHandler = 0wxf1 (* Just deletes the handler - no jump. *) and opcode_jump16 = 0wxf7 and opcode_jump16False = 0wxf8 and opcode_setHandler16 = 0wxf9 and opcode_constAddr8 = 0wxfa (*and opcode_stackSize8 = 0wxfb*) and opcode_stackSize16 = 0wxfc and opcode_escape = 0wxfe (* For two-byte opcodes. *) (*and opcode_enterIntX86 = 0wxff*) (* Reserved - this is the first byte of a call *) (* Extended opcodes - preceded by 0xfe escape *) val ext_opcode_containerW = 0wx0b and ext_opcode_allocMutClosureW = 0wx0f (* Allocate a mutable closure for mutual recursion *) and ext_opcode_indirectClosureW = 0wx10 and ext_opcode_indirectContainerW= 0wx11 and ext_opcode_indirectW = 0wx14 and ext_opcode_moveToContainerW = 0wx15 and ext_opcode_moveToMutClosureW = 0wx16 and ext_opcode_setStackValW = 0wx17 and ext_opcode_resetW = 0wx18 and ext_opcode_resetR_w = 0wx19 and ext_opcode_callFastRTSRRtoR = 0wx1c and ext_opcode_callFastRTSRGtoR = 0wx1d and ext_opcode_jump32True = 0wx48 and ext_opcode_floatAbs = 0wx56 and ext_opcode_floatNeg = 0wx57 and ext_opcode_fixedIntToFloat = 0wx58 and ext_opcode_floatToReal = 0wx59 and ext_opcode_realToFloat = 0wx5a and ext_opcode_floatEqual = 0wx5b and ext_opcode_floatLess = 0wx5c and ext_opcode_floatLessEq = 0wx5d and ext_opcode_floatGreater = 0wx5e and ext_opcode_floatGreaterEq = 0wx5f and ext_opcode_floatAdd = 0wx60 and ext_opcode_floatSub = 0wx61 and ext_opcode_floatMult = 0wx62 and ext_opcode_floatDiv = 0wx63 and ext_opcode_tupleW = 0wx67 and ext_opcode_realToInt = 0wx6e and ext_opcode_floatToInt = 0wx6f and ext_opcode_callFastRTSFtoF = 0wx70 and ext_opcode_callFastRTSGtoF = 0wx71 and ext_opcode_callFastRTSFFtoF = 0wx72 and ext_opcode_callFastRTSFGtoF = 0wx73 and ext_opcode_realUnordered = 0wx79 and ext_opcode_floatUnordered = 0wx7a and ext_opcode_tail = 0wx7c and ext_opcode_callFastRTSRtoR = 0wx8f and ext_opcode_callFastRTSGtoR = 0wx90 and ext_opcode_atomicReset = 0wx99 and ext_opcode_longWToTagged = 0wx9a and ext_opcode_signedToLongW = 0wx9b and ext_opcode_unsignedToLongW = 0wx9c and ext_opcode_realAbs = 0wx9d and ext_opcode_realNeg = 0wx9e and ext_opcode_fixedIntToReal = 0wx9f and ext_opcode_fixedDiv = 0wxaf and ext_opcode_fixedMod = 0wxb0 and ext_opcode_wordShiftRArith = 0wxbc and ext_opcode_lgWordEqual = 0wxbe and ext_opcode_lgWordLess = 0wxc0 and ext_opcode_lgWordLessEq = 0wxc1 and ext_opcode_lgWordGreater = 0wxc2 and ext_opcode_lgWordGreaterEq = 0wxc3 and ext_opcode_lgWordAdd = 0wxc4 and ext_opcode_lgWordSub = 0wxc5 and ext_opcode_lgWordMult = 0wxc6 and ext_opcode_lgWordDiv = 0wxc7 and ext_opcode_lgWordMod = 0wxc8 and ext_opcode_lgWordAnd = 0wxc9 and ext_opcode_lgWordOr = 0wxca and ext_opcode_lgWordXor = 0wxcb and ext_opcode_lgWordShiftLeft = 0wxcc and ext_opcode_lgWordShiftRLog = 0wxcd and ext_opcode_lgWordShiftRArith = 0wxce and ext_opcode_realEqual = 0wxcf and ext_opcode_closureW = 0wxd0 and ext_opcode_realLess = 0wxd1 and ext_opcode_realLessEq = 0wxd2 and ext_opcode_realGreater = 0wxd3 and ext_opcode_realGreaterEq = 0wxd4 and ext_opcode_realAdd = 0wxd5 and ext_opcode_realSub = 0wxd6 and ext_opcode_realMult = 0wxd7 and ext_opcode_realDiv = 0wxd8 and ext_opcode_loadC8 = 0wxdd and ext_opcode_loadC16 = 0wxde and ext_opcode_loadC32 = 0wxdf and ext_opcode_loadC64 = 0wxe0 and ext_opcode_loadCFloat = 0wxe1 and ext_opcode_loadCDouble = 0wxe2 and ext_opcode_storeC8 = 0wxe5 and ext_opcode_storeC16 = 0wxe6 and ext_opcode_storeC32 = 0wxe7 and ext_opcode_storeC64 = 0wxe8 and ext_opcode_storeCFloat = 0wxe9 and ext_opcode_storeCDouble = 0wxea and ext_opcode_jump32 = 0wxf2 (* 32-bit signed jump, forwards or backwards. *) and ext_opcode_jump32False = 0wxf3 (* Test top item. Take 32-bit signed jump if false. *) and ext_opcode_constAddr32 = 0wxf4 (* Followed by a 32-bit offset. Load a constant at that address. *) and ext_opcode_setHandler32 = 0wxf5 (* Setup a handler whose address is given by the 32-bit signed offset. *) and ext_opcode_case32 = 0wxf6 (* Indexed case with 32-bit offsets *) and ext_opcode_allocCSpace = 0wxfd and ext_opcode_freeCSpace = 0wxfe (* A Label is a ref that is later set to the location. Several labels can be linked together so that they are only set at a single point. Only forward jumps are linked so when we come to finally set the label we will have the full list. *) type labels = Word.word ref list ref (* Used for jump, jumpFalse, setHandler and delHandler. *) datatype jumpTypes = Jump | JumpBack | JumpFalse | JumpTrue | SetHandler datatype opcode = SimpleCode of Word8.word list (* Bytes that don't need any special treatment *) | LabelCode of labels (* A label - forwards or backwards. *) | JumpInstruction of { label: labels, jumpType: jumpTypes, size: jumpSize ref } (* Jumps or SetHandler. *) | PushConstant of { constNum: int, size : jumpSize ref, isCall: bool } | PushShort of Word.word | IndexedCase of { labels: labels list, size : jumpSize ref } | LoadLocal of Word8.word (* Locals - simplifies peephole optimisation. *) | IndirectLocal of { localAddr: Word8.word, indirect: Word8.word } (* Ditto *) | UncondTransfer of Word8.word list (* Raisex, return and tail. *) | IsTaggedLocalB of Word8.word | JumpOnIsTaggedLocalB of { label: labels, size: jumpSize ref, localAddr: Word8.word } | JumpNotEqualLocalInd0BB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } | JumpNotEqualLocalConstBB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } and jumpSize = Size8 | Size16 | Size32 and code = Code of { constVec: machineWord list ref, (* Vector of words to be put at end *) procName: string, (* Name of the procedure. *) printAssemblyCode:bool, (* Whether to print the code when we finish. *) printStream: string->unit, (* The stream to use *) stage1Code: opcode list ref, enterIntMode: int (* 0 => None, 1 => X86. *) } val getEnterIntMode: unit -> int = RunCall.rtsCallFast0 "PolyInterpretedEnterIntMode" (* create and initialise a code segment *) fun codeCreate (name : string, parameters) = let val printStream = PRETTY.getSimplePrinter(parameters, []) in Code { constVec = ref [], procName = name, printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters, printStream = printStream, stage1Code = ref [], enterIntMode = getEnterIntMode() } end (* Find the offset in the constant area of a constant. *) (* The first has offset 0. *) fun addConstToVec (valu, Code{constVec, ...}) = let (* Search the list to see if the constant is already there. *) fun findConst valu [] num = (* Add to the list *) ( constVec := ! constVec @ [valu]; num ) | findConst valu (h :: t) num = if wordEq (valu, h) then num else findConst valu t (num + 1) (* Not equal *) in findConst valu (! constVec) 0 end fun printCode (seg: codeVec, procName: string, endcode, printStream) = let val () = printStream "\n"; val () = if procName = "" (* No name *) then printStream "?" else printStream procName; val () = printStream ":\n"; (* prints a string representation of a number *) fun printHex (v) = printStream(Word.fmt StringCvt.HEX v); val ptr = ref 0w0; (* Gets "length" bytes from locations "addr", "addr"+1... Returns an unsigned number. *) fun getB (0, _, _) = 0w0 | getB (length, addr, seg) = (getB (length - 1, addr + 0w1, seg) << 0w8) + word8ToWord (codeVecGet (seg, addr)) (* Prints a relative address. *) fun printDisp (len, spacer: string) = let val ad = getB(len, !ptr, seg) + !ptr + Word.fromInt len val () = printStream spacer; val () = printHex ad; in ptr := !ptr + Word.fromInt len end (* Prints an operand of an instruction *) fun printOp (len, spacer : string) = let val () = printStream spacer; val () = printHex (getB (len, !ptr, seg)) in ptr := !ptr + Word.fromInt len end; in while !ptr < endcode do let val addr = !ptr in printHex addr; (* The address. *) let (* It's an instruction. *) val () = printStream "\t" val opc = codeVecGet (seg, !ptr) (* opcode *) val () = ptr := !ptr + 0w1 in case opc of 0wx02 => (printStream "jump"; printDisp (1, "\t\t")) | 0wx03 => (printStream "jumpFalse"; printDisp (1, "\t")) | 0wx04 => printStream "loadMLWord" | 0wx05 => printStream "storeMLWord" | 0wx06 => printStream "alloc_ref" | 0wx07 => printStream "blockMoveWord" | 0wx08 => printStream "loadUntagged" | 0wx09 => printStream "storeUntagged" | 0wx0a => let (* Have to find out how many items there are. *) val limit = getB (2, !ptr, seg); val () = printOp (2, "case16\t"); val base = !ptr; fun printEntry _ = (printStream "\n\t"; printHex(base + getB(2, !ptr, seg)); ptr := !ptr + 0w2) fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) in forLoop printEntry 0w0 limit end | 0wx0c => printStream "callClosure" | 0wx0d => printOp(2, "returnW\t") | 0wx0e => printStream "containerB" | 0wx0f => printOp(2, "allocMutClosure") | 0wx10 => printStream "raiseEx" | 0wx11 => printDisp (2, "callConstAddr16\t") | 0wx12 => printDisp (1, "callConstAddr8\t") | 0wx13 => printOp(2, "localW\t") | 0wx16 => printOp(1, "callLocalB\t") | 0wx1a => (printStream "constAddr16"; printDisp (2, "\t")) | 0wx1b => printOp(2, "constIntW\t") | 0wx1e => ((* Should be negative *) printStream "jumpBack8\t"; printHex((!ptr - 0w1) - getB(1, !ptr, seg)); ptr := !ptr + 0w1 ) | 0wx1f => printOp(1, "returnB\t") | 0wx20 => ( printStream "jumpBack16\t"; printHex((!ptr - 0w1) - getB(2, !ptr, seg)); ptr := !ptr + 0w2 ) | 0wx21 => (printOp(1, "indirectLocalBB\t"); printOp(1, ",")) | 0wx22 => printOp(1, "localB\t") | 0wx23 => printOp(1, "indirectB\t") | 0wx24 => printOp(1, "moveToContainerB\t") | 0wx25 => printOp(1, "setStackValB\t") | 0wx26 => printOp(1, "resetB\t") | 0wx27 => printOp(1, "resetRB\t") | 0wx28 => printOp(1, "constIntB\t") | 0wx29 => printStream "local_0" | 0wx2a => printStream "local_1" | 0wx2b => printStream "local_2" | 0wx2c => printStream "local_3" | 0wx2d => printStream "local_4" | 0wx2e => printStream "local_5" | 0wx2f => printStream "local_6" | 0wx30 => printStream "local_7" | 0wx31 => printStream "local_8" | 0wx32 => printStream "local_9" | 0wx33 => printStream "local_10" | 0wx34 => printStream "local_11" | 0wx35 => printStream "indirect_0" | 0wx36 => printStream "indirect_1" | 0wx37 => printStream "indirect_2" | 0wx38 => printStream "indirect_3" | 0wx39 => printStream "indirect_4" | 0wx3a => printStream "indirect_5" | 0wx3b => printStream "const_0" | 0wx3c => printStream "const_1" | 0wx3d => printStream "const_2" | 0wx3e => printStream "const_3" | 0wx3f => printStream "const_4" | 0wx40 => printStream "const_10" | 0wx41 => printStream "return_0" | 0wx42 => printStream "return_1" | 0wx43 => printStream "return_2" | 0wx44 => printStream "return_3" | 0wx45 => printStream "local_12" | 0wx46 => (printStream "jumpTrue"; printDisp (1, "\t")) | 0wx47 => (printStream "jumpTrue"; printDisp (2, "\t")) | 0wx49 => printStream "local_13" | 0wx4a => printStream "local_14" | 0wx4b => printStream "local_15" | 0wx50 => printStream "reset_1" | 0wx51 => printStream "reset_2" | 0wx54 => (printOp(1, "indirectClosureBB\t"); printOp(1, ", ")) | 0wx64 => printStream "resetR_1" | 0wx65 => printStream "resetR_2" | 0wx66 => printStream "resetR_3" | 0wx68 => printOp(1, "tupleB\t") | 0wx69 => printStream "tuple_2" | 0wx6a => printStream "tuple_3" | 0wx6b => printStream "tuple_4" | 0wx6c => printStream "lock" | 0wx6d => printStream "ldexc" | 0wx74 => printOp(1, "indirectContainerB\t") | 0wx75 => printOp(1, "moveToMutClosureB\t") | 0wx76 => printOp(1, "allocMutClosureB\t") | 0wx77 => printOp(1, "indirectClosureB0\t") | 0wx78 => printStream "pushHandler" | 0wx7a => printOp(1, "indirectClosureB1\t") | 0wx7b => (printOp (1, "tailbb\t"); printOp (1, ",")) | 0wx7c => printOp(1, "indirectClosureB2\t") | 0wx7d => printOp(1, "tail3b\t") | 0wx7e => printOp(1, "tail4b\t") | 0wx7f => printStream "tail3_2" | 0wx80 => printStream "tail3_3" | 0wx81 => (printStream "setHandler"; printDisp (1, "\t")) | 0wx83 => printStream "callFastRTS0" | 0wx84 => printStream "callFastRTS1" | 0wx85 => printStream "callFastRTS2" | 0wx86 => printStream "callFastRTS3" | 0wx87 => printStream "callFastRTS4" | 0wx88 => printStream "callFastRTS5" | 0wx91 => printStream "notBoolean" | 0wx92 => printStream "isTagged" | 0wx93 => printStream "cellLength" | 0wx94 => printStream "cellFlags" | 0wx95 => printStream "clearMutable" | 0wx97 => printStream "atomicIncr" | 0wx98 => printStream "atomicDecr" | 0wxa0 => printStream "equalWord" | 0wxa1 => printOp(1, "equalWordConstB\t") | 0wxa2 => printStream "lessSigned" | 0wxa3 => printStream "lessUnsigned" | 0wxa4 => printStream "lessEqSigned" | 0wxa5 => printStream "lessEqUnsigned" | 0wxa6 => printStream "greaterSigned" | 0wxa7 => printStream "greaterUnsigned" | 0wxa8 => printStream "greaterEqSigned" | 0wxa9 => printStream "greaterEqUnsigned" | 0wxaa => printStream "fixedAdd" | 0wxab => printStream "fixedSub" | 0wxac => printStream "fixedMult" | 0wxad => printStream "fixedQuot" | 0wxae => printStream "fixedRem" | 0wxb1 => printStream "wordAdd" | 0wxb2 => printStream "wordSub" | 0wxb3 => printStream "wordMult" | 0wxb4 => printStream "wordDiv" | 0wxb5 => printStream "wordMod" | 0wxb7 => printStream "wordAnd" | 0wxb8 => printStream "wordOr" | 0wxb9 => printStream "wordXor" | 0wxba => printStream "wordShiftLeft" | 0wxbb => printStream "wordShiftRLog" | 0wxbd => printStream "allocByteMem" | 0wxc1 => printOp(1, "indirectLocalB1\t") | 0wxc2 => printOp(1, "isTaggedLocalB\t") | 0wxc3 => (printOp(1, "jumpNEqLocalInd\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) | 0wxc4 => (printOp(1, "jumpTaggedLocal\t"); printDisp(1, "\t")) | 0wxc5 => (printOp(1, "jumpNEqLocal\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) | 0wxc6 => printStream "indirect0Local0" | 0wxc7 => printOp(1, "indirectLocalB0\t") | 0wxd0 => printOp(1, "closureB\t") | 0wxd9 => printStream "getThreadId" | 0wxda => printStream "allocWordMemory" | 0wxdc => printStream "loadMLByte" | 0wxe4 => printStream "storeMLByte" | 0wxec => printStream "blockMoveByte" | 0wxed => printStream "blockEqualByte" | 0wxee => printStream "blockCompareByte" | 0wxf1 => printStream "deleteHandler" | 0wxf7 => printStream "jump16" | 0wxf8 => printStream "jump16False" | 0wxf9 => printStream "setHandler16" | 0wxfa => printDisp (1, "constAddr8\t") | 0wxfb => printOp(1, "stackSize8\t") | 0wxfc => printOp(2, "stackSize16\t") | 0wxff => printStream "enterIntX86" | 0wxfe => ( case codeVecGet (seg, !ptr) before ptr := !ptr + 0w1 of 0wx0b => printStream "containerW" | 0wx10 => printOp(2, "indirectClosureW\t") | 0wx11 => printOp(2, "indirectContainerW\t") | 0wx14 => printOp(2, "indirectW\t") | 0wx15 => printOp(2, "moveToContainerW\t") | 0wx16 => printOp(2, "moveToMutClosureW\t") | 0wx17 => printOp(2, "setStackValW\t") | 0wx18 => printOp(2, "resetW\t") | 0wx19 => printOp(2, "resetR_w\t") | 0wx1c => printStream "callFastRTSRRtoR" | 0wx1d => printStream "callFastRTSRGtoR" | 0wx48 => (printStream "jumpTrue"; printDisp (4, "\t")) | 0wx56 => printStream "floatAbs" | 0wx57 => printStream "floatNeg" | 0wx58 => printStream "fixedIntToFloat" | 0wx59 => printStream "floatToReal" | 0wx5a => printOp(1, "realToFloat\t") | 0wx5b => printStream "floatEqual" | 0wx5c => printStream "floatLess" | 0wx5d => printStream "floatLessEq" | 0wx5e => printStream "floatGreater" | 0wx5f => printStream "floatGreaterEq" | 0wx60 => printStream "floatAdd" | 0wx61 => printStream "floatSub" | 0wx62 => printStream "floatMult" | 0wx63 => printStream "floatDiv" | 0wx67 => printOp(2, "tupleW\t") | 0wx6e => printOp(1, "realToInt\t") | 0wx6f => printOp(1, "floatToInt\t") | 0wx70 => printStream "callFastRTSFtoF" | 0wx71 => printStream "callFastRTSGtoF" | 0wx72 => printStream "callFastRTSFFtoF" | 0wx73 => printStream "callFastRTSFGtoF" | 0wx79 => printStream "realUnordered" | 0wx7a => printStream "floatUnordered" | 0wx7c => (printOp (2, "tail\t"); printOp (2, ",")) | 0wx8f => printStream "callFastRTSRtoR" | 0wx90 => printStream "callFastRTSGtoR" | 0wx99 => printStream "atomicReset" | 0wx9a => printStream "longWToTagged" | 0wx9b => printStream "signedToLongW" | 0wx9c => printStream "unsignedToLongW" | 0wx9d => printStream "realAbs" | 0wx9e => printStream "realNeg" | 0wx9f => printStream "fixedIntToReal" | 0wxaf => printStream "fixedDiv" | 0wxb0 => printStream "fixedMod" | 0wxbc => printStream "wordShiftRArith" | 0wxbe => printStream "lgWordEqual" | 0wxc0 => printStream "lgWordLess" | 0wxc1 => printStream "lgWordLessEq" | 0wxc2 => printStream "lgWordGreater" | 0wxc3 => printStream "lgWordGreaterEq" | 0wxc4 => printStream "lgWordAdd" | 0wxc5 => printStream "lgWordSub" | 0wxc6 => printStream "lgWordMult" | 0wxc7 => printStream "lgWordDiv" | 0wxc8 => printStream "lgWordMod" | 0wxc9 => printStream "lgWordAnd" | 0wxca => printStream "lgWordOr" | 0wxcb => printStream "lgWordXor" | 0wxcc => printStream "lgWordShiftLeft" | 0wxcd => printStream "lgWordShiftRLog" | 0wxce => printStream "lgWordShiftRArith" | 0wxcf => printStream "realEqual" | 0wxd0 => printOp(2, "closureW\t") | 0wxd1 => printStream "realLess" | 0wxd2 => printStream "realLessEq" | 0wxd3 => printStream "realGreater" | 0wxd4 => printStream "realGreaterEq" | 0wxd5 => printStream "realAdd" | 0wxd6 => printStream "realSub" | 0wxd7 => printStream "realMult" | 0wxd8 => printStream "realDiv" | 0wxdd => printStream "loadC8" | 0wxde => printStream "loadC16" | 0wxdf => printStream "loadC32" | 0wxe0 => printStream "loadC64" | 0wxe1 => printStream "loadCFloat" | 0wxe2 => printStream "loadCDouble" | 0wxe5 => printStream "storeC8" | 0wxe6 => printStream "storeC16" | 0wxe7 => printStream "storeC32" | 0wxe8 => printStream "storeC64" | 0wxe9 => printStream "storeCFloat" | 0wxea => printStream "storeCDouble" | 0wxf2 => printDisp (4, "jump32\t") | 0wxf3 => printDisp (4, "jump32False\t") | 0wxf4 => printDisp (4, "constAddr32\t") | 0wxf5 => printDisp (4, "setHandler32\t") | 0wxf6 => let (* Have to find out how many items there are. *) val limit = getB (2, !ptr, seg); val () = printOp (2, "case32\t"); val base = !ptr; fun printEntry _ = (printStream "\n\t"; printHex(base + getB(4, !ptr, seg)); ptr := !ptr + 0w4) fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) in forLoop printEntry 0w0 limit end | 0wxfd => printStream "allocCSpace" | 0wxfe => printStream "freeCSpace" | _ => printStream ("unknown:0xfe 0x" ^ Word8.toString opc) ) | opc => printStream("unknown:0x" ^ Word8.toString opc) end; (* an instruction. *) printStream "\n" end (* main loop *) end (* printCode *) fun codeSize (SimpleCode l) = List.length l | codeSize (LabelCode _) = 0 | codeSize (JumpInstruction{size=ref Size8, ...}) = 2 | codeSize (JumpInstruction{size=ref Size16, ...}) = 3 | codeSize (JumpInstruction{size=ref Size32, ...}) = 6 | codeSize (PushConstant{size=ref Size8, ...}) = 2 | codeSize (PushConstant{size=ref Size16, ...}) = 3 | codeSize (PushConstant{size=ref Size32, isCall=false, ...}) = 6 | codeSize (PushConstant{size=ref Size32, isCall=true, ...}) = 7 | codeSize (PushShort value) = if value <= 0w4 orelse value = 0w10 then 1 else if value < 0w256 then 2 else 3 | codeSize (IndexedCase{labels, size=ref Size32, ...}) = 4 + List.length labels * 4 | codeSize (IndexedCase{labels, size=ref Size16, ...}) = 3 + List.length labels * 2 | codeSize (IndexedCase{labels=_, size=ref Size8, ...}) = raise InternalError "codeSize" | codeSize (LoadLocal w) = if w <= 0w15 then 1 else 2 | codeSize (IndirectLocal{indirect=0w0, localAddr=0w0}) = 1 | codeSize (IndirectLocal{indirect=0w0, ...}) = 2 | codeSize (IndirectLocal{indirect=0w1, ...}) = 2 | codeSize (IndirectLocal _) = 3 | codeSize (UncondTransfer l) = List.length l | codeSize (IsTaggedLocalB _) = 2 | codeSize (JumpOnIsTaggedLocalB{size=ref Size8, ...}) = 3 | codeSize (JumpOnIsTaggedLocalB{size=ref Size16, ...}) = 5 | codeSize (JumpOnIsTaggedLocalB{size=ref Size32, ...}) = 8 | codeSize (JumpNotEqualLocalInd0BB{size=ref Size8, ...}) = 4 | codeSize (JumpNotEqualLocalInd0BB{label, size, localAddr, const}) = codeSize(IndirectLocal{localAddr=localAddr, indirect=0w0}) + codeSize(PushShort(word8ToWord const)) + 1 + codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) | codeSize (JumpNotEqualLocalConstBB{size=ref Size8, ...}) = 4 | codeSize (JumpNotEqualLocalConstBB {label, size, localAddr, const}) = codeSize(LoadLocal localAddr) + codeSize(PushShort(word8ToWord const)) + 1 + codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) (* General function to process the code. ic is the byte counter within the original code. *) fun foldCode startIc foldFn ops = let fun doFold(oper :: operList, ic) = doFold(operList, (* Get the size BEFORE any possible change. *) ic + Word.fromInt(codeSize oper) before foldFn(oper, ic)) | doFold(_, ic) = ic in doFold(ops, startIc) end (* Process the code, setting the destination of any labels. Return the length of the code. *) fun setLabels(LabelCode(ref labs) :: ops, ic) = (List.app(fn d => d := ic) labs; setLabels(ops, ic)) | setLabels(oper :: ops, ic) = setLabels(ops, ic + Word.fromInt(codeSize oper)) | setLabels([], ic) = ic (* Set the sizes of branches depending on the distance to the destination. *) fun setLabelsAndSizes ops = let val wordLength = wordSize (* Set the labels and adjust the sizes, repeating until it never gets smaller*) fun setLabAndSize(ops, lastSize) = let (* Calculate offsets for constants. *) val endIC = Word.andb(lastSize + wordLength - 0w1, ~ wordLength) val firstConstant = endIC + wordLength * 0w3 (* Because the constant area is word aligned we have to allow for the possibility that the distance between a "load constant" instruction and the target could actually increase. *) val alignment = wordLength - 0w1 fun adjust(JumpInstruction{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = if dest <= ic (* N.B. Include infinite loops as backwards. *) then ic - dest (* Backwards - Counts from start of instruction. *) else dest - (ic + 0w6) (* Forwards - Relative to the current end. *) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(JumpInstruction{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest <= ic then if ic - dest < 0wx100 then size := Size8 else () else if dest - (ic + 0w3) < 0wx100 then size := Size8 else () end | adjust(IndexedCase{size as ref Size32, labels}, ic) = let val startAddr = ic+0w4 (* Use 16-bit case if all the offsets are 16-bits. *) fun is16bit(ref lab) = let val dest = !(hd lab) in dest > startAddr andalso dest < startAddr+0wx10000 end in if List.all is16bit labels then size := Size16 else () end | adjust(PushConstant{size as ref Size32, constNum, ...}, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordLength val offset = constAddr - (ic + 0w6) in if offset < 0wx100-alignment then size := Size8 else if offset < 0wx10000-alignment then size := Size16 else () end | adjust(PushConstant{size as ref Size16, constNum, ...}, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordLength val offset = constAddr - (ic + 0w3) in if offset < 0wx100-alignment then size := Size8 else () end | adjust(JumpOnIsTaggedLocalB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + 0w8) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(JumpOnIsTaggedLocalB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + 0w5) < 0wx100 then size := Size8 else () end | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + Word.fromInt(codeSize j)) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () end | adjust(j as JumpNotEqualLocalConstBB{size as ref Size32, label=ref lab, ...}, ic) = let val dest = !(hd lab) val diff = dest - (ic + Word.fromInt(codeSize j)) in if diff < 0wx100 then size := Size8 else if diff < 0wx10000 then size := Size16 else () end | adjust(j as JumpNotEqualLocalConstBB{size as ref Size16, label=ref lab, ...}, ic) = let val dest = !(hd lab) in if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () end | adjust _ = () val _ = foldCode 0w0 adjust ops val nextSize = setLabels(ops, 0w0) in if nextSize < lastSize then setLabAndSize(ops, nextSize) else if nextSize = lastSize then lastSize else raise InternalError "setLabAndSize - size increased" end in setLabAndSize(ops, setLabels(ops, 0w0)) end fun genCode(ops, Code {constVec, ...}) = let (* First pass - set the labels. *) val codeSize = setLabelsAndSizes ops val wordSize = wordSize (* Align to wordLength. *) val endIC = Word.andb(codeSize + wordSize - 0w1, ~ wordSize) val paddingBytes = List.tabulate(Word.toInt(endIC - codeSize), fn _ => SimpleCode[opcode_const_0]) val endOfCode = endIC div wordSize - val firstConstant = endIC + wordSize * 0w3 (* Add 3 for fn name, unused and profile count. *) + val firstConstant = endIC + wordSize * 0w3 (* Add 3 for no of consts, fn name and profile count. *) val segSize = endOfCode + Word.fromInt(List.length(! constVec)) + 0w4 val codeVec = byteVecMake segSize val ic = ref 0w0 fun genByte b = byteVecSet(codeVec, !ic, b) before ic := !ic + 0w1 fun genByteCode(SimpleCode bytes, _) = (* Simple code - just generate the bytes. *) List.app genByte bytes | genByteCode(UncondTransfer bytes, _) = List.app genByte bytes | genByteCode(LabelCode _, _) = () | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size32, ...}, ic) = let val dest = !(hd labs) val extOpc = case jumpType of SetHandler => ext_opcode_setHandler32 | JumpFalse => ext_opcode_jump32False | JumpTrue => ext_opcode_jump32True | Jump => ext_opcode_jump32 | JumpBack => ext_opcode_jump32 val diff = dest - (ic + 0w6) in genByte opcode_escape; genByte extOpc; genByte(wordToWord8 diff); (* This may be negative so we must use an arithmetic shift. *) genByte(wordToWord8(diff ~>> 0w8)); genByte(wordToWord8(diff ~>> 0w16)); genByte(wordToWord8(diff ~>> 0w24)) end | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size16, ...}, ic) = let val dest = !(hd labs) in if dest <= ic then (* Jump back. *) let val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" val diff = ic - dest val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" in genByte opcode_jumpBack16; genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end else let val opc = case jumpType of SetHandler => opcode_setHandler16 | JumpFalse => opcode_jump16False | JumpTrue => opcode_jump16True | Jump => opcode_jump16 | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" val diff = dest - (ic + 0w3) val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" in genByte opc; genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end end | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size8, ...}, ic) = let val dest = !(hd labs) in if dest <= ic then (* Jump back. *) let val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" val diff = ic - dest val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" in genByte opcode_jumpBack8; genByte(wordToWord8 diff) end else let val opc = case jumpType of SetHandler => opcode_setHandler | JumpFalse => opcode_jumpFalse | JumpTrue => opcode_jumpTrue | Jump => opcode_jump | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" val diff = dest - (ic + 0w2) val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" in genByte opc; genByte(wordToWord8 diff) end end | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=false, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize (* Offsets are calculated from the END of the instruction *) val offset = constAddr - (ic + 0w6) in genByte opcode_escape; genByte ext_opcode_constAddr32; genByte(wordToWord8 offset); genByte(wordToWord8(offset >> 0w8)); genByte(wordToWord8(offset >> 0w16)); genByte(wordToWord8(offset >> 0w24)) end | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=true, ... }, ic) = ( (* Turn this back into a push of a constant and call-closure. *) genByteCode(PushConstant{ constNum=constNum, size=ref Size32, isCall=false }, ic); genByte opcode_callClosure ) | genByteCode(PushConstant{ constNum, size=ref Size16, isCall, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize val offset = constAddr - (ic + 0w3) val _ = offset < 0wx10000 orelse raise InternalError "genByteCode - constant range" in genByte(if isCall then opcode_callConstAddr16 else opcode_constAddr16); genByte(wordToWord8 offset); genByte(wordToWord8(offset >> 0w8)) end | genByteCode(PushConstant{ constNum, size=ref Size8, isCall, ... }, ic) = let val constAddr = firstConstant + Word.fromInt constNum * wordSize val offset = constAddr - (ic + 0w2) val _ = offset < 0wx100 orelse raise InternalError "genByteCode - constant range" in genByte(if isCall then opcode_callConstAddr8 else opcode_constAddr8); genByte(wordToWord8 offset) end | genByteCode(PushShort 0w0, _) = genByte opcode_const_0 | genByteCode(PushShort 0w1, _) = genByte opcode_const_1 | genByteCode(PushShort 0w2, _) = genByte opcode_const_2 | genByteCode(PushShort 0w3, _) = genByte opcode_const_3 | genByteCode(PushShort 0w4, _) = genByte opcode_const_4 | genByteCode(PushShort 0w10, _) = genByte opcode_const_10 | genByteCode(PushShort value, _) = if value < 0w256 then (genByte opcode_constIntB; genByte(wordToWord8 value)) else (genByte opcode_constIntW; genByte(wordToWord8 value); genByte(wordToWord8(value >> 0w8))) | genByteCode(IndexedCase{labels, size=ref Size32, ...}, ic) = let val nCases = List.length labels val () = genByte opcode_escape val () = genByte ext_opcode_case32 val () = genByte(Word8.fromInt nCases) val () = genByte(Word8.fromInt (nCases div 256)) val startOffset = ic+0w4 (* Offsets are relative to here. *) fun putLabel(ref labs) = let val dest = !(hd labs) val diff = dest - startOffset val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" in genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)); genByte(wordToWord8(diff >> 0w16)); genByte(wordToWord8(diff >> 0w24)) end in List.app putLabel labels end | genByteCode(IndexedCase{labels, size=ref Size16, ...}, ic) = let val nCases = List.length labels val () = genByte(opcode_case16) val () = genByte(Word8.fromInt nCases) val () = genByte(Word8.fromInt (nCases div 256)) val startOffset = ic+0w3 (* Offsets are relative to here. *) fun putLabel(ref labs) = let val dest = !(hd labs) val diff = dest - startOffset val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - indexed case" in genByte(wordToWord8 diff); genByte(wordToWord8(diff >> 0w8)) end in List.app putLabel labels end | genByteCode(IndexedCase{size=ref Size8, ...}, _) = raise InternalError "genByteCode - IndexedCase byte" | genByteCode(LoadLocal 0w0, _) = genByte opcode_local_0 | genByteCode(LoadLocal 0w1, _) = genByte opcode_local_1 | genByteCode(LoadLocal 0w2, _) = genByte opcode_local_2 | genByteCode(LoadLocal 0w3, _) = genByte opcode_local_3 | genByteCode(LoadLocal 0w4, _) = genByte opcode_local_4 | genByteCode(LoadLocal 0w5, _) = genByte opcode_local_5 | genByteCode(LoadLocal 0w6, _) = genByte opcode_local_6 | genByteCode(LoadLocal 0w7, _) = genByte opcode_local_7 | genByteCode(LoadLocal 0w8, _) = genByte opcode_local_8 | genByteCode(LoadLocal 0w9, _) = genByte opcode_local_9 | genByteCode(LoadLocal 0w10, _) = genByte opcode_local_10 | genByteCode(LoadLocal 0w11, _) = genByte opcode_local_11 | genByteCode(LoadLocal 0w12, _) = genByte opcode_local_12 | genByteCode(LoadLocal 0w13, _) = genByte opcode_local_13 | genByteCode(LoadLocal 0w14, _) = genByte opcode_local_14 | genByteCode(LoadLocal 0w15, _) = genByte opcode_local_15 | genByteCode(LoadLocal w, _) = (genByte opcode_localB; genByte w) | genByteCode(IndirectLocal{localAddr=0w0, indirect=0w0}, _) = genByte opcode_indirect0Local0 | genByteCode(IndirectLocal{localAddr, indirect=0w0}, _) = (genByte opcode_indirectLocalB0; genByte localAddr) | genByteCode(IndirectLocal{localAddr, indirect=0w1}, _) = (genByte opcode_indirectLocalB1; genByte localAddr) | genByteCode(IndirectLocal{localAddr, indirect}, _) = (genByte opcode_indirectLocalBB; genByte localAddr; genByte indirect) | genByteCode(IsTaggedLocalB addr, _) = (genByte opcode_isTaggedLocalB; genByte addr) | genByteCode(JumpOnIsTaggedLocalB {label=ref labs, size=ref Size8, localAddr}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w3) in genByte opcode_jumpTaggedLocal; genByte localAddr; genByte(wordToWord8 diff) end | genByteCode(JumpOnIsTaggedLocalB {label, size, localAddr}, ic) = ( (* Turn this back into the original sequence. *) genByteCode(IsTaggedLocalB localAddr, ic); genByteCode(JumpInstruction{jumpType=JumpTrue, label=label, size=size}, ic+0w2) ) | genByteCode(JumpNotEqualLocalInd0BB {label=ref labs, size=ref Size8, localAddr, const}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w4) in genByte opcode_jumpNEqLocalInd; genByte localAddr; genByte const; genByte(wordToWord8 diff) end | genByteCode(JumpNotEqualLocalInd0BB {label, size, localAddr, const}, ic) = (* Turn this back into the original sequence. *) (foldCode ic genByteCode [IndirectLocal{localAddr=localAddr, indirect=0w0}, PushShort(word8ToWord const), SimpleCode[opcode_equalWord], JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) | genByteCode(JumpNotEqualLocalConstBB {label=ref labs, size=ref Size8, localAddr, const}, ic) = let val dest = !(hd labs) val diff = dest - (ic + 0w4) in genByte opcode_jumpNEqLocal; genByte localAddr; genByte const; genByte(wordToWord8 diff) end | genByteCode(JumpNotEqualLocalConstBB {label, size, localAddr, const}, ic) = (* Turn this back into the original sequence. *) (foldCode ic genByteCode [LoadLocal localAddr, PushShort(word8ToWord const), SimpleCode[opcode_equalWord], JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) in foldCode 0w0 genByteCode (ops @ paddingBytes); (codeVec (* Return the completed code. *), endIC (* And the size. *)) end fun setLong (value, addrs, seg) = let val wordLength = wordSize fun putBytes(value, a, seg, i) = if i = wordLength then () else ( byteVecSet(seg, if not isBigEndian then a+i else a+wordLength-i-0w1, Word8.fromInt(value mod 256)); putBytes(value div 256, a, seg, i+0w1) ) in putBytes(value, addrs, seg, 0w0) end (* Peephole optimisation. *) local fun peepHole([], _, output) = List.rev output | peepHole(LabelCode lab1 :: (instrs as LabelCode lab2 :: _), exited, output) = ( (* Consecutive labels. Merge these, discarding the first. *) lab2 := !lab1 @ !lab2; peepHole(instrs, exited, output) ) (* A label followed by an unconditional branch. Forward the original label. Although JumpBack is also unconditional we don't forward those because we don't have a conditional backwards jump. *) | peepHole((LabelCode lab1) :: (jump as JumpInstruction{jumpType=Jump, label=lab2, ...}) :: tl, exited, output) = ( lab2 := !lab1 @ !lab2; (* Leave the jump in the stream and leave "exited" unchanged. This will now be unreachable if we had previously exited but we need to take the jump if we hadn't. *) peepHole(jump :: tl, exited, output) ) (* Discard everything after an unconditional transfer until the next label. *) | peepHole((label as LabelCode _) :: tl, _, output) = peepHole(tl, false, label::output) | peepHole(_ :: tl, true, output) = peepHole(tl, true, output) | peepHole((jump as JumpInstruction{jumpType=Jump, ...}) :: tl, _, output) = peepHole(tl, true, jump :: output) (* Return, raise-exception and tail-call. *) | peepHole((uncond as UncondTransfer _) :: tl, _, output) = peepHole(tl, true, uncond :: output) (* A conditional branch round an unconditional branch. Replace by a conditional branch with the sense reversed. *) | peepHole((cond as JumpInstruction{jumpType=JumpFalse, label=lab1, ...}) :: (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: (tail as LabelCode lab3 :: _), _, output) = if lab1 = lab3 then peepHole(tail, false, JumpInstruction{jumpType=JumpTrue, label=lab2, size=size} :: output) else peepHole(uncond :: tail, false, cond :: output) | peepHole((cond as JumpInstruction{jumpType=JumpTrue, label=lab1, ...}) :: (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: (tail as LabelCode lab3 :: _), _, output) = if lab1 = lab3 then peepHole(tail, false, JumpInstruction{jumpType=JumpFalse, label=lab2, size=size} :: output) else peepHole(uncond :: tail, false, cond :: output) | peepHole(IsTaggedLocalB addr :: JumpInstruction{jumpType=JumpTrue, label, size} :: tail, _, output) = peepHole(tail, false, JumpOnIsTaggedLocalB {label=label, size=size, localAddr=addr} :: output) | peepHole((indLocal as IndirectLocal{localAddr, indirect=0w0}) :: (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = if const < 0w256 then peepHole(tail, false, JumpNotEqualLocalInd0BB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) else peepHole(instrs, false, indLocal :: output) | peepHole((load as LoadLocal localAddr) :: (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = if const < 0w256 then peepHole(tail, false, JumpNotEqualLocalConstBB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) else peepHole(instrs, false, load :: output) | peepHole(hd::tl, exited, output) = peepHole(tl, exited, hd::output) in fun optimise code = peepHole(code, false, []) end (* Generate the code sequence to enter the interpreter when this code is called or returned to or an exception is raised. This is only required when bootstrapping a native code compiler. *) fun genEnterInt(_, Code { enterIntMode = 0 (* None *), ...}) = [] | genEnterInt(b, Code { enterIntMode = 1 (* X86_32 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx24, b]] | genEnterInt(b, Code { enterIntMode = 2 (* X86_64 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx48, b]] | genEnterInt(b, Code { enterIntMode = 3 (* X86_32_64 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx48, b]] | genEnterInt _ = raise InternalError "genEnterInt: unknown architecture value" (* Adds the constants onto the code, and copies the code into a new segment *) fun copyCode {code as Code{ printAssemblyCode, printStream, procName, constVec, stage1Code, ...}, maxStack, numberOfArguments, resultClosure} = let val cvec = code local val revCode = optimise(List.rev(!stage1Code)) (* Add a stack check. This is only needed if the function needs more than 128 words since the call and tail functions check for this much. *) in val codeList = if maxStack < 128 then revCode else SimpleCode[opcode_stackSize16, Word8.fromInt maxStack, Word8.fromInt(maxStack div 256)] :: revCode end (* Add an enterInt if necessary *) (* If we need enter-int code it must go first. *) val enterInt = genEnterInt(Word8.fromInt numberOfArguments + 0wx80, cvec) val (byteVec, endIC) = genCode(enterInt @ codeList, cvec) val wordLength = wordSize (* +3 for profile count, function name and constants count *) val numOfConst = List.length(! constVec) val endOfCode = endIC div wordLength val segSize = endOfCode + Word.fromInt numOfConst + 0w4 - val firstConstant = endIC + wordLength * 0w3 (* Add 3 for fn name, unused and profile count. *) + val firstConstant = endIC + wordLength * 0w3 (* Add 3 for no of consts, fn name and profile count. *) (* Put in the number of constants. This must go in before we actually put in any constants. *) local - val addr = ((segSize - 0w1) * wordLength) + val lastWord = (segSize - 0w1) * wordLength in - val () = setLong (numOfConst + 3, addr, byteVec) + val () = setLong(numOfConst + 2, endIC, byteVec) + (* Set the last word of the code to the (negative) byte offset of the start of the code area + from the end of this word. *) + val () = setLong((numOfConst + 3) * ~ (Word.toInt wordLength), lastWord, byteVec) end (* Now we've filled in all the size info we need to convert the segment into a proper code segment before it's safe to put in any ML values. *) val codeVec = byteVecToCodeVec(byteVec, resultClosure) local val name : string = procName val nameWord : machineWord = toMachineWord name in - val () = codeVecPutWord (codeVec, endOfCode, nameWord) + val () = codeVecPutWord (codeVec, endOfCode+0w1, nameWord) end - (* This used to be used on X86 for the register mask. *) - val () = codeVecPutWord (codeVec, endOfCode+0w1, toMachineWord 1) (* Profile ref. A byte ref used by the profiler in the RTS. *) local val v = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(v, i-0w1, 0w0); clear (i-0w1)) val () = clear(wordSize) in val () = codeVecPutWord (codeVec, endOfCode+0w2, toMachineWord v) end (* and then copy the constants from the constant list. *) local fun setConstant(value, num) = let val constAddr = (firstConstant div wordLength) + num in codeVecPutWord (codeVec, constAddr, value); num+0w1 end in val _ = List.foldl setConstant 0w0 (!constVec) end in if printAssemblyCode then (* print out the code *) (printCode (codeVec, procName, endIC, printStream); printStream"\n") else (); codeVecLock(codeVec, resultClosure) end (* copyCode *) fun addItemToList(item, Code{stage1Code, ...}) = stage1Code := item :: !stage1Code val genOpcode = addItemToList fun putBranchInstruction(brOp, label, cvec) = addItemToList(JumpInstruction{label=label, jumpType=brOp, size = ref Size32}, cvec) fun setLabel(label, cvec) = addItemToList(LabelCode label, cvec) fun createLabel () = ref [ref 0w0] local fun genOpc(opc, cvec) = addItemToList(SimpleCode [opc], cvec) and genExtOpc(opc, cvec) = addItemToList(SimpleCode [opcode_escape, opc], cvec) and genOpcByte(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(SimpleCode [opc, Word8.fromInt arg1], cvec) else raise InternalError "genOpcByte" and genExtOpcByte(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(SimpleCode [opcode_escape, opc, Word8.fromInt arg1], cvec) else raise InternalError "genExtOpcByte" and genExtOpcWord(opc, arg1, cvec) = if 0 <= arg1 andalso arg1 < 65536 then addItemToList(SimpleCode[opcode_escape, opc, Word8.fromInt arg1, Word8.fromInt (arg1 div 256)], cvec) else raise InternalError "genExtOpcWord" open IEEEReal fun encodeRound TO_NEAREST = 0 | encodeRound TO_NEGINF = 1 | encodeRound TO_POSINF = 2 | encodeRound TO_ZERO = 3 in fun genRaiseEx cvec = addItemToList(UncondTransfer [opcode_raiseEx], cvec) fun genLock cvec = genOpc (opcode_lock, cvec) fun genLdexc cvec = genOpc (opcode_ldexc, cvec) fun genPushHandler cvec = genOpc (opcode_pushHandler, cvec) fun genRTSCallFast(0, cvec) = genOpc (opcode_callFastRTS0, cvec) | genRTSCallFast(1, cvec) = genOpc (opcode_callFastRTS1, cvec) | genRTSCallFast(2, cvec) = genOpc (opcode_callFastRTS2, cvec) | genRTSCallFast(3, cvec) = genOpc (opcode_callFastRTS3, cvec) | genRTSCallFast(4, cvec) = genOpc (opcode_callFastRTS4, cvec) | genRTSCallFast(5, cvec) = genOpc (opcode_callFastRTS5, cvec) | genRTSCallFast(_, _) = raise InternalError "genRTSFastCall" fun genContainer (size, cvec) = if size < 256 then genOpcByte(opcode_containerB, size, cvec) else genExtOpcWord(ext_opcode_containerW, size, cvec) fun genCase (nCases, cvec) = let val labels = List.tabulate(nCases, fn _ => createLabel()) in addItemToList(IndexedCase{labels=labels, size=ref Size32}, cvec); labels end (* For the moment don't try to merge stack resets. *) fun resetStack(0, _, _) = () | resetStack(1, true, cvec) = addItemToList(SimpleCode[opcode_resetR_1], cvec) | resetStack(2, true, cvec) = addItemToList(SimpleCode[opcode_resetR_2], cvec) | resetStack(3, true, cvec) = addItemToList(SimpleCode[opcode_resetR_3], cvec) | resetStack(offset, true, cvec) = if offset < 0 then raise InternalError "resetStack" else if offset > 255 then genExtOpcWord(ext_opcode_resetR_w, offset, cvec) else genOpcByte(opcode_resetRB, offset, cvec) | resetStack(1, false, cvec) = addItemToList(SimpleCode[opcode_reset_1], cvec) | resetStack(2, false, cvec) = addItemToList(SimpleCode[opcode_reset_2], cvec) | resetStack(offset, false, cvec) = if offset < 0 then raise InternalError "resetStack" else if offset > 255 then genExtOpcWord(ext_opcode_resetW, offset, cvec) else genOpcByte(opcode_resetB, offset, cvec) fun genCallClosure(Code{stage1Code as ref(PushConstant{constNum, size, isCall=false} :: tail), ...}) = stage1Code := PushConstant{constNum=constNum, size=size, isCall=true} :: tail | genCallClosure(Code{stage1Code as ref(LoadLocal w :: tail), ...}) = stage1Code := SimpleCode [opcode_callLocalB, w] :: tail | genCallClosure(Code{stage1Code, ...}) = stage1Code := SimpleCode [opcode_callClosure] :: !stage1Code fun genTailCall (toslide, slideby, cvec) = if toslide < 256 andalso slideby < 256 then (* General byte case *) addItemToList(UncondTransfer[opcode_tailbb, Word8.fromInt toslide, Word8.fromInt slideby], cvec) else (* General case. *) addItemToList( UncondTransfer[opcode_escape, ext_opcode_tail, Word8.fromInt toslide, Word8.fromInt(toslide div 256), Word8.fromInt slideby, Word8.fromInt (slideby div 256)], cvec) fun pushConst (value : machineWord, cvec) = if isShort value andalso toShort value < 0w32768 then addItemToList(PushShort(toShort value), cvec) else (* address or large short *) addItemToList(PushConstant{constNum = addConstToVec(value, cvec), size=ref Size32, isCall=false}, cvec) fun genRTSCallFastRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRtoR, cvec) and genRTSCallFastRealRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRRtoR, cvec) and genRTSCallFastGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSGtoR, cvec) and genRTSCallFastRealGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSRGtoR, cvec) and genRTSCallFastFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFtoF, cvec) and genRTSCallFastFloatFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFFtoF, cvec) and genRTSCallFastGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSGtoF, cvec) and genRTSCallFastFloatGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSFGtoF, cvec) fun genDoubleToFloat(SOME rnding, cvec) = genExtOpcByte(ext_opcode_realToFloat, encodeRound rnding, cvec) | genDoubleToFloat(NONE, cvec) = genExtOpcByte(ext_opcode_realToFloat, 5, cvec) and genRealToInt(rnding, cvec) = genExtOpcByte(ext_opcode_realToInt, encodeRound rnding, cvec) and genFloatToInt(rnding, cvec) = genExtOpcByte(ext_opcode_floatToInt, encodeRound rnding, cvec) fun genEqualWordConst(w, cvec) = (pushConst(toMachineWord w, cvec); genOpc(opcode_equalWord, cvec)) fun genIsTagged(Code{stage1Code as ref(LoadLocal addr :: tail), ...}) = stage1Code := IsTaggedLocalB addr :: tail | genIsTagged cvec = genOpc(opcode_isTagged, cvec) fun genIndirectSimple(0, cvec) = genOpc(opcode_indirect_0, cvec) | genIndirectSimple(1, cvec) = genOpc(opcode_indirect_1, cvec) | genIndirectSimple(2, cvec) = genOpc(opcode_indirect_2, cvec) | genIndirectSimple(3, cvec) = genOpc(opcode_indirect_3, cvec) | genIndirectSimple(4, cvec) = genOpc(opcode_indirect_4, cvec) | genIndirectSimple(5, cvec) = genOpc(opcode_indirect_5, cvec) | genIndirectSimple(arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_indirectB, arg1, cvec) else genExtOpcWord(ext_opcode_indirectW, arg1, cvec) fun genIndirectContainer(arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_indirectContainerB, arg1, cvec) else genExtOpcWord(ext_opcode_indirectContainerW, arg1, cvec) fun genMoveToContainer (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_moveToContainerB, arg1, cvec) else genExtOpcWord(ext_opcode_moveToContainerW, arg1, cvec) fun genMoveToMutClosure (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_moveToMutClosureB, arg1, cvec) else genExtOpcWord(ext_opcode_moveToMutClosureW, arg1, cvec) fun genSetStackVal (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_setStackValB, arg1, cvec) else genExtOpcWord(ext_opcode_setStackValW, arg1, cvec) fun genTuple (2, cvec) = genOpc(opcode_tuple_2, cvec) | genTuple (3, cvec) = genOpc(opcode_tuple_3, cvec) | genTuple (4, cvec) = genOpc(opcode_tuple_4, cvec) | genTuple (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_tupleB, arg1, cvec) else genExtOpcWord(ext_opcode_tupleW, arg1, cvec) fun genAllocMutableClosure(closureSize, cvec) = if closureSize < 256 then genOpcByte(opcode_allocMutClosureB, closureSize, cvec) else genExtOpcWord(ext_opcode_allocMutClosureW, closureSize, cvec) fun genClosure (arg1, cvec) = if arg1 < 256 then genOpcByte(opcode_closureB, arg1, cvec) else genExtOpcWord(ext_opcode_closureW, arg1, cvec) fun genLocal (arg1, cvec) = if 0 <= arg1 andalso arg1 < 256 then addItemToList(LoadLocal(Word8.fromInt arg1), cvec) else addItemToList(SimpleCode[opcode_localW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)], cvec) fun genIndirectClosure{ addr, item, code=cvec } = if addr < 256 andalso item < 256 then ( case item of 0 => genOpcByte(opcode_indirectClosureB0, addr, cvec) | 1 => genOpcByte(opcode_indirectClosureB1, addr, cvec) | 2 => genOpcByte(opcode_indirectClosureB2, addr, cvec) | _ => addItemToList(SimpleCode[opcode_indirectClosureBB, Word8.fromInt addr, Word8.fromInt item], cvec) ) else ( genLocal (addr, cvec); addItemToList(SimpleCode[opcode_escape, ext_opcode_indirectClosureW, Word8.fromInt item, Word8.fromInt (item div 256)], cvec) ) end fun genReturn(1, cvec) = addItemToList(UncondTransfer[opcode_return_1], cvec) | genReturn(2, cvec) = addItemToList(UncondTransfer[opcode_return_2], cvec) | genReturn(3, cvec) = addItemToList(UncondTransfer[opcode_return_3], cvec) | genReturn(arg1, cvec) = addItemToList(UncondTransfer( if 0 <= arg1 andalso arg1 <= 255 then [opcode_returnB, Word8.fromInt arg1] else [opcode_returnW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)]), cvec) fun genIndirect (arg1, cvec as Code{stage1Code as ref(LoadLocal w :: tail), ...}) = if 0 <= arg1 andalso arg1 <= 255 then stage1Code := IndirectLocal{localAddr=w, indirect=Word8.fromInt arg1} :: tail else genIndirectSimple(arg1, cvec) | genIndirect (arg1, cvec) = genIndirectSimple(arg1, cvec) fun genEnterIntCatch(code as Code{stage1Code, ...}) = stage1Code := genEnterInt(0wxff, code) @ !stage1Code and genEnterIntCall(code as Code{stage1Code, ...}, args) = stage1Code := genEnterInt(Word8.fromInt args, code) @ !stage1Code val opcode_notBoolean = SimpleCode [opcode_notBoolean] val opcode_cellLength = SimpleCode [opcode_cellLength] and opcode_cellFlags = SimpleCode [opcode_cellFlags] and opcode_clearMutable = SimpleCode [opcode_clearMutable] and opcode_atomicIncr = SimpleCode [opcode_atomicIncr] and opcode_atomicDecr = SimpleCode [opcode_atomicDecr] and opcode_atomicReset = SimpleCode [opcode_escape, ext_opcode_atomicReset] and opcode_longWToTagged = SimpleCode [opcode_escape, ext_opcode_longWToTagged] and opcode_signedToLongW = SimpleCode [opcode_escape, ext_opcode_signedToLongW] and opcode_unsignedToLongW = SimpleCode [opcode_escape, ext_opcode_unsignedToLongW] and opcode_realAbs = SimpleCode [opcode_escape, ext_opcode_realAbs] and opcode_realNeg = SimpleCode [opcode_escape, ext_opcode_realNeg] and opcode_fixedIntToReal = SimpleCode [opcode_escape, ext_opcode_fixedIntToReal] and opcode_fixedIntToFloat = SimpleCode [opcode_escape, ext_opcode_fixedIntToFloat] and opcode_floatToReal = SimpleCode [opcode_escape, ext_opcode_floatToReal] val opcode_equalWord = SimpleCode [opcode_equalWord] and opcode_lessSigned = SimpleCode [opcode_lessSigned] and opcode_lessUnsigned = SimpleCode [opcode_lessUnsigned] and opcode_lessEqSigned = SimpleCode [opcode_lessEqSigned] and opcode_lessEqUnsigned = SimpleCode [opcode_lessEqUnsigned] and opcode_greaterSigned = SimpleCode [opcode_greaterSigned] and opcode_greaterUnsigned = SimpleCode [opcode_greaterUnsigned] and opcode_greaterEqSigned = SimpleCode [opcode_greaterEqSigned] and opcode_greaterEqUnsigned = SimpleCode [opcode_greaterEqUnsigned] val opcode_fixedAdd = SimpleCode [opcode_fixedAdd] val opcode_fixedSub = SimpleCode [opcode_fixedSub] val opcode_fixedMult = SimpleCode [opcode_fixedMult] val opcode_fixedQuot = SimpleCode [opcode_fixedQuot] val opcode_fixedRem = SimpleCode [opcode_fixedRem] val opcode_fixedDiv = SimpleCode [opcode_escape, ext_opcode_fixedDiv] val opcode_fixedMod = SimpleCode [opcode_escape, ext_opcode_fixedMod] val opcode_wordAdd = SimpleCode [opcode_wordAdd] val opcode_wordSub = SimpleCode [opcode_wordSub] val opcode_wordMult = SimpleCode [opcode_wordMult] val opcode_wordDiv = SimpleCode [opcode_wordDiv] val opcode_wordMod = SimpleCode [opcode_wordMod] val opcode_wordAnd = SimpleCode [opcode_wordAnd] val opcode_wordOr = SimpleCode [opcode_wordOr] val opcode_wordXor = SimpleCode [opcode_wordXor] val opcode_wordShiftLeft = SimpleCode [opcode_wordShiftLeft] val opcode_wordShiftRLog = SimpleCode [opcode_wordShiftRLog] val opcode_wordShiftRArith = SimpleCode [opcode_escape, ext_opcode_wordShiftRArith] val opcode_allocByteMem = SimpleCode [opcode_allocByteMem] val opcode_lgWordEqual = SimpleCode [opcode_escape, ext_opcode_lgWordEqual] val opcode_lgWordLess = SimpleCode [opcode_escape, ext_opcode_lgWordLess] val opcode_lgWordLessEq = SimpleCode [opcode_escape, ext_opcode_lgWordLessEq] val opcode_lgWordGreater = SimpleCode [opcode_escape, ext_opcode_lgWordGreater] val opcode_lgWordGreaterEq = SimpleCode [opcode_escape, ext_opcode_lgWordGreaterEq] val opcode_lgWordAdd = SimpleCode [opcode_escape, ext_opcode_lgWordAdd] val opcode_lgWordSub = SimpleCode [opcode_escape, ext_opcode_lgWordSub] val opcode_lgWordMult = SimpleCode [opcode_escape, ext_opcode_lgWordMult] val opcode_lgWordDiv = SimpleCode [opcode_escape, ext_opcode_lgWordDiv] val opcode_lgWordMod = SimpleCode [opcode_escape, ext_opcode_lgWordMod] val opcode_lgWordAnd = SimpleCode [opcode_escape, ext_opcode_lgWordAnd] val opcode_lgWordOr = SimpleCode [opcode_escape, ext_opcode_lgWordOr] val opcode_lgWordXor = SimpleCode [opcode_escape, ext_opcode_lgWordXor] val opcode_lgWordShiftLeft = SimpleCode [opcode_escape, ext_opcode_lgWordShiftLeft] val opcode_lgWordShiftRLog = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRLog] val opcode_lgWordShiftRArith = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRArith] val opcode_realEqual = SimpleCode [opcode_escape, ext_opcode_realEqual] val opcode_realLess = SimpleCode [opcode_escape, ext_opcode_realLess] val opcode_realLessEq = SimpleCode [opcode_escape, ext_opcode_realLessEq] val opcode_realGreater = SimpleCode [opcode_escape, ext_opcode_realGreater] val opcode_realGreaterEq = SimpleCode [opcode_escape, ext_opcode_realGreaterEq] val opcode_realUnordered = SimpleCode [opcode_escape, ext_opcode_realUnordered] val opcode_realAdd = SimpleCode [opcode_escape, ext_opcode_realAdd] val opcode_realSub = SimpleCode [opcode_escape, ext_opcode_realSub] val opcode_realMult = SimpleCode [opcode_escape, ext_opcode_realMult] val opcode_realDiv = SimpleCode [opcode_escape, ext_opcode_realDiv] and opcode_floatAbs = SimpleCode [opcode_escape, ext_opcode_floatAbs] and opcode_floatNeg = SimpleCode [opcode_escape, ext_opcode_floatNeg] val opcode_floatEqual = SimpleCode [opcode_escape, ext_opcode_floatEqual] val opcode_floatLess = SimpleCode [opcode_escape, ext_opcode_floatLess] val opcode_floatLessEq = SimpleCode [opcode_escape, ext_opcode_floatLessEq] val opcode_floatGreater = SimpleCode [opcode_escape, ext_opcode_floatGreater] val opcode_floatGreaterEq = SimpleCode [opcode_escape, ext_opcode_floatGreaterEq] val opcode_floatUnordered = SimpleCode [opcode_escape, ext_opcode_floatUnordered] val opcode_floatAdd = SimpleCode [opcode_escape, ext_opcode_floatAdd] val opcode_floatSub = SimpleCode [opcode_escape, ext_opcode_floatSub] val opcode_floatMult = SimpleCode [opcode_escape, ext_opcode_floatMult] val opcode_floatDiv = SimpleCode [opcode_escape, ext_opcode_floatDiv] val opcode_getThreadId = SimpleCode [opcode_getThreadId] val opcode_allocWordMemory = SimpleCode [opcode_allocWordMemory] val opcode_alloc_ref = SimpleCode [opcode_alloc_ref] val opcode_loadMLWord = SimpleCode [opcode_loadMLWord] val opcode_loadMLByte = SimpleCode [opcode_loadMLByte] val opcode_loadC8 = SimpleCode [opcode_escape, ext_opcode_loadC8] val opcode_loadC16 = SimpleCode [opcode_escape, ext_opcode_loadC16] val opcode_loadC32 = SimpleCode [opcode_escape, ext_opcode_loadC32] val opcode_loadC64 = SimpleCode [opcode_escape, ext_opcode_loadC64] val opcode_loadCFloat = SimpleCode [opcode_escape, ext_opcode_loadCFloat] val opcode_loadCDouble = SimpleCode [opcode_escape, ext_opcode_loadCDouble] val opcode_loadUntagged = SimpleCode [opcode_loadUntagged] val opcode_storeMLWord = SimpleCode [opcode_storeMLWord] val opcode_storeMLByte = SimpleCode [opcode_storeMLByte] val opcode_storeC8 = SimpleCode [opcode_escape, ext_opcode_storeC8] val opcode_storeC16 = SimpleCode [opcode_escape, ext_opcode_storeC16] val opcode_storeC32 = SimpleCode [opcode_escape, ext_opcode_storeC32] val opcode_storeC64 = SimpleCode [opcode_escape, ext_opcode_storeC64] val opcode_storeCFloat = SimpleCode [opcode_escape, ext_opcode_storeCFloat] val opcode_storeCDouble = SimpleCode [opcode_escape, ext_opcode_storeCDouble] val opcode_storeUntagged = SimpleCode [opcode_storeUntagged] val opcode_blockMoveWord = SimpleCode [opcode_blockMoveWord] val opcode_blockMoveByte = SimpleCode [opcode_blockMoveByte] val opcode_blockEqualByte = SimpleCode [opcode_blockEqualByte] val opcode_blockCompareByte = SimpleCode [opcode_blockCompareByte] val opcode_deleteHandler = SimpleCode [opcode_deleteHandler] val opcode_allocCSpace = SimpleCode [opcode_escape, ext_opcode_allocCSpace] val opcode_freeCSpace = SimpleCode [opcode_escape, ext_opcode_freeCSpace] structure Sharing = struct type code = code type opcode = opcode type labels = labels type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML b/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML index c7c84b16..79c61b95 100644 --- a/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML +++ b/mlsource/MLCompiler/CodeTree/ByteCode/INTGCODE.ML @@ -1,1218 +1,1222 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Further development copyright David C.J. Matthews 2016-18,2020 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Generate interpretable code for Poly system from the code tree. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) (* This generates byte-code that is interpreted by the run-time system. It is now used as a fall-back to allow Poly/ML to run on non-X86 architectures. Early versions were used as a porting aid while a native code-generator was being developed and the "enter-int" instructions that were needed for that have been retained although they no longer actually generate code. *) functor INTGCODE ( structure CODECONS : INTCODECONSSIG structure BACKENDTREE: BackendIntermediateCodeSig structure CODE_ARRAY: CODEARRAYSIG sharing CODECONS.Sharing = BACKENDTREE.Sharing = CODE_ARRAY.Sharing ) : GENCODESIG = struct open CODECONS open Address open BACKENDTREE open Misc open CODE_ARRAY 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() ) (* Loads a local, argument or closure value; translating local stack addresses to real stack offsets. *) fun locaddr(BICLoadArgument locn) = pushLocalStackValue (numOfArgs-locn) | locaddr(BICLoadLocal locn) = ( (* positive address - on the stack. *) case Array.sub (decVec, locn) of StackAddr n => pushLocalStackValue (~ n) | _ => (* Should be on the stack, not a function. *) raise InternalError "locaddr: bad stack address" ) | locaddr(BICLoadClosure locn) = (* closure-pointer relative *) ( genIndirectClosure{addr = !realstackptr-1, item=locn, code=cvec}; incsp() ) | locaddr BICLoadRecursive = pushLocalStackValue ~1 (* The closure itself - first value on the stack. *) (* 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 locaddr ext | BICField {base, offset} => (gencde (base, ToStack, NotEnd, loopAddr); genIndirect (offset, cvec)) | BICLoadContainer {base, offset} => (gencde (base, ToStack, NotEnd, loopAddr); genIndirectContainer (offset, cvec)) | BICLambda lam => genProc (lam, false, fn () => ()) | BICConstnt(w, _) => let val () = pushConst (w, cvec); in incsp () end | 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 ) | 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) (* Now process the handler itself. First we have to reset the stack. Note that we have to use "ToStack" again to be consistent with the stack-handling in the body-part. If we actually wanted "NoResult", the stack adjustment code at the end of gencde will take care of this. This means that I don't want to do any clever "end-of-function" optimisation either. SPF 6/1/97 *) val () = realstackptr := oldsp val () = setLabel (handlerLabel, cvec) (* If we were executing machine code we must re-enter the interpreter. *) val () = genEnterIntCatch 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. *) ) | 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) | AtomicIncrement => genOpcode(opcode_atomicIncr, cvec) | AtomicDecrement => genOpcode(opcode_atomicDecr, 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) ; 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 { longCall, ... } => (* Just use the long-precision case in the interpreted version. *) ( gencde (longCall, whereto, tailKind, loopAddr) ) in (* body of gencde *) (* This ensures that there is precisely one item on the stack if whereto = ToStack and no items if whereto = NoResult. There are two points to note carefully here: (1) Negative stack adjustments are legal if we have exited. This is because matchFailFn can cut the stack back too far for its immediately enclosing expression. This is harmless because the code actually exits that expression. (2) A stack adjustment of ~1 is legal if we're generating a declaration in "ToStack" mode, because not all declarations actually generate the dummy value that we expect. This used to be handled in resetStack itself, but it's more transparent to do it here. (In addition, there was a bug in resetStack - it accumulated the stack resets, but didn't correctly accumulate these "~1" dummy value pushes.) It's all much better now. SPF 9/1/97 *) 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; (* Called after the args and the closure to call have been pushed onto the stack. *) fun callClosure () : unit = case tailKind of NotEnd => (* Normal call. *) genCallClosure cvec | EndOfProc => (* Tail recursive call. *) let (* Get the return address onto the top of the stack. *) val () = pushLocalStackValue 0 (* Slide the return address, closure and args over the old closure, return address and args, and reset the stack. Then jump to the closure. *) val () = genTailCall(argsToPass + 2, !realstackptr - 1 + (numOfArgs - argsToPass), cvec); (* It's "-1" not "-2", because we didn't bump the realstackptr when we pushed the return address. SPF 3/1/97 *) in () 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 val () = callClosure () (* Call the function. *) (* Make sure we interpret when we return from the call *) val () = genEnterIntCall (cvec, argsToPass) in (* body of genEval *) realstackptr := !realstackptr - argsToPass (* Args popped by caller. *) end (* 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 () = genReturn (numOfArgs, cvec); in (* body of codegen *) (* Having code-generated the body of the function, it is copied into a new data segment. *) copyCode{code = cvec, maxStack = !maxStack, resultClosure=resultClosure, numberOfArguments=numOfArgs} end (* codegen *); fun gencodeLambda({ name, body, argTypes, localCount, ...}:bicLambdaForm, parameters, closure) = let (* 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 local val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" fun rtsCall makeCall (entryName: string, numOfArgs, debugArgs: Universal.universal list): machineWord = let open Address val cvec = codeCreate (entryName, debugArgs) val entryPointAddr = makeEntryPoint entryName (* Each argument is at the same offset, essentially we're just shifting them *) fun genLocals 0 = () | genLocals n = (genLocal(numOfArgs +1, cvec); genLocals (n-1)) val () = genLocals numOfArgs val () = pushConst(entryPointAddr, cvec) val () = makeCall(numOfArgs, cvec) val () = genReturn (numOfArgs, cvec) val closure = makeConstantClosure() val () = copyCode{code=cvec, maxStack=numOfArgs+1, numberOfArguments=numOfArgs, resultClosure=closure} in closureAsAddress closure end in structure Foreign = struct val rtsCallFast = rtsCall genRTSCallFast fun rtsCallFastRealtoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealtoReal c) (entryName, 1, debugArgs) and rtsCallFastRealRealtoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealRealtoReal c) (entryName, 2, debugArgs) and rtsCallFastGeneraltoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastGeneraltoReal c) (entryName, 1, debugArgs) and rtsCallFastRealGeneraltoReal(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastRealGeneraltoReal c) (entryName, 2, debugArgs) fun rtsCallFastFloattoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloattoFloat c) (entryName, 1, debugArgs) and rtsCallFastFloatFloattoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloatFloattoFloat c) (entryName, 2, debugArgs) and rtsCallFastGeneraltoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastGeneraltoFloat c) (entryName, 1, debugArgs) and rtsCallFastFloatGeneraltoFloat(entryName, debugArgs) = rtsCall (fn (_, c) => genRTSCallFastFloatGeneraltoFloat c) (entryName, 2, debugArgs) type abi = int (* This must match the type in Foreign.LowLevel. Once this is bootstrapped we could use that type but note that this is the type we use within the compiler and we build Foreign.LowLevel AFTER compiling this. *) datatype cTypeForm = CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } val abiList: unit -> (string * abi) list = RunCall.rtsCallFull0 "PolyInterpretedGetAbiList" - type cif = LargeWord.word + type cif = Foreign.Memory.voidStar val createCIF: abi * cType * cType list -> cif= RunCall.rtsCallFull3 "PolyInterpretedCreateCIF" val callCFunction: cif * LargeWord.word * LargeWord.word * LargeWord.word -> unit = RunCall.rtsCallFull4 "PolyInterpretedCallFunction" (* foreignCall returns a function that actually calls the foreign function. *) fun foreignCall(abi, argTypes, resultType) = let - val cif = createCIF(abi, resultType, argTypes) + val memocif = Foreign.Memory.memoise (fn () => createCIF(abi, resultType, argTypes)) () val closure = makeConstantClosure() (* For compatibility with the native code version we have to construct a function that takes three arguments rather than a single triple. *) val bodyCode = BICEval{function=BICConstnt(toMachineWord callCFunction, []), argList=[ (BICTuple[ - BICConstnt(toMachineWord cif, []), + BICEval{ + function=BICConstnt(toMachineWord memocif, []), + argList=[(BICConstnt(toMachineWord 0, []), GeneralType)], (* Unit. *) + resultType=GeneralType + }, BICExtract(BICLoadArgument 0), BICExtract(BICLoadArgument 2), BICExtract(BICLoadArgument 1)], GeneralType) ], resultType=GeneralType} val lambdaCode = { body = bodyCode, name = "foreignCall", closure=[], argTypes=[GeneralType, GeneralType, GeneralType], resultType = GeneralType, localCount=0, heapClosure=false} val () = gencodeLambda(lambdaCode, [], closure) in closureAsAddress closure end fun buildCallBack((*abi*) _, (*argTypes*) _, (*resultType*)_) = let fun buildClosure ((*mlFun*)_: LargeWord.word*LargeWord.word -> unit) = (* The result is the SysWord.word holding the C function. *) raise Foreign.Foreign "foreignCall not implemented" in Address.toMachineWord buildClosure end end end structure Sharing = struct open BACKENDTREE.Sharing type closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML index faf1dec1..c60440fb 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML @@ -1,4014 +1,4015 @@ (* Copyright David C. J. Matthews 1989, 2000, 2009-10, 2012-13, 2015-20 Based on original code: Copyright (c) 2000 Cambridge University Technical Services Limited This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Code Generator Routines. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1989 *) (* This module contains the code vector and operations to insert code into it. Each procedure is compiled into a separate segment. Initially it is compiled into a fixed size segment, and then copied into a segment of the correct size at the end. This module contains all the definitions of the X86 opCodes and registers. It uses "codeseg" to create and operate on the segment itself. *) functor X86OUTPUTCODE ( structure DEBUG: DEBUG structure PRETTY: PRETTYSIG (* for compilerOutTag *) structure CODE_ARRAY: CODEARRAYSIG ) : X86CODESIG = struct open CODE_ARRAY open DEBUG open Address open Misc (* May be targeted at native 32-bit, native 64-bit or X86/64 with 32-bit words and addresses as object Ids. *) datatype targetArch = Native32Bit | Native64Bit | ObjectId32Bit val targetArch = case PolyML.architecture() of "I386" => Native32Bit | "X86_64" => Native64Bit | "X86_64_32" => ObjectId32Bit | _ => raise InternalError "Unknown target architecture" (* Some checks - *) val () = case (targetArch, wordSize, nativeWordSize) of (Native32Bit, 0w4, 0w4) => () | (Native64Bit, 0w8, 0w8) => () | (ObjectId32Bit, 0w4, 0w8) => () | _ => raise InternalError "Mismatch of architecture and word-length" val hostIsX64 = targetArch <> Native32Bit infix 5 << <<+ <<- >> >>+ >>- ~>> ~>>+ ~>>- (* Shift operators *) infix 3 andb orb xorb andbL orbL xorbL andb8 orb8 xorb8 val op << = Word.<< and op >> = Word.>> val (*op <<+ = LargeWord.<< and *) op >>+ = LargeWord.>> val op <<- = Word8.<< and op >>- = Word8.>> val op orb8 = Word8.orb val op andb8 = Word8.andb val op andb = Word.andb (* and op andbL = LargeWord.andb *) and op orb = Word.orb val wordToWord8 = Word8.fromLargeWord o Word.toLargeWord (*and word8ToWord = Word.fromLargeWord o Word8.toLargeWord*) val exp2_16 = 0x10000 val exp2_31 = 0x80000000: LargeInt.int (* Returns true if this a 32-bit machine or if the constant is within 32-bits. This is exported to the higher levels. N.B. The test for not isX64 avoids a significant overhead with arbitrary precision arithmetic on X86/32. *) fun is32bit v = not hostIsX64 orelse ~exp2_31 <= v andalso v < exp2_31 (* tag a short constant *) fun tag c = 2 * c + 1; fun is8BitL (n: LargeInt.int) = ~ 0x80 <= n andalso n < 0x80 local val shift = if wordSize = 0w4 then 0w2 else if wordSize = 0w8 then 0w3 else raise InternalError "Invalid word size for x86_32 or x86+64" in fun wordsToBytes n = n << shift and bytesToWords n = n >> shift end infix 6 addrPlus addrMinus; (* All indexes into the code vector have type "addrs". This is really a legacy. *) type addrs = Word.word val addrZero = 0w0 (* This is the external label type used when constructing operations. *) datatype label = Label of { labelNo: int } (* Constants which are too large to go inline in the code are put in a list and put at the end of the code. They are arranged so that the garbage collector can find them and change them as necessary. A reference to a constant is treated like a forward reference to a label. *) datatype code = Code of { procName: string, (* Name of the procedure. *) printAssemblyCode:bool, (* Whether to print the code when we finish. *) printStream: string->unit, (* The stream to use *) lowLevelOptimise: bool, (* Whether to do the low-level optimisation pass *) profileObject : machineWord (* The profile object for this code. *) } (* Exported functions *) fun lowLevelOptimise(Code{lowLevelOptimise, ...}) = lowLevelOptimise (* EBP/RBP points to a structure that interfaces to the RTS. These are offsets into that structure. *) val memRegLocalMPointer = 0 (* Not used in 64-bit *) and memRegHandlerRegister = Word.toInt nativeWordSize and memRegLocalMbottom = 2 * Word.toInt nativeWordSize and memRegStackLimit = 3 * Word.toInt nativeWordSize and memRegExceptionPacket = 4 * Word.toInt nativeWordSize and memRegCStackPtr = 6 * Word.toInt nativeWordSize and memRegThreadSelf = 7 * Word.toInt nativeWordSize and memRegStackPtr = 8 * Word.toInt nativeWordSize and memRegHeapOverflowCall = 10 * Word.toInt nativeWordSize and memRegStackOverflowCall = 11 * Word.toInt nativeWordSize and memRegStackOverflowCallEx = 12 * Word.toInt nativeWordSize and memRegSavedRbx = 14 * Word.toInt nativeWordSize (* Heap base in 32-in-64. *) (* create and initialise a code segment *) fun codeCreate (name : string, profObj, parameters) : code = let val printStream = PRETTY.getSimplePrinter(parameters, []) in Code { procName = name, printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters, printStream = printStream, lowLevelOptimise = DEBUG.getParameter DEBUG.lowlevelOptimiseTag parameters, profileObject = profObj } end (* Put 1 unsigned byte at a given offset in the segment. *) fun set8u (b, addr, seg) = byteVecSet (seg, addr, b) (* Put 4 bytes at a given offset in the segment. *) (* b0 is the least significant byte. *) fun set4Bytes (b3, b2, b1, b0, addr, seg) = let val a = addr; in (* Little-endian *) byteVecSet (seg, a, b0); byteVecSet (seg, a + 0w1, b1); byteVecSet (seg, a + 0w2, b2); byteVecSet (seg, a + 0w3, b3) end; (* Put 1 unsigned word at a given offset in the segment. *) fun set32u (ival: LargeWord.word, addr, seg) : unit = let val b3 = Word8.fromLargeWord (ival >>+ 0w24) val b2 = Word8.fromLargeWord (ival >>+ 0w16) val b1 = Word8.fromLargeWord (ival >>+ 0w8) val b0 = Word8.fromLargeWord ival in set4Bytes (b3, b2, b1, b0, addr, seg) end (* Put 1 signed word at a given offset in the segment. *) fun set32s (ival: LargeInt.int, addr, seg) = set32u(LargeWord.fromLargeInt ival, addr, seg) fun byteSigned ival = if ~0x80 <= ival andalso ival < 0x80 then Word8.fromInt ival else raise InternalError "byteSigned: invalid byte" (* Convert a large-word value to a little-endian byte sequence. *) fun largeWordToBytes(_, 0) = [] | largeWordToBytes(ival: LargeWord.word, n) = Word8.fromLargeWord ival :: largeWordToBytes(ival >>+ 0w8, n-1) fun word32Unsigned(ival: LargeWord.word) = largeWordToBytes(ival, 4) fun int32Signed(ival: LargeInt.int) = if is32bit ival then word32Unsigned(LargeWord.fromLargeInt ival) else raise InternalError "int32Signed: invalid word" (* Registers. *) datatype genReg = GeneralReg of Word8.word * bool and fpReg = FloatingPtReg of Word8.word and xmmReg = SSE2Reg of Word8.word datatype reg = GenReg of genReg | FPReg of fpReg | XMMReg of xmmReg (* These are the real registers we have. The AMD extension encodes the additional registers through the REX prefix. *) val rax = GeneralReg (0w0, false) val rcx = GeneralReg (0w1, false) val rdx = GeneralReg (0w2, false) val rbx = GeneralReg (0w3, false) val rsp = GeneralReg (0w4, false) val rbp = GeneralReg (0w5, false) val rsi = GeneralReg (0w6, false) val rdi = GeneralReg (0w7, false) val eax = rax and ecx = rcx and edx = rdx and ebx = rbx and esp = rsp and ebp = rbp and esi = rsi and edi = rdi val r8 = GeneralReg (0w0, true) val r9 = GeneralReg (0w1, true) val r10 = GeneralReg (0w2, true) val r11 = GeneralReg (0w3, true) val r12 = GeneralReg (0w4, true) val r13 = GeneralReg (0w5, true) val r14 = GeneralReg (0w6, true) val r15 = GeneralReg (0w7, true) (* Floating point "registers". Actually entries on the floating point stack. The X86 has a floating point stack with eight entries. *) val fp0 = FloatingPtReg 0w0 and fp1 = FloatingPtReg 0w1 and fp2 = FloatingPtReg 0w2 and fp3 = FloatingPtReg 0w3 and fp4 = FloatingPtReg 0w4 and fp5 = FloatingPtReg 0w5 and fp6 = FloatingPtReg 0w6 and fp7 = FloatingPtReg 0w7 (* SSE2 Registers. These are used for floating point in 64-bity mode. We only use XMM0-6 because the others are callee save and we don't currently save them. *) val xmm0 = SSE2Reg 0w0 and xmm1 = SSE2Reg 0w1 and xmm2 = SSE2Reg 0w2 and xmm3 = SSE2Reg 0w3 and xmm4 = SSE2Reg 0w4 and xmm5 = SSE2Reg 0w5 and xmm6 = SSE2Reg 0w6 and xmm7 = SSE2Reg 0w7 fun getReg (GeneralReg r) = r fun mkReg n = GeneralReg n (* reg.up *) (* The maximum size of the register vectors and masks. Although the X86/32 has a floating point stack with eight entries it's much simpler to treat it as having seven "real" registers. Items are pushed to the stack and then stored and popped into the current location. It may be possible to improve the code by some peephole optimisation. *) val regs = 30 (* Include the X86/64 registers even if this is 32-bit. *) (* The nth register (counting from 0). *) (* Profiling shows that applying the constructors here creates a lot of garbage. Create the entries once and then use vector indexing instead. *) local fun regN i = if i < 8 then GenReg(GeneralReg(Word8.fromInt i, false)) else if i < 16 then GenReg(GeneralReg(Word8.fromInt(i-8), true)) else if i < 23 then FPReg(FloatingPtReg(Word8.fromInt(i-16))) else XMMReg(SSE2Reg(Word8.fromInt(i-23))) val regVec = Vector.tabulate(regs, regN) in fun regN i = Vector.sub(regVec, i) handle Subscript => raise InternalError "Bad register number" end (* The number of the register. *) fun nReg(GenReg(GeneralReg(r, false))) = Word8.toInt r | nReg(GenReg(GeneralReg(r, true))) = Word8.toInt r + 8 | nReg(FPReg(FloatingPtReg r)) = Word8.toInt r + 16 | nReg(XMMReg(SSE2Reg r)) = Word8.toInt r + 23 datatype opsize = SZByte | SZWord | SZDWord | SZQWord (* Default size when printing regs. *) val sz32_64 = if hostIsX64 then SZQWord else SZDWord fun genRegRepr(GeneralReg (0w0, false), SZByte) = "al" | genRegRepr(GeneralReg (0w1, false), SZByte) = "cl" | genRegRepr(GeneralReg (0w2, false), SZByte) = "dl" | genRegRepr(GeneralReg (0w3, false), SZByte) = "bl" | genRegRepr(GeneralReg (0w4, false), SZByte) = "ah" | genRegRepr(GeneralReg (0w5, false), SZByte) = "ch" | genRegRepr(GeneralReg (0w6, false), SZByte) = "sil" (* Assume there's a Rex code that forces low-order reg *) | genRegRepr(GeneralReg (0w7, false), SZByte) = "dil" | genRegRepr(GeneralReg (reg, true), SZByte) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "b" | genRegRepr(GeneralReg (0w0, false), SZDWord) = "eax" | genRegRepr(GeneralReg (0w1, false), SZDWord) = "ecx" | genRegRepr(GeneralReg (0w2, false), SZDWord) = "edx" | genRegRepr(GeneralReg (0w3, false), SZDWord) = "ebx" | genRegRepr(GeneralReg (0w4, false), SZDWord) = "esp" | genRegRepr(GeneralReg (0w5, false), SZDWord) = "ebp" | genRegRepr(GeneralReg (0w6, false), SZDWord) = "esi" | genRegRepr(GeneralReg (0w7, false), SZDWord) = "edi" | genRegRepr(GeneralReg (reg, true), SZDWord) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "d" | genRegRepr(GeneralReg (0w0, false), SZQWord) = "rax" | genRegRepr(GeneralReg (0w1, false), SZQWord) = "rcx" | genRegRepr(GeneralReg (0w2, false), SZQWord) = "rdx" | genRegRepr(GeneralReg (0w3, false), SZQWord) = "rbx" | genRegRepr(GeneralReg (0w4, false), SZQWord) = "rsp" | genRegRepr(GeneralReg (0w5, false), SZQWord) = "rbp" | genRegRepr(GeneralReg (0w6, false), SZQWord) = "rsi" | genRegRepr(GeneralReg (0w7, false), SZQWord) = "rdi" | genRegRepr(GeneralReg (reg, true), SZQWord) = "r" ^ Int.toString(Word8.toInt reg +8) | genRegRepr(GeneralReg (0w0, false), SZWord) = "ax" | genRegRepr(GeneralReg (0w1, false), SZWord) = "cx" | genRegRepr(GeneralReg (0w2, false), SZWord) = "dx" | genRegRepr(GeneralReg (0w3, false), SZWord) = "bx" | genRegRepr(GeneralReg (0w4, false), SZWord) = "sp" | genRegRepr(GeneralReg (0w5, false), SZWord) = "bp" | genRegRepr(GeneralReg (0w6, false), SZWord) = "si" | genRegRepr(GeneralReg (0w7, false), SZWord) = "di" | genRegRepr(GeneralReg (reg, true), SZWord) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "w" | genRegRepr _ = "unknown" (* Suppress warning because word values are not exhaustive. *) and fpRegRepr(FloatingPtReg n) = "fp" ^ Word8.toString n and xmmRegRepr(SSE2Reg n) = "xmm" ^ Word8.toString n fun regRepr(GenReg r) = genRegRepr (r, sz32_64) | regRepr(FPReg r) = fpRegRepr r | regRepr(XMMReg r) = xmmRegRepr r (* Install a pretty printer. This is simply for when this code is being run under the debugger. N.B. We need PolyML.PrettyString here. *) val () = PolyML.addPrettyPrinter(fn _ => fn _ => fn r => PolyML.PrettyString(regRepr r)) datatype argType = ArgGeneral | ArgFP (* Size of operand. OpSize64 is only valid in 64-bit mode. *) datatype opSize = OpSize32 | OpSize64 structure RegSet = struct (* Implement a register set as a bit mask. *) datatype regSet = RegSet of word fun singleton r = RegSet(0w1 << Word.fromInt(nReg r)) fun regSetUnion(RegSet r1, RegSet r2) = RegSet(Word.orb(r1, r2)) fun regSetIntersect(RegSet r1, RegSet r2) = RegSet(Word.andb(r1, r2)) local fun addReg(acc, n) = if n = regs then acc else addReg(regSetUnion(acc, singleton(regN n)), n+1) in val allRegisters = addReg(RegSet 0w0, 0) end val noRegisters = RegSet 0w0 fun inSet(r, rs) = regSetIntersect(singleton r, rs) <> noRegisters fun regSetMinus(RegSet s1, RegSet s2) = RegSet(Word.andb(s1, Word.notb s2)) val listToSet = List.foldl (fn(r, rs) => regSetUnion(singleton r, rs)) noRegisters local val regs = case targetArch of Native32Bit => [eax, ecx, edx, ebx, esi, edi] | Native64Bit => [eax, ecx, edx, ebx, esi, edi, r8, r9, r10, r11, r12, r13, r14] | ObjectId32Bit => [eax, ecx, edx, esi, edi, r8, r9, r10, r11, r12, r13, r14] in val generalRegisters = listToSet(map GenReg regs) end (* The floating point stack. Note that this excludes one item so it is always possible to load a value onto the top of the FP stack. *) val floatingPtRegisters = listToSet(map FPReg [fp0, fp1, fp2, fp3, fp4, fp5, fp6(*, fp7*)]) val sse2Registers = listToSet(map XMMReg [xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6]) fun isAllRegs rs = rs = allRegisters fun setToList (RegSet regSet)= let fun testBit (n, bit, res) = if n = regs then res else testBit(n+1, bit << 0w1, if (regSet andb bit) <> 0w0 then regN n :: res else res) in testBit(0, 0w1, []) end val cardinality = List.length o setToList (* Choose one of the set. This chooses the least value which means that the ordering of the registers is significant. This is a hot-spot so is coded directly with the word operations. *) fun oneOf(RegSet regSet) = let fun find(n, bit) = if n = Word.fromInt regs then raise InternalError "oneOf: empty" else if Word.andb(bit, regSet) <> 0w0 then n else find(n+0w1, Word.<<(bit, 0w1)) in regN(Word.toInt(find(0w0, 0w1))) end fun regSetRepr regSet = let val regs = setToList regSet in "[" ^ String.concatWith "," (List.map regRepr regs) ^ "]" end (* Install a pretty printer for when this code is being debugged. *) val () = PolyML.addPrettyPrinter(fn _ => fn _ => fn r => PolyML.PrettyString(regSetRepr r)) end open RegSet datatype arithOp = ADD | OR (*|ADC | SBB*) | AND | SUB | XOR | CMP fun arithOpToWord ADD = 0w0: Word8.word | arithOpToWord OR = 0w1 | arithOpToWord AND = 0w4 | arithOpToWord SUB = 0w5 | arithOpToWord XOR = 0w6 | arithOpToWord CMP = 0w7 fun arithOpRepr ADD = "Add" | arithOpRepr OR = "Or" | arithOpRepr AND = "And" | arithOpRepr SUB = "Sub" | arithOpRepr XOR = "Xor" | arithOpRepr CMP = "Cmp" datatype shiftType = SHL | SHR | SAR fun shiftTypeToWord SHL = 0w4: Word8.word | shiftTypeToWord SHR = 0w5 | shiftTypeToWord SAR = 0w7 fun shiftTypeRepr SHL = "Shift Left Logical" | shiftTypeRepr SHR = "Shift Right Logical" | shiftTypeRepr SAR = "Shift Right Arithemetic" datatype repOps = CMPS8 | MOVS8 | MOVS32 | STOS8 | STOS32 | MOVS64 | STOS64 fun repOpsToWord CMPS8 = 0wxa6: Word8.word | repOpsToWord MOVS8 = 0wxa4 | repOpsToWord MOVS32 = 0wxa5 | repOpsToWord MOVS64 = 0wxa5 (* Plus Rex.w *) | repOpsToWord STOS8 = 0wxaa | repOpsToWord STOS32 = 0wxab | repOpsToWord STOS64 = 0wxab (* Plus Rex.w *) fun repOpsRepr CMPS8 = "CompareBytes" | repOpsRepr MOVS8 = "MoveBytes" | repOpsRepr MOVS32 = "MoveWords32" | repOpsRepr MOVS64 = "MoveWords64" | repOpsRepr STOS8 = "StoreBytes" | repOpsRepr STOS32 = "StoreWords32" | repOpsRepr STOS64 = "StoreWords64" datatype fpOps = FADD | FMUL | FCOM | FCOMP | FSUB | FSUBR | FDIV | FDIVR fun fpOpToWord FADD = 0w0: Word8.word | fpOpToWord FMUL = 0w1 | fpOpToWord FCOM = 0w2 | fpOpToWord FCOMP = 0w3 | fpOpToWord FSUB = 0w4 | fpOpToWord FSUBR = 0w5 | fpOpToWord FDIV = 0w6 | fpOpToWord FDIVR = 0w7 fun fpOpRepr FADD = "FPAdd" | fpOpRepr FMUL = "FPMultiply" | fpOpRepr FCOM = "FPCompare" | fpOpRepr FCOMP = "FPCompareAndPop" | fpOpRepr FSUB = "FPSubtract" | fpOpRepr FSUBR = "FPReverseSubtract" | fpOpRepr FDIV = "FPDivide" | fpOpRepr FDIVR = "FPReverseDivide" datatype fpUnaryOps = FCHS | FABS | FLD1 | FLDZ fun fpUnaryToWords FCHS = {rm=0w0:Word8.word, nnn=0w4: Word8.word} | fpUnaryToWords FABS = {rm=0w1, nnn=0w4} | fpUnaryToWords FLD1 = {rm=0w0, nnn=0w5} | fpUnaryToWords FLDZ = {rm=0w6, nnn=0w5} fun fpUnaryRepr FCHS = "FPChangeSign" | fpUnaryRepr FABS = "FPAbs" | fpUnaryRepr FLD1 = "FPLoadOne" | fpUnaryRepr FLDZ = "FPLoadZero" datatype branchOps = JO | JNO | JE | JNE | JL | JGE | JLE | JG | JB | JNB | JNA | JA | JP | JNP fun branchOpToWord JO = 0wx0: Word8.word | branchOpToWord JNO = 0wx1 | branchOpToWord JB = 0wx2 | branchOpToWord JNB = 0wx3 | branchOpToWord JE = 0wx4 | branchOpToWord JNE = 0wx5 | branchOpToWord JNA = 0wx6 | branchOpToWord JA = 0wx7 | branchOpToWord JP = 0wxa | branchOpToWord JNP = 0wxb | branchOpToWord JL = 0wxc | branchOpToWord JGE = 0wxd | branchOpToWord JLE = 0wxe | branchOpToWord JG = 0wxf fun branchOpRepr JO = "Overflow" | branchOpRepr JNO = "NotOverflow" | branchOpRepr JE = "Equal" | branchOpRepr JNE = "NotEqual" | branchOpRepr JL = "Less" | branchOpRepr JGE = "GreaterOrEqual" | branchOpRepr JLE = "LessOrEqual" | branchOpRepr JG = "Greater" | branchOpRepr JB = "Before" | branchOpRepr JNB= "NotBefore" | branchOpRepr JNA = "NotAfter" | branchOpRepr JA = "After" | branchOpRepr JP = "Parity" | branchOpRepr JNP = "NoParity" (* Invert a test. This is used if we want to change the sense of a test from jumping if the condition is true to jumping if it is false. *) fun invertTest JE = JNE | invertTest JNE = JE | invertTest JA = JNA | invertTest JB = JNB | invertTest JNA = JA | invertTest JNB = JB | invertTest JL = JGE | invertTest JG = JLE | invertTest JLE = JG | invertTest JGE = JL | invertTest JO = JNO | invertTest JNO = JO | invertTest JP = JNP | invertTest JNP = JP datatype sse2Operations = SSE2MoveDouble | SSE2MoveFloat | SSE2CompDouble | SSE2AddDouble | SSE2SubDouble | SSE2MulDouble | SSE2DivDouble | SSE2Xor | SSE2And | SSE2FloatToDouble | SSE2DoubleToFloat | SSE2CompSingle | SSE2AddSingle | SSE2SubSingle | SSE2MulSingle | SSE2DivSingle fun sse2OpRepr SSE2MoveDouble = "SSE2MoveDouble" | sse2OpRepr SSE2MoveFloat = "SSE2MoveFloat" | sse2OpRepr SSE2CompDouble = "SSE2CompDouble" | sse2OpRepr SSE2AddDouble = "SSE2AddDouble" | sse2OpRepr SSE2SubDouble = "SSE2SubDouble" | sse2OpRepr SSE2MulDouble = "SSE2MulDouble" | sse2OpRepr SSE2DivDouble = "SSE2DivDouble" | sse2OpRepr SSE2Xor = "SSE2Xor" | sse2OpRepr SSE2And = "SSE2And" | sse2OpRepr SSE2CompSingle = "SSE2CompSingle" | sse2OpRepr SSE2AddSingle = "SSE2AddSingle" | sse2OpRepr SSE2SubSingle = "SSE2SubSingle" | sse2OpRepr SSE2MulSingle = "SSE2MulSingle" | sse2OpRepr SSE2DivSingle = "SSE2DivSingle" | sse2OpRepr SSE2FloatToDouble = "SSE2FloatToDouble" | sse2OpRepr SSE2DoubleToFloat = "SSE2DoubleToFloat" (* Primary opCodes. N.B. only opCodes actually used are listed here. If new instruction are added check they will be handled by the run-time system in the event of trap. *) datatype opCode = Group1_8_A32 | Group1_8_A64 | Group1_32_A32 | Group1_32_A64 | Group1_8_a | JMP_8 | JMP_32 | CALL_32 | MOVL_A_R32 | MOVL_A_R64 | MOVL_R_A32 | MOVL_R_A64 | MOVL_R_A16 | MOVB_R_A32 | MOVB_R_A64 of {forceRex: bool} | PUSH_R of Word8.word | POP_R of Word8.word | Group5 | NOP | LEAL32 | LEAL64 | MOVL_32_R of Word8.word | MOVL_64_R of Word8.word | MOVL_32_A32 | MOVL_32_A64 | MOVB_8_A | POP_A | RET | RET_16 | CondJump of branchOps | CondJump32 of branchOps | SetCC of branchOps | Arith32 of arithOp * Word8.word | Arith64 of arithOp * Word8.word | Group3_A32 | Group3_A64 | Group3_a | Group2_8_A32 | Group2_8_A64 | Group2_CL_A32 | Group2_CL_A64 | Group2_1_A32 | Group2_1_A64 | PUSH_8 | PUSH_32 | TEST_ACC8 | LOCK_XADD32 | LOCK_XADD64 | FPESC of Word8.word | XCHNG32 | XCHNG64 | REP (* Rep prefix *) | MOVZB (* Needs escape code. *) | MOVZW (* Needs escape code. *) | MOVSXB32 (* Needs escape code. *) | MOVSXW32 (* Needs escape code. *) | MOVSXB64 (* Needs escape code. *) | MOVSXW64 (* Needs escape code. *) | IMUL32 (* Needs escape code. *) | IMUL64 (* Needs escape code. *) | SSE2StoreSingle (* movss with memory destination - needs escape sequence. *) | SSE2StoreDouble (* movsd with memory destination - needs escape sequence. *) | CQO_CDQ32 (* Sign extend before divide.. *) | CQO_CDQ64 (* Sign extend before divide.. *) | SSE2Ops of sse2Operations (* SSE2 instructions. *) | CVTSI2SD32 | CVTSI2SD64 | HLT (* End of code marker. *) | IMUL_C8_32 | IMUL_C8_64 | IMUL_C32_32 | IMUL_C32_64 | MOVDFromXMM (* move 32 bit value from XMM to general reg. *) | MOVQToXMM (* move 64 bit value from general reg.to XMM *) | PSRLDQ (* Shift XMM register *) | LDSTMXCSR | CVTSD2SI32 (* Double to 32-bit int *) | CVTSD2SI64 (* Double to 64-bit int *) | CVTSS2SI32 (* Single to 32-bit int *) | CVTSS2SI64 (* Single to 64-bit int *) | CVTTSD2SI32 (* Double to 32-bit int - truncate towards zero *) | CVTTSD2SI64 (* Double to 64-bit int - truncate towards zero *) | CVTTSS2SI32 (* Single to 32-bit int - truncate towards zero *) | CVTTSS2SI64 (* Single to 64-bit int - truncate towards zero *) | MOVSXD | CMOV32 of branchOps | CMOV64 of branchOps fun opToInt Group1_8_A32 = 0wx83 | opToInt Group1_8_A64 = 0wx83 | opToInt Group1_32_A32 = 0wx81 | opToInt Group1_32_A64 = 0wx81 | opToInt Group1_8_a = 0wx80 | opToInt JMP_8 = 0wxeb | opToInt JMP_32 = 0wxe9 | opToInt CALL_32 = 0wxe8 | opToInt MOVL_A_R32 = 0wx8b | opToInt MOVL_A_R64 = 0wx8b | opToInt MOVL_R_A32 = 0wx89 | opToInt MOVL_R_A64 = 0wx89 | opToInt MOVL_R_A16 = 0wx89 (* Also has an OPSIZE prefix. *) | opToInt MOVB_R_A32 = 0wx88 | opToInt (MOVB_R_A64 _) = 0wx88 | opToInt (PUSH_R reg) = 0wx50 + reg | opToInt (POP_R reg) = 0wx58 + reg | opToInt Group5 = 0wxff | opToInt NOP = 0wx90 | opToInt LEAL32 = 0wx8d | opToInt LEAL64 = 0wx8d | opToInt (MOVL_32_R reg) = 0wxb8 + reg | opToInt (MOVL_64_R reg) = 0wxb8 + reg | opToInt MOVL_32_A32 = 0wxc7 | opToInt MOVL_32_A64 = 0wxc7 | opToInt MOVB_8_A = 0wxc6 | opToInt POP_A = 0wx8f | opToInt RET = 0wxc3 | opToInt RET_16 = 0wxc2 | opToInt (CondJump opc) = 0wx70 + branchOpToWord opc | opToInt (CondJump32 opc) = 0wx80 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (SetCC opc) = 0wx90 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (Arith32 (ao,dw)) = arithOpToWord ao * 0w8 + dw | opToInt (Arith64 (ao,dw)) = arithOpToWord ao * 0w8 + dw | opToInt Group3_A32 = 0wxf7 | opToInt Group3_A64 = 0wxf7 | opToInt Group3_a = 0wxf6 | opToInt Group2_8_A32 = 0wxc1 | opToInt Group2_8_A64 = 0wxc1 | opToInt Group2_1_A32 = 0wxd1 | opToInt Group2_1_A64 = 0wxd1 | opToInt Group2_CL_A32 = 0wxd3 | opToInt Group2_CL_A64 = 0wxd3 | opToInt PUSH_8 = 0wx6a | opToInt PUSH_32 = 0wx68 | opToInt TEST_ACC8 = 0wxa8 | opToInt LOCK_XADD32 = 0wxC1 (* Needs lock and escape prefixes. *) | opToInt LOCK_XADD64 = 0wxC1 (* Needs lock and escape prefixes. *) | opToInt (FPESC n) = 0wxD8 orb8 n | opToInt XCHNG32 = 0wx87 | opToInt XCHNG64 = 0wx87 | opToInt REP = 0wxf3 | opToInt MOVZB = 0wxb6 (* Needs escape code. *) | opToInt MOVZW = 0wxb7 (* Needs escape code. *) | opToInt MOVSXB32 = 0wxbe (* Needs escape code. *) | opToInt MOVSXW32 = 0wxbf (* Needs escape code. *) | opToInt MOVSXB64 = 0wxbe (* Needs escape code. *) | opToInt MOVSXW64 = 0wxbf (* Needs escape code. *) | opToInt IMUL32 = 0wxaf (* Needs escape code. *) | opToInt IMUL64 = 0wxaf (* Needs escape code. *) | opToInt SSE2StoreSingle = 0wx11 (* Needs F3 0F escape. *) | opToInt SSE2StoreDouble = 0wx11 (* Needs F2 0F escape. *) | opToInt CQO_CDQ32 = 0wx99 | opToInt CQO_CDQ64 = 0wx99 | opToInt (SSE2Ops SSE2MoveDouble) = 0wx10 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2MoveFloat) = 0wx10 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2CompDouble) = 0wx2E (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2AddDouble) = 0wx58 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2SubDouble) = 0wx5c (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2MulDouble) = 0wx59 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2DivDouble) = 0wx5e (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2CompSingle) = 0wx2E (* Needs 0F escape. *) | opToInt (SSE2Ops SSE2AddSingle) = 0wx58 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2SubSingle) = 0wx5c (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2MulSingle) = 0wx59 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2DivSingle) = 0wx5e (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2And) = 0wx54 (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2Xor) = 0wx57 (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2FloatToDouble) = 0wx5A (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2DoubleToFloat) = 0wx5A (* Needs F2 0F escape. *) | opToInt CVTSI2SD32 = 0wx2a (* Needs F2 0F escape. *) | opToInt CVTSI2SD64 = 0wx2a (* Needs F2 0F escape. *) | opToInt HLT = 0wxf4 | opToInt IMUL_C8_32 = 0wx6b | opToInt IMUL_C8_64 = 0wx6b | opToInt IMUL_C32_32 = 0wx69 | opToInt IMUL_C32_64 = 0wx69 | opToInt MOVDFromXMM = 0wx7e (* Needs 66 0F escape. *) | opToInt MOVQToXMM = 0wx6e (* Needs 66 0F escape. *) | opToInt PSRLDQ = 0wx73 (* Needs 66 0F escape. *) | opToInt LDSTMXCSR = 0wxae (* Needs 0F prefix. *) | opToInt CVTSD2SI32 = 0wx2d (* Needs F2 0F prefix. *) | opToInt CVTSD2SI64 = 0wx2d (* Needs F2 0F prefix and rex.w. *) | opToInt CVTSS2SI32 = 0wx2d (* Needs F3 0F prefix. *) | opToInt CVTSS2SI64 = 0wx2d (* Needs F3 0F prefix and rex.w. *) | opToInt CVTTSD2SI32 = 0wx2c (* Needs F2 0F prefix. *) | opToInt CVTTSD2SI64 = 0wx2c (* Needs F2 0F prefix. *) | opToInt CVTTSS2SI32 = 0wx2c (* Needs F3 0F prefix. *) | opToInt CVTTSS2SI64 = 0wx2c (* Needs F3 0F prefix and rex.w. *) | opToInt MOVSXD = 0wx63 | opToInt (CMOV32 opc) = 0wx40 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (CMOV64 opc) = 0wx40 + branchOpToWord opc (* Needs 0F prefix and rex.w *) datatype mode = Based0 (* mod = 0 *) | Based8 (* mod = 1 *) | Based32 (* mod = 2 *) | Register (* mod = 3 *) ; (* Put together the three fields which make up the mod r/m byte. *) fun modrm (md : mode, rg: Word8.word, rm : Word8.word) : Word8.word = let val _ = if rg > 0w7 then raise InternalError "modrm: bad rg" else () val _ = if rm > 0w7 then raise InternalError "modrm: bad rm" else () val modField: Word8.word = case md of Based0 => 0w0 | Based8 => 0w1 | Based32 => 0w2 | Register => 0w3 in (modField <<- 0w6) orb8 (rg <<- 0w3) orb8 rm end (* REX prefix *) fun rex {w,r,x,b} = 0wx40 orb8 (if w then 0w8 else 0w0) orb8 (if r then 0w4 else 0w0) orb8 (if x then 0w2 else 0w0) orb8 (if b then 0w1 else 0w0) (* The X86 has the option to include an index register and to scale it. *) datatype indexType = NoIndex | Index1 of genReg | Index2 of genReg | Index4 of genReg | Index8 of genReg (* Lock, Opsize and REPNE prefixes come before the REX. *) fun opcodePrefix LOCK_XADD32 = [0wxF0] (* Requires LOCK prefix. *) | opcodePrefix LOCK_XADD64 = [0wxF0] (* Requires LOCK prefix. *) | opcodePrefix MOVL_R_A16 = [0wx66] (* Requires OPSIZE prefix. *) | opcodePrefix SSE2StoreSingle = [0wxf3] | opcodePrefix SSE2StoreDouble = [0wxf2] | opcodePrefix(SSE2Ops SSE2CompDouble) = [0wx66] | opcodePrefix(SSE2Ops SSE2And) = [0wx66] | opcodePrefix(SSE2Ops SSE2Xor) = [0wx66] | opcodePrefix(SSE2Ops SSE2CompSingle) = [] (* No prefix *) | opcodePrefix(SSE2Ops SSE2MoveDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2AddDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2SubDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2MulDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2DivDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2DoubleToFloat) = [0wxf2] | opcodePrefix(SSE2Ops SSE2MoveFloat) = [0wxf3] | opcodePrefix(SSE2Ops SSE2AddSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2SubSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2MulSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2DivSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2FloatToDouble) = [0wxf3] | opcodePrefix CVTSI2SD32 = [0wxf2] | opcodePrefix CVTSI2SD64 = [0wxf2] | opcodePrefix MOVDFromXMM = [0wx66] | opcodePrefix MOVQToXMM = [0wx66] | opcodePrefix PSRLDQ = [0wx66] | opcodePrefix CVTSD2SI32 = [0wxf2] | opcodePrefix CVTSD2SI64 = [0wxf2] | opcodePrefix CVTSS2SI32 = [0wxf3] | opcodePrefix CVTSS2SI64 = [0wxf3] | opcodePrefix CVTTSD2SI32 = [0wxf2] | opcodePrefix CVTTSD2SI64 = [0wxf2] | opcodePrefix CVTTSS2SI32 = [0wxf3] | opcodePrefix CVTTSS2SI64 = [0wxf3] | opcodePrefix _ = [] (* A few instructions require an escape. Escapes come after the REX. *) fun escapePrefix MOVZB = [0wx0f] | escapePrefix MOVZW = [0wx0f] | escapePrefix MOVSXB32 = [0wx0f] | escapePrefix MOVSXW32 = [0wx0f] | escapePrefix MOVSXB64 = [0wx0f] | escapePrefix MOVSXW64 = [0wx0f] | escapePrefix LOCK_XADD32 = [0wx0f] | escapePrefix LOCK_XADD64 = [0wx0f] | escapePrefix IMUL32 = [0wx0f] | escapePrefix IMUL64 = [0wx0f] | escapePrefix(CondJump32 _) = [0wx0f] | escapePrefix(SetCC _) = [0wx0f] | escapePrefix SSE2StoreSingle = [0wx0f] | escapePrefix SSE2StoreDouble = [0wx0f] | escapePrefix(SSE2Ops _) = [0wx0f] | escapePrefix CVTSI2SD32 = [0wx0f] | escapePrefix CVTSI2SD64 = [0wx0f] | escapePrefix MOVDFromXMM = [0wx0f] | escapePrefix MOVQToXMM = [0wx0f] | escapePrefix PSRLDQ = [0wx0f] | escapePrefix LDSTMXCSR = [0wx0f] | escapePrefix CVTSD2SI32 = [0wx0f] | escapePrefix CVTSD2SI64 = [0wx0f] | escapePrefix CVTSS2SI32 = [0wx0f] | escapePrefix CVTSS2SI64 = [0wx0f] | escapePrefix CVTTSD2SI32 = [0wx0f] | escapePrefix CVTTSD2SI64 = [0wx0f] | escapePrefix CVTTSS2SI32 = [0wx0f] | escapePrefix CVTTSS2SI64 = [0wx0f] | escapePrefix(CMOV32 _) = [0wx0f] | escapePrefix(CMOV64 _) = [0wx0f] | escapePrefix _ = [] (* Generate an opCode byte after doing any pending operations. *) fun opCodeBytes(opb:opCode, rx) = let val rexByte = case rx of NONE => [] | SOME rxx => if hostIsX64 then [rex rxx] else raise InternalError "opCodeBytes: rex prefix in 32 bit mode"; in opcodePrefix opb @ rexByte @ escapePrefix opb @ [opToInt opb] end fun rexByte(opb, rrX, rbX, riX) = let (* We need a rex prefix if we need to set the length to 64-bit. *) val need64bit = case opb of Group1_8_A64 => true (* Arithmetic operations - must be 64-bit *) | Group1_32_A64 => true (* Arithmetic operations - must be 64-bit *) | Group2_1_A64 => true (* 1-bit shifts - must be 64-bit *) | Group2_8_A64 => true (* n-bit shifts - must be 64-bit *) | Group2_CL_A64 => true (* Shifts by value in CL *) | Group3_A64 => true (* Test, Not, Mul etc. *) | Arith64 (_, _) => true | MOVL_A_R64 => true (* Needed *) | MOVL_R_A64 => true (* Needed *) | XCHNG64 => true | LEAL64 => true (* Needed to ensure the result is 64-bits *) | MOVL_64_R _ => true (* Needed *) | MOVL_32_A64 => true (* Needed *) | IMUL64 => true (* Needed to ensure the result is 64-bits *) | LOCK_XADD64 => true (* Needed to ensure the result is 64-bits *) | CQO_CDQ64 => true (* It's only CQO if there's a Rex prefix. *) | CVTSI2SD64 => true (* This affects the size of the integer source. *) | IMUL_C8_64 => true | IMUL_C32_64 => true | MOVQToXMM => true | CVTSD2SI64 => true (* This affects the size of the integer source. *) | CVTSS2SI64 => true | CVTTSD2SI64 => true | CVTTSS2SI64 => true | MOVSXD => true | CMOV64 _ => true | MOVSXB64 => true | MOVSXW64 => true (* Group5 - We only use 2/4/6 and they don't need prefix *) | _ => false (* If we are using MOVB_R_A with SIL or DIL we need to force a REX prefix. That's only possible in 64-bit mode. This also applies with Test and SetCC but they are dealt with elsewhere. *) val forceRex = case opb of MOVB_R_A64 {forceRex=true} => true (* This is allowed in X86/64 but not in X86/32. *) | _ => false in if need64bit orelse rrX orelse rbX orelse riX orelse forceRex then [rex{w=need64bit, r=rrX, b=rbX, x = riX}] else [] end (* Register/register operation. *) fun opReg(opb:opCode, (*dest*)GeneralReg(rrC, rrX), (*source*)GeneralReg(rbC, rbX)) = let val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, rrX, rbX, false) val esc = escapePrefix opb (* Generate the ESCAPE code if needed. *) val opc = opToInt opb val mdrm = modrm(Register, rrC, rbC) in pref @ rex @ esc @ [opc, mdrm] end (* Operations on a register where the second "register" is actually an operation code. *) fun opRegPlus2(opb:opCode, rd: genReg, op2: Word8.word) = let val (rrC, rrX) = getReg rd val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, false, rrX, false) val opc = opToInt opb val mdrm = modrm(Register, op2, rrC) in pref @ rex @ [opc, mdrm] end local (* General instruction form with modrm and optional sib bytes. rb is an option since the base register may be omitted. This is used with LEA to tag integers. *) fun opIndexedGen (opb:opCode, offset: LargeInt.int, rb: genReg option, ri: indexType, (rrC, rrX)) = let (* Base encoding. (Based0, 0w5) means "no base" so if we need ebp as the base we have to use Based8 at least. *) val (offsetCode, rbC, rbX) = case rb of NONE => (Based0, 0w5 (* no base register *), false) | SOME rb => let val (rbC, rbX) = getReg rb val base = if offset = 0 andalso rbC <> 0wx5 (* Can't use ebp with Based0 *) then Based0 (* no disp field *) else if is8BitL offset then Based8 (* use 8-bit disp field *) else Based32 (* use 32-bit disp field *) in (base, rbC, rbX) end (* Index coding. esp can't be used as an index so (0w4, false) means "no index". But r12 (0w4, true) CAN be. *) val ((riC, riX), scaleFactor) = case ri of NoIndex => ((0w4, false), 0w0) | Index1 i => (getReg i, 0w0) | Index2 i => (getReg i, 0w1) | Index4 i => (getReg i, 0w2) | Index8 i => (getReg i, 0w3) (* If the base register is esp or r12 we have to use a sib byte even if there's no index. That's because 0w4 as a base register means "there's a SIB byte". *) val modRmAndOptionalSib = if rbC = 0w4 (* Code for esp and r12 *) orelse riC <> 0w4 orelse riX then let val mdrm = modrm(offsetCode, rrC, 0w4 (* s-i-b *)) val sibByte = (scaleFactor <<- 0w6) orb8 (riC <<- 0w3) orb8 rbC in [mdrm, sibByte] end else [modrm(offsetCode, rrC, rbC)] (* Generate the disp field (if any) *) val dispField = case (offsetCode, rb) of (Based8, _) => [Word8.fromLargeInt offset] | (Based32, _) => int32Signed offset | (_, NONE) => (* 32 bit absolute used as base *) int32Signed offset | _ => [] in opcodePrefix opb @ rexByte(opb, rrX, rbX, riX) @ escapePrefix opb @ opToInt opb :: modRmAndOptionalSib @ dispField end in fun opEA(opb, offset, rb, r) = opIndexedGen(opb, offset, SOME rb, NoIndex, getReg r) (* Generate a opcode plus a second modrm byte but where the "register" field in the modrm byte is actually a code. *) and opPlus2(opb, offset, rb, op2) = opIndexedGen(opb, offset, SOME rb, NoIndex, (op2, false)) and opIndexedPlus2(opb, offset, rb, ri, op2) = opIndexedGen(opb, offset, SOME rb, ri, (op2, false)) fun opIndexed (opb, offset, rb, ri, rd) = opIndexedGen(opb, offset, rb, ri, getReg rd) fun opAddress(opb, offset, rb, ri, rd) = opIndexedGen (opb, offset, SOME rb, ri, getReg rd) and mMXAddress(opb, offset, rb, ri, SSE2Reg rrC) = opIndexedGen(opb, offset, SOME rb, ri, (rrC, false)) and opAddressPlus2(opb, offset, rb, ri, op2) = opIndexedGen(opb, offset, SOME rb, ri, (op2, false)) end (* An operation with an operand that needs to go in the constant area, or in the case of native 32-bit, where the constant is stored in an object and the address of the object is inline. This just puts in the instruction and the address. The details of the constant are dealt with in putConst. *) fun opConstantOperand(opb, (*dest*)GeneralReg(rrC, rrX)) = let val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, rrX, false, false) val esc = escapePrefix opb (* Generate the ESCAPE code if needed. *) val opc = opToInt opb val mdrm = modrm(Based0, rrC, 0w5 (* PC-relative or absolute *)) in pref @ rex @ esc @ [opc, mdrm] @ int32Signed(tag 0) end fun immediateOperand (opn: arithOp, rd: genReg, imm: LargeInt.int, opSize) = if is8BitL imm then (* Can use one byte immediate *) opRegPlus2(case opSize of OpSize64 => Group1_8_A64 | OpSize32 => Group1_8_A32, rd, arithOpToWord opn) @ [Word8.fromLargeInt imm] else if is32bit imm then (* Need 32 bit immediate. *) opRegPlus2(case opSize of OpSize64 => Group1_32_A64 | OpSize32 => Group1_32_A32, rd, arithOpToWord opn) @ int32Signed imm else (* It won't fit in the immediate; put it in the non-address area. *) let val opc = case opSize of OpSize64 => Arith64 | OpSize32 => Arith32 in opConstantOperand(opc(opn, 0w3 (* r/m to reg *)), rd) end fun arithOpReg(opn: arithOp, rd: genReg, rs: genReg, opIs64) = opReg ((if opIs64 then Arith64 else Arith32) (opn, 0w3 (* r/m to reg *)), rd, rs) type handlerLab = addrs ref fun floatingPtOp{escape, md, nnn, rm} = opCodeBytes(FPESC escape, NONE) @ [(md <<- 0w6) orb8 (nnn <<- 0w3) orb8 rm] datatype trapEntries = StackOverflowCall | StackOverflowCallEx | HeapOverflowCall (* RTS call. We need to save any registers that may contain addresses to the stack. All the registers are preserved but not seen by the GC. *) fun rtsCall(rtsEntry, regSet) = let val entry = case rtsEntry of StackOverflowCall => memRegStackOverflowCall | StackOverflowCallEx => memRegStackOverflowCallEx | HeapOverflowCall => memRegHeapOverflowCall val regSet = List.foldl(fn (r, a) => (0w1 << Word.fromInt(nReg(GenReg r))) orb a) 0w0 regSet val callInstr = opPlus2(Group5, LargeInt.fromInt entry, ebp, 0w2 (* call *)) val regSetInstr = if regSet >= 0w256 then [0wxca, (* This is actually a FAR RETURN *) wordToWord8 regSet, (* Low byte*) wordToWord8 (regSet >> 0w8) (* High byte*)] else if regSet <> 0w0 then [0wxcd, (* This is actually INT n *) wordToWord8 regSet] else [] in callInstr @ regSetInstr end (* Operations. *) type cases = word * label type memoryAddress = { base: genReg, offset: int, index: indexType } datatype 'reg regOrMemoryArg = RegisterArg of 'reg | MemoryArg of memoryAddress | NonAddressConstArg of LargeInt.int | AddressConstArg of machineWord datatype moveSize = Move64 | Move32 | Move8 | Move16 | Move32X64 | Move8X32 | Move8X64 | Move16X32 | Move16X64 and fpSize = SinglePrecision | DoublePrecision datatype operation = Move of { source: genReg regOrMemoryArg, destination: genReg regOrMemoryArg, moveSize: moveSize } | PushToStack of genReg regOrMemoryArg | PopR of genReg | ArithToGenReg of { opc: arithOp, output: genReg, source: genReg regOrMemoryArg, opSize: opSize } | ArithMemConst of { opc: arithOp, address: memoryAddress, source: LargeInt.int, opSize: opSize } | ArithMemLongConst of { opc: arithOp, address: memoryAddress, source: machineWord } | ArithByteMemConst of { opc: arithOp, address: memoryAddress, source: Word8.word } | ShiftConstant of { shiftType: shiftType, output: genReg, shift: Word8.word, opSize: opSize } | ShiftVariable of { shiftType: shiftType, output: genReg, opSize: opSize } (* Shift amount is in ecx *) | ConditionalBranch of { test: branchOps, label: label } | SetCondition of { output: genReg, test: branchOps } | LoadAddress of { output: genReg, offset: int, base: genReg option, index: indexType, opSize: opSize } | TestByteBits of { arg: genReg regOrMemoryArg, bits: Word8.word } | CallRTS of {rtsEntry: trapEntries, saveRegs: genReg list } | AllocStore of { size: int, output: genReg, saveRegs: genReg list } | AllocStoreVariable of { size: genReg, output: genReg, saveRegs: genReg list } | StoreInitialised | CallAddress of genReg regOrMemoryArg | JumpAddress of genReg regOrMemoryArg | ReturnFromFunction of int | RaiseException of { workReg: genReg } | UncondBranch of label | ResetStack of { numWords: int, preserveCC: bool } | JumpLabel of label | LoadLabelAddress of { label: label, output: genReg } | RepeatOperation of repOps | DivideAccR of {arg: genReg, isSigned: bool, opSize: opSize } | DivideAccM of {base: genReg, offset: int, isSigned: bool, opSize: opSize } | AtomicXAdd of {address: memoryAddress, output: genReg, opSize: opSize } | FPLoadFromMemory of { address: memoryAddress, precision: fpSize } | FPLoadFromFPReg of { source: fpReg, lastRef: bool } | FPLoadFromConst of { constant: machineWord, precision: fpSize } | FPStoreToFPReg of { output: fpReg, andPop: bool } | FPStoreToMemory of { address: memoryAddress, precision: fpSize, andPop: bool } | FPArithR of { opc: fpOps, source: fpReg } | FPArithConst of { opc: fpOps, source: machineWord, precision: fpSize } | FPArithMemory of { opc: fpOps, base: genReg, offset: int, precision: fpSize } | FPUnary of fpUnaryOps | FPStatusToEAX | FPLoadInt of { base: genReg, offset: int, opSize: opSize } | FPFree of fpReg | MultiplyR of { source: genReg regOrMemoryArg, output: genReg, opSize: opSize } | XMMArith of { opc: sse2Operations, source: xmmReg regOrMemoryArg, output: xmmReg } | XMMStoreToMemory of { toStore: xmmReg, address: memoryAddress, precision: fpSize } | XMMConvertFromInt of { source: genReg, output: xmmReg, opSize: opSize } | SignExtendForDivide of opSize | XChng of { reg: genReg, arg: genReg regOrMemoryArg, opSize: opSize } | Negative of { output: genReg, opSize: opSize } | JumpTable of { cases: label list, jumpSize: jumpSize ref } | IndexedJumpCalc of { addrReg: genReg, indexReg: genReg, jumpSize: jumpSize ref } | MoveXMMRegToGenReg of { source: xmmReg, output: genReg } | MoveGenRegToXMMReg of { source: genReg, output: xmmReg } | XMMShiftRight of { output: xmmReg, shift: Word8.word } | FPLoadCtrlWord of memoryAddress (* Load FP control word. *) | FPStoreCtrlWord of memoryAddress (* Store FP control word. *) | XMMLoadCSR of memoryAddress (* Load combined control/status word. *) | XMMStoreCSR of memoryAddress (* Store combined control/status word. *) | FPStoreInt of memoryAddress | XMMStoreInt of { source: xmmReg regOrMemoryArg, output: genReg, precision: fpSize, isTruncate: bool } | CondMove of { test: branchOps, output: genReg, source: genReg regOrMemoryArg, opSize: opSize } | LoadAbsolute of { destination: genReg, value: machineWord } and jumpSize = JumpSize2 | JumpSize8 type operations = operation list fun printOperation(operation, stream) = let fun printGReg r = stream(genRegRepr(r, sz32_64)) val printFPReg = stream o fpRegRepr and printXMMReg = stream o xmmRegRepr fun printBaseOffset(b, x, i) = ( stream(Int.toString i); stream "("; printGReg b; stream ")"; case x of NoIndex => () | Index1 x => (stream "["; printGReg x; stream "]") | Index2 x => (stream "["; printGReg x; stream "*2]") | Index4 x => (stream "["; printGReg x; stream "*4]") | Index8 x => (stream "["; printGReg x; stream "*8]") ) fun printMemAddress({ base, offset, index }) = printBaseOffset(base, index, offset) fun printRegOrMemoryArg printReg (RegisterArg r) = printReg r | printRegOrMemoryArg _ (MemoryArg{ base, offset, index }) = printBaseOffset(base, index, offset) | printRegOrMemoryArg _ (NonAddressConstArg c) = stream(LargeInt.toString c) | printRegOrMemoryArg _ (AddressConstArg c) = stream(Address.stringOfWord c) fun printOpSize OpSize32 = "32" | printOpSize OpSize64 = "64" in case operation of Move { source, destination, moveSize } => ( case moveSize of Move64 => stream "Move64 " | Move32 => stream "Move32 " | Move8 => stream "Move8 " | Move16 => stream "Move16 " | Move32X64 => stream "Move32X64 " | Move8X32 => stream "Move8X32 " | Move8X64 => stream "Move8X64 " | Move16X32 => stream "Move16X32 " | Move16X64 => stream "Move16X64 "; printRegOrMemoryArg printGReg destination; stream " <= "; printRegOrMemoryArg printGReg source ) | ArithToGenReg { opc, output, source, opSize } => (stream (arithOpRepr opc); stream "RR"; stream(printOpSize opSize); stream " "; printGReg output; stream " <= "; printRegOrMemoryArg printGReg source ) | ArithMemConst { opc, address, source, opSize } => ( stream (arithOpRepr opc); stream "MC"; stream(printOpSize opSize); stream " "; printMemAddress address; stream " "; stream(LargeInt.toString source) ) | ArithMemLongConst { opc, address, source } => ( stream (arithOpRepr opc ^ "MC "); printMemAddress address; stream " <= "; stream(Address.stringOfWord source) ) | ArithByteMemConst { opc, address, source } => ( stream (arithOpRepr opc); stream "MC8"; stream " "; printMemAddress address; stream " "; stream(Word8.toString source) ) | ShiftConstant { shiftType, output, shift, opSize } => ( stream(shiftTypeRepr shiftType); stream(printOpSize opSize); stream " "; printGReg output; stream " by "; stream(Word8.toString shift) ) | ShiftVariable { shiftType, output, opSize } => (* Shift amount is in ecx *) ( stream(shiftTypeRepr shiftType); stream(printOpSize opSize); stream " "; printGReg output; stream " by ECX" ) | ConditionalBranch { test, label=Label{labelNo, ...} } => ( stream "Jump"; stream(branchOpRepr test); stream " L"; stream(Int.toString labelNo) ) | SetCondition { output, test } => ( stream "SetCC"; stream(branchOpRepr test); stream " => "; printGReg output ) | PushToStack source => (stream "Push "; printRegOrMemoryArg printGReg source) | PopR dest => (stream "PopR "; printGReg dest) | LoadAddress{ output, offset, base, index, opSize } => ( stream "LoadAddress"; stream(printOpSize opSize); stream " "; case base of NONE => () | SOME r => (printGReg r; stream " + "); stream(Int.toString offset); case index of NoIndex => () | Index1 x => (stream " + "; printGReg x) | Index2 x => (stream " + "; printGReg x; stream "*2 ") | Index4 x => (stream " + "; printGReg x; stream "*4 ") | Index8 x => (stream " + "; printGReg x; stream "*8 "); stream " => "; printGReg output ) | TestByteBits { arg, bits } => ( stream "TestByteBits "; printRegOrMemoryArg printGReg arg; stream " 0x"; stream(Word8.toString bits) ) | CallRTS {rtsEntry, ...} => ( stream "CallRTS "; case rtsEntry of StackOverflowCall => stream "StackOverflowCall" | HeapOverflowCall => stream "HeapOverflow" | StackOverflowCallEx => stream "StackOverflowCallEx" ) | AllocStore { size, output, ... } => (stream "AllocStore "; stream(Int.toString size); stream " => "; printGReg output ) | AllocStoreVariable { output, size, ...} => (stream "AllocStoreVariable "; printGReg size; stream " => "; printGReg output ) | StoreInitialised => stream "StoreInitialised" | CallAddress source => (stream "CallAddress "; printRegOrMemoryArg printGReg source) | JumpAddress source => (stream "JumpAddress "; printRegOrMemoryArg printGReg source) | ReturnFromFunction argsToRemove => (stream "ReturnFromFunction "; stream(Int.toString argsToRemove)) | RaiseException { workReg } => (stream "RaiseException "; printGReg workReg) | UncondBranch(Label{labelNo, ...})=> (stream "UncondBranch L"; stream(Int.toString labelNo)) | ResetStack{numWords, preserveCC} => (stream "ResetStack "; stream(Int.toString numWords); if preserveCC then stream " preserve CC" else ()) | JumpLabel(Label{labelNo, ...}) => (stream "L"; stream(Int.toString labelNo); stream ":") | LoadLabelAddress{ label=Label{labelNo, ...}, output } => (stream "LoadLabelAddress L"; stream(Int.toString labelNo); stream "=>"; printGReg output) | RepeatOperation repOp => (stream "Repeat "; stream(repOpsRepr repOp)) | DivideAccR{arg, isSigned, opSize} => ( stream(if isSigned then "DivideSigned" else "DivideUnsigned"); stream(printOpSize opSize); stream " "; printGReg arg) | DivideAccM{base, offset, isSigned, opSize} => ( stream(if isSigned then "DivideSigned" else "DivideUnsigned"); stream(printOpSize opSize); stream " "; printBaseOffset(base, NoIndex, offset)) | AtomicXAdd{address, output, opSize} => (stream "LockedXAdd"; stream(printOpSize opSize); printMemAddress address; stream " <=> "; printGReg output) | FPLoadFromMemory{address, precision=DoublePrecision} => (stream "FPLoadDouble "; printMemAddress address) | FPLoadFromMemory{address, precision=SinglePrecision} => (stream "FPLoadSingle "; printMemAddress address) | FPLoadFromFPReg {source, lastRef} => (stream "FPLoad "; printFPReg source; if lastRef then stream " (LAST)" else()) | FPLoadFromConst{constant, precision} => ( case precision of DoublePrecision => stream "FPLoadD " | SinglePrecision => stream "FPLoadS"; stream(Address.stringOfWord constant) ) | FPStoreToFPReg{ output, andPop } => (if andPop then stream "FPStoreAndPop => " else stream "FPStore => "; printFPReg output) | FPStoreToMemory{ address, precision=DoublePrecision, andPop: bool } => ( if andPop then stream "FPStoreDoubleAndPop => " else stream "FPStoreDouble => "; printMemAddress address ) | FPStoreToMemory{ address, precision=SinglePrecision, andPop: bool } => ( if andPop then stream "FPStoreSingleAndPop => " else stream "FPStoreSingle => "; printMemAddress address ) | FPArithR{ opc, source } => (stream(fpOpRepr opc); stream " "; printFPReg source) | FPArithConst{ opc, source, precision } => (stream(fpOpRepr opc); case precision of DoublePrecision => stream "D " | SinglePrecision => stream "S "; stream(Address.stringOfWord source)) | FPArithMemory{ opc, base, offset, precision } => (stream(fpOpRepr opc); case precision of DoublePrecision => stream "D " | SinglePrecision => stream "S "; printBaseOffset(base, NoIndex, offset)) | FPUnary opc => stream(fpUnaryRepr opc) | FPStatusToEAX => (stream "FPStatus "; printGReg eax) | FPLoadInt { base, offset, opSize} => (stream "FPLoadInt"; stream(printOpSize opSize); stream " "; printBaseOffset(base, NoIndex, offset)) | FPFree reg => (stream "FPFree "; printFPReg reg) | MultiplyR {source, output, opSize } => (stream "MultiplyR"; stream(printOpSize opSize); stream " "; printRegOrMemoryArg printGReg source; stream " *=>"; printGReg output) | XMMArith { opc, source, output } => ( stream (sse2OpRepr opc ^ "RM "); printXMMReg output; stream " <= "; printRegOrMemoryArg printXMMReg source ) | XMMStoreToMemory { toStore, address, precision=DoublePrecision } => ( stream "MoveDouble "; printXMMReg toStore; stream " => "; printMemAddress address ) | XMMStoreToMemory { toStore, address, precision=SinglePrecision } => ( stream "MoveSingle "; printXMMReg toStore; stream " => "; printMemAddress address ) | XMMConvertFromInt { source, output, opSize } => ( stream "ConvertFromInt "; stream(printOpSize opSize); stream " "; printGReg source; stream " => "; printXMMReg output ) | SignExtendForDivide opSize => ( stream "SignExtendForDivide"; stream(printOpSize opSize) ) | XChng { reg, arg, opSize } => (stream "XChng"; stream(printOpSize opSize); stream " "; printGReg reg; stream " <=> "; printRegOrMemoryArg printGReg arg) | Negative { output, opSize } => (stream "Negative"; stream(printOpSize opSize); stream " "; printGReg output) | JumpTable{cases, ...} => List.app(fn(Label{labelNo, ...}) => (stream "UncondBranch L"; stream(Int.toString labelNo); stream "\n")) cases | IndexedJumpCalc { addrReg, indexReg, jumpSize=ref jumpSize } => ( stream "IndexedJumpCalc "; printGReg addrReg; stream " += "; printGReg indexReg; stream (case jumpSize of JumpSize2 => " * 2" | JumpSize8 => " * 8 ") ) | MoveXMMRegToGenReg { source, output } => ( stream "MoveXMMRegToGenReg "; printXMMReg source; stream " => "; printGReg output ) | MoveGenRegToXMMReg { source, output } => ( stream "MoveGenRegToXMMReg "; printGReg source; stream " => "; printXMMReg output ) | XMMShiftRight { output, shift } => ( stream "XMMShiftRight "; printXMMReg output; stream " by "; stream(Word8.toString shift) ) | FPLoadCtrlWord address => ( stream "FPLoadCtrlWord "; stream " => "; printMemAddress address ) | FPStoreCtrlWord address => ( stream "FPStoreCtrlWord "; stream " <= "; printMemAddress address ) | XMMLoadCSR address => ( stream "XMMLoadCSR "; stream " => "; printMemAddress address ) | XMMStoreCSR address => ( stream "XMMStoreCSR "; stream " <= "; printMemAddress address ) | FPStoreInt address => ( stream "FPStoreInt "; stream " <= "; printMemAddress address ) | XMMStoreInt{ source, output, precision, isTruncate } => ( stream "XMMStoreInt"; case precision of SinglePrecision => stream "Single" | DoublePrecision => stream "Double"; if isTruncate then stream "Truncate " else stream " "; printGReg output; stream " <= "; printRegOrMemoryArg printXMMReg source ) | CondMove { test, output, source, opSize } => ( stream "CondMove"; stream(branchOpRepr test); stream(printOpSize opSize); printGReg output; stream " <= "; printRegOrMemoryArg printGReg source ) | LoadAbsolute { destination, value } => ( stream "LoadAbsolute "; printGReg destination; stream " <= "; stream(Address.stringOfWord value) ) ; stream "\n" end datatype implement = ImplementGeneral | ImplementLiteral of machineWord fun printLowLevelCode(ops, Code{printAssemblyCode, printStream, procName, ...}) = if printAssemblyCode then ( if procName = "" (* No name *) then printStream "?" else printStream procName; printStream ":\n"; List.app(fn i => printOperation(i, printStream)) ops; printStream "\n" ) else () (* val opLen = if isX64 then OpSize64 else OpSize32 *) (* Code generate a list of operations. The list is in reverse order i.e. last instruction first. *) fun codeGenerate ops = let fun cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move64 }) = (* Move from one general register to another. N.B. Because we're using the "store" version of the Move the source and output are reversed. *) opReg(MOVL_R_A64, source, output) | cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move32 }) = opReg(MOVL_R_A32, source, output) | cgOp(Move{ source=NonAddressConstArg source, destination=RegisterArg output, moveSize=Move64}) = if targetArch <> Native32Bit then ( (* N.B. There is related code in getConstant that deals with PC-relative values and also checks the range of constants that need to be in the constant area. *) if source >= 0 andalso source < 0x100000000 then (* Unsigned 32 bits. We can use a 32-bit instruction to set the value because it will zero extend to 64-bits. This may also allow us to save a rex byte. *) let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ word32Unsigned(LargeWord.fromLargeInt source) end else if source >= ~0x80000000 andalso source < 0 then (* Signed 32-bits. *) (* This is not scanned in 64-bit mode because 32-bit values aren't big enough to contain addresses. *) opRegPlus2(MOVL_32_A64, output, 0w0) @ int32Signed source else (* Too big for 32-bits; put it in the non-word area. *) opConstantOperand(MOVL_A_R64, output) ) else (* 32-bit mode. *) ( (* The RTS scans for possible addresses in MOV instructions so we can only use MOV if this is a tagged value. If it isn't we have to use something else such as XOR/ADD. In particular this is used before LOCK XADD for atomic inc/dec. We expect Move to preserve the CC so shouldn't use anything that affects it. There was a previous comment that said that using LEA wasn't a good idea. Perhaps because it takes 6 bytes. *) if source mod 2 = 0 then opIndexed(LEAL32, source, NONE, NoIndex, output) else let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ int32Signed source end ) | cgOp(Move{ source=NonAddressConstArg source, destination=RegisterArg output, moveSize=Move32}) = if targetArch <> Native32Bit then ( (* N.B. There is related code in getConstant that deals with PC-relative values and also checks the range of constants that need to be in the constant area. *) if source >= 0 andalso source < 0x100000000 then (* Unsigned 32 bits. We can use a 32-bit instruction to set the value because it will zero extend to 64-bits. This may also allow us to save a rex byte. *) let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ word32Unsigned(LargeWord.fromLargeInt source) end else if source >= ~0x80000000 andalso source < 0 then (* Signed 32-bits. *) (* This is not scanned in 64-bit mode because 32-bit values aren't big enough to contain addresses. *) opRegPlus2(MOVL_32_A64, output, 0w0) @ int32Signed source else (* Too big for 32-bits; put it in the non-word area. *) opConstantOperand(MOVL_A_R64, output) ) else (* 32-bit mode. *) ( (* The RTS scans for possible addresses in MOV instructions so we can only use MOV if this is a tagged value. If it isn't we have to use something else such as XOR/ADD. In particular this is used before LOCK XADD for atomic inc/dec. We expect Move to preserve the CC so shouldn't use anything that affects it. There was a previous comment that said that using LEA wasn't a good idea. Perhaps because it takes 6 bytes. *) if source mod 2 = 0 then opIndexed(LEAL32, source, NONE, NoIndex, output) else let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ int32Signed source end ) | cgOp(Move{ source=AddressConstArg _, destination=RegisterArg output, moveSize=Move64 }) = ( (* The constant area is currently PolyWords. That means we MUST use a 32-bit load in 32-in-64. *) targetArch = Native64Bit orelse raise InternalError "Move64 in 32-bit"; (* Put address constants in the constant area. *) opConstantOperand(MOVL_A_R64, output) ) | cgOp(Move{ source=AddressConstArg _, destination=RegisterArg output, moveSize=Move32 }) = ( case targetArch of Native64Bit => raise InternalError "Move32 - AddressConstArg" | ObjectId32Bit => (* Put address constants in the constant area. *) (* The constant area is currently PolyWords. That means we MUST use a 32-bit load in 32-in-64. *) opConstantOperand(MOVL_A_R32, output) | Native32Bit => (* Immediate constant *) let val (rc, _) = getReg output in opCodeBytes(MOVL_32_R rc, NONE) @ int32Signed(tag 0) end ) | cgOp(LoadAbsolute{ destination, ... }) = ( (* Immediate address constant. This is currently only used the special case of loading the address of PolyX86GetThreadData in a callback when we don't have rbx in 32-in-64. *) case targetArch of Native32Bit => let val (rc, _) = getReg destination in opCodeBytes(MOVL_32_R rc, NONE) @ int32Signed(tag 0) end | Native64Bit => opConstantOperand(MOVL_A_R64, destination) | ObjectId32Bit => let val (rc, rx) = getReg destination in opCodeBytes(MOVL_64_R rc, SOME{w=true, r=false, b=rx, x=false}) @ largeWordToBytes(LargeWord.fromLargeInt(tag 0), 8) end ) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move32 }) = opAddress(MOVL_A_R32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move64 }) = opAddress(MOVL_A_R64, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move8 }) = (* We don't need a REX.W bit here because the top 32-bits of a 64-bit register will always be zeroed. *) opAddress(MOVZB, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move8 }) = let (* Zero extend an 8-bit value in a register to 32/64 bits. *) val (rrC, rrX) = getReg output val (rbC, rbX) = getReg source (* We don't need a REX.W bit here because the top 32-bits of a 64-bit register will always be zeroed but we may need a REX byte if we're using esi or edi. *) val rexByte = if rrC < 0w4 andalso not rrX andalso not rbX then NONE else if hostIsX64 then SOME {w=false, r=rrX, b=rbX, x=false} else raise InternalError "Move8 with esi/edi" in opCodeBytes(MOVZB, rexByte) @ [modrm(Register, rrC, rbC)] end | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move8X32 }) = opAddress(MOVSXB32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move8X64 }) = (* But we will need a Rex.W here. *) opAddress(MOVSXB64, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move16, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = (* No need for Rex.W *) opAddress(MOVZW, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move16X32, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = opAddress(MOVSXW32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move16X64, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = (* But we do need Rex.W here *) opAddress(MOVSXW64, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move32X64, source=RegisterArg source, destination=RegisterArg output }) = (* We should have a REX.W bit here. *) opReg(MOVSXD, output, source) | cgOp(Move{moveSize=Move32X64, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = (* We should have a REX.W bit here. *) opAddress(MOVSXD, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move32X64, ...}) = raise InternalError "cgOp: LoadNonWord Size32Bit" | cgOp(LoadAddress{ offset, base, index, output, opSize }) = (* This provides a mixture of addition and multiplication in a single instruction. *) opIndexed(case opSize of OpSize64 => LEAL64 | OpSize32 => LEAL32, LargeInt.fromInt offset, base, index, output) | cgOp(ArithToGenReg{ opc, output, source=RegisterArg source, opSize }) = arithOpReg (opc, output, source, opSize=OpSize64) | cgOp(ArithToGenReg{ opc, output, source=NonAddressConstArg source, opSize }) = let (* On the X86/32 we use CMP with literal sources to compare with an address and the RTS searches for them in the code. Any non-address constant must be tagged. Most will be but we might want to use this to compare with the contents of a LargeWord value. *) val _ = if hostIsX64 orelse is8BitL source orelse opc <> CMP orelse IntInf.andb(source, 1) = 1 then () else raise InternalError "CMP with constant that looks like an address" in immediateOperand(opc, output, source, opSize) end | cgOp(ArithToGenReg{ opc, output, source=AddressConstArg _, opSize }) = (* This is only used for opc=CMP to compare addresses for equality. *) if hostIsX64 then (* We use this in 32-in-64 as well as native 64-bit. *) opConstantOperand( (case opSize of OpSize64 => Arith64 | OpSize32 => Arith32) (opc, 0w3), output) else let val (rc, _) = getReg output val opb = opCodeBytes(Group1_32_A32 (* group1, 32 bit immediate *), NONE) val mdrm = modrm(Register, arithOpToWord opc, rc) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp(ArithToGenReg{ opc, output, source=MemoryArg{offset, base, index}, opSize }) = opAddress((case opSize of OpSize64 => Arith64 | OpSize32 => Arith32) (opc, 0w3), LargeInt.fromInt offset, base, index, output) | cgOp(ArithByteMemConst{ opc, address={offset, base, index}, source }) = opIndexedPlus2(Group1_8_a (* group1, 8 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ [source] | cgOp(ArithMemConst{ opc, address={offset, base, index}, source, opSize }) = if is8BitL source then (* Can use one byte immediate *) opIndexedPlus2(case opSize of OpSize64 => Group1_8_A64 | OpSize32 => Group1_8_A32 (* group1, 8 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ [Word8.fromLargeInt source] else (* Need 32 bit immediate. *) opIndexedPlus2(case opSize of OpSize64 => Group1_32_A64 | OpSize32 => Group1_32_A32(* group1, 32 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ int32Signed source | cgOp(ArithMemLongConst{ opc, address={offset, base, index}, ... }) = (* Currently this is always a comparison. It is only valid in 32-bit mode because the constant is only 32-bits. *) if hostIsX64 then raise InternalError "ArithMemLongConst in 64-bit mode" else let val opb = opIndexedPlus2 (Group1_32_A32, LargeInt.fromInt offset, base, index, arithOpToWord opc) in opb @ int32Signed(tag 0) end | cgOp(ShiftConstant { shiftType, output, shift, opSize }) = if shift = 0w1 then opRegPlus2(case opSize of OpSize64 => Group2_1_A64 | OpSize32 => Group2_1_A32, output, shiftTypeToWord shiftType) else opRegPlus2(case opSize of OpSize64 => Group2_8_A64 | OpSize32 => Group2_8_A32, output, shiftTypeToWord shiftType) @ [shift] | cgOp(ShiftVariable { shiftType, output, opSize }) = opRegPlus2(case opSize of OpSize64 => Group2_CL_A64 | OpSize32 => Group2_CL_A32, output, shiftTypeToWord shiftType) | cgOp(TestByteBits{arg=RegisterArg reg, bits}) = let (* Test the bottom bit and jump depending on its value. This is used for tag tests in arbitrary precision operations and also for testing for short/long values. *) val (regNum, rx) = getReg reg in if reg = eax then (* Special instruction for testing accumulator. Can use an 8-bit test. *) opCodeBytes(TEST_ACC8, NONE) @ [bits] else if hostIsX64 then let (* We can use a REX code to force it to always use the low order byte. *) val opb = opCodeBytes(Group3_a, if rx orelse regNum >= 0w4 then SOME{w=false, r=false, b=rx, x=false} else NONE) val mdrm = modrm (Register, 0w0 (* test *), regNum) in opb @ [mdrm, bits] end else if reg = ebx orelse reg = ecx orelse reg = edx (* can we use an 8-bit test? *) then (* Yes. The register value refers to low-order byte. *) let val opb = opCodeBytes(Group3_a, NONE) val mdrm = modrm(Register, 0w0 (* test *), regNum) in opb @ [mdrm, bits] end else let val opb = opCodeBytes(Group3_A32, NONE) val mdrm = modrm (Register, 0w0 (* test *), regNum) in opb @ mdrm :: word32Unsigned(Word8.toLarge bits) end end | cgOp(TestByteBits{arg=MemoryArg{base, offset, index}, bits}) = (* Test the tag bit and set the condition code. *) opIndexedPlus2(Group3_a, LargeInt.fromInt offset, base, index, 0w0 (* test *)) @ [ bits] | cgOp(TestByteBits _) = raise InternalError "cgOp: TestByteBits" | cgOp(ConditionalBranch{ test=opc, ... }) = opCodeBytes(CondJump32 opc, NONE) @ word32Unsigned 0w0 | cgOp(SetCondition{ output, test}) = let val (rrC, rx) = getReg output (* In 64-bit mode we can specify the low-order byte of RSI/RDI but we must use a REX prefix. This isn't possible in 32-bit mode. *) in if hostIsX64 orelse rrC < 0w4 then let val opb = opCodeBytes(SetCC test, if rx orelse rrC >= 0w4 then SOME{w=false, r=false, b=rx, x=false} else NONE) val mdrm = modrm (Register, 0w0, rrC) in opb @ [mdrm] end else raise InternalError "High byte register" end | cgOp(CallRTS{rtsEntry, saveRegs}) = rtsCall(rtsEntry, saveRegs) | cgOp(RepeatOperation repOp) = let (* We don't explicitly clear the direction flag. Should that be done? *) val opb = opCodeBytes(REP, NONE) (* Put in a rex prefix to force 64-bit mode. *) val optRex = if case repOp of STOS64 => true | MOVS64 => true | _ => false then [rex{w=true, r=false, b=false, x=false}] else [] val repOp = repOpsToWord repOp in opb @ optRex @ [repOp] end | cgOp(DivideAccR{arg, isSigned, opSize}) = opRegPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, arg, if isSigned then 0w7 else 0w6) | cgOp(DivideAccM{base, offset, isSigned, opSize}) = opPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, LargeInt.fromInt offset, base, if isSigned then 0w7 else 0w6) | cgOp(AtomicXAdd{address={offset, base, index}, output, opSize}) = (* Locked exchange-and-add. We need the lock prefix before the REX prefix. *) opAddress(case opSize of OpSize64 => LOCK_XADD64 | OpSize32 => LOCK_XADD32, LargeInt.fromInt offset, base, index, output) | cgOp(PushToStack(RegisterArg reg)) = let val (rc, rx) = getReg reg in (* Always 64-bit but a REX prefix may be needed for the register. *) opCodeBytes(PUSH_R rc, if rx then SOME{w=false, b = true, x=false, r = false } else NONE) end | cgOp(PushToStack(MemoryArg{base, offset, index})) = opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w6 (* push *)) | cgOp(PushToStack(NonAddressConstArg constnt)) = if is8BitL constnt then opCodeBytes(PUSH_8, NONE) @ [Word8.fromLargeInt constnt] else if is32bit constnt then opCodeBytes(PUSH_32, NONE) @ int32Signed constnt else (* It won't fit in the immediate; put it in the non-address area. *) let val opb = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w6 (* push *), 0w5 (* PC rel *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp(PushToStack(AddressConstArg _)) = ( case targetArch of Native64Bit => (* Put it in the constant area. *) let val opb = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w6 (* push *), 0w5 (* PC rel *)); in opb @ [mdrm] @ int32Signed(tag 0) end | Native32Bit => opCodeBytes(PUSH_32, NONE) @ int32Signed(tag 0) | ObjectId32Bit => (* We can't do this. The constant area contains 32-bit quantities and 32-bit literals are sign-extended rather than zero-extended. *) raise InternalError "PushToStack:AddressConstArg" ) | cgOp(PopR reg ) = let val (rc, rx) = getReg reg in (* Always 64-bit but a REX prefix may be needed for the register. Because the register is encoded in the instruction the rex bit for the register is b not r. *) opCodeBytes(POP_R rc, if rx then SOME{w=false, b = true, x=false, r = false } else NONE) end | cgOp(Move{source=RegisterArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move64}) = opAddress(MOVL_R_A64, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{source=RegisterArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move32}) = opAddress(MOVL_R_A32, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move64 }) = ( (* Short constant. In 32-bit mode this is scanned as a possible address. That means we can't have an untagged constant in it. That's not a problem in 64-bit mode. There's a special check for using this to set the length word on newly allocated memory. *) targetArch <> Native32Bit orelse toStore = 0 orelse toStore mod 2 = 1 orelse offset = ~ (Word.toInt wordSize) orelse raise InternalError "cgOp: StoreConstToMemory not tagged"; opAddressPlus2(MOVL_32_A64, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed toStore ) | cgOp(Move{source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move32 }) = ( (* Short constant. In 32-bit mode this is scanned as a possible address. That means we can't have an untagged constant in it. That's not a problem in 64-bit mode. There's a special check for using this to set the length word on newly allocated memory. *) targetArch <> Native32Bit orelse toStore = 0 orelse toStore mod 2 = 1 orelse offset = ~ (Word.toInt wordSize) orelse raise InternalError "cgOp: StoreConstToMemory not tagged"; opAddressPlus2(MOVL_32_A32, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed toStore ) | cgOp(Move{source=AddressConstArg _, destination=MemoryArg{offset, base, index}, moveSize=Move32}) = (* This is not used for addresses even in 32-in-64. We don't scan for addresses after MOVL_32_A. *) if targetArch <> Native32Bit then raise InternalError "StoreLongConstToMemory in 64-bit mode" else opAddressPlus2(MOVL_32_A32, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed (tag 0) | cgOp(Move{source=AddressConstArg _, destination=MemoryArg _, ...}) = raise InternalError "cgOp: Move - AddressConstArg => MemoryArg" | cgOp(Move{ moveSize = Move8, source=RegisterArg toStore, destination=MemoryArg{offset, base, index} }) = let val (rrC, _) = getReg toStore (* In 64-bit mode we can specify the low-order byte of RSI/RDI but we must use a REX prefix. This isn't possible in 32-bit mode. *) val opcode = if hostIsX64 then MOVB_R_A64{forceRex= rrC >= 0w4} else if rrC < 0w4 then MOVB_R_A32 else raise InternalError "High byte register" in opAddress(opcode, LargeInt.fromInt offset, base, index, toStore) end | cgOp(Move{ moveSize = Move16, source=RegisterArg toStore, destination=MemoryArg{offset, base, index}}) = opAddress(MOVL_R_A16, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{ moveSize = Move8, source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}}) = opAddressPlus2(MOVB_8_A, LargeInt.fromInt offset, base, index, 0w0) @ [Word8.fromLargeInt toStore] | cgOp(Move _) = raise InternalError "Move: Unimplemented arguments" (* Allocation is dealt with by expanding the code. *) | cgOp(AllocStore _) = raise InternalError "cgOp: AllocStore" | cgOp(AllocStoreVariable _) = raise InternalError "cgOp: AllocStoreVariable" | cgOp StoreInitialised = raise InternalError "cgOp: StoreInitialised" | cgOp(CallAddress(NonAddressConstArg _)) = (* Call to the start of the code. Offset is patched in later. *) opCodeBytes (CALL_32, NONE) @ int32Signed 0 | cgOp(CallAddress(AddressConstArg _)) = if targetArch = Native64Bit then let val opc = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w2 (* call *), 0w5 (* PC rel *)) in opc @ [mdrm] @ int32Signed(tag 0) end (* Because this is a relative branch we need to point this at itself. Until it is set to the relative offset of the destination it needs to contain an address within the code and this could be the last instruction. *) else opCodeBytes (CALL_32, NONE) @ int32Signed ~5 | cgOp(CallAddress(RegisterArg reg)) = opRegPlus2(Group5, reg, 0w2 (* call *)) | cgOp(CallAddress(MemoryArg{base, offset, index})) = opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w2 (* call *)) | cgOp(JumpAddress(NonAddressConstArg _)) = (* Jump to the start of the current function. Offset is patched in later. *) opCodeBytes (JMP_32, NONE) @ int32Signed 0 | cgOp(JumpAddress (AddressConstArg _)) = if targetArch = Native64Bit then let val opb = opCodeBytes (Group5, NONE) val mdrm = modrm(Based0, 0w4 (* jmp *), 0w5 (* PC rel *)) in opb @ [mdrm] @ int32Signed(tag 0) end else opCodeBytes (JMP_32, NONE) @ int32Signed ~5 (* As with Call. *) | cgOp(JumpAddress (RegisterArg reg)) = (* Used as part of indexed case - not for entering a function. *) opRegPlus2(Group5, reg, 0w4 (* jmp *)) | cgOp(JumpAddress(MemoryArg{base, offset, index})) = opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w4 (* jmp *)) | cgOp(ReturnFromFunction args) = if args = 0 then opCodeBytes(RET, NONE) else let val offset = Word.fromInt args * nativeWordSize in opCodeBytes(RET_16, NONE) @ [wordToWord8 offset, wordToWord8(offset >> 0w8)] end | cgOp (RaiseException { workReg }) = opEA(if hostIsX64 then MOVL_A_R64 else MOVL_A_R32, LargeInt.fromInt memRegHandlerRegister, ebp, workReg) @ opAddressPlus2(Group5, 0, workReg, NoIndex, 0w4 (* jmp *)) | cgOp(UncondBranch _) = opToInt JMP_32 :: word32Unsigned 0w0 | cgOp(ResetStack{numWords, preserveCC}) = let val bytes = Word.toLargeInt(Word.fromInt numWords * nativeWordSize) in (* If we don't need to preserve the CC across the reset we use ADD since it's shorter. *) if preserveCC then opEA(if hostIsX64 then LEAL64 else LEAL32, bytes, esp, esp) else immediateOperand(ADD, esp, bytes, if hostIsX64 then OpSize64 else OpSize32) end | cgOp(JumpLabel _) = [] (* No code. *) | cgOp(LoadLabelAddress{ output, ... }) = (* Load the address of a label. Used when setting up an exception handler or in indexed cases. *) (* On X86/64 we can use pc-relative addressing to set the start of the handler. On X86/32 we have to load the address of the start of the code and add an offset. *) if hostIsX64 then opConstantOperand(LEAL64, output) else let val (rc, _) = getReg output in opCodeBytes(MOVL_32_R rc , NONE) @ int32Signed(tag 0) @ opRegPlus2(Group1_32_A32, output, arithOpToWord ADD) @ int32Signed 0 end | cgOp (FPLoadFromMemory {address={ base, offset, index }, precision}) = let val loadInstr = case precision of DoublePrecision => FPESC 0w5 | SinglePrecision => FPESC 0w1 in opAddressPlus2(loadInstr, LargeInt.fromInt offset, base, index, 0wx0) end | cgOp (FPLoadFromFPReg{source=FloatingPtReg fp, ...}) = (* Assume there's nothing currently on the stack. *) floatingPtOp({escape=0w1, md=0w3, nnn=0w0, rm= fp + 0w0}) (* FLD ST(r1) *) | cgOp (FPLoadFromConst {precision, ...} ) = (* The real constant here is actually the address of a memory object. FLD takes the address as the argument and in 32-bit mode we use an absolute address. In 64-bit mode we need to put the constant at the end of the code segment and use PC-relative addressing which happens to be encoded in the same way. There are special cases for zero and one but it's probably too much work to detect them. *) let val esc = case precision of SinglePrecision => 0w1 | DoublePrecision => 0w5 val opb = opCodeBytes(FPESC esc, NONE) (* FLD [Constant] *) val mdrm = modrm (Based0, 0w0, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (FPStoreToFPReg{ output=FloatingPtReg dest, andPop }) = (* Assume there's one item on the stack. *) floatingPtOp({escape=0w5, md=0w3, nnn=if andPop then 0wx3 else 0wx2, rm = dest+0w1(* One item *)}) (* FSTP ST(n+1) *) | cgOp (FPStoreToMemory{address={ base, offset, index}, precision, andPop }) = let val storeInstr = case precision of DoublePrecision => FPESC 0w5 | SinglePrecision => FPESC 0w1 val subInstr = if andPop then 0wx3 else 0wx2 in opAddressPlus2(storeInstr, LargeInt.fromInt offset, base, index, subInstr) end | cgOp (FPArithR{ opc, source = FloatingPtReg src}) = floatingPtOp({escape=0w0, md=0w3, nnn=fpOpToWord opc, rm=src + 0w1 (* One item already there *)}) | cgOp (FPArithConst{ opc, precision, ... }) = (* See comment on FPLoadFromConst *) let val fpesc = case precision of DoublePrecision => 0w4 | SinglePrecision => 0w0 val opb = opCodeBytes(FPESC fpesc, NONE) (* FADD etc [constnt] *) val mdrm = modrm (Based0, fpOpToWord opc, 0w5 (* constant address *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (FPArithMemory{ opc, base, offset, precision }) = let val fpesc = case precision of DoublePrecision => 0w4 | SinglePrecision => 0w0 in opPlus2(FPESC fpesc, LargeInt.fromInt offset, base, fpOpToWord opc) (* FADD/FMUL etc [r2] *) end | cgOp (FPUnary opc ) = let val {rm, nnn} = fpUnaryToWords opc in floatingPtOp({escape=0w1, md=0w3, nnn=nnn, rm=rm}) (* FCHS etc *) end | cgOp (FPStatusToEAX ) = opCodeBytes(FPESC 0w7, NONE) @ [0wxe0] (* FNSTSW AX *) | cgOp (FPFree(FloatingPtReg reg)) = floatingPtOp({escape=0w5, md=0w3, nnn=0w0, rm=reg}) (* FFREE FP(n) *) | cgOp (FPLoadInt{base, offset, opSize=OpSize64}) = (* fildl (esp) in 32-bit mode or fildq (esp) in 64-bit mode. *) opPlus2(FPESC 0w7, LargeInt.fromInt offset, base, 0w5) | cgOp (FPLoadInt{base, offset, opSize=OpSize32}) = (* fildl (esp) in 32-bit mode or fildq (esp) in 64-bit mode. *) opPlus2(FPESC 0w3, LargeInt.fromInt offset, base, 0w0) | cgOp (MultiplyR {source=RegisterArg srcReg, output, opSize}) = (* We use the 0F AF form of IMUL rather than the Group3 MUL or IMUL because the former allows us to specify the destination register. The Group3 forms produce double length results in RAX:RDX/EAX:EDX but we only ever want the low-order half. *) opReg(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32 (* 2 byte opcode *), output, srcReg) | cgOp (MultiplyR {source=MemoryArg{base, offset, index}, output, opSize}) = (* This may be used for large-word multiplication. *) opAddress(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32 (* 2 byte opcode *), LargeInt.fromInt offset, base, index, output) | cgOp(MultiplyR {source=NonAddressConstArg constnt, output, opSize}) = (* If the constant is an 8-bit or 32-bit value we are actually using a three-operand instruction where the argument can be a register or memory and the destination register does not need to be the same as the source. *) if is8BitL constnt then opReg(case opSize of OpSize64 => IMUL_C8_64 | OpSize32 => IMUL_C8_32, output, output) @ [Word8.fromLargeInt constnt] else if is32bit constnt then opReg(case opSize of OpSize64 => IMUL_C32_64 | OpSize32 => IMUL_C32_32, output, output) @ int32Signed constnt else opConstantOperand(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32, output) | cgOp(MultiplyR {source=AddressConstArg _, ...}) = raise InternalError "Multiply - address constant" | cgOp (XMMArith { opc, source=MemoryArg{base, offset, index}, output }) = mMXAddress(SSE2Ops opc, LargeInt.fromInt offset, base, index, output) | cgOp (XMMArith { opc, source=AddressConstArg _, output=SSE2Reg rrC }) = let (* The real constant here is actually the address of an 8-byte memory object. In 32-bit mode we put this address into the code and retain this memory object. In 64-bit mode we copy the real value out of the memory object into the non-address constant area and use PC-relative addressing. These happen to be encoded the same way. *) val opb = opCodeBytes(SSE2Ops opc, NONE) val mdrm = modrm (Based0, rrC, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (XMMArith { opc, source=RegisterArg(SSE2Reg rrS), output=SSE2Reg rrC }) = let val oper = SSE2Ops opc val pref = opcodePrefix oper val esc = escapePrefix oper val opc = opToInt oper val mdrm = modrm(Register, rrC, rrS) in pref @ esc @ [opc, mdrm] end | cgOp (XMMArith { opc, source=NonAddressConstArg _, output=SSE2Reg rrC }) = let val _ = hostIsX64 orelse raise InternalError "XMMArith-NonAddressConstArg in 32-bit mode" (* This is currently used for 32-bit float arguments but can equally be used for 64-bit values since the actual argument will always be put in the 64-bit constant area. *) val opb = opCodeBytes(SSE2Ops opc, NONE) val mdrm = modrm (Based0, rrC, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (XMMStoreToMemory { toStore, address={base, offset, index}, precision }) = let val oper = case precision of DoublePrecision => SSE2StoreDouble | SinglePrecision => SSE2StoreSingle in mMXAddress(oper, LargeInt.fromInt offset, base, index, toStore) end | cgOp (XMMConvertFromInt { source, output=SSE2Reg rrC, opSize }) = let (* The source is a general register and the output a XMM register. *) (* TODO: The source can be a memory location. *) val (rbC, rbX) = getReg source val oper = case opSize of OpSize64 => CVTSI2SD64 | OpSize32 => CVTSI2SD32 in (* This is a special case with both an XMM and general register. *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp (SignExtendForDivide OpSize64) = opCodeBytes(CQO_CDQ64, SOME {w=true, r=false, b=false, x=false}) | cgOp (SignExtendForDivide OpSize32) = opCodeBytes(CQO_CDQ32, NONE) | cgOp (XChng { reg, arg=RegisterArg regY, opSize }) = opReg(case opSize of OpSize64 => XCHNG64 | OpSize32 => XCHNG32, reg, regY) | cgOp (XChng { reg, arg=MemoryArg{offset, base, index}, opSize }) = opAddress(case opSize of OpSize64 => XCHNG64 | OpSize32 => XCHNG32, LargeInt.fromInt offset, base, index, reg) | cgOp (XChng _) = raise InternalError "cgOp: XChng" | cgOp (Negative {output, opSize}) = opRegPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, output, 0w3 (* neg *)) | cgOp (JumpTable{cases, jumpSize=ref jumpSize}) = let val _ = jumpSize = JumpSize8 orelse raise InternalError "cgOp: JumpTable" (* Make one jump for each case and pad it 8 bytes with Nops. *) fun makeJump (_, l) = opToInt JMP_32 :: word32Unsigned 0w0 @ [opToInt NOP, opToInt NOP, opToInt NOP] @ l in List.foldl makeJump [] cases end | cgOp(IndexedJumpCalc{ addrReg, indexReg, jumpSize=ref jumpSize }) = ( jumpSize = JumpSize8 orelse raise InternalError "cgOp: IndexedJumpCalc"; (* Should currently be JumpSize8 which requires a multiplier of 4 and 4 to be subtracted to remove the shifted tag. *) opAddress(if hostIsX64 then LEAL64 else LEAL32, ~4, addrReg, Index4 indexReg, addrReg) ) | cgOp(MoveXMMRegToGenReg { source=SSE2Reg rrC, output }) = let (* The source is a XMM register and the output a general register. *) val (rbC, rbX) = getReg output val oper = MOVDFromXMM in (* This is a special case with both an XMM and general register. *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp(MoveGenRegToXMMReg { source, output=SSE2Reg rrC }) = let (* The source is a general register and the output a XMM register. *) val (rbC, rbX) = getReg source val oper = MOVQToXMM in (* This is a special case with both an XMM and general register. *) (* This needs to move the whole 64-bit value. TODO: This is inconsistent with MoveXMMRegToGenReg *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp(XMMShiftRight { output=SSE2Reg rrC, shift }) = let val oper = PSRLDQ in opcodePrefix oper @ escapePrefix oper @ [opToInt oper, modrm(Register, 0w3, rrC), shift] end | cgOp(FPLoadCtrlWord {base, offset, index}) = opIndexedPlus2(FPESC 0w1, LargeInt.fromInt offset, base, index, 0w5) | cgOp(FPStoreCtrlWord {base, offset, index}) = opIndexedPlus2(FPESC 0w1, LargeInt.fromInt offset, base, index, 0w7) | cgOp(XMMLoadCSR {base, offset, index}) = opIndexedPlus2(LDSTMXCSR, LargeInt.fromInt offset, base, index, 0w2) | cgOp(XMMStoreCSR {base, offset, index}) = opIndexedPlus2(LDSTMXCSR, LargeInt.fromInt offset, base, index, 0w3) | cgOp(FPStoreInt {base, offset, index}) = (* fistp dword ptr [esp] in 32-bit mode or fistp qword ptr [rsp] in 64-bit mode. *) if hostIsX64 then opIndexedPlus2(FPESC 0w7, LargeInt.fromInt offset, base, index, 0w7) else opIndexedPlus2(FPESC 0w3, LargeInt.fromInt offset, base, index, 0w3) | cgOp(XMMStoreInt {source, output, precision, isTruncate}) = let (* The destination is a general register. The source is an XMM register or memory. *) val (rbC, rbX) = getReg output val oper = case (hostIsX64, precision, isTruncate) of (false, DoublePrecision, false) => CVTSD2SI32 | (true, DoublePrecision, false) => CVTSD2SI64 | (false, SinglePrecision, false) => CVTSS2SI32 | (true, SinglePrecision, false) => CVTSS2SI64 | (false, DoublePrecision, true) => CVTTSD2SI32 | (true, DoublePrecision, true) => CVTTSD2SI64 | (false, SinglePrecision, true) => CVTTSS2SI32 | (true, SinglePrecision, true) => CVTTSS2SI64 in case source of MemoryArg{base, offset, index} => opAddress(oper, LargeInt.fromInt offset, base, index, output) | RegisterArg(SSE2Reg rrS) => opcodePrefix oper @ rexByte(oper, rbX, false, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rbC, rrS)] | _ => raise InternalError "XMMStoreInt: Not register or memory" end | cgOp(CondMove { test, output, source=RegisterArg source, opSize=OpSize32 }) = opReg(CMOV32 test, output, source) | cgOp(CondMove { test, output, source=RegisterArg source, opSize=OpSize64 }) = opReg(CMOV64 test, output, source) | cgOp(CondMove { test, output, source=NonAddressConstArg _, opSize }) = ( (* We currently support only native-64 bit and put the constant in the non-address constant area. These are 64-bit values both in native 64-bit and in 32-in-64. To support it in 32-bit mode we'd have to put the constant in a single-word object and put its absolute address into the code. *) targetArch <> Native32Bit orelse raise InternalError "CondMove: constant in 32-bit mode"; opConstantOperand((case opSize of OpSize32 => CMOV32 | OpSize64 => CMOV64) test, output) ) | cgOp(CondMove { test, output, source=AddressConstArg _, opSize=OpSize64 }) = (* An address constant. The opSize must match the size of a polyWord since the value it going into the constant area. *) ( targetArch = Native64Bit orelse raise InternalError "CondMove: AddressConstArg"; opConstantOperand(CMOV64 test, output) ) | cgOp(CondMove { test, output, source=AddressConstArg _, opSize=OpSize32 }) = ( (* We only support address constants in 32-in-64. *) targetArch = ObjectId32Bit orelse raise InternalError "CondMove: AddressConstArg"; opConstantOperand(CMOV32 test, output) ) | cgOp(CondMove { test, output, source=MemoryArg{base, offset, index}, opSize=OpSize32 }) = opAddress(CMOV32 test, LargeInt.fromInt offset, base, index, output) | cgOp(CondMove { test, output, source=MemoryArg{base, offset, index}, opSize=OpSize64 }) = opAddress(CMOV64 test, LargeInt.fromInt offset, base, index, output) in List.rev(List.foldl (fn (c, list) => Word8Vector.fromList(cgOp c) :: list) [] ops) end (* General function to process the code. ic is the byte counter within the original code. *) fun foldCode foldFn n (ops, byteList) = let fun doFold(oper :: operList, bytes :: byteList, ic, acc) = doFold(operList, byteList, ic + Word.fromInt(Word8Vector.length bytes), foldFn(oper, bytes, ic, acc)) | doFold(_, _, _, n) = n in doFold(ops, byteList, 0w0, n) end (* Go through the code and update branch and similar instructions with the destinations of the branches. Long branches are converted to short where possible and the code is reprocessed. That might repeat if the effect of shorting one branch allows another to be shortened. *) fun fixupLabels(ops, bytesList, labelCount) = let (* Label array - initialise to 0wxff... . Every label should be defined but just in case, this is more likely to be detected in int32Signed. *) val labelArray = Array.array(labelCount, ~ 0w1) (* First pass - Set the addresses of labels. *) fun setLabelAddresses(oper :: operList, bytes :: byteList, ic) = ( case oper of JumpLabel(Label{labelNo, ...}) => Array.update(labelArray, labelNo, ic) | _ => (); setLabelAddresses(operList, byteList, ic + Word.fromInt(Word8Vector.length bytes)) ) | setLabelAddresses(_, _, ic) = ic (* Return the length of the code. *) fun fixup32(destination, bytes, ic) = let val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in Word8VectorSlice.concat[ Word8VectorSlice.slice(bytes, 0, SOME(brLength-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt diff))) ] end fun fixupAddress(UncondBranch(Label{labelNo, ...}), bytes, ic, list) = let val destination = Array.sub(labelArray, labelNo) val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in if brLength = 2 then (* It's a short branch. Take the original operand and set the relative offset. *) Word8Vector.fromList [opToInt JMP_8, byteSigned diff] :: list else if brLength <> 5 then raise InternalError "fixupAddress" else (* 32-bit offset. If it will fit in a byte we can use a short branch. If this is a reverse branch we can actually use values up to -131 here because we've calculated using the end of the long branch. *) if diff <= 127 andalso diff >= ~(128 + 3) then Word8Vector.fromList [opToInt JMP_8, 0w0 (* Fixed on next pass *)] :: list else Word8Vector.fromList(opToInt JMP_32 :: int32Signed(LargeInt.fromInt diff)) :: list end | fixupAddress(ConditionalBranch{label=Label{labelNo, ...}, test, ...}, bytes, ic, list) = let val destination = Array.sub(labelArray, labelNo) val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in if brLength = 2 then (* It's a short branch. Take the original operand and set the relative offset. *) Word8Vector.fromList [opToInt(CondJump test), byteSigned diff] :: list else if brLength <> 6 then raise InternalError "fixupAddress" else if diff <= 127 andalso diff >= ~(128+4) then Word8Vector.fromList[opToInt(CondJump test), 0w0 (* Fixed on next pass *)] :: list else Word8Vector.fromList(opCodeBytes(CondJump32 test, NONE) @ int32Signed(LargeInt.fromInt diff)) :: list end | fixupAddress(LoadLabelAddress{ label=Label{labelNo, ...}, ... }, brCode, ic, list) = let val destination = Array.sub(labelArray, labelNo) in if hostIsX64 then (* This is a relative offset on the X86/64. *) fixup32(destination, brCode, ic) :: list else (* On X86/32 the address is relative to the start of the code so we simply put in the destination address. *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(Word8Vector.length brCode-4)), Word8VectorSlice.full(Word8Vector.fromList(int32Signed(Word.toLargeInt destination)))] :: list end | fixupAddress(JumpTable{cases, jumpSize as ref JumpSize8}, brCode: Word8Vector.vector, ic, list) = let (* Each branch is a 32-bit jump padded up to 8 bytes. *) fun processCase(Label{labelNo, ...} :: cases, offset, ic) = fixup32(Array.sub(labelArray, labelNo), Word8VectorSlice.vector(Word8VectorSlice.slice(brCode, offset, SOME 5)), ic) :: Word8VectorSlice.vector(Word8VectorSlice.slice(brCode, offset+5, SOME 3)) :: processCase(cases, offset+8, ic+0w8) | processCase _ = [] (* Could we use short branches? If all of the branches were short the table would be smaller so the offsets we use would be less. Ignore backwards branches - could only occur if we have linked labels in a loop. *) val newStartOfCode = ic + Word.fromInt(List.length cases * 6) fun tryShort(Label{labelNo, ...} :: cases, ic) = let val destination = Array.sub(labelArray, labelNo) in if destination > ic + 0w2 andalso destination - ic - 0w2 < 0w127 then tryShort(cases, ic+0w2) else false end | tryShort _ = true val newCases = if tryShort(cases, newStartOfCode) then ( jumpSize := JumpSize2; (* Generate a short branch table. *) List.map(fn _ => Word8Vector.fromList [opToInt JMP_8, 0w0 (* Fixed on next pass *)]) cases ) else processCase(cases, 0, ic) in Word8Vector.concat newCases :: list end | fixupAddress(JumpTable{cases, jumpSize=ref JumpSize2}, _, ic, list) = let (* Each branch is a short jump. *) fun processCase(Label{labelNo, ...} :: cases, offset, ic) = let val destination = Array.sub(labelArray, labelNo) val brLength = 2 val diff = Word.toInt destination - Word.toInt ic - brLength in Word8Vector.fromList[opToInt JMP_8, byteSigned diff] :: processCase(cases, offset+2, ic+0w2) end | processCase _ = [] in Word8Vector.concat(processCase(cases, 0, ic)) :: list end (* If we've shortened a jump table we have to change the indexing. *) | fixupAddress(IndexedJumpCalc{ addrReg, indexReg, jumpSize=ref JumpSize2 }, _, _, list) = (* On x86/32 it might be shorter to use DEC addrReg; ADD addrReg, indexReg. *) Word8Vector.fromList(opAddress(if hostIsX64 then LEAL64 else LEAL32, ~1, addrReg, Index1 indexReg, addrReg)) :: list | fixupAddress(CallAddress(NonAddressConstArg _), brCode, ic, list) = let val brLen = Word8Vector.length brCode in (* Call to the start of the code. Offset is -(bytes to start). *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(brLen-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt(~(Word.toInt ic+brLen))))) ] :: list end | fixupAddress(JumpAddress(NonAddressConstArg _), brCode, ic, list) = let val brLen = Word8Vector.length brCode in (* Call to the start of the code. Offset is -(bytes to start). *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(brLen-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt(~(Word.toInt ic+brLen))))) ] :: list end | fixupAddress(_, bytes, _, list) = bytes :: list fun reprocess(bytesList, lastCodeSize) = let val fixedList = List.rev(foldCode fixupAddress [] (ops, bytesList)) val newCodeSize = setLabelAddresses(ops, fixedList, 0w0) in if newCodeSize = lastCodeSize then (fixedList, lastCodeSize) else if newCodeSize > lastCodeSize then raise InternalError "reprocess - size increased" else reprocess(fixedList, newCodeSize) end in reprocess(bytesList, setLabelAddresses(ops, bytesList, 0w0)) end (* The handling of constants generally differs between 32- and 64-bits. In 32-bits we put all constants inline and the GC processes the code to find the addresss. For real values the "constant" is actually the address of the boxed real value. In 64-bit mode inline constants were used with the MOV instruction but this has now been removed. All constants are stored in one of two areas at the end of the code segment. Non-addresses, including the actual values of reals, are stored in the non-address area and addresses go in the address area. Only the latter is scanned by the GC. The address area is also used in 32-bit mode but only has the address of the function name and the address of the profile ref in it. *) datatype inline32constants = SelfAddress (* The address of the start of the code - inline absolute address 32-bit only *) | InlineAbsoluteAddress of machineWord (* An address in the code: 32-bit only *) | InlineRelativeAddress of machineWord (* A relative address: 32-bit only. *) local (* Turn an integer constant into an 8-byte vector. *) fun intConst ival = LargeWord.fromLargeInt ival (* Copy a real constant from memory into an 8-byte vector. *) fun realConst c = let val cAsAddr = toAddress c (* This may be a boxed real or, in 32-in-64 mode, a boxed float. *) val cLength = length cAsAddr * wordSize val _ = ((cLength = 0w8 orelse cLength = 0w4) andalso flags cAsAddr = F_bytes) orelse raise InternalError "realConst: Not a real number" fun getBytes(i, a) = if i = 0w0 then a else getBytes(i-0w1, a*0w256 + Word8.toLargeWord(loadByte(cAsAddr, i-0w1))) in getBytes(cLength, 0w0) end fun getConstant(Move{ source=NonAddressConstArg source, moveSize=Move32, ...}, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then ( if source >= ~0x80000000 andalso source < 0x100000000 then (* Signed or unsigned 32-bits. *) (inl, addr, na) else (* Too big for 32-bits. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) ) else (inl, addr, na) (* 32-bit mode. The constant will always be inline even if we've had to use LEA r,c *) | getConstant(Move{ source=NonAddressConstArg source, moveSize=Move64, ...}, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then ( if source >= ~0x80000000 andalso source < 0x100000000 then (* Signed or unsigned 32-bits. *) (inl, addr, na) else (* Too big for 32-bits. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) ) else (inl, addr, na) (* 32-bit mode. The constant will always be inline even if we've had to use XOR r,r; ADD r,c *) | getConstant(Move{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (* Address constants go in the constant area. *) (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - wordSize, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(LoadAbsolute{value, ...}, bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (* Address constants go in the constant area. *) (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, value) :: addr, na) (* This is the only case of an inline constant in 32-in-64 *) else ((ic + Word.fromInt(Word8Vector.length bytes) - nativeWordSize, InlineAbsoluteAddress value) :: inl, addr, na) | getConstant(ArithToGenReg{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if is32bit source then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) | getConstant(ArithToGenReg{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(ArithMemLongConst{ source, ... }, bytes, ic, (inl, addr, na)) = (* 32-bit only. *) ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(PushToStack(NonAddressConstArg constnt), bytes, ic, (inl, addr, na)) = if is32bit constnt then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst constnt) :: na) | getConstant(PushToStack(AddressConstArg constnt), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, constnt) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constnt) :: inl, addr, na) | getConstant(CallAddress(AddressConstArg w), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, w) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineRelativeAddress w) :: inl, addr, na) | getConstant(JumpAddress(AddressConstArg w), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, w) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineRelativeAddress w) :: inl, addr, na) | getConstant(LoadLabelAddress _, _, ic, (inl, addr, na)) = (* We need the address of the code itself but it's in the first of a pair of instructions. *) if hostIsX64 then (inl, addr, na) else ((ic + 0w1, SelfAddress) :: inl, addr, na) | getConstant(FPLoadFromConst{constant, ...}, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst constant) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constant) :: inl, addr, na) | getConstant(FPArithConst{ source, ... }, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst source) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(XMMArith { source=AddressConstArg constVal, ... }, bytes, ic, (inl, addr, na)) = (* Real.real constant or, with 32-bit words, a Real32.real constant. *) if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst constVal) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constVal) :: inl, addr, na) | getConstant(XMMArith { source=NonAddressConstArg constVal, ... }, bytes, ic, (inl, addr, na)) = (* Real32.real constant in native 64-bit. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst constVal) :: na) | getConstant(MultiplyR{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if is32bit source then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) | getConstant(CondMove{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) else (inl, addr, na) (* 32-bit mode. The constant will always be inline. *) | getConstant(CondMove{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (* Address constants go in the constant area. *) (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - wordSize, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(_, _, _, l) = l in val getConstants = foldCode getConstant ([], [], []) end (* It is convenient to have AllocStore and AllocStoreVariable as primitives at the higher level but at this point it's better to expand them into their basic instructions. *) fun expandComplexOperations(instrs, oldLabelCount) = let val labelCount = ref oldLabelCount fun mkLabel() = Label{labelNo= !labelCount} before labelCount := !labelCount + 1 (* On X86/64 the local pointer is in r15. On X86/32 it's in memRegs. *) val localPointer = if hostIsX64 then RegisterArg r15 else MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex} val nativeWordOpSize = if hostIsX64 then OpSize64 else OpSize32 fun allocStoreCommonCode (resultReg, isVarAlloc, regSaveSet: genReg list) = let val compare = ArithToGenReg{opc=CMP, output=resultReg, source=MemoryArg{base=ebp, offset=memRegLocalMbottom, index=NoIndex}, opSize=nativeWordOpSize} (* Normally we won't have run out of store so we want the default branch prediction to skip the test here. However doing that involves adding an extra branch which lengthens the code so it's probably not worth while. *) (* Just checking against the lower limit can fail in the situation where the heap pointer is at the low end of the address range and the store required is so large that the subtraction results in a negative number. In that case it will be > (unsigned) lower_limit so in addition we have to check that the result is < (unsigned) heap_pointer. This actually happened on Windows with X86-64. In theory this can happen with fixed-size allocations as well as variable allocations but in practice fixed-size allocations are going to be small enough that it's not a problem. *) val destLabel = mkLabel() val branches = if isVarAlloc then let val extraLabel = mkLabel() in [ConditionalBranch{test=JB, label=extraLabel}, ArithToGenReg{opc=CMP, output=resultReg, source=localPointer, opSize=nativeWordOpSize}, ConditionalBranch{test=JB, label=destLabel}, JumpLabel extraLabel] end else [ConditionalBranch{test=JNB, label=destLabel}] val callRts = CallRTS{rtsEntry=HeapOverflowCall, saveRegs=regSaveSet} val fixup = JumpLabel destLabel (* Update the heap pointer now we have the store. This is also used by the RTS in the event of a trap to work out how much store was being allocated. *) val update = if hostIsX64 then Move{source=RegisterArg resultReg, destination=RegisterArg r15, moveSize=Move64} else Move{source=RegisterArg resultReg, destination=MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex}, moveSize=Move32} in compare :: branches @ [callRts, fixup, update] end fun doExpansion([], code, _) = code | doExpansion(AllocStore {size, output, saveRegs} :: instrs, code, inAllocation) = let val _ = inAllocation andalso raise InternalError "doExpansion: Allocation started but not complete" val () = if List.exists (fn r => r = output) saveRegs then raise InternalError "AllocStore: in set" else () val startCode = case targetArch of Native64Bit => let val bytes = (size + 1) * Word.toInt wordSize in [LoadAddress{output=output, offset = ~ bytes, base=SOME r15, index=NoIndex, opSize=OpSize64}] (* TODO: What if it's too big to fit? *) end | Native32Bit => let val bytes = (size + 1) * Word.toInt wordSize in [Move{source=MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex}, destination=RegisterArg output, moveSize=Move32}, LoadAddress{output=output, offset = ~ bytes, base=SOME output, index=NoIndex, opSize=OpSize32}] end | ObjectId32Bit => let (* We must allocate an even number of words. *) val heapWords = if Int.rem(size, 2) = 1 then size+1 else size+2 val bytes = heapWords * Word.toInt wordSize in [LoadAddress{output=output, offset = ~ bytes, base=SOME r15, index=NoIndex, opSize=OpSize64}] end val resultCode = startCode @ allocStoreCommonCode(output, false, saveRegs) in doExpansion(instrs, (List.rev resultCode) @ code, true) end | doExpansion(AllocStoreVariable {size, output, saveRegs} :: instrs, code, inAllocation) = let (* Allocates memory. The "size" register contains the number of words as a tagged int. *) val _ = inAllocation andalso raise InternalError "doExpansion: Allocation started but not complete" val () = if List.exists (fn r => r = output) saveRegs then raise InternalError "AllocStore: in set" else () (* Negate the length and add it to the current heap pointer. *) (* Compute the number of bytes into dReg. The length in sReg is the number of words as a tagged value so we need to multiply it, add wordSize to include one word for the header then subtract the, multiplied, tag. We use LEA here but want to avoid having an empty base register. *) val _ = size = output andalso raise InternalError "AllocStoreVariable : same register for size and output" val startCode = if wordSize = 0w8 (* 8-byte words *) then [ ArithToGenReg{opc=XOR, output=output, source=RegisterArg output, opSize=OpSize32 (* Rest is zeroed *)}, ArithToGenReg{opc=SUB, output=output, source=RegisterArg size, opSize=OpSize64}, LoadAddress{output=output, base=SOME r15, offset= ~(Word.toInt wordSize-4), index=Index4 output, opSize=OpSize64 } ] else (* 4 byte words *) [ LoadAddress{output=output, base=SOME size, offset=Word.toInt wordSize-2, index=Index1 size, opSize=nativeWordOpSize }, Negative{output=output, opSize=nativeWordOpSize}, ArithToGenReg{opc=ADD, output=output, source=localPointer, opSize=nativeWordOpSize} ] (* If this is 32-in-64 we need to round down to the next 8-byte boundary. *) val roundCode = if targetArch = ObjectId32Bit then [ArithToGenReg{opc=AND, output=output, source=NonAddressConstArg ~8, opSize=OpSize64 }] else [] val resultCode = startCode @ roundCode @ allocStoreCommonCode(output, true, saveRegs) in doExpansion(instrs, (List.rev resultCode) @ code, true) end | doExpansion(StoreInitialised :: instrs, code, _) = doExpansion(instrs, code, false) | doExpansion(instr :: instrs, code, inAlloc) = doExpansion(instrs, instr::code, inAlloc) val expanded = List.rev(doExpansion(instrs, [], false)) in (expanded, !labelCount) end fun printCode (Code{procName, printStream, ...}, seg) = let val print = printStream val ptr = ref 0w0; (* prints a string representation of a number *) fun printValue v = if v < 0 then (print "-"; print(LargeInt.toString (~ v))) else print(LargeInt.toString v) infix 3 +:= ; fun (x +:= y) = (x := !x + (y:word)); fun get16s (a, seg) : int = let val b0 = Word8.toInt (codeVecGet (seg, a)); val b1 = Word8.toInt (codeVecGet (seg, a + 0w1)); val b1' = if b1 >= 0x80 then b1 - 0x100 else b1; in (b1' * 0x100) + b0 end fun get16u(a, seg) : int = Word8.toInt (codeVecGet (seg, a + 0w1)) * 0x100 + Word8.toInt (codeVecGet (seg, a)) (* Get 1 unsigned byte from the given offset in the segment. *) fun get8u (a, seg) : Word8.word = codeVecGet (seg, a); (* Get 1 signed byte from the given offset in the segment. *) fun get8s (a, seg) : int = Word8.toIntX (codeVecGet (seg, a)); (* Get 1 signed 32 bit word from the given offset in the segment. *) fun get32s (a, seg) : LargeInt.int = let val b0 = Word8.toLargeInt (codeVecGet (seg, a)); val b1 = Word8.toLargeInt (codeVecGet (seg, a + 0w1)); val b2 = Word8.toLargeInt (codeVecGet (seg, a + 0w2)); val b3 = Word8.toLargeInt (codeVecGet (seg, a + 0w3)); val b3' = if b3 >= 0x80 then b3 - 0x100 else b3; val topHw = (b3' * 0x100) + b2; val bottomHw = (b1 * 0x100) + b0; in (topHw * exp2_16) + bottomHw end fun get64s (a, seg) : LargeInt.int = let val b0 = Word8.toLargeInt (codeVecGet (seg, a)); val b1 = Word8.toLargeInt (codeVecGet (seg, a + 0w1)); val b2 = Word8.toLargeInt (codeVecGet (seg, a + 0w2)); val b3 = Word8.toLargeInt (codeVecGet (seg, a + 0w3)); val b4 = Word8.toLargeInt (codeVecGet (seg, a + 0w4)); val b5 = Word8.toLargeInt (codeVecGet (seg, a + 0w5)); val b6 = Word8.toLargeInt (codeVecGet (seg, a + 0w6)); val b7 = Word8.toLargeInt (codeVecGet (seg, a + 0w7)); val b7' = if b7 >= 0x80 then b7 - 0x100 else b7; in ((((((((b7' * 0x100 + b6) * 0x100 + b5) * 0x100 + b4) * 0x100 + b3) * 0x100 + b2) * 0x100) + b1) * 0x100) + b0 end fun print32 () = printValue (get32s (!ptr, seg)) before (ptr +:= 0w4) and print64 () = printValue (get64s (!ptr, seg)) before (ptr +:= 0w8) and print16 () = printValue (LargeInt.fromInt(get16s (!ptr, seg)) before (ptr +:= 0w2)) and print8 () = printValue (LargeInt.fromInt(get8s (!ptr, seg)) before (ptr +:= 0w1)) fun printJmp () = let val valu = get8s (!ptr, seg) before ptr +:= 0w1 in print (Word.fmt StringCvt.HEX (Word.fromInt valu + !ptr)) end (* Print an effective address. The register field may designate a general register or an xmm register depending on the instruction. *) fun printEAGeneral printRegister (rex, sz) = let val modrm = codeVecGet (seg, !ptr) val () = ptr +:= 0w1 (* Decode the Rex prefix if present. *) val rexX = (rex andb8 0wx2) <> 0w0 val rexB = (rex andb8 0wx1) <> 0w0 val prefix = case sz of SZByte => "byte ptr " | SZWord => "word ptr " | SZDWord => "dword ptr " | SZQWord => "qword ptr " in case (modrm >>- 0w6, modrm andb8 0w7, hostIsX64) of (0w3, rm, _) => printRegister(rm, rexB, sz) | (md, 0w4, _) => let (* s-i-b present. *) val sib = codeVecGet (seg, !ptr) val () = ptr +:= 0w1 val ss = sib >>- 0w6 val index = (sib >>- 0w3) andb8 0w7 val base = sib andb8 0w7 in print prefix; case (md, base, hostIsX64) of (0w1, _, _) => print8 () | (0w2, _, _) => print32 () | (0w0, 0w5, _) => print32 () (* Absolute in 32-bit mode. PC-relative in 64-bit ?? *) | _ => (); print "["; if md <> 0w0 orelse base <> 0w5 then ( print (genRegRepr (mkReg (base, rexB), sz32_64)); if index = 0w4 then () else print "," ) else (); if index = 0w4 andalso not rexX (* No index. *) then () else print (genRegRepr (mkReg(index, rexX), sz32_64) ^ (if ss = 0w0 then "*1" else if ss = 0w1 then "*2" else if ss = 0w2 then "*4" else "*8")); print "]" end | (0w0, 0w5, false) => (* Absolute address.*) (print prefix; print32 ()) | (0w0, 0w5, _) => (* PC-relative in 64-bit *) (print prefix; print ".+"; print32 ()) | (md, rm, _) => (* register plus offset. *) ( print prefix; if md = 0w1 then print8 () else if md = 0w2 then print32 () else (); print ("[" ^ genRegRepr (mkReg(rm, rexB), sz32_64) ^ "]") ) end (* For most instructions we want to print a general register. *) val printEA = printEAGeneral (fn (rm, rexB, sz) => print (genRegRepr (mkReg(rm, rexB), sz))) and printEAxmm = printEAGeneral (fn (rm, _, _) => print (xmmRegRepr(SSE2Reg rm))) fun printArith opc = print (case opc of 0 => "add " | 1 => "or " | 2 => "adc " | 3 => "sbb " | 4 => "and " | 5 => "sub " | 6 => "xor " | _ => "cmp " ) fun printGvEv (opByte, rex, rexR, sz) = let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in printArith(Word8.toInt((opByte div 0w8) mod 0w8)); print "\t"; print (genRegRepr (mkReg(reg, rexR), sz)); print ","; printEA(rex, sz) end fun printMovCToR (opByte, sz, rexB) = ( print "mov \t"; print(genRegRepr (mkReg (opByte mod 0w8, rexB), sz)); print ","; case sz of SZDWord => print32 () | SZQWord => print64 () | _ => print "???" ) fun printShift (opByte, rex, sz) = let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 4 => "shl " | 5 => "shr " | 7 => "sar " | _ => "???" ); print "\t"; printEA(rex, sz); print ","; if opByte = opToInt Group2_1_A32 then print "1" else if opByte = opToInt Group2_CL_A32 then print "cl" else print8 () end fun printFloat (opByte, rex) = let (* Opcode is in next byte. *) val opByte2 = codeVecGet (seg, !ptr) val nnn = (opByte2 >>- 0w3) andb8 0w7 val escNo = opByte andb8 0wx7 in if (opByte2 andb8 0wxC0) = 0wxC0 then (* mod = 11 *) ( case (escNo, nnn, opByte2 andb8 0wx7 (* modrm *)) of (0w1, 0w4, 0w0) => print "fchs" | (0w1, 0w4, 0w1) => print "fabs" | (0w1, 0w5, 0w6) => print "fldz" | (0w1, 0w5, 0w1) => print "flf1" | (0w7, 0w4, 0w0) => print "fnstsw\tax" | (0w1, 0w5, 0w0) => print "fld1" | (0w1, 0w6, 0w3) => print "fpatan" | (0w1, 0w7, 0w2) => print "fsqrt" | (0w1, 0w7, 0w6) => print "fsin" | (0w1, 0w7, 0w7) => print "fcos" | (0w1, 0w6, 0w7) => print "fincstp" | (0w1, 0w6, 0w6) => print "fdecstp" | (0w3, 0w4, 0w2) => print "fnclex" | (0w5, 0w2, rno) => print ("fst \tst(" ^ Word8.toString rno ^ ")") | (0w5, 0w3, rno) => print ("fstp\tst(" ^ Word8.toString rno ^ ")") | (0w1, 0w0, rno) => print ("fld \tst(" ^ Word8.toString rno ^ ")") | (0w1, 0w1, rno) => print ("fxch\tst(" ^ Word8.toString rno ^ ")") | (0w0, 0w3, rno) => print ("fcomp\tst(" ^ Word8.toString rno ^ ")") | (0w0, 0w0, rno) => print ("fadd\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w1, rno) => print ("fmul\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w4, rno) => print ("fsub\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w5, rno) => print ("fsubr\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w6, rno) => print ("fdiv\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w7, rno) => print ("fdivr\tst,st(" ^ Word8.toString rno ^ ")") | (0w5, 0w0, rno) => print ("ffree\tst(" ^ Word8.toString rno ^ ")") | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)); ptr +:= 0w1 ) else (* mod = 00, 01, 10 *) ( case (escNo, nnn) of (0w0, 0w0) => (print "fadd\t"; printEA(rex, SZDWord)) (* Single precision. *) | (0w0, 0w1) => (print "fmul\t"; printEA(rex, SZDWord)) | (0w0, 0w3) => (print "fcomp\t"; printEA(rex, SZDWord)) | (0w0, 0w4) => (print "fsub\t"; printEA(rex, SZDWord)) | (0w0, 0w5) => (print "fsubr\t"; printEA(rex, SZDWord)) | (0w0, 0w6) => (print "fdiv\t"; printEA(rex, SZDWord)) | (0w0, 0w7) => (print "fdivr\t"; printEA(rex, SZDWord)) | (0w1, 0w0) => (print "fld \t"; printEA(rex, SZDWord)) | (0w1, 0w2) => (print "fst\t"; printEA(rex, SZDWord)) | (0w1, 0w3) => (print "fstp\t"; printEA(rex, SZDWord)) | (0w1, 0w5) => (print "fldcw\t"; printEA(rex, SZWord)) (* Control word is 16 bits *) | (0w1, 0w7) => (print "fstcw\t"; printEA(rex, SZWord)) (* Control word is 16 bits *) | (0w3, 0w0) => (print "fild\t"; printEA(rex, SZDWord)) (* 32-bit int. *) | (0w7, 0w5) => (print "fild\t"; printEA(rex, SZQWord)) (* 64-bit int. *) | (0w3, 0w3) => (print "fistp\t"; printEA(rex, SZDWord)) (* 32-bit int. *) | (0w7, 0w7) => (print "fistp\t"; printEA(rex, SZQWord)) (* 64-bit int. *) | (0w4, 0w0) => (print "fadd\t"; printEA(rex, SZQWord)) (* Double precision. *) | (0w4, 0w1) => (print "fmul\t"; printEA(rex, SZQWord)) | (0w4, 0w3) => (print "fcomp\t"; printEA(rex, SZQWord)) | (0w4, 0w4) => (print "fsub\t"; printEA(rex, SZQWord)) | (0w4, 0w5) => (print "fsubr\t"; printEA(rex, SZQWord)) | (0w4, 0w6) => (print "fdiv\t"; printEA(rex, SZQWord)) | (0w4, 0w7) => (print "fdivr\t"; printEA(rex, SZQWord)) | (0w5, 0w0) => (print "fld \t"; printEA(rex, SZQWord)) | (0w5, 0w2) => (print "fst\t"; printEA(rex, SZQWord)) | (0w5, 0w3) => (print "fstp\t"; printEA(rex, SZQWord)) | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)) ) end fun printJmp32 oper = let val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print oper; print "\t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end fun printMask mask = let val wordMask = Word.fromInt mask fun printAReg n = if n = regs then () else ( if (wordMask andb (0w1 << Word.fromInt n)) <> 0w0 then (print(regRepr(regN n)); print " ") else (); printAReg(n+1) ) in printAReg 0 end in if procName = "" (* No name *) then print "?" else print procName; print ":\n"; while get8u (!ptr, seg) <> 0wxf4 (* HLT. *) do let val () = print (Word.fmt StringCvt.HEX (!ptr)) (* The address in hex. *) val () = print "\t" (* See if we have a lock prefix. *) val () = if get8u (!ptr, seg) = 0wxF0 then (print "lock "; ptr := !ptr + 0w1) else () val legacyPrefix = let val p = get8u (!ptr, seg) in if p = 0wxF2 orelse p = 0wxF3 orelse p = 0wx66 then (ptr := !ptr + 0w1; p) else 0wx0 end (* See if we have a REX byte. *) val rex = let val b = get8u (!ptr, seg); in if b >= 0wx40 andalso b <= 0wx4f then (ptr := !ptr + 0w1; b) else 0w0 end val rexW = (rex andb8 0wx8) <> 0w0 val rexR = (rex andb8 0wx4) <> 0w0 val rexB = (rex andb8 0wx1) <> 0w0 val opByte = get8u (!ptr, seg) before ptr +:= 0w1 val sizeFromRexW = if rexW then SZQWord else SZDWord in case opByte of 0wx03 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx0b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx0f => (* ESCAPE *) let (* Opcode is in next byte. *) val opByte2 = codeVecGet (seg, !ptr) val () = (ptr +:= 0w1) fun printcmov movop = let val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print movop; print "\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end in case legacyPrefix of 0w0 => ( case opByte2 of 0wx2e => let (* ucomiss doesn't have a prefix. *) val nb = codeVecGet (seg, !ptr) val reg = SSE2Reg((nb >>- 0w3) andb8 0w7) in print "ucomiss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) end | 0wx40 => printcmov "cmovo" | 0wx41 => printcmov "cmovno" | 0wx42 => printcmov "cmovb" | 0wx43 => printcmov "cmovnb" | 0wx44 => printcmov "cmove" | 0wx45 => printcmov "cmovne" | 0wx46 => printcmov "cmovna" | 0wx47 => printcmov "cmova" | 0wx48 => printcmov "cmovs" | 0wx49 => printcmov "cmovns" | 0wx4a => printcmov "cmovp" | 0wx4b => printcmov "cmovnp" | 0wx4c => printcmov "cmovl" | 0wx4d => printcmov "cmovge" | 0wx4e => printcmov "cmovle" | 0wx4f => printcmov "cmovg" | 0wxC1 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in (* The address argument comes first in the assembly code. *) print "xadd\t"; printEA (rex, sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wxB6 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movzx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZByte) end | 0wxB7 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movzx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZWord) end | 0wxBE => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movsx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZByte) end | 0wxBF => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movsx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZWord) end | 0wxAE => let (* Opcode is determined by the next byte. *) val opByte2 = codeVecGet (seg, !ptr); val nnn = (opByte2 >>- 0w3) andb8 0w7 in case nnn of 0wx2 => (print "ldmxcsr\t"; printEA(rex, SZDWord)) | 0wx3 => (print "stmxcsr\t"; printEA(rex, SZDWord)) | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)) end | 0wxAF => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, sizeFromRexW) end | 0wx80 => printJmp32 "jo " | 0wx81 => printJmp32 "jno " | 0wx82 => printJmp32 "jb " | 0wx83 => printJmp32 "jnb " | 0wx84 => printJmp32 "je " | 0wx85 => printJmp32 "jne " | 0wx86 => printJmp32 "jna " | 0wx87 => printJmp32 "ja " | 0wx88 => printJmp32 "js " | 0wx89 => printJmp32 "jns " | 0wx8a => printJmp32 "jp " | 0wx8b => printJmp32 "jnp " | 0wx8c => printJmp32 "jl " | 0wx8d => printJmp32 "jge " | 0wx8e => printJmp32 "jle " | 0wx8f => printJmp32 "jg " | 0wx90 => (print "seto\t"; printEA (rex, SZByte)) | 0wx91 => (print "setno\t"; printEA (rex, SZByte)) | 0wx92 => (print "setb\t"; printEA (rex, SZByte)) | 0wx93 => (print "setnb\t"; printEA (rex, SZByte)) | 0wx94 => (print "sete\t"; printEA (rex, SZByte)) | 0wx95 => (print "setne\t"; printEA (rex, SZByte)) | 0wx96 => (print "setna\t"; printEA (rex, SZByte)) | 0wx97 => (print "seta\t"; printEA (rex, SZByte)) | 0wx98 => (print "sets\t"; printEA (rex, SZByte)) | 0wx99 => (print "setns\t"; printEA (rex, SZByte)) | 0wx9a => (print "setp\t"; printEA (rex, SZByte)) | 0wx9b => (print "setnp\t"; printEA (rex, SZByte)) | 0wx9c => (print "setl\t"; printEA (rex, SZByte)) | 0wx9d => (print "setge\t"; printEA (rex, SZByte)) | 0wx9e => (print "setle\t"; printEA (rex, SZByte)) | 0wx9f => (print "setg\t"; printEA (rex, SZByte)) | _ => (print "esc\t"; printValue(Word8.toLargeInt opByte2)) ) | 0wxf2 => (* SSE2 instruction *) let val nb = codeVecGet (seg, !ptr) val rr = (nb >>- 0w3) andb8 0w7 val reg = SSE2Reg rr in case opByte2 of 0wx10 => ( print "movsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx11 => ( print "movsd\t"; printEAxmm(rex, SZQWord); print ","; print(xmmRegRepr reg) ) | 0wx2a => ( print "cvtsi2sd\t"; print(xmmRegRepr reg); print ","; printEA(rex, sizeFromRexW) ) | 0wx2c => ( print "cvttsd2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx2d => ( print "cvtsd2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx58 => ( print "addsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx59 => ( print "mulsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5a => ( print "cvtsd2ss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5c => ( print "subsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5e => ( print "divsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | b => (print "F2\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | 0wxf3 => (* SSE2 instruction. *) let val nb = codeVecGet (seg, !ptr) val rr = (nb >>- 0w3) andb8 0w7 val reg = SSE2Reg rr in case opByte2 of 0wx10 => ( print "movss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx11 => ( print "movss\t"; printEAxmm(rex, SZDWord); print ","; print(xmmRegRepr reg) ) | 0wx2c => ( print "cvttss2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx2d => ( print "cvtss2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx5a => ( print "cvtss2sd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx58 => ( print "addss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx59 => ( print "mulss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx5c => ( print "subss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx5e => ( print "divss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | b => (print "F3\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | 0wx66 => (* SSE2 instruction *) let val nb = codeVecGet (seg, !ptr) val reg = SSE2Reg((nb >>- 0w3) andb8 0w7) in case opByte2 of 0wx2e => ( print "ucomisd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx54 => ( print "andpd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx57 => ( print "xorpd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx6e => ( print (if rexW then "movq\t" else "movd\t"); print(xmmRegRepr reg); print ","; printEA(rex, sizeFromRexW) ) | 0wx7e => ( print (if rexW then "movq\t" else "movd\t"); printEA(rex, sizeFromRexW); print ","; print(xmmRegRepr reg) ) | 0wx73 => ( print "psrldq\t"; printEAxmm(rex, SZQWord); print ","; print8 ()) | b => (print "66\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | _ => (print "esc\t"; printValue(Word8.toLargeInt opByte2)) end (* ESCAPE *) | 0wx13 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx1b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx23 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx2b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx33 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx3b => printGvEv (opByte, rex, rexR, sizeFromRexW) (* Push and Pop. These are 64-bit on X86/64 whether there is REX prefix or not. *) | 0wx50 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx51 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx52 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx53 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx54 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx55 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx56 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx57 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx58 => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx59 => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5a => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5b => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5c => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5d => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5e => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5f => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx63 => (* MOVSXD. This is ARPL in 32-bit mode but that's never used here. *) let val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "movsxd\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, SZDWord) end | 0wx68 => (print "push\t"; print32 ()) | 0wx69 => let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print(genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW); print ","; print32 () end | 0wx6a => (print "push\t"; print8 ()) | 0wx6b => let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print(genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW); print ","; print8 () end | 0wx70 => (print "jo \t"; printJmp()) | 0wx71 => (print "jno \t"; printJmp()) | 0wx72 => (print "jb \t"; printJmp()) | 0wx73 => (print "jnb \t"; printJmp()) | 0wx74 => (print "je \t"; printJmp()) | 0wx75 => (print "jne \t"; printJmp()) | 0wx76 => (print "jna \t"; printJmp()) | 0wx77 => (print "ja \t"; printJmp()) | 0wx78 => (print "js \t"; printJmp()) | 0wx79 => (print "jns \t"; printJmp()) | 0wx7a => (print "jp \t"; printJmp()) | 0wx7b => (print "jnp \t"; printJmp()) | 0wx7c => (print "jl \t"; printJmp()) | 0wx7d => (print "jge \t"; printJmp()) | 0wx7e => (print "jle \t"; printJmp()) | 0wx7f => (print "jg \t"; printJmp()) | 0wx80 => (* Group1_8_a *) let (* Memory, byte constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, SZByte); print ","; print8 () end | 0wx81 => let (* Memory, 32-bit constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, sizeFromRexW); print ","; print32 () end | 0wx83 => let (* Word memory, 8-bit constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, sizeFromRexW); print ","; print8 () end | 0wx87 => let (* xchng *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "xchng \t"; printEA(rex, sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wx88 => let (* mov eb,gb i.e a store *) (* Register is in next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)); val reg = (nb div 8) mod 8; in print "mov \t"; printEA(rex, SZByte); print ","; if rexR then print ("r" ^ Int.toString(reg+8) ^ "B") else case reg of 0 => print "al" | 1 => print "cl" | 2 => print "dl" | 3 => print "bl" (* If there is a REX byte these select the low byte of the registers. *) | 4 => print (if rex = 0w0 then "ah" else "sil") | 5 => print (if rex = 0w0 then "ch" else "dil") | 6 => print (if rex = 0w0 then "dh" else "bpl") | 7 => print (if rex = 0w0 then "bh" else "spl") | _ => print ("r" ^ Int.toString reg) end | 0wx89 => let (* mov ev,gv i.e. a store *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "mov \t"; (* This may have an opcode prefix. *) printEA(rex, if legacyPrefix = 0wx66 then SZWord else sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wx8b => let (* mov gv,ev i.e. a load *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "mov \t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end | 0wx8d => let (* lea gv.M *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "lea \t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end | 0wx8f => (print "pop \t"; printEA(rex, sz32_64)) | 0wx90 => print "nop" | 0wx99 => if rexW then print "cqo" else print "cdq" | 0wx9e => print "sahf\n" | 0wxa4 => (if legacyPrefix = 0wxf3 then print "rep " else (); print "movsb") | 0wxa5 => (if legacyPrefix = 0wxf3 then print "rep " else (); print "movsl") | 0wxa6 => (if legacyPrefix = 0wxf3 then print "repe " else (); print "cmpsb") | 0wxa8 => (print "test\tal,"; print8 ()) | 0wxaa => (if legacyPrefix = 0wxf3 then print "rep " else (); print "stosb") | 0wxab => ( if legacyPrefix = 0wxf3 then print "rep " else (); if rexW then print "stosq" else print "stosl" ) | 0wxb8 => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxb9 => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxba => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbb => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbc => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbd => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbe => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbf => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxc1 => (* Group2_8_A *) printShift (opByte, rex, sizeFromRexW) | 0wxc2 => (print "ret \t"; print16 ()) | 0wxc3 => print "ret" | 0wxc6 => (* move 8-bit constant to memory *) ( print "mov \t"; printEA(rex, SZByte); print ","; print8 () ) | 0wxc7 => (* move 32/64-bit constant to memory *) ( print "mov \t"; printEA(rex, sizeFromRexW); print ","; print32 () ) | 0wxca => (* Register mask *) let val mask = get16u (!ptr, seg) before (ptr +:= 0w2) in print "SAVE\t"; printMask mask end | 0wxcd => (* Register mask *) let val mask = get8u (!ptr, seg) before (ptr +:= 0w1) in print "SAVE\t"; printMask(Word8.toInt mask) end | 0wxd1 => (* Group2_1_A *) printShift (opByte, rex, sizeFromRexW) | 0wxd3 => (* Group2_CL_A *) printShift (opByte, rex, sizeFromRexW) | 0wxd8 => printFloat (opByte, rex) (* Floating point escapes *) | 0wxd9 => printFloat (opByte, rex) | 0wxda => printFloat (opByte, rex) | 0wxdb => printFloat (opByte, rex) | 0wxdc => printFloat (opByte, rex) | 0wxdd => printFloat (opByte, rex) | 0wxde => printFloat (opByte, rex) | 0wxdf => printFloat (opByte, rex) | 0wxe8 => let (* 32-bit relative call. *) val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print "call\t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end | 0wxe9 => let (* 32-bit relative jump. *) val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print "jmp \t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end | 0wxeb => (print "jmp \t"; printJmp()) | 0wxf4 => print "hlt" (* Marker to indicate end-of-code. *) | 0wxf6 => (* Group3_a *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 0 => "test" | 3 => "neg" | _ => "???" ); print "\t"; printEA(rex, SZByte); if opc = 0 then (print ","; print8 ()) else () end | 0wxf7 => (* Group3_A *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 0 => "test" | 3 => "neg " | 4 => "mul " | 5 => "imul" | 6 => "div " | 7 => "idiv" | _ => "???" ); print "\t"; printEA(rex, sizeFromRexW); (* Test has an immediate operand. It's 32-bits even in 64-bit mode. *) if opc = 0 then (print ","; print32 ()) else () end | 0wxff => (* Group5 *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 2 => "call" | 4 => "jmp " | 6 => "push" | _ => "???" ); print "\t"; printEA(rex, sz32_64) (* None of the cases we use need a prefix. *) end | _ => print(Word8.fmt StringCvt.HEX opByte); print "\n" end; (* end of while loop *) print "\n" end (* printCode *); (* Although this is used locally it must be defined at the top level otherwise a new RTS function will be compiler every time the containing function is called *) val sortFunction: (machineWord * word) array -> bool = RunCall.rtsCallFast1 "PolySortArrayOfAddresses" (* This actually does the final code-generation. *) fun generateCode {ops=operations, code=cvec as Code{procName, printAssemblyCode, printStream, profileObject, ...}, labelCount, resultClosure} : unit = let val (expanded, newLabelCount) = expandComplexOperations (operations, labelCount) val () = printLowLevelCode(expanded, cvec) local val initialBytesList = codeGenerate expanded in (* Fixup labels and shrink long branches to short. *) val (bytesList, codeSize) = fixupLabels(expanded, initialBytesList, newLabelCount) end local (* Extract the constants and the location of the references from the code. *) val (inlineConstants, addressConstants, nonAddressConstants) = getConstants(expanded, bytesList) (* Sort the non-address constants to remove duplicates. There don't seem to be many in practice. Since we're not actually interested in the order but only sorting to remove duplicates we can use a stripped-down Quicksort. *) fun sort([], out) = out | sort((addr, median) :: tl, out) = partition(median, tl, [addr], [], [], out) and partition(median, [], addrs, less, greater, out) = sort(less, sort(greater, (addrs, median) :: out)) | partition(median, (entry as (addr, value)) :: tl, addrs, less, greater, out) = if value = median then partition(median, tl, addr::addrs, less, greater, out) else if value < median then partition(median, tl, addrs, entry :: less, greater, out) else partition(median, tl, addrs, less, entry :: greater, out) (* Non-address constants. We can't use any ordering on them because a GC could change the values half way through the sort. Instead we use a simple search for a small number of constants and use an RTS call for larger numbers. We want to avoid quadratic cost when there are large numbers. *) val sortedConstants = if List.length addressConstants < 10 then let fun findDups([], out) = out | findDups((addr, value) :: tl, out) = let fun partition(e as (a, v), (eq, neq)) = if PolyML.pointerEq(value, v) then (a :: eq, neq) else (eq, e :: neq) val (eqAddr, neq) = List.foldl partition ([addr], []) tl in findDups(neq, (eqAddr, value) :: out) end in findDups(addressConstants, []) end else let fun swap (a, b) = (b, a) val arrayToSort: (machineWord * word) array = Array.fromList (List.map swap addressConstants) val _ = sortFunction arrayToSort fun makeList((v, a), []) = [([a], v)] | makeList((v, a), l as (aa, vv) :: tl) = if PolyML.pointerEq(v, vv) then (a :: aa, vv) :: tl else ([a], v) :: l in Array.foldl makeList [] arrayToSort end in val inlineConstants = inlineConstants and addressConstants = sortedConstants and nonAddressConstants = sort(nonAddressConstants, []) end (* Get the number of constants that need to be added to the address area. *) val constsInConstArea = List.length addressConstants local (* Add one byte for the HLT and round up to a number of words. *) val endOfCode = (codeSize+nativeWordSize) div nativeWordSize * (nativeWordSize div wordSize) val numOfNonAddrWords = Word.fromInt(List.length nonAddressConstants) (* Each entry in the non-address constant area is 8 bytes. *) val intSize = 0w8 div wordSize in val endOfByteArea = endOfCode + numOfNonAddrWords * intSize - (* +4 for function name, register mask (no longer used), profile object and count of constants. *) + (* +4 for no of consts. function name, profile object and offset to start of consts. *) val segSize = endOfByteArea + Word.fromInt constsInConstArea + 0w4 end (* Create a byte vector and copy the data in. This is a byte area and not scanned by the GC so cannot contain any addresses. *) val byteVec = byteVecMake segSize val ic = ref 0w0 local fun genByte (ival: Word8.word) = set8u (ival, !ic, byteVec) before ic := !ic + 0w1 in fun genBytes l = Word8Vector.app (fn i => genByte i) l val () = List.app (fn b => genBytes b) bytesList val () = genBytes(Word8Vector.fromList(opCodeBytes(HLT, NONE))) (* Marker - this is used by ScanConstants in the RTS. *) end (* Align ic onto a fullword boundary. *) val () = ic := ((!ic + nativeWordSize - 0w1) andb ~nativeWordSize) (* Copy the non-address constants. These are only used in 64-bit mode and are either real constants or integers that are too large to fit in a 32-bit inline constants. We don't use this for real constants in 32-bit mode because we don't have relative addressing. Instead a real constant is the inline address of a boxed real number. *) local fun putNonAddrConst(addrs, constant) = let val addrOfConst = ! ic val () = genBytes(Word8Vector.fromList(largeWordToBytes(constant, 8))) fun setAddr addr = set32s(Word.toLargeInt(addrOfConst - addr - 0w4), addr, byteVec) in List.app setAddr addrs end in val () = List.app putNonAddrConst nonAddressConstants end val _ = bytesToWords(! ic) = endOfByteArea orelse raise InternalError "mismatch" (* Put in the number of constants. This must go in before we actually put - in any constants. In 32-bit mode there are only three constants: the - function name and the register mask, now unused and the profile object. + in any constants. In 32-bit mode there are only two constants: the + function name and the profile object. All other constants are in the code. *) local - val addr = wordsToBytes(endOfByteArea + 0w3 + Word.fromInt constsInConstArea) + val lastWord = wordsToBytes(endOfByteArea + 0w3 + Word.fromInt constsInConstArea) fun setBytes(_, _, 0) = () | setBytes(ival, offset, count) = ( byteVecSet(byteVec, offset, Word8.fromLargeInt(ival mod 256)); setBytes(ival div 256, offset+0w1, count-1) ) in - val () = setBytes(LargeInt.fromInt(3 + constsInConstArea), addr, Word.toInt wordSize) + val () = setBytes(LargeInt.fromInt(2 + constsInConstArea), wordsToBytes endOfByteArea, Word.toInt wordSize) + (* Set the last word of the code to the (negative) byte offset of the start of the code area + from the end of this word. *) + val () = setBytes(Word.toLargeIntX(wordsToBytes endOfByteArea - lastWord), lastWord, Word.toInt wordSize) end; (* We've put in all the byte data so it is safe to convert this to a mutable code cell that can contain addresses and will be scanned by the GC. *) val codeSeg = byteVecToCodeVec(byteVec, resultClosure) (* Various RTS functions assume that the first constant is the function name. - The profiler assumes that the third word is the address of the mutable that - contains the profile count. The second word used to be used for the register - mask but is no longer used. *) - val () = codeVecPutWord (codeSeg, endOfByteArea, toMachineWord procName) - val () = codeVecPutWord (codeSeg, endOfByteArea + 0w1, toMachineWord 1 (* No longer used. *)) + The profiler assumes that the second word is the address of the mutable that + contains the profile count. *) + val () = codeVecPutWord (codeSeg, endOfByteArea + 0w1, toMachineWord procName) (* Next the profile object. *) val () = codeVecPutWord (codeSeg, endOfByteArea + 0w2, profileObject) in let fun setBytes(_, _, 0w0) = () | setBytes(b, addr, count) = ( codeVecSet (codeSeg, addr, wordToWord8 b); setBytes(b >> 0w8, addr+0w1, count-0w1) ) (* Inline constants - native 32-bit only plus one special case in 32-in-64 *) fun putInlConst (addrs, SelfAddress) = (* Self address goes inline. *) codeVecPutConstant (codeSeg, addrs, toMachineWord(codeVecAddr codeSeg), ConstAbsolute) | putInlConst (addrs, InlineAbsoluteAddress m) = codeVecPutConstant (codeSeg, addrs, m, ConstAbsolute) | putInlConst (addrs, InlineRelativeAddress m) = codeVecPutConstant (codeSeg, addrs, m, ConstX86Relative) val _ = List.app putInlConst inlineConstants (* Address constants - native 64-bit and 32-in-64. *) fun putAddrConst ((addrs, m), constAddr) = (* Put the constant in the constant area and set the original address to be the relative offset to the constant itself. *) ( codeVecPutWord (codeSeg, constAddr, m); (* Put in the 32-bit offset - always unsigned since the destination is after the reference. *) List.app(fn addr => setBytes(constAddr * wordSize - addr - 0w4, addr, 0w4)) addrs; constAddr+0w1 ) (* Put the constants. Any values in the constant area start at +3 i.e. after the profile. *) val _ = List.foldl putAddrConst (endOfByteArea+0w3) addressConstants val () = if printAssemblyCode then (* print out the code *) ( printCode(cvec, codeSeg); printStream "\n\n" ) else () in (* Finally lock the code. *) codeVecLock(codeSeg, resultClosure) end (* the result *) end (* generateCode *) structure Sharing = struct type code = code and reg = reg and genReg = genReg and fpReg = fpReg and addrs = addrs and operation = operation and regSet = RegSet.regSet and label = label and branchOps = branchOps and arithOp = arithOp and shiftType = shiftType and repOps = repOps and fpOps = fpOps and fpUnaryOps = fpUnaryOps and sse2Operations = sse2Operations and opSize = opSize and closureRef = closureRef end end (* struct *) (* CODECONS *);