1/* 2 Title: An interpreter for a compact instruction set. 3 Author: Dave Matthews, Cambridge University Computer Laboratory 4 5 Copyright (c) 2000-7 6 Cambridge University Technical Services Limited 7 Further development Copyright David C.J. Matthews 2015-18, 2020. 8 9 This library is free software; you can redistribute it and/or 10 modify it under the terms of the GNU Lesser General Public 11 License version 2.1 as published by the Free Software Foundation. 12 13 This library is distributed in the hope that it will be useful, 14 but WITHOUT ANY WARRANTY; without even the implied warranty of 15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 Lesser General Public License for more details. 17 18 You should have received a copy of the GNU Lesser General Public 19 License along with this library; if not, write to the Free Software 20 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 21 22*/ 23 24#ifdef HAVE_CONFIG_H 25#include "config.h" 26#elif defined(_WIN32) 27#include "winconfig.h" 28#else 29#error "No configuration file" 30#endif 31 32#ifdef HAVE_STDIO_H 33#include <stdio.h> 34#endif 35 36#ifdef HAVE_ASSERT_H 37#include <assert.h> 38#define ASSERT(x) assert(x) 39#else 40#define ASSERT(x) 0 41#endif 42 43#ifdef HAVE_STRING_H 44#include <string.h> 45#endif 46 47#ifdef HAVE_FLOAT_H 48#include <float.h> 49#endif 50 51#ifdef HAVE_MATH_H 52#include <math.h> 53#endif 54 55#include <cmath> // Currently just for isnan. 56 57#include "globals.h" 58#include "int_opcodes.h" 59#include "machine_dep.h" 60#include "sys.h" 61#include "profiling.h" 62#include "arb.h" 63#include "reals.h" 64#include "processes.h" 65#include "run_time.h" 66#include "gc.h" 67#include "diagnostics.h" 68#include "polystring.h" 69#include "save_vec.h" 70#include "memmgr.h" 71#include "scanaddrs.h" 72#include "rtsentry.h" 73 74#if (SIZEOF_VOIDP == 8 && !defined(POLYML32IN64)) 75#define IS64BITS 1 76#endif 77 78 79#define arg1 (pc[0] + pc[1]*256) 80#define arg2 (pc[2] + pc[3]*256) 81 82const PolyWord True = TAGGED(1); 83const PolyWord False = TAGGED(0); 84const PolyWord Zero = TAGGED(0); 85 86#define CHECKED_REGS 2 87#define UNCHECKED_REGS 0 88 89#define EXTRA_STACK 0 // Don't need any extra - signals aren't handled on the Poly stack. 90 91/* the amount of ML stack space to reserve for registers, 92 C exception handling etc. The compiler requires us to 93 reserve 2 stack-frames worth (2 * 20 words) plus whatever 94 we require for the register save area. We actually reserve 95 slightly more than this. SPF 3/3/97 96*/ 97#define OVERFLOW_STACK_SIZE \ 98 (50 + \ 99 CHECKED_REGS + \ 100 UNCHECKED_REGS + \ 101 EXTRA_STACK) 102 103 104// This duplicates some code in reals.cpp but is now updated. 105#define DOUBLESIZE (sizeof(double)/sizeof(POLYUNSIGNED)) 106 107union realdb { double dble; POLYUNSIGNED puns[DOUBLESIZE]; }; 108 109#define LGWORDSIZE (sizeof(uintptr_t) / sizeof(PolyWord)) 110 111// We're using float for Real32 so it needs to be 32-bits. 112// Assume that's true for the moment. 113#if (SIZEOF_FLOAT != 4) 114#error "Float is not 32-bits. Please report this" 115#endif 116 117union flt { float fl; int32_t i; }; 118 119class IntTaskData: public TaskData { 120public: 121 IntTaskData(); 122 ~IntTaskData(); 123 124 virtual void GarbageCollect(ScanAddress *process); 125 void ScanStackAddress(ScanAddress *process, stackItem& val, StackSpace *stack); 126 virtual void EnterPolyCode(); // Start running ML 127 128 // Switch to Poly and return with the io function to call. 129 int SwitchToPoly(); 130 virtual void SetException(poly_exn *exc); 131 virtual void InterruptCode(); 132 133 // AddTimeProfileCount is used in time profiling. 134 virtual bool AddTimeProfileCount(SIGNALCONTEXT *context); 135 136 virtual void InitStackFrame(TaskData *newTask, Handle proc, Handle arg); 137 138 // Increment or decrement the first word of the object pointed to by the 139 // mutex argument and return the new value. 140 virtual Handle AtomicDecrement(Handle mutexp); 141 // Set a mutex to zero. 142 virtual void AtomicReset(Handle mutexp); 143 144 // Return the minimum space occupied by the stack. Used when setting a limit. 145 virtual uintptr_t currentStackSpace(void) const { return ((stackItem*)this->stack->top - this->taskSp) + OVERFLOW_STACK_SIZE; } 146 147 virtual void addProfileCount(POLYUNSIGNED words) { addSynchronousCount(taskPc, words); } 148 149 virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length); 150 151 bool interrupt_requested; 152 153 // Allocate memory on the heap. Returns with the address of the cell. Does not set the 154 // length word or any of the data. 155 PolyObject *allocateMemory(POLYUNSIGNED words, POLYCODEPTR &pc, stackItem *&sp) 156 { 157 words++; // Add the size of the length word. 158 // N.B. The allocation area may be empty so that both of these are zero. 159 if (this->allocPointer >= this->allocLimit + words + 1) 160 { 161#ifdef POLYML32IN64 162 if (words & 1) words++; 163#endif 164 this->allocPointer -= words; 165 return (PolyObject *)(this->allocPointer+1); 166 } 167 // Insufficient space. 168 SaveInterpreterState(pc, sp); 169 // Find some space to allocate in. Returns a pointer to the newly allocated space. 170 // N.B. This may return zero if the heap is exhausted and it has set this 171 // up for an exception. Generally it allocates by decrementing allocPointer 172 // but if the required memory is large it may allocate in a separate area. 173 PolyWord *space = processes->FindAllocationSpace(this, words, true); 174 LoadInterpreterState(pc, sp); 175 if (space == 0) return 0; 176 return (PolyObject *)(space+1); 177 } 178 179 // Put a real result in a "box" 180 PolyObject *boxDouble(double d, POLYCODEPTR &pc, stackItem*&sp) 181 { 182 PolyObject *mem = this->allocateMemory(DOUBLESIZE, pc, sp); 183 if (mem == 0) return 0; 184 mem->SetLengthWord(DOUBLESIZE, F_BYTE_OBJ); 185 union realdb uniondb; 186 uniondb.dble = d; 187 // Copy the words. Depending on the word length this may copy one or more words. 188 for (unsigned i = 0; i < DOUBLESIZE; i++) 189 mem->Set(i, PolyWord::FromUnsigned(uniondb.puns[i])); 190 return mem; 191 } 192 193 // Extract a double value from a box. 194 double unboxDouble(PolyWord p) 195 { 196 union realdb uniondb; 197 for (unsigned i = 0; i < DOUBLESIZE; i++) 198 uniondb.puns[i] = p.AsObjPtr()->Get(i).AsUnsigned(); 199 return uniondb.dble; 200 } 201 202 // Largely copied from reals.cpp 203 204#if (SIZEOF_FLOAT < SIZEOF_POLYWORD) 205 206 // Typically for 64-bit mode. Use a tagged representation. 207 // The code-generator on the X86/64 assumes the float is in the 208 // high order word. 209#define FLT_SHIFT ((SIZEOF_POLYWORD-SIZEOF_FLOAT)*8) 210 float unboxFloat(PolyWord p) 211 { 212 union flt argx; 213 argx.i = p.AsSigned() >> FLT_SHIFT; 214 return argx.fl; 215 } 216 217 PolyObject *boxFloat(float f, POLYCODEPTR &pc, stackItem*&sp) 218 { 219 union flt argx; 220 argx.fl = f; 221 PolyWord p = PolyWord::FromSigned(((POLYSIGNED)argx.i << FLT_SHIFT) + 1); 222 return p.AsObjPtr(); // Temporarily cast it to this even though it isn't really 223 } 224#else 225 // Typically for 32-bit mode. Use a boxed representation. 226 PolyObject *boxFloat(float f, POLYCODEPTR &pc, stackItem*&sp) 227 { 228 PolyObject *mem = this->allocateMemory(1, pc, sp); 229 if (mem == 0) return 0; 230 mem->SetLengthWord(1, F_BYTE_OBJ); 231 union flt argx; 232 argx.fl = f; 233 mem->Set(0, PolyWord::FromSigned(argx.i)); 234 return mem; 235 } 236 237 // Extract a double value from a box. 238 float unboxFloat(PolyWord p) 239 { 240 union flt argx; 241 argx.i = (int32_t)p.AsObjPtr()->Get(0).AsSigned(); 242 return argx.fl; 243 } 244 245#endif 246 247 // Update the copies in the task object 248 void SaveInterpreterState(POLYCODEPTR pc, stackItem*sp) 249 { 250 taskPc = pc; 251 taskSp = sp; 252 } 253 254 // Update the local state 255 void LoadInterpreterState(POLYCODEPTR &pc, stackItem*&sp) 256 { 257 pc = taskPc; 258 sp = taskSp; 259 } 260 261 POLYCODEPTR taskPc; /* Program counter. */ 262 stackItem *taskSp; /* Stack pointer. */ 263 stackItem *hr; 264 stackItem exception_arg; 265 bool raiseException; 266 stackItem *sl; /* Stack limit register. */ 267 268 PolyObject *overflowPacket, *dividePacket; 269 270#ifdef PROFILEOPCODES 271 unsigned frequency[256], arg1Value[256], arg2Value[256]; 272#endif 273}; 274 275IntTaskData::IntTaskData() : interrupt_requested(false), overflowPacket(0), dividePacket(0) 276{ 277#ifdef PROFILEOPCODES 278 memset(frequency, 0, sizeof(frequency)); 279 memset(arg1Value, 0, sizeof(arg1Value)); 280 memset(arg2Value, 0, sizeof(arg2Value)); 281#endif 282} 283 284IntTaskData::~IntTaskData() 285{ 286#ifdef PROFILEOPCODES 287 OutputDebugStringA("Frequency\n"); 288 for (unsigned i = 0; i < 256; i++) 289 { 290 if (frequency[i] != 0) 291 { 292 char buffer[100]; 293 sprintf(buffer, "%02X: %u\n", i, frequency[i]); 294 OutputDebugStringA(buffer); 295 } 296 } 297 OutputDebugStringA("Arg1\n"); 298 for (unsigned i = 0; i < 256; i++) 299 { 300 if (arg1Value[i] != 0) 301 { 302 char buffer[100]; 303 sprintf(buffer, "%02X: %u\n", i, arg1Value[i]); 304 OutputDebugStringA(buffer); 305 } 306 } 307 OutputDebugStringA("Arg2\n"); 308 for (unsigned i = 0; i < 256; i++) 309 { 310 if (arg2Value[i] != 0) 311 { 312 char buffer[100]; 313 sprintf(buffer, "%02X: %u\n", i, arg2Value[i]); 314 OutputDebugStringA(buffer); 315 } 316 } 317#endif 318} 319 320// This lock is used to synchronise all atomic operations. 321// It is not needed in the X86 version because that can use a global 322// memory lock. 323static PLock mutexLock; 324 325// Special value for return address. 326#define SPECIAL_PC_END_THREAD ((POLYCODEPTR)0) 327 328class Interpreter : public MachineDependent { 329public: 330 Interpreter() {} 331 332 // Create a task data object. 333 virtual TaskData *CreateTaskData(void) { return new IntTaskData(); } 334 virtual Architectures MachineArchitecture(void) { return MA_Interpreted; } 335}; 336 337void IntTaskData::InitStackFrame(TaskData *parentTask, Handle proc, Handle arg) 338/* Initialise stack frame. */ 339{ 340 StackSpace *space = this->stack; 341 StackObject *stack = (StackObject *)space->stack(); 342 PolyObject *closure = DEREFWORDHANDLE(proc); 343 uintptr_t stack_size = space->spaceSize() * sizeof(PolyWord) / sizeof(stackItem); 344 this->taskPc = *(POLYCODEPTR*)closure; 345 346 this->exception_arg = TAGGED(0); /* Used for exception argument. */ 347 this->taskSp = (stackItem*)stack + stack_size; 348 this->raiseException = false; 349 350 /* Set up exception handler */ 351 /* No previous handler so point it at itself. */ 352 this->taskSp--; 353 this->taskSp->stackAddr = this->taskSp; 354 (--this->taskSp)->codeAddr = SPECIAL_PC_END_THREAD; /* Default return address. */ 355 this->hr = this->taskSp; 356 357 /* If this function takes an argument store it on the stack. */ 358 if (arg != 0) *(--this->taskSp) = DEREFWORD(arg); 359 360 (*(--this->taskSp)).codeAddr = SPECIAL_PC_END_THREAD; /* Return address. */ 361 *(--this->taskSp) = (PolyWord)closure; /* Closure address */ 362 363 // Make packets for exceptions. 364 overflowPacket = makeExceptionPacket(parentTask, EXC_overflow); 365 dividePacket = makeExceptionPacket(parentTask, EXC_divide); 366} 367 368extern "C" { 369 typedef POLYUNSIGNED(*callFastRts0)(); 370 typedef POLYUNSIGNED(*callFastRts1)(intptr_t); 371 typedef POLYUNSIGNED(*callFastRts2)(intptr_t, intptr_t); 372 typedef POLYUNSIGNED(*callFastRts3)(intptr_t, intptr_t, intptr_t); 373 typedef POLYUNSIGNED(*callFastRts4)(intptr_t, intptr_t, intptr_t, intptr_t); 374 typedef POLYUNSIGNED(*callFastRts5)(intptr_t, intptr_t, intptr_t, intptr_t, intptr_t); 375 typedef POLYUNSIGNED(*callFullRts0)(PolyObject *); 376 typedef POLYUNSIGNED(*callFullRts1)(PolyObject *, intptr_t); 377 typedef POLYUNSIGNED(*callFullRts2)(PolyObject *, intptr_t, intptr_t); 378 typedef POLYUNSIGNED(*callFullRts3)(PolyObject *, intptr_t, intptr_t, intptr_t); 379 typedef double (*callRTSRtoR) (double); 380 typedef double (*callRTSRRtoR) (double, double); 381 typedef double (*callRTSGtoR) (intptr_t); 382 typedef double (*callRTSRGtoR) (double, intptr_t); 383 typedef float(*callRTSFtoF) (float); 384 typedef float(*callRTSFFtoF) (float, float); 385 typedef float(*callRTSGtoF) (intptr_t); 386 typedef float(*callRTSFGtoF) (float, intptr_t); 387} 388 389void IntTaskData::InterruptCode() 390/* Stop the Poly code at a suitable place. */ 391/* We may get an asynchronous interrupt at any time. */ 392{ 393 IntTaskData *itd = (IntTaskData *)this; 394 itd->interrupt_requested = true; 395} 396 397 398void IntTaskData::SetException(poly_exn *exc) 399/* Set up the stack of a process to raise an exception. */ 400{ 401 this->raiseException = true; 402 *(--this->taskSp) = (PolyWord)exc; /* push exception data */ 403} 404 405int IntTaskData::SwitchToPoly() 406/* (Re)-enter the Poly code from C. */ 407{ 408 // Local values. These are copies of member variables but are used so frequently that 409 // it is important that access should be fast. 410 POLYCODEPTR pc; 411 stackItem*sp; 412 413 LoadInterpreterState(pc, sp); 414 415 sl = (stackItem*)((PolyWord*)this->stack->stack() + OVERFLOW_STACK_SIZE); 416 417 // We may have taken an interrupt which has set an exception. 418 if (this->raiseException) goto RAISE_EXCEPTION; 419 420 for(;;){ /* Each instruction */ 421#if (0) 422 char buff[1000]; 423 sprintf(buff, "addr = %p sp=%p instr=%02x *sp=%p\n", pc, sp, *pc, (*sp).stackAddr); 424 OutputDebugStringA(buff); 425#endif 426 // These are temporary values used where one instruction jumps to 427 // common code. 428 POLYUNSIGNED tailCount; 429 stackItem* tailPtr; 430 POLYUNSIGNED returnCount; 431 POLYUNSIGNED storeWords; 432 POLYUNSIGNED stackCheck; 433 PolyObject *closure; 434 double dv; 435 436#ifdef PROFILEOPCODES 437 frequency[*pc]++; 438#endif 439 switch(*pc++) { 440 441 case INSTR_jump8false: 442 { 443 PolyWord u = *sp++; 444 if (u == True) pc += 1; 445 else pc += *pc + 1; 446 break; 447 } 448 449 case INSTR_jump8: pc += *pc + 1; break; 450 451 case INSTR_jump8True: 452 { 453 PolyWord u = *sp++; 454 if (u == False) pc += 1; 455 else pc += *pc + 1; 456 break; 457 } 458 459 case INSTR_jump16True: 460 // Invert the sense of the test and fall through. 461 *sp = ((*sp).w() == True) ? False : True; 462 463 case INSTR_jump16false: 464 { 465 PolyWord u = *sp++; /* Pop argument */ 466 if (u == True) { pc += 2; break; } 467 /* else - false - take the jump */ 468 } 469 470 case INSTR_jump16: 471 pc += arg1 + 2; break; 472 473 case INSTR_push_handler: /* Save the old handler value. */ 474 (*(--sp)).stackAddr = this->hr; /* Push old handler */ 475 break; 476 477 case INSTR_setHandler8: /* Set up a handler */ 478 (*(--sp)).codeAddr = pc + *pc + 1; /* Address of handler */ 479 this->hr = sp; 480 pc += 1; 481 break; 482 483 case INSTR_setHandler16: /* Set up a handler */ 484 (*(--sp)).codeAddr = pc + arg1 + 2; /* Address of handler */ 485 this->hr = sp; 486 pc += 2; 487 break; 488 489 case INSTR_deleteHandler: /* Delete handler retaining the result. */ 490 { 491 stackItem u = *sp++; 492 sp = this->hr; 493 sp++; // Remove handler entry point 494 this->hr = (*sp).stackAddr; // Restore old handler 495 *sp = u; // Put back the result 496 break; 497 } 498 499 case INSTR_case16: 500 { 501 // arg1 is the largest value that is in the range 502 POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ 503 if (u >= arg1 || u < 0) pc += 2 + arg1*2; /* Out of range */ 504 else { 505 pc += 2; 506 pc += /* Index */pc[u*2]+pc[u*2 + 1]*256; } 507 break; 508 } 509 510 511 case INSTR_tail_3_bLegacy: 512 tailCount = 3; 513 tailPtr = sp + tailCount; 514 sp = tailPtr + *pc; 515 goto TAIL_CALL; 516 517 case INSTR_tail_3_2Legacy: 518 tailCount = 3; 519 tailPtr = sp + tailCount; 520 sp = tailPtr + 2; 521 goto TAIL_CALL; 522 523 case INSTR_tail_3_3Legacy: 524 tailCount = 3; 525 tailPtr = sp + tailCount; 526 sp = tailPtr + 3; 527 goto TAIL_CALL; 528 529 case INSTR_tail_4_bLegacy: 530 tailCount = 4; 531 tailPtr = sp + tailCount; 532 sp = tailPtr + *pc; 533 goto TAIL_CALL; 534 535 case INSTR_tail_b_b: 536 tailCount = *pc; 537 tailPtr = sp + tailCount; 538 sp = tailPtr + pc[1]; 539 TAIL_CALL: /* For general case. */ 540 if (tailCount < 2) Crash("Invalid argument\n"); 541 for (; tailCount > 0; tailCount--) *(--sp) = *(--tailPtr); 542 pc = (*sp++).codeAddr; /* Pop the original return address. */ 543 closure = (*sp++).w().AsObjPtr(); 544 goto CALL_CLOSURE; /* And drop through. */ 545 546 case INSTR_call_closure: /* Closure call. */ 547 { 548 closure = (*sp++).w().AsObjPtr(); 549 CALL_CLOSURE: 550 (--sp)->codeAddr = pc; /* Save return address. */ 551 *(--sp) = (PolyWord)closure; 552 pc = *(POLYCODEPTR*)closure; /* Get entry point. */ 553 this->taskPc = pc; // Update in case we're profiling 554 // Check that there at least 128 words on the stack 555 stackCheck = 128; 556 goto STACKCHECK; 557 } 558 559 case INSTR_callConstAddr8: 560 closure = (*(PolyWord*)(pc + pc[0] + 1)).AsObjPtr(); pc += 1; goto CALL_CLOSURE; 561 562 case INSTR_callConstAddr16: 563 closure = (*(PolyWord*)(pc + arg1 + 2)).AsObjPtr(); pc += 2; goto CALL_CLOSURE; 564 565 case INSTR_callLocalB: 566 { 567 closure = (sp[*pc++]).w().AsObjPtr(); 568 goto CALL_CLOSURE; 569 } 570 571 case INSTR_return_w: 572 returnCount = arg1; /* Get no. of args to remove. */ 573 574 RETURN: /* Common code for return. */ 575 { 576 stackItem result = *sp++; /* Result */ 577 sp++; /* Remove the link/closure */ 578 pc = (*sp++).codeAddr; /* Return address */ 579 sp += returnCount; /* Add on number of args. */ 580 if (pc == SPECIAL_PC_END_THREAD) 581 exitThread(this); // This thread is exiting. 582 *(--sp) = result; /* Result */ 583 this->taskPc = pc; // Update in case we're profiling 584 } 585 break; 586 587 case INSTR_return_b: returnCount = *pc; goto RETURN; 588 case INSTR_return_0Legacy: returnCount = 0; goto RETURN; 589 case INSTR_return_1: returnCount = 1; goto RETURN; 590 case INSTR_return_2: returnCount = 2; goto RETURN; 591 case INSTR_return_3: returnCount = 3; goto RETURN; 592 593 case INSTR_stackSize8Legacy: 594 stackCheck = *pc++; 595 goto STACKCHECK; 596 597 case INSTR_stackSize16: 598 { 599 stackCheck = arg1; pc += 2; 600 STACKCHECK: 601 // Check there is space on the stack 602 if (sp - stackCheck < sl) 603 { 604 uintptr_t min_size = (this->stack->top - (PolyWord*)sp) + OVERFLOW_STACK_SIZE + stackCheck; 605 SaveInterpreterState(pc, sp); 606 CheckAndGrowStack(this, min_size); 607 LoadInterpreterState(pc, sp); 608 sl = (stackItem*)this->stack->stack() + OVERFLOW_STACK_SIZE; 609 } 610 // Also check for interrupts 611 if (this->interrupt_requested) 612 { 613 // Check for interrupts 614 this->interrupt_requested = false; 615 SaveInterpreterState(pc, sp); 616 return -1; 617 } 618 break; 619 } 620 621 case INSTR_raise_ex: 622 { 623 RAISE_EXCEPTION: 624 this->raiseException = false; 625 PolyException *exn = (PolyException*)((*sp).w().AsObjPtr()); 626 this->exception_arg = (PolyWord)exn; /* Get exception data */ 627 sp = this->hr; 628 pc = (*sp++).codeAddr; 629 if (pc == SPECIAL_PC_END_THREAD) 630 exitThread(this); // Default handler for thread. 631 this->hr = (*sp++).stackAddr; 632 break; 633 } 634 635 case INSTR_tuple_2: storeWords = 2; goto TUPLE; 636 case INSTR_tuple_3: storeWords = 3; goto TUPLE; 637 case INSTR_tuple_4: storeWords = 4; goto TUPLE; 638 case INSTR_tuple_b: storeWords = *pc; pc++; goto TUPLE; 639 640 case INSTR_closureB: 641 storeWords = *pc++; 642 goto CREATE_CLOSURE; 643 break; 644 645 case INSTR_local_w: 646 { 647 stackItem u = sp[arg1]; 648 *(--sp) = u; 649 pc += 2; 650 break; 651 } 652 653 case INSTR_constAddr8: 654 *(--sp) = *(PolyWord*)(pc + pc[0] + 1); pc += 1; break; 655 656 case INSTR_constAddr16: 657 *(--sp) = *(PolyWord*)(pc + arg1 + 2); pc += 2; break; 658 659 case INSTR_const_int_w: *(--sp) = TAGGED(arg1); pc += 2; break; 660 661 case INSTR_jump_back8: 662 pc -= *pc + 1; 663 if (this->interrupt_requested) 664 { 665 // Check for interrupt in case we're in a loop 666 this->interrupt_requested = false; 667 SaveInterpreterState(pc, sp); 668 return -1; 669 } 670 break; 671 672 case INSTR_jump_back16: 673 pc -= arg1 + 1; 674 if (this->interrupt_requested) 675 { 676 // Check for interrupt in case we're in a loop 677 this->interrupt_requested = false; 678 SaveInterpreterState(pc, sp); 679 return -1; 680 } 681 break; 682 683 case INSTR_lock: 684 { 685 PolyObject *obj = (*sp).w().AsObjPtr(); 686 obj->SetLengthWord(obj->LengthWord() & ~_OBJ_MUTABLE_BIT); 687 break; 688 } 689 690 case INSTR_ldexc: *(--sp) = this->exception_arg; break; 691 692 case INSTR_local_b: { stackItem u = sp[*pc]; *(--sp) = u; pc += 1; break; } 693 694 case INSTR_indirect_b: 695 *sp = (*sp).w().AsObjPtr()->Get(*pc); pc += 1; break; 696 697 case INSTR_indirectLocalBB: 698 { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(*pc++); break; } 699 700 case INSTR_indirectLocalB0: 701 { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(0); break; } 702 703 case INSTR_indirect0Local0: 704 { PolyWord u = sp[0]; *(--sp) = u.AsObjPtr()->Get(0); break; } 705 706 case INSTR_indirectLocalB1: 707 { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(1); break; } 708 709 case INSTR_moveToContainerB: 710 { PolyWord u = *sp++; (*sp).stackAddr[*pc] = u; pc += 1; break; } 711 712 case INSTR_moveToMutClosureB: 713 { 714 PolyWord u = *sp++; 715 (*sp).w().AsObjPtr()->Set(*pc++ + sizeof(uintptr_t) / sizeof(PolyWord), u); 716 break; 717 } 718 719 case INSTR_indirectContainerB: 720 *sp = (*sp).stackAddr[*pc]; pc += 1; break; 721 722 case INSTR_indirectClosureBB: 723 { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(*pc++ + sizeof(uintptr_t) / sizeof(PolyWord)); break; } 724 725 case INSTR_indirectClosureB0: 726 { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord)); break; } 727 728 case INSTR_indirectClosureB1: 729 { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord) + 1); break; } 730 731 case INSTR_indirectClosureB2: 732 { PolyWord u = sp[*pc++]; *(--sp) = u.AsObjPtr()->Get(sizeof(uintptr_t) / sizeof(PolyWord) + 2); break; } 733 734 case INSTR_set_stack_val_b: 735 { PolyWord u = *sp++; sp[*pc-1] = u; pc += 1; break; } 736 737 case INSTR_reset_b: sp += *pc; pc += 1; break; 738 739 case INSTR_reset_r_b: 740 { PolyWord u = *sp; sp += *pc; *sp = u; pc += 1; break; } 741 742 case INSTR_const_int_b: *(--sp) = TAGGED(*pc); pc += 1; break; 743 744 case INSTR_local_0: { stackItem u = sp[0]; *(--sp) = u; break; } 745 case INSTR_local_1: { stackItem u = sp[1]; *(--sp) = u; break; } 746 case INSTR_local_2: { stackItem u = sp[2]; *(--sp) = u; break; } 747 case INSTR_local_3: { stackItem u = sp[3]; *(--sp) = u; break; } 748 case INSTR_local_4: { stackItem u = sp[4]; *(--sp) = u; break; } 749 case INSTR_local_5: { stackItem u = sp[5]; *(--sp) = u; break; } 750 case INSTR_local_6: { stackItem u = sp[6]; *(--sp) = u; break; } 751 case INSTR_local_7: { stackItem u = sp[7]; *(--sp) = u; break; } 752 case INSTR_local_8: { stackItem u = sp[8]; *(--sp) = u; break; } 753 case INSTR_local_9: { stackItem u = sp[9]; *(--sp) = u; break; } 754 case INSTR_local_10: { stackItem u = sp[10]; *(--sp) = u; break; } 755 case INSTR_local_11: { stackItem u = sp[11]; *(--sp) = u; break; } 756 case INSTR_local_12: { stackItem u = sp[12]; *(--sp) = u; break; } 757 case INSTR_local_13: { stackItem u = sp[13]; *(--sp) = u; break; } 758 case INSTR_local_14: { stackItem u = sp[14]; *(--sp) = u; break; } 759 case INSTR_local_15: { stackItem u = sp[15]; *(--sp) = u; break; } 760 761 case INSTR_indirect_0: 762 *sp = (*sp).w().AsObjPtr()->Get(0); break; 763 764 case INSTR_indirect_1: 765 *sp = (*sp).w().AsObjPtr()->Get(1); break; 766 767 case INSTR_indirect_2: 768 *sp = (*sp).w().AsObjPtr()->Get(2); break; 769 770 case INSTR_indirect_3: 771 *sp = (*sp).w().AsObjPtr()->Get(3); break; 772 773 case INSTR_indirect_4: 774 *sp = (*sp).w().AsObjPtr()->Get(4); break; 775 776 case INSTR_indirect_5: 777 *sp = (*sp).w().AsObjPtr()->Get(5); break; 778 779 case INSTR_const_0: *(--sp) = Zero; break; 780 case INSTR_const_1: *(--sp) = TAGGED(1); break; 781 case INSTR_const_2: *(--sp) = TAGGED(2); break; 782 case INSTR_const_3: *(--sp) = TAGGED(3); break; 783 case INSTR_const_4: *(--sp) = TAGGED(4); break; 784 case INSTR_const_10: *(--sp) = TAGGED(10); break; 785 786 case INSTR_reset_r_1: { PolyWord u = *sp; sp += 1; *sp = u; break; } 787 case INSTR_reset_r_2: { PolyWord u = *sp; sp += 2; *sp = u; break; } 788 case INSTR_reset_r_3: { PolyWord u = *sp; sp += 3; *sp = u; break; } 789 790 case INSTR_reset_1: sp += 1; break; 791 case INSTR_reset_2: sp += 2; break; 792 793 case INSTR_stack_containerB: 794 { 795 POLYUNSIGNED words = *pc++; 796 while (words-- > 0) *(--sp) = Zero; 797 sp--; 798 (*sp).stackAddr = sp + 1; 799 break; 800 } 801 802 case INSTR_tuple_containerLegacy: /* Create a tuple from a container. */ 803 { 804 storeWords = arg1; 805 PolyObject *t = this->allocateMemory(storeWords, pc, sp); 806 if (t == 0) goto RAISE_EXCEPTION; 807 t->SetLengthWord(storeWords, 0); 808 for(; storeWords > 0; ) 809 { 810 storeWords--; 811 t->Set(storeWords, (*sp).stackAddr[storeWords]); 812 } 813 *sp = (PolyWord)t; 814 pc += 2; 815 break; 816 } 817 818 case INSTR_callFastRTS0: 819 { 820 callFastRts0 doCall = *(callFastRts0*)(*sp++).w().AsObjPtr(); 821 this->raiseException = false; 822 SaveInterpreterState(pc, sp); 823 POLYUNSIGNED result = doCall(); 824 LoadInterpreterState(pc, sp); 825 // If this raised an exception 826 if (this->raiseException) goto RAISE_EXCEPTION; 827 *(--sp) = PolyWord::FromUnsigned(result); 828 break; 829 } 830 831 case INSTR_callFastRTS1: 832 { 833 callFastRts1 doCall = *(callFastRts1*)(*sp++).w().AsObjPtr(); 834 intptr_t rtsArg1 = (*sp++).argValue; 835 this->raiseException = false; 836 SaveInterpreterState(pc, sp); 837 POLYUNSIGNED result = doCall(rtsArg1); 838 LoadInterpreterState(pc, sp); 839 // If this raised an exception 840 if (this->raiseException) goto RAISE_EXCEPTION; 841 *(--sp) = PolyWord::FromUnsigned(result); 842 break; 843 } 844 845 case INSTR_callFastRTS2: 846 { 847 callFastRts2 doCall = *(callFastRts2*)(*sp++).w().AsObjPtr(); 848 intptr_t rtsArg2 = (*sp++).argValue; // Pop off the args, last arg first. 849 intptr_t rtsArg1 = (*sp++).argValue; 850 this->raiseException = false; 851 SaveInterpreterState(pc, sp); 852 POLYUNSIGNED result = doCall(rtsArg1, rtsArg2); 853 LoadInterpreterState(pc, sp); 854 // If this raised an exception 855 if (this->raiseException) goto RAISE_EXCEPTION; 856 *(--sp) = PolyWord::FromUnsigned(result); 857 break; 858 } 859 860 case INSTR_callFastRTS3: 861 { 862 callFastRts3 doCall = *(callFastRts3*)(*sp++).w().AsObjPtr(); 863 intptr_t rtsArg3 = (*sp++).argValue; // Pop off the args, last arg first. 864 intptr_t rtsArg2 = (*sp++).argValue; 865 intptr_t rtsArg1 = (*sp++).argValue; 866 this->raiseException = false; 867 SaveInterpreterState(pc, sp); 868 POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3); 869 LoadInterpreterState(pc, sp); 870 // If this raised an exception 871 if (this->raiseException) goto RAISE_EXCEPTION; 872 *(--sp) = PolyWord::FromUnsigned(result); 873 break; 874 } 875 876 case INSTR_callFastRTS4: 877 { 878 callFastRts4 doCall = *(callFastRts4*)(*sp++).w().AsObjPtr(); 879 intptr_t rtsArg4 = (*sp++).argValue; // Pop off the args, last arg first. 880 intptr_t rtsArg3 = (*sp++).argValue; 881 intptr_t rtsArg2 = (*sp++).argValue; 882 intptr_t rtsArg1 = (*sp++).argValue; 883 this->raiseException = false; 884 SaveInterpreterState(pc, sp); 885 POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4); 886 LoadInterpreterState(pc, sp); 887 // If this raised an exception 888 if (this->raiseException) goto RAISE_EXCEPTION; 889 *(--sp) = PolyWord::FromUnsigned(result); 890 break; 891 } 892 893 case INSTR_callFastRTS5: 894 { 895 callFastRts5 doCall = *(callFastRts5*)(*sp++).w().AsObjPtr(); 896 intptr_t rtsArg5 = (*sp++).argValue; // Pop off the args, last arg first. 897 intptr_t rtsArg4 = (*sp++).argValue; 898 intptr_t rtsArg3 = (*sp++).argValue; 899 intptr_t rtsArg2 = (*sp++).argValue; 900 intptr_t rtsArg1 = (*sp++).argValue; 901 this->raiseException = false; 902 SaveInterpreterState(pc, sp); 903 POLYUNSIGNED result = doCall(rtsArg1, rtsArg2, rtsArg3, rtsArg4, rtsArg5); 904 LoadInterpreterState(pc, sp); 905 // If this raised an exception 906 if (this->raiseException) goto RAISE_EXCEPTION; 907 *(--sp) = PolyWord::FromUnsigned(result); 908 break; 909 } 910 911 case INSTR_callFullRTS0: 912 { 913 callFullRts0 doCall = *(callFullRts0*)(*sp++).w().AsObjPtr(); 914 this->raiseException = false; 915 SaveInterpreterState(pc, sp); 916 POLYUNSIGNED result = doCall(this->threadObject); 917 LoadInterpreterState(pc, sp); 918 // If this raised an exception 919 if (this->raiseException) goto RAISE_EXCEPTION; 920 *(--sp)= PolyWord::FromUnsigned(result); 921 break; 922 } 923 924 case INSTR_callFullRTS1: 925 { 926 callFullRts1 doCall = *(callFullRts1*)(*sp++).w().AsObjPtr(); 927 intptr_t rtsArg1 = (*sp++).argValue; 928 this->raiseException = false; 929 SaveInterpreterState(pc, sp); 930 POLYUNSIGNED result = doCall(this->threadObject, rtsArg1); 931 LoadInterpreterState(pc, sp); 932 // If this raised an exception 933 if (this->raiseException) goto RAISE_EXCEPTION; 934 *(--sp) = PolyWord::FromUnsigned(result); 935 break; 936 } 937 938 case INSTR_callFullRTS2: 939 { 940 callFullRts2 doCall = *(callFullRts2*)(*sp++).w().AsObjPtr(); 941 intptr_t rtsArg2 = (*sp++).argValue; // Pop off the args, last arg first. 942 intptr_t rtsArg1 = (*sp++).argValue; 943 this->raiseException = false; 944 SaveInterpreterState(pc, sp); 945 POLYUNSIGNED result = doCall(this->threadObject, rtsArg1, rtsArg2); 946 LoadInterpreterState(pc, sp); 947 // If this raised an exception 948 if (this->raiseException) goto RAISE_EXCEPTION; 949 *(--sp) = PolyWord::FromUnsigned(result); 950 break; 951 } 952 953 case INSTR_callFullRTS3: 954 { 955 callFullRts3 doCall = *(callFullRts3*)(*sp++).w().AsObjPtr(); 956 intptr_t rtsArg3 = (*sp++).argValue; // Pop off the args, last arg first. 957 intptr_t rtsArg2 = (*sp++).argValue; 958 intptr_t rtsArg1 = (*sp++).argValue; 959 this->raiseException = false; 960 SaveInterpreterState(pc, sp); 961 POLYUNSIGNED result = doCall(this->threadObject, rtsArg1, rtsArg2, rtsArg3); 962 LoadInterpreterState(pc, sp); 963 // If this raised an exception 964 if (this->raiseException) goto RAISE_EXCEPTION; 965 *(--sp) = PolyWord::FromUnsigned(result); 966 break; 967 } 968 969 case INSTR_notBoolean: 970 *sp = ((*sp).w() == True) ? False : True; break; 971 972 case INSTR_isTagged: 973 *sp = (*sp).w().IsTagged() ? True : False; break; 974 975 case INSTR_cellLength: 976 /* Return the length word. */ 977 *sp = TAGGED((*sp).w().AsObjPtr()->Length()); 978 break; 979 980 case INSTR_cellFlags: 981 { 982 PolyObject *p = (*sp).w().AsObjPtr(); 983 POLYUNSIGNED f = (p->LengthWord()) >> OBJ_PRIVATE_FLAGS_SHIFT; 984 *sp = TAGGED(f); 985 break; 986 } 987 988 case INSTR_clearMutable: 989 { 990 PolyObject *obj = (*sp).w().AsObjPtr(); 991 POLYUNSIGNED lengthW = obj->LengthWord(); 992 /* Clear the mutable bit. */ 993 obj->SetLengthWord(lengthW & ~_OBJ_MUTABLE_BIT); 994 *sp = Zero; 995 break; 996 } 997 998// case INSTR_stringLength: // Now replaced by loadUntagged 999// *sp = TAGGED(((PolyStringObject*)(*sp).AsObjPtr())->length); 1000// break; 1001 1002 case INSTR_atomicIncr: 1003 { 1004 PLocker l(&mutexLock); 1005 PolyObject *p = (*sp).w().AsObjPtr(); 1006 PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))+1); 1007 p->Set(0, newValue); 1008 *sp = newValue; 1009 break; 1010 } 1011 1012 case INSTR_atomicDecr: 1013 { 1014 PLocker l(&mutexLock); 1015 PolyObject *p = (*sp).w().AsObjPtr(); 1016 PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))-1); 1017 p->Set(0, newValue); 1018 *sp = newValue; 1019 break; 1020 } 1021 1022 case INSTR_equalWord: 1023 { 1024 PolyWord u = *sp++; 1025 *sp = u == (*sp) ? True : False; 1026 break; 1027 } 1028 1029 case INSTR_jumpNEqLocal: 1030 { 1031 // Compare a local with a constant and jump if not equal. 1032 PolyWord u = sp[pc[0]]; 1033 if (u.IsTagged() && u.UnTagged() == pc[1]) 1034 pc += 3; 1035 else pc += pc[2] + 3; 1036 break; 1037 } 1038 1039 case INSTR_jumpNEqLocalInd: 1040 { 1041 // Test the union tag value in the first word of a tuple. 1042 PolyWord u = sp[pc[0]]; 1043 u = u.AsObjPtr()->Get(0); 1044 if (u.IsTagged() && u.UnTagged() == pc[1]) 1045 pc += 3; 1046 else pc += pc[2] + 3; 1047 break; 1048 } 1049 1050 case INSTR_isTaggedLocalB: 1051 { 1052 PolyWord u = sp[*pc++]; 1053 *(--sp) = u.IsTagged() ? True : False; 1054 break; 1055 } 1056 1057 case INSTR_jumpTaggedLocal: 1058 { 1059 PolyWord u = sp[*pc]; 1060 // Jump if the value is tagged. 1061 if (u.IsTagged()) 1062 pc += pc[1] + 2; 1063 else pc += 2; 1064 break; 1065 } 1066 1067 case INSTR_lessSigned: 1068 { 1069 PolyWord u = *sp++; 1070 *sp = ((*sp).w().AsSigned() < u.AsSigned()) ? True : False; 1071 break; 1072 } 1073 1074 case INSTR_lessUnsigned: 1075 { 1076 PolyWord u = *sp++; 1077 *sp = ((*sp).w().AsUnsigned() < u.AsUnsigned()) ? True : False; 1078 break; 1079 } 1080 1081 case INSTR_lessEqSigned: 1082 { 1083 PolyWord u = *sp++; 1084 *sp = ((*sp).w().AsSigned() <= u.AsSigned()) ? True : False; 1085 break; 1086 } 1087 1088 case INSTR_lessEqUnsigned: 1089 { 1090 PolyWord u = *sp++; 1091 *sp = ((*sp).w().AsUnsigned() <= u.AsUnsigned()) ? True : False; 1092 break; 1093 } 1094 1095 case INSTR_greaterSigned: 1096 { 1097 PolyWord u = *sp++; 1098 *sp = ((*sp).w().AsSigned() > u.AsSigned()) ? True : False; 1099 break; 1100 } 1101 1102 case INSTR_greaterUnsigned: 1103 { 1104 PolyWord u = *sp++; 1105 *sp = ((*sp).w().AsUnsigned() > u.AsUnsigned()) ? True : False; 1106 break; 1107 } 1108 1109 case INSTR_greaterEqSigned: 1110 { 1111 PolyWord u = *sp++; 1112 *sp = ((*sp).w().AsSigned() >= u.AsSigned()) ? True : False; 1113 break; 1114 } 1115 1116 case INSTR_greaterEqUnsigned: 1117 { 1118 PolyWord u = *sp++; 1119 *sp = ((*sp).w().AsUnsigned() >= u.AsUnsigned()) ? True : False; 1120 break; 1121 } 1122 1123 case INSTR_fixedAdd: 1124 { 1125 PolyWord x = *sp++; 1126 PolyWord y = (*sp); 1127 POLYSIGNED t = UNTAGGED(x) + UNTAGGED(y); 1128 if (t <= MAXTAGGED && t >= -MAXTAGGED-1) 1129 *sp = TAGGED(t); 1130 else 1131 { 1132 *(--sp) = (PolyWord)overflowPacket; 1133 goto RAISE_EXCEPTION; 1134 } 1135 break; 1136 } 1137 1138 case INSTR_fixedSub: 1139 { 1140 PolyWord x = *sp++; 1141 PolyWord y = (*sp); 1142 POLYSIGNED t = UNTAGGED(y) - UNTAGGED(x); 1143 if (t <= MAXTAGGED && t >= -MAXTAGGED-1) 1144 *sp = TAGGED(t); 1145 else 1146 { 1147 *(--sp) = (PolyWord)overflowPacket; 1148 goto RAISE_EXCEPTION; 1149 } 1150 break; 1151 } 1152 1153 case INSTR_fixedMult: 1154 { 1155 POLYSIGNED x = UNTAGGED(*sp++); 1156 POLYSIGNED y = (*sp).w().AsSigned() - 1; // Just remove the tag 1157 POLYSIGNED t = x * y; 1158 if (x != 0 && t / x != y) 1159 { 1160 *(--sp) = (PolyWord)overflowPacket; 1161 goto RAISE_EXCEPTION; 1162 } 1163 *sp = PolyWord::FromSigned(t+1); // Add back the tag 1164 break; 1165 } 1166 1167 case INSTR_fixedQuot: 1168 { 1169 // Zero and overflow are checked for in ML. 1170 POLYSIGNED u = UNTAGGED(*sp++); 1171 PolyWord y = (*sp); 1172 *sp = TAGGED(UNTAGGED(y) / u); 1173 break; 1174 } 1175 1176 case INSTR_fixedRem: 1177 { 1178 // Zero and overflow are checked for in ML. 1179 POLYSIGNED u = UNTAGGED(*sp++); 1180 PolyWord y = (*sp); 1181 *sp = TAGGED(UNTAGGED(y) % u); 1182 break; 1183 } 1184 1185 case INSTR_wordAdd: 1186 { 1187 PolyWord u = *sp++; 1188 // Because we're not concerned with overflow we can just add the values and subtract the tag. 1189 *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() + u.AsUnsigned() - TAGGED(0).AsUnsigned()); 1190 break; 1191 } 1192 1193 case INSTR_wordSub: 1194 { 1195 PolyWord u = *sp++; 1196 *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() - u.AsUnsigned() + TAGGED(0).AsUnsigned()); 1197 break; 1198 } 1199 1200 case INSTR_wordMult: 1201 { 1202 PolyWord u = *sp++; 1203 *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) * UNTAGGED_UNSIGNED(u)); 1204 break; 1205 } 1206 1207 case INSTR_wordDiv: 1208 { 1209 POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); 1210 // Detection of zero is done in ML 1211 *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) / u); break; 1212 } 1213 1214 case INSTR_wordMod: 1215 { 1216 POLYUNSIGNED u = UNTAGGED_UNSIGNED(*sp++); 1217 *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) % u); 1218 break; 1219 } 1220 1221 case INSTR_wordAnd: 1222 { 1223 PolyWord u = *sp++; 1224 // Since both of these should be tagged the tag bit will be preserved. 1225 *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() & u.AsUnsigned()); 1226 break; 1227 } 1228 1229 case INSTR_wordOr: 1230 { 1231 PolyWord u = *sp++; 1232 // Since both of these should be tagged the tag bit will be preserved. 1233 *sp = PolyWord::FromUnsigned((*sp).w().AsUnsigned() | u.AsUnsigned()); 1234 break; 1235 } 1236 1237 case INSTR_wordXor: 1238 { 1239 PolyWord u = *sp++; 1240 // This will remove the tag bit so it has to be reinstated. 1241 *sp = PolyWord::FromUnsigned(((*sp).w().AsUnsigned() ^ u.AsUnsigned()) | TAGGED(0).AsUnsigned()); 1242 break; 1243 } 1244 1245 case INSTR_wordShiftLeft: 1246 { 1247 // ML requires shifts greater than a word to return zero. 1248 // That's dealt with at the higher level. 1249 PolyWord u = *sp++; 1250 *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) << UNTAGGED_UNSIGNED(u)); 1251 break; 1252 } 1253 1254 case INSTR_wordShiftRLog: 1255 { 1256 PolyWord u = *sp++; 1257 *sp = TAGGED(UNTAGGED_UNSIGNED(*sp) >> UNTAGGED_UNSIGNED(u)); 1258 break; 1259 } 1260 1261 case INSTR_allocByteMem: 1262 { 1263 // Allocate byte segment. This does not need to be initialised. 1264 POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); 1265 POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); 1266 PolyObject *t = this->allocateMemory(length, pc, sp); 1267 if (t == 0) goto RAISE_EXCEPTION; // Exception 1268 t->SetLengthWord(length, (byte)flags); 1269 *sp = (PolyWord)t; 1270 break; 1271 } 1272 1273 case INSTR_getThreadId: 1274 *(--sp) = (PolyWord)this->threadObject; 1275 break; 1276 1277 case INSTR_allocWordMemory: 1278 { 1279 // Allocate word segment. This must be initialised. 1280 // We mustn't pop the initialiser until after any potential GC. 1281 POLYUNSIGNED length = UNTAGGED_UNSIGNED(sp[2]); 1282 PolyObject *t = this->allocateMemory(length, pc, sp); 1283 if (t == 0) goto RAISE_EXCEPTION; 1284 PolyWord initialiser = *sp++; 1285 POLYUNSIGNED flags = UNTAGGED_UNSIGNED(*sp++); 1286 t->SetLengthWord(length, (byte)flags); 1287 *sp = (PolyWord)t; 1288 // Have to initialise the data. 1289 for (; length > 0; ) t->Set(--length, initialiser); 1290 break; 1291 } 1292 1293 case INSTR_alloc_ref: 1294 { 1295 // Allocate a single word mutable cell. This is more common than allocWordMemory on its own. 1296 PolyObject *t = this->allocateMemory(1, pc, sp); 1297 if (t == 0) goto RAISE_EXCEPTION; 1298 PolyWord initialiser = (*sp); 1299 t->SetLengthWord(1, F_MUTABLE_BIT); 1300 t->Set(0, initialiser); 1301 *sp = (PolyWord)t; 1302 break; 1303 } 1304 1305 case INSTR_allocMutClosureB: 1306 { 1307 // Allocate memory for a mutable closure and copy in the code address. 1308 POLYUNSIGNED length = *pc++ + sizeof(uintptr_t) / sizeof(PolyWord); 1309 PolyObject* t = this->allocateMemory(length, pc, sp); 1310 if (t == 0) goto RAISE_EXCEPTION; 1311 t->SetLengthWord(length, F_CLOSURE_OBJ | F_MUTABLE_BIT); 1312 PolyObject* srcClosure = (*sp).w().AsObjPtr(); 1313 *(uintptr_t*)t = *(uintptr_t*)srcClosure; 1314 for (POLYUNSIGNED i = sizeof(uintptr_t) / sizeof(PolyWord); i < length; i++) 1315 t->Set(i, TAGGED(0)); 1316 *sp = (PolyWord)t; 1317 break; 1318 } 1319 1320 case INSTR_loadMLWordLegacy: 1321 { 1322 // The values on the stack are base, index and offset. 1323 POLYUNSIGNED offset = UNTAGGED(*sp++); 1324 POLYUNSIGNED index = UNTAGGED(*sp++); 1325 PolyObject *p = (PolyObject*)((*sp).w().AsCodePtr() + offset); 1326 *sp = p->Get(index); 1327 break; 1328 } 1329 1330 case INSTR_loadMLWord: 1331 { 1332 POLYUNSIGNED index = UNTAGGED(*sp++); 1333 PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); 1334 *sp = p->Get(index); 1335 break; 1336 } 1337 1338 case INSTR_loadMLByte: 1339 { 1340 // The values on the stack are base and index. 1341 POLYUNSIGNED index = UNTAGGED(*sp++); 1342 POLYCODEPTR p = (*sp).w().AsCodePtr(); 1343 *sp = TAGGED(p[index]); // Have to tag the result 1344 break; 1345 } 1346 1347 case INSTR_loadUntaggedLegacy: 1348 { 1349 // The values on the stack are base, index and offset. 1350 POLYUNSIGNED offset = UNTAGGED(*sp++); 1351 POLYUNSIGNED index = UNTAGGED(*sp++); 1352 PolyObject *p = (PolyObject*)((*sp).w().AsCodePtr() + offset); 1353 *sp = TAGGED(p->Get(index).AsUnsigned()); 1354 break; 1355 } 1356 1357 case INSTR_loadUntagged: 1358 { 1359 POLYUNSIGNED index = UNTAGGED(*sp++); 1360 PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); 1361 *sp = TAGGED(p->Get(index).AsUnsigned()); 1362 break; 1363 } 1364 1365 case INSTR_storeMLWordLegacy: 1366 { 1367 PolyWord toStore = *sp++; 1368 POLYUNSIGNED offset = UNTAGGED(*sp++); 1369 POLYUNSIGNED index = UNTAGGED(*sp++); 1370 PolyObject *p = (PolyObject*)((*sp).w().AsCodePtr() + offset); 1371 p->Set(index, toStore); 1372 *sp = Zero; 1373 break; 1374 } 1375 1376 case INSTR_storeMLWord: 1377 { 1378 PolyWord toStore = *sp++; 1379 POLYUNSIGNED index = UNTAGGED(*sp++); 1380 PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); 1381 p->Set(index, toStore); 1382 *sp = Zero; 1383 break; 1384 } 1385 1386 case INSTR_storeMLByte: 1387 { 1388 POLYUNSIGNED toStore = UNTAGGED(*sp++); 1389 POLYUNSIGNED index = UNTAGGED(*sp++); 1390 POLYCODEPTR p = (*sp).w().AsCodePtr(); 1391 p[index] = (byte)toStore; 1392 *sp = Zero; 1393 break; 1394 } 1395 1396 case INSTR_storeUntaggedLegacy: 1397 { 1398 PolyWord toStore = PolyWord::FromUnsigned(UNTAGGED_UNSIGNED(*sp++)); 1399 POLYUNSIGNED offset = UNTAGGED(*sp++); 1400 POLYUNSIGNED index = UNTAGGED(*sp++); 1401 PolyObject *p = (PolyObject*)((*sp).w().AsCodePtr() + offset); 1402 p->Set(index, toStore); 1403 *sp = Zero; 1404 break; 1405 } 1406 1407 case INSTR_storeUntagged: 1408 { 1409 PolyWord toStore = PolyWord::FromUnsigned(UNTAGGED_UNSIGNED(*sp++)); 1410 POLYUNSIGNED index = UNTAGGED(*sp++); 1411 PolyObject* p = (PolyObject*)((*sp).w().AsCodePtr()); 1412 p->Set(index, toStore); 1413 *sp = Zero; 1414 break; 1415 } 1416 1417 case INSTR_blockMoveWordLegacy: 1418 { 1419 // The offsets are byte counts but the the indexes are in words. 1420 POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); 1421 POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); 1422 POLYUNSIGNED destIndex = UNTAGGED_UNSIGNED(*sp++); 1423 PolyObject *dest = (PolyObject*)((*sp++).w().AsCodePtr() + destOffset); 1424 POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); 1425 POLYUNSIGNED srcIndex = UNTAGGED_UNSIGNED(*sp++); 1426 PolyObject *src = (PolyObject*)((*sp).w().AsCodePtr() + srcOffset); 1427 for (POLYUNSIGNED u = 0; u < length; u++) dest->Set(destIndex+u, src->Get(srcIndex+u)); 1428 *sp = Zero; 1429 break; 1430 } 1431 1432 case INSTR_blockMoveWord: 1433 { 1434 POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); 1435 POLYUNSIGNED destIndex = UNTAGGED_UNSIGNED(*sp++); 1436 PolyObject* dest = (PolyObject*)((*sp++).w().AsCodePtr()); 1437 POLYUNSIGNED srcIndex = UNTAGGED_UNSIGNED(*sp++); 1438 PolyObject* src = (PolyObject*)((*sp).w().AsCodePtr()); 1439 for (POLYUNSIGNED u = 0; u < length; u++) dest->Set(destIndex + u, src->Get(srcIndex + u)); 1440 *sp = Zero; 1441 break; 1442 } 1443 1444 case INSTR_blockMoveByte: 1445 { 1446 POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); 1447 POLYUNSIGNED destOffset = UNTAGGED_UNSIGNED(*sp++); 1448 POLYCODEPTR dest = (*sp++).w().AsCodePtr(); 1449 POLYUNSIGNED srcOffset = UNTAGGED_UNSIGNED(*sp++); 1450 POLYCODEPTR src = (*sp).w().AsCodePtr(); 1451 memcpy(dest+destOffset, src+srcOffset, length); 1452 *sp = Zero; 1453 break; 1454 } 1455 1456 case INSTR_blockEqualByte: 1457 { 1458 POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); 1459 POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); 1460 POLYCODEPTR arg2Ptr = (*sp++).w().AsCodePtr(); 1461 POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); 1462 POLYCODEPTR arg1Ptr = (*sp).w().AsCodePtr(); 1463 *sp = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length) == 0 ? True : False; 1464 break; 1465 } 1466 1467 case INSTR_blockCompareByte: 1468 { 1469 POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp++); 1470 POLYUNSIGNED arg2Offset = UNTAGGED_UNSIGNED(*sp++); 1471 POLYCODEPTR arg2Ptr = (*sp++).w().AsCodePtr(); 1472 POLYUNSIGNED arg1Offset = UNTAGGED_UNSIGNED(*sp++); 1473 POLYCODEPTR arg1Ptr = (*sp).w().AsCodePtr(); 1474 int result = memcmp(arg1Ptr+arg1Offset, arg2Ptr+arg2Offset, length); 1475 *sp = result == 0 ? TAGGED(0) : result < 0 ? TAGGED(-1) : TAGGED(1); 1476 break; 1477 } 1478 1479 // Backwards compatibility. 1480 // These are either used in the current compiler or compiled by it 1481 // while building the basis library. 1482 case EXTINSTR_stack_containerW: 1483 case EXTINSTR_reset_r_w: 1484 case EXTINSTR_tuple_w: 1485 case EXTINSTR_unsignedToLongW: 1486 case EXTINSTR_signedToLongW: 1487 case EXTINSTR_longWToTagged: 1488 case EXTINSTR_lgWordShiftLeft: 1489 case EXTINSTR_fixedIntToReal: 1490 case EXTINSTR_callFastRtoR: 1491 case EXTINSTR_realMult: 1492 case EXTINSTR_realDiv: 1493 case EXTINSTR_realNeg: 1494 case EXTINSTR_realAbs: 1495 case EXTINSTR_realToFloat: 1496 case EXTINSTR_floatDiv: 1497 case EXTINSTR_floatNeg: 1498 case EXTINSTR_floatAbs: 1499 case EXTINSTR_callFastFtoF: 1500 case EXTINSTR_floatMult: 1501 case EXTINSTR_callFastGtoR: 1502 case EXTINSTR_realUnordered: 1503 case EXTINSTR_realEqual: 1504 case EXTINSTR_lgWordEqual: 1505 case EXTINSTR_lgWordOr: 1506 case EXTINSTR_wordShiftRArith: 1507 case EXTINSTR_lgWordLess: 1508 // Back up and handle them as though they were escaped. 1509 pc--; 1510 1511 case INSTR_escape: 1512 { 1513 switch (*pc++) { 1514 1515 case EXTINSTR_callFastRRtoR: 1516 { 1517 // Floating point call. 1518 callRTSRRtoR doCall = *(callRTSRRtoR*)(*sp++).w().AsObjPtr(); 1519 PolyWord rtsArg2 = *sp++; 1520 PolyWord rtsArg1 = *sp++; 1521 double argument1 = unboxDouble(rtsArg1); 1522 double argument2 = unboxDouble(rtsArg2); 1523 // Allocate memory for the result. 1524 double result = doCall(argument1, argument2); 1525 PolyObject* t = boxDouble(result, pc, sp); 1526 if (t == 0) goto RAISE_EXCEPTION; 1527 *(--sp) = (PolyWord)t; 1528 break; 1529 } 1530 1531 case EXTINSTR_callFastRGtoR: 1532 { 1533 // Call that takes a POLYUNSIGNED argument and returns a double. 1534 callRTSRGtoR doCall = *(callRTSRGtoR*)(*sp++).w().AsObjPtr(); 1535 intptr_t rtsArg2 = (*sp++).w().AsSigned(); 1536 PolyWord rtsArg1 = *sp++; 1537 double argument1 = unboxDouble(rtsArg1); 1538 // Allocate memory for the result. 1539 double result = doCall(argument1, rtsArg2); 1540 PolyObject* t = boxDouble(result, pc, sp); 1541 if (t == 0) goto RAISE_EXCEPTION; 1542 *(--sp) = (PolyWord)t; 1543 break; 1544 } 1545 1546 case EXTINSTR_callFastGtoR: 1547 { 1548 // Call that takes a POLYUNSIGNED argument and returns a double. 1549 callRTSGtoR doCall = *(callRTSGtoR*)(*sp++).w().AsObjPtr(); 1550 intptr_t rtsArg1 = (*sp++).w().AsSigned(); 1551 // Allocate memory for the result. 1552 double result = doCall(rtsArg1); 1553 PolyObject* t = boxDouble(result, pc, sp); 1554 if (t == 0) goto RAISE_EXCEPTION; 1555 *(--sp) = (PolyWord)t; 1556 break; 1557 } 1558 1559 case EXTINSTR_callFastFtoF: 1560 { 1561 // Floating point call. The call itself does not allocate but we 1562 // need to put the result into a "box". 1563 callRTSFtoF doCall = *(callRTSFtoF*)(*sp++).w().AsObjPtr(); 1564 PolyWord rtsArg1 = *sp++; 1565 float argument = unboxFloat(rtsArg1); 1566 // Allocate memory for the result. 1567 float result = doCall(argument); 1568 PolyObject* t = boxFloat(result, pc, sp); 1569 if (t == 0) goto RAISE_EXCEPTION; 1570 *(--sp) = (PolyWord)t; 1571 break; 1572 } 1573 1574 case EXTINSTR_callFastFFtoF: 1575 { 1576 // Floating point call. 1577 callRTSFFtoF doCall = *(callRTSFFtoF*)(*sp++).w().AsObjPtr(); 1578 PolyWord rtsArg2 = *sp++; 1579 PolyWord rtsArg1 = *sp++; 1580 float argument1 = unboxFloat(rtsArg1); 1581 float argument2 = unboxFloat(rtsArg2); 1582 // Allocate memory for the result. 1583 float result = doCall(argument1, argument2); 1584 PolyObject* t = boxFloat(result, pc, sp); 1585 if (t == 0) goto RAISE_EXCEPTION; 1586 *(--sp) = (PolyWord)t; 1587 break; 1588 } 1589 1590 case EXTINSTR_callFastGtoF: 1591 { 1592 // Call that takes a POLYUNSIGNED argument and returns a double. 1593 callRTSGtoF doCall = *(callRTSGtoF*)(*sp++).w().AsObjPtr(); 1594 intptr_t rtsArg1 = (*sp++).w().AsSigned(); 1595 // Allocate memory for the result. 1596 float result = doCall(rtsArg1); 1597 PolyObject* t = boxFloat(result, pc, sp); 1598 if (t == 0) goto RAISE_EXCEPTION; 1599 *(--sp) = (PolyWord)t; 1600 break; 1601 } 1602 1603 case EXTINSTR_callFastFGtoF: 1604 { 1605 // Call that takes a POLYUNSIGNED argument and returns a double. 1606 callRTSFGtoF doCall = *(callRTSFGtoF*)(*sp++).w().AsObjPtr(); 1607 intptr_t rtsArg2 = (*sp++).w().AsSigned(); 1608 PolyWord rtsArg1 = *sp++; 1609 float argument1 = unboxFloat(rtsArg1); 1610 // Allocate memory for the result. 1611 float result = doCall(argument1, rtsArg2); 1612 PolyObject* t = boxFloat(result, pc, sp); 1613 if (t == 0) goto RAISE_EXCEPTION; 1614 *(--sp) = (PolyWord)t; 1615 break; 1616 } 1617 1618 case EXTINSTR_callFastRtoR: 1619 { 1620 // Floating point call. The call itself does not allocate but we 1621 // need to put the result into a "box". 1622 callRTSRtoR doCall = *(callRTSRtoR*)(*sp++).w().AsObjPtr(); 1623 PolyWord rtsArg1 = *sp++; 1624 double argument = unboxDouble(rtsArg1); 1625 // Allocate memory for the result. 1626 double result = doCall(argument); 1627 PolyObject* t = boxDouble(result, pc, sp); 1628 if (t == 0) goto RAISE_EXCEPTION; 1629 *(--sp) = (PolyWord)t; 1630 break; 1631 } 1632 1633 case EXTINSTR_atomicReset: 1634 { 1635 // This is needed in the interpreted version otherwise there 1636 // is a chance that we could set the value to zero while another 1637 // thread is between getting the old value and setting it to the new value. 1638 PLocker l(&mutexLock); 1639 PolyObject* p = (*sp).w().AsObjPtr(); 1640 p->Set(0, TAGGED(0)); // Set this to released. 1641 *sp = TAGGED(0); // Push the unit result 1642 break; 1643 } 1644 1645 case EXTINSTR_longWToTagged: 1646 { 1647 // Extract the first word and return it as a tagged value. This loses the top-bit 1648 POLYUNSIGNED wx = (*sp).w().AsObjPtr()->Get(0).AsUnsigned(); 1649 *sp = TAGGED(wx); 1650 break; 1651 } 1652 1653 case EXTINSTR_signedToLongW: 1654 { 1655 // Shift the tagged value to remove the tag and put it into the first word. 1656 // The original sign bit is copied in the shift. 1657 intptr_t wx = (*sp).w().UnTagged(); 1658 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1659 if (t == 0) goto RAISE_EXCEPTION; 1660 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1661 *(intptr_t*)t = wx; 1662 *sp = (PolyWord)t; 1663 break; 1664 } 1665 1666 case EXTINSTR_unsignedToLongW: 1667 { 1668 // As with the above except the value is treated as an unsigned 1669 // value and the top bit is zero. 1670 uintptr_t wx = (*sp).w().UnTaggedUnsigned(); 1671 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1672 if (t == 0) goto RAISE_EXCEPTION; 1673 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1674 *(uintptr_t*)t = wx; 1675 *sp = (PolyWord)t; 1676 break; 1677 } 1678 1679 case EXTINSTR_realAbs: 1680 { 1681 PolyObject* t = this->boxDouble(fabs(unboxDouble(*sp)), pc, sp); 1682 if (t == 0) goto RAISE_EXCEPTION; 1683 *sp = (PolyWord)t; 1684 break; 1685 } 1686 1687 case EXTINSTR_realNeg: 1688 { 1689 PolyObject* t = this->boxDouble(-(unboxDouble(*sp)), pc, sp); 1690 if (t == 0) goto RAISE_EXCEPTION; 1691 *sp = (PolyWord)t; 1692 break; 1693 } 1694 1695 case EXTINSTR_floatAbs: 1696 { 1697 PolyObject* t = this->boxFloat(fabs(unboxFloat(*sp)), pc, sp); 1698 if (t == 0) goto RAISE_EXCEPTION; 1699 *sp = (PolyWord)t; 1700 break; 1701 } 1702 1703 case EXTINSTR_floatNeg: 1704 { 1705 PolyObject* t = this->boxFloat(-(unboxFloat(*sp)), pc, sp); 1706 if (t == 0) goto RAISE_EXCEPTION; 1707 *sp = (PolyWord)t; 1708 break; 1709 } 1710 1711 case EXTINSTR_fixedIntToReal: 1712 { 1713 POLYSIGNED u = UNTAGGED(*sp); 1714 PolyObject* t = this->boxDouble((double)u, pc, sp); 1715 if (t == 0) goto RAISE_EXCEPTION; 1716 *sp = (PolyWord)t; 1717 break; 1718 } 1719 1720 case EXTINSTR_fixedIntToFloat: 1721 { 1722 POLYSIGNED u = UNTAGGED(*sp); 1723 PolyObject* t = this->boxFloat((float)u, pc, sp); 1724 if (t == 0) goto RAISE_EXCEPTION; 1725 *sp = (PolyWord)t; 1726 break; 1727 } 1728 1729 case EXTINSTR_floatToReal: 1730 { 1731 float u = unboxFloat(*sp); 1732 PolyObject* t = this->boxDouble((double)u, pc, sp); 1733 if (t == 0) goto RAISE_EXCEPTION; 1734 *sp = (PolyWord)t; 1735 break; 1736 } 1737 1738 case EXTINSTR_wordShiftRArith: 1739 { 1740 PolyWord u = *sp++; 1741 // Strictly speaking, C does not require that this uses 1742 // arithmetic shifting so we really ought to set the 1743 // high-order bits explicitly. 1744 *sp = TAGGED(UNTAGGED(*sp) >> UNTAGGED(u)); 1745 break; 1746 } 1747 1748 1749 case EXTINSTR_lgWordEqual: 1750 { 1751 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1752 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1753 *sp = wx == wy ? True : False; 1754 break; 1755 } 1756 1757 case EXTINSTR_lgWordLess: 1758 { 1759 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1760 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1761 *sp = (wy < wx) ? True : False; 1762 break; 1763 } 1764 1765 case EXTINSTR_lgWordLessEq: 1766 { 1767 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1768 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1769 *sp = (wy <= wx) ? True : False; 1770 break; 1771 } 1772 1773 case EXTINSTR_lgWordGreater: 1774 { 1775 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1776 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1777 *sp = (wy > wx) ? True : False; 1778 break; 1779 } 1780 1781 case EXTINSTR_lgWordGreaterEq: 1782 { 1783 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1784 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1785 *sp = (wy >= wx) ? True : False; 1786 break; 1787 } 1788 1789 case EXTINSTR_lgWordAdd: 1790 { 1791 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1792 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1793 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1794 if (t == 0) goto RAISE_EXCEPTION; 1795 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1796 *(uintptr_t*)t = wy + wx; 1797 *sp = (PolyWord)t; 1798 break; 1799 } 1800 1801 case EXTINSTR_lgWordSub: 1802 { 1803 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1804 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1805 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1806 if (t == 0) goto RAISE_EXCEPTION; 1807 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1808 *(uintptr_t*)t = wy - wx; 1809 *sp = (PolyWord)t; 1810 break; 1811 } 1812 1813 case EXTINSTR_lgWordMult: 1814 { 1815 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1816 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1817 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1818 if (t == 0) goto RAISE_EXCEPTION; 1819 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1820 *(uintptr_t*)t = wy * wx; 1821 *sp = (PolyWord)t; 1822 break; 1823 } 1824 1825 case EXTINSTR_lgWordDiv: 1826 { 1827 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1828 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1829 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1830 if (t == 0) goto RAISE_EXCEPTION; 1831 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1832 *(uintptr_t*)t = wy / wx; 1833 *sp = (PolyWord)t; 1834 break; 1835 } 1836 1837 case EXTINSTR_lgWordMod: 1838 { 1839 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1840 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1841 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1842 if (t == 0) goto RAISE_EXCEPTION; 1843 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1844 *(uintptr_t*)t = wy % wx; 1845 *sp = (PolyWord)t; 1846 break; 1847 } 1848 1849 case EXTINSTR_lgWordAnd: 1850 { 1851 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1852 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1853 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1854 if (t == 0) goto RAISE_EXCEPTION; 1855 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1856 *(uintptr_t*)t = wy & wx; 1857 *sp = (PolyWord)t; 1858 break; 1859 } 1860 1861 case EXTINSTR_lgWordOr: 1862 { 1863 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1864 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1865 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1866 if (t == 0) goto RAISE_EXCEPTION; 1867 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1868 *(uintptr_t*)t = wy | wx; 1869 *sp = (PolyWord)t; 1870 break; 1871 } 1872 1873 case EXTINSTR_lgWordXor: 1874 { 1875 uintptr_t wx = *(uintptr_t*)((*sp++).w().AsObjPtr()); 1876 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1877 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1878 if (t == 0) goto RAISE_EXCEPTION; 1879 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1880 *(uintptr_t*)t = wy ^ wx; 1881 *sp = (PolyWord)t; 1882 break; 1883 } 1884 1885 case EXTINSTR_lgWordShiftLeft: 1886 { 1887 // The shift amount is a tagged word not a boxed large word 1888 POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); 1889 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1890 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1891 if (t == 0) goto RAISE_EXCEPTION; 1892 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1893 *(uintptr_t*)t = wy << wx; 1894 *sp = (PolyWord)t; 1895 break; 1896 } 1897 1898 case EXTINSTR_lgWordShiftRLog: 1899 { 1900 // The shift amount is a tagged word not a boxed large word 1901 POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); 1902 uintptr_t wy = *(uintptr_t*)((*sp).w().AsObjPtr()); 1903 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1904 if (t == 0) goto RAISE_EXCEPTION; 1905 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1906 *(uintptr_t*)t = wy >> wx; 1907 *sp = (PolyWord)t; 1908 break; 1909 } 1910 1911 case EXTINSTR_lgWordShiftRArith: 1912 { 1913 // The shift amount is a tagged word not a boxed large word 1914 POLYUNSIGNED wx = UNTAGGED_UNSIGNED(*sp++); 1915 intptr_t wy = *(intptr_t*)((*sp).w().AsObjPtr()); 1916 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 1917 if (t == 0) goto RAISE_EXCEPTION; 1918 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 1919 *(intptr_t*)t = wy >> wx; 1920 *sp = (PolyWord)t; 1921 break; 1922 } 1923 1924 case EXTINSTR_realEqual: 1925 { 1926 double u = unboxDouble(*sp++); 1927 *sp = u == unboxDouble(*sp) ? True : False; 1928 break; 1929 } 1930 1931 case EXTINSTR_realLess: 1932 { 1933 double u = unboxDouble(*sp++); 1934 *sp = unboxDouble(*sp) < u ? True : False; 1935 break; 1936 } 1937 1938 case EXTINSTR_realLessEq: 1939 { 1940 double u = unboxDouble(*sp++); 1941 *sp = unboxDouble(*sp) <= u ? True : False; 1942 break; 1943 } 1944 1945 case EXTINSTR_realGreater: 1946 { 1947 double u = unboxDouble(*sp++); 1948 *sp = unboxDouble(*sp) > u ? True : False; 1949 break; 1950 } 1951 1952 case EXTINSTR_realGreaterEq: 1953 { 1954 double u = unboxDouble(*sp++); 1955 *sp = unboxDouble(*sp) >= u ? True : False; 1956 break; 1957 } 1958 1959 case EXTINSTR_realUnordered: 1960 { 1961 double u = unboxDouble(*sp++); 1962 double v = unboxDouble(*sp); 1963 *sp = (std::isnan(u) || std::isnan(v)) ? True : False; 1964 break; 1965 } 1966 1967 case EXTINSTR_realAdd: 1968 { 1969 double u = unboxDouble(*sp++); 1970 double v = unboxDouble(*sp); 1971 PolyObject* t = this->boxDouble(v + u, pc, sp); 1972 if (t == 0) goto RAISE_EXCEPTION; 1973 *sp = (PolyWord)t; 1974 break; 1975 } 1976 1977 case EXTINSTR_realSub: 1978 { 1979 double u = unboxDouble(*sp++); 1980 double v = unboxDouble(*sp); 1981 PolyObject* t = this->boxDouble(v - u, pc, sp); 1982 if (t == 0) goto RAISE_EXCEPTION; 1983 *sp = (PolyWord)t; 1984 break; 1985 } 1986 1987 case EXTINSTR_realMult: 1988 { 1989 double u = unboxDouble(*sp++); 1990 double v = unboxDouble(*sp); 1991 PolyObject* t = this->boxDouble(v * u, pc, sp); 1992 if (t == 0) goto RAISE_EXCEPTION; 1993 *sp = (PolyWord)t; 1994 break; 1995 } 1996 1997 case EXTINSTR_realDiv: 1998 { 1999 double u = unboxDouble(*sp++); 2000 double v = unboxDouble(*sp); 2001 PolyObject* t = this->boxDouble(v / u, pc, sp); 2002 if (t == 0) goto RAISE_EXCEPTION; 2003 *sp = (PolyWord)t; 2004 break; 2005 } 2006 2007 case EXTINSTR_floatEqual: 2008 { 2009 float u = unboxFloat(*sp++); 2010 *sp = u == unboxFloat(*sp) ? True : False; 2011 break; 2012 } 2013 2014 case EXTINSTR_floatLess: 2015 { 2016 float u = unboxFloat(*sp++); 2017 *sp = unboxFloat(*sp) < u ? True : False; 2018 break; 2019 } 2020 2021 case EXTINSTR_floatLessEq: 2022 { 2023 float u = unboxFloat(*sp++); 2024 *sp = unboxFloat(*sp) <= u ? True : False; 2025 break; 2026 } 2027 2028 case EXTINSTR_floatGreater: 2029 { 2030 float u = unboxFloat(*sp++); 2031 *sp = unboxFloat(*sp) > u ? True : False; 2032 break; 2033 } 2034 2035 case EXTINSTR_floatGreaterEq: 2036 { 2037 float u = unboxFloat(*sp++); 2038 *sp = unboxFloat(*sp) >= u ? True : False; 2039 break; 2040 } 2041 2042 case EXTINSTR_floatUnordered: 2043 { 2044 float u = unboxFloat(*sp++); 2045 float v = unboxFloat(*sp); 2046 *sp = (std::isnan(u) || std::isnan(v)) ? True : False; 2047 break; 2048 } 2049 2050 case EXTINSTR_floatAdd: 2051 { 2052 float u = unboxFloat(*sp++); 2053 float v = unboxFloat(*sp); 2054 PolyObject* t = this->boxFloat(v + u, pc, sp); 2055 if (t == 0) goto RAISE_EXCEPTION; 2056 *sp = (PolyWord)t; 2057 break; 2058 } 2059 2060 case EXTINSTR_floatSub: 2061 { 2062 float u = unboxFloat(*sp++); 2063 float v = unboxFloat(*sp); 2064 PolyObject* t = this->boxFloat(v - u, pc, sp); 2065 if (t == 0) goto RAISE_EXCEPTION; 2066 *sp = (PolyWord)t; 2067 break; 2068 } 2069 2070 case EXTINSTR_floatMult: 2071 { 2072 float u = unboxFloat(*sp++); 2073 float v = unboxFloat(*sp); 2074 PolyObject* t = this->boxFloat(v * u, pc, sp); 2075 if (t == 0) goto RAISE_EXCEPTION; 2076 *sp = (PolyWord)t; 2077 break; 2078 } 2079 2080 case EXTINSTR_floatDiv: 2081 { 2082 float u = unboxFloat(*sp++); 2083 float v = unboxFloat(*sp); 2084 PolyObject* t = this->boxFloat(v / u, pc, sp); 2085 if (t == 0) goto RAISE_EXCEPTION; 2086 *sp = (PolyWord)t; 2087 break; 2088 } 2089 2090 case EXTINSTR_realToFloat: 2091 { 2092 // Convert a double to a float. It's complicated because it depends on the rounding mode. 2093 int rMode = *pc++; 2094 int current = getrounding(); 2095 // If the rounding is 4 it means "use current rounding". 2096 // Don't call unboxDouble until we're set the rounding. GCC seems to convert it 2097 // before the actual float cast. 2098 if (rMode < 4) setrounding(rMode); 2099 double d = unboxDouble(*sp); 2100 float v = (float)d; // Convert with the appropriate rounding. 2101 setrounding(current); 2102 PolyObject* t = this->boxFloat(v, pc, sp); 2103 if (t == 0) goto RAISE_EXCEPTION; 2104 *sp = (PolyWord)t; 2105 break; 2106 } 2107 2108 case EXTINSTR_realToInt: 2109 dv = unboxDouble(*sp); 2110 goto realtoint; 2111 2112 case EXTINSTR_floatToInt: 2113 dv = (double)unboxFloat(*sp); 2114 realtoint: 2115 { 2116 // Convert a double or a float to a tagged integer. 2117 int rMode = *pc++; 2118 // We mustn't try converting a value that will overflow the conversion 2119 // but we need to be careful that we don't raise overflow incorrectly due 2120 // to rounding. 2121 if (dv > (double)(MAXTAGGED + MAXTAGGED / 2) || 2122 dv < -(double)(MAXTAGGED + MAXTAGGED / 2)) 2123 { 2124 *(--sp) = (PolyWord)overflowPacket; 2125 goto RAISE_EXCEPTION; 2126 } 2127 POLYSIGNED p; 2128 switch (rMode) 2129 { 2130 case POLY_ROUND_TONEAREST: 2131 p = (POLYSIGNED)round(dv); 2132 break; 2133 case POLY_ROUND_DOWNWARD: 2134 p = (POLYSIGNED)floor(dv); 2135 break; 2136 case POLY_ROUND_UPWARD: 2137 p = (POLYSIGNED)ceil(dv); 2138 break; 2139 case POLY_ROUND_TOZERO: 2140 default: 2141 // Truncation is the default for C. 2142 p = (POLYSIGNED)dv; 2143 } 2144 2145 // Check that the value can be tagged. 2146 if (p > MAXTAGGED || p < -MAXTAGGED - 1) 2147 { 2148 *(--sp) = (PolyWord)overflowPacket; 2149 goto RAISE_EXCEPTION; 2150 } 2151 *sp = TAGGED(p); 2152 break; 2153 } 2154 2155 case EXTINSTR_loadC8: 2156 { 2157 // This is similar to loadMLByte except that the base address is a boxed large-word. 2158 // Also the index is SIGNED. 2159 POLYSIGNED offset = UNTAGGED(*sp++); 2160 POLYSIGNED index = UNTAGGED(*sp++); 2161 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2162 *sp = TAGGED(p[index]); // Have to tag the result 2163 break; 2164 } 2165 2166 case EXTINSTR_loadC16: 2167 { 2168 // This and the other loads are similar to loadMLWord with separate 2169 // index and offset values. 2170 POLYSIGNED offset = UNTAGGED(*sp++); 2171 POLYSIGNED index = UNTAGGED(*sp++); 2172 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2173 POLYUNSIGNED r = ((uint16_t*)p)[index]; 2174 *sp = TAGGED(r); 2175 break; 2176 } 2177 2178 case EXTINSTR_loadC32: 2179 { 2180 POLYSIGNED offset = UNTAGGED(*sp++); 2181 POLYSIGNED index = UNTAGGED(*sp++); 2182 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2183 uintptr_t r = ((uint32_t*)p)[index]; 2184#ifdef IS64BITS 2185 // This is tagged in 64-bit mode 2186 * sp = TAGGED(r); 2187#else 2188 // But boxed in 32-bit mode. 2189 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 2190 if (t == 0) goto RAISE_EXCEPTION; 2191 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 2192 *(uintptr_t*)t = r; 2193 *sp = (PolyWord)t; 2194#endif 2195 break; 2196 } 2197 2198#if (defined(IS64BITS) || defined(POLYML32IN64)) 2199 case EXTINSTR_loadC64: 2200 { 2201 POLYSIGNED offset = UNTAGGED(*sp++); 2202 POLYSIGNED index = UNTAGGED(*sp++); 2203 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2204 uintptr_t r = ((uint64_t*)p)[index]; 2205 // This must be boxed. 2206 PolyObject* t = this->allocateMemory(LGWORDSIZE, pc, sp); 2207 if (t == 0) goto RAISE_EXCEPTION; 2208 t->SetLengthWord(LGWORDSIZE, F_BYTE_OBJ); 2209 *(uintptr_t*)t = r; 2210 *sp = (PolyWord)t; 2211 break; 2212 } 2213#endif 2214 2215 case EXTINSTR_loadCFloat: 2216 { 2217 POLYSIGNED offset = UNTAGGED(*sp++); 2218 POLYSIGNED index = UNTAGGED(*sp++); 2219 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2220 double r = ((float*)p)[index]; 2221 // This must be boxed. 2222 PolyObject* t = this->boxDouble(r, pc, sp); 2223 if (t == 0) goto RAISE_EXCEPTION; 2224 *sp = (PolyWord)t; 2225 break; 2226 } 2227 2228 case EXTINSTR_loadCDouble: 2229 { 2230 POLYSIGNED offset = UNTAGGED(*sp++); 2231 POLYSIGNED index = UNTAGGED(*sp++); 2232 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2233 double r = ((double*)p)[index]; 2234 // This must be boxed. 2235 PolyObject* t = this->boxDouble(r, pc, sp); 2236 if (t == 0) goto RAISE_EXCEPTION; 2237 *sp = (PolyWord)t; 2238 break; 2239 } 2240 2241 case EXTINSTR_storeC8: 2242 { 2243 // Similar to storeMLByte except that the base address is a boxed large-word. 2244 POLYUNSIGNED toStore = UNTAGGED(*sp++); 2245 POLYSIGNED offset = UNTAGGED(*sp++); 2246 POLYSIGNED index = UNTAGGED(*sp++); 2247 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2248 p[index] = (byte)toStore; 2249 *sp = Zero; 2250 break; 2251 } 2252 2253 case EXTINSTR_storeC16: 2254 { 2255 uint16_t toStore = (uint16_t)UNTAGGED(*sp++); 2256 POLYSIGNED offset = UNTAGGED(*sp++); 2257 POLYSIGNED index = UNTAGGED(*sp++); 2258 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2259 ((uint16_t*)p)[index] = toStore; 2260 *sp = Zero; 2261 break; 2262 } 2263 2264 case EXTINSTR_storeC32: 2265 { 2266#ifdef IS64BITS 2267 // This is a tagged value in 64-bit mode. 2268 uint32_t toStore = (uint32_t)UNTAGGED(*sp++); 2269#else 2270 // but a boxed value in 32-bit mode. 2271 uint32_t toStore = (uint32_t)(*(uintptr_t*)((*sp++).w().AsObjPtr())); 2272#endif 2273 POLYSIGNED offset = UNTAGGED(*sp++); 2274 POLYSIGNED index = UNTAGGED(*sp++); 2275 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2276 ((uint32_t*)p)[index] = toStore; 2277 *sp = Zero; 2278 break; 2279 } 2280 2281#if (defined(IS64BITS) || defined(POLYML32IN64)) 2282 case EXTINSTR_storeC64: 2283 { 2284 // This is a boxed value. 2285 uint64_t toStore = *(uintptr_t*)((*sp++).w().AsObjPtr()); 2286 POLYSIGNED offset = UNTAGGED(*sp++); 2287 POLYSIGNED index = UNTAGGED(*sp++); 2288 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2289 ((uint64_t*)p)[index] = toStore; 2290 *sp = Zero; 2291 break; 2292 } 2293#endif 2294 2295 case EXTINSTR_storeCFloat: 2296 { 2297 // This is a boxed value. 2298 float toStore = (float)unboxDouble(*sp++); 2299 POLYSIGNED offset = UNTAGGED(*sp++); 2300 POLYSIGNED index = UNTAGGED(*sp++); 2301 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2302 ((float*)p)[index] = toStore; 2303 *sp = Zero; 2304 break; 2305 } 2306 2307 case EXTINSTR_storeCDouble: 2308 { 2309 // This is a boxed value. 2310 double toStore = unboxDouble(*sp++); 2311 POLYSIGNED offset = UNTAGGED(*sp++); 2312 POLYSIGNED index = UNTAGGED(*sp++); 2313 POLYCODEPTR p = *((byte**)((*sp).w().AsObjPtr())) + offset; 2314 ((double*)p)[index] = toStore; 2315 *sp = Zero; 2316 break; 2317 } 2318 2319 case EXTINSTR_jump32True: 2320 // Invert the sense of the test and fall through. 2321 *sp = ((*sp).w() == True) ? False : True; 2322 2323 case EXTINSTR_jump32False: 2324 { 2325 PolyWord u = *sp++; /* Pop argument */ 2326 if (u == True) { pc += 4; break; } 2327 /* else - false - take the jump */ 2328 } 2329 2330 case EXTINSTR_jump32: 2331 { 2332 // This is a 32-bit signed quantity on both 64-bits and 32-bits. 2333 POLYSIGNED offset = pc[3] & 0x80 ? -1 : 0; 2334 offset = (offset << 8) | pc[3]; 2335 offset = (offset << 8) | pc[2]; 2336 offset = (offset << 8) | pc[1]; 2337 offset = (offset << 8) | pc[0]; 2338 pc += offset + 4; 2339 break; 2340 } 2341 2342 case EXTINSTR_setHandler32: /* Set up a handler */ 2343 { 2344 POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); 2345 (--sp)->codeAddr = pc + offset + 4; /* Address of handler */ 2346 this->hr = sp; 2347 pc += 4; 2348 break; 2349 } 2350 2351 case EXTINSTR_case32: 2352 { 2353 // arg1 is the number of cases i.e. one more than the largest value 2354 // This is followed by that number of 32-bit offsets. 2355 // If the value is out of range the default case is immediately after the table. 2356 POLYSIGNED u = UNTAGGED(*sp++); /* Get the value */ 2357 if (u >= arg1 || u < 0) pc += 2 + arg1 * 4; /* Out of range */ 2358 else 2359 { 2360 pc += 2; 2361 pc += /* Index */pc[u * 4] + (pc[u * 4 + 1] << 8) + (pc[u * 4 + 2] << 16) + (pc[u * 4 + 3] << 24); 2362 } 2363 break; 2364 } 2365 2366 case EXTINSTR_tuple_w: 2367 { 2368 storeWords = arg1; pc += 2; 2369 TUPLE: /* Common code for tupling. */ 2370 PolyObject* p = this->allocateMemory(storeWords, pc, sp); 2371 if (p == 0) goto RAISE_EXCEPTION; // Exception 2372 p->SetLengthWord(storeWords, 0); 2373 for (; storeWords > 0; ) p->Set(--storeWords, *sp++); 2374 *(--sp) = (PolyWord)p; 2375 break; 2376 } 2377 2378 case EXTINSTR_indirect_w: 2379 *sp = (*sp).w().AsObjPtr()->Get(arg1); pc += 2; break; 2380 2381 case EXTINSTR_moveToContainerW: 2382 { 2383 PolyWord u = *sp++; 2384 (*sp).stackAddr[arg1] =u; 2385 pc += 2; 2386 break; 2387 } 2388 2389 case EXTINSTR_moveToMutClosureW: 2390 { 2391 PolyWord u = *sp++; 2392 (*sp).w().AsObjPtr()->Set(arg1 + sizeof(uintptr_t)/sizeof(PolyWord), u); 2393 pc += 2; 2394 break; 2395 } 2396 2397 case EXTINSTR_indirectContainerW: 2398 *sp = (*sp).stackAddr[arg1]; pc += 2; break; 2399 2400 case EXTINSTR_indirectClosureW: 2401 *sp = (*sp).w().AsObjPtr()->Get(arg1+sizeof(uintptr_t)/sizeof(PolyWord)); pc += 2; break; 2402 2403 case EXTINSTR_set_stack_val_w: 2404 { 2405 PolyWord u = *sp++; 2406 sp[arg1 - 1] = u; 2407 pc += 2; 2408 break; 2409 } 2410 2411 case EXTINSTR_reset_w: sp += arg1; pc += 2; break; 2412 2413 case EXTINSTR_reset_r_w: 2414 { 2415 PolyWord u = *sp; 2416 sp += arg1; 2417 *sp = u; 2418 pc += 2; 2419 break; 2420 } 2421 2422 case EXTINSTR_stack_containerW: 2423 { 2424 POLYUNSIGNED words = arg1; pc += 2; 2425 while (words-- > 0) *(--sp) = Zero; 2426 sp--; 2427 (*sp).stackAddr = sp + 1; 2428 break; 2429 } 2430 2431 case EXTINSTR_constAddr32: 2432 { 2433 POLYUNSIGNED offset = pc[0] + (pc[1] << 8) + (pc[2] << 16) + (pc[3] << 24); 2434 *(--sp) = *(PolyWord*)(pc + offset + 4); 2435 pc += 4; 2436 break; 2437 } 2438 2439 case EXTINSTR_allocCSpace: 2440 { 2441 // Allocate this on the C heap. 2442 POLYUNSIGNED length = UNTAGGED_UNSIGNED(*sp); 2443 void* memory = malloc(length); 2444 *sp = Make_sysword(this, (uintptr_t)memory)->Word(); 2445 break; 2446 } 2447 2448 case EXTINSTR_freeCSpace: 2449 { 2450 // Both the address and the size are passed as arguments. 2451 sp++; // Size 2452 PolyWord addr = *sp; 2453 free(*(void**)(addr.AsObjPtr())); 2454 *sp = TAGGED(0); 2455 break; 2456 } 2457 2458 case EXTINSTR_tail: 2459 /* Tail recursive call. */ 2460 /* Move items up the stack. */ 2461 /* There may be an overlap if the function we are calling 2462 has more args than this one. */ 2463 tailCount = arg1; 2464 tailPtr = sp + tailCount; 2465 sp = tailPtr + arg2; 2466 goto TAIL_CALL; 2467 2468 2469 case EXTINSTR_allocMutClosureW: 2470 { 2471 // Allocate memory for a mutable closure and copy in the code address. 2472 POLYUNSIGNED length = arg1 + sizeof(uintptr_t) / sizeof(PolyWord); 2473 pc += 2; 2474 PolyObject* t = this->allocateMemory(length, pc, sp); 2475 if (t == 0) goto RAISE_EXCEPTION; 2476 t->SetLengthWord(length, F_CLOSURE_OBJ | F_MUTABLE_BIT); 2477 PolyObject* srcClosure = (*sp).w().AsObjPtr(); 2478 *(uintptr_t*)t = *(uintptr_t*)srcClosure; 2479 for (POLYUNSIGNED i = sizeof(uintptr_t) / sizeof(PolyWord); i < length; i++) 2480 t->Set(i, TAGGED(0)); 2481 *sp = (PolyWord)t; 2482 break; 2483 } 2484 2485 case EXTINSTR_closureW: 2486 { 2487 storeWords = arg1; 2488 pc += 2; 2489 CREATE_CLOSURE: 2490 // Allocate a closure. storeWords is the number of non-locals. 2491 POLYUNSIGNED length = storeWords + sizeof(uintptr_t) / sizeof(PolyWord); 2492 PolyObject* t = this->allocateMemory(length, pc, sp); 2493 if (t == 0) goto RAISE_EXCEPTION; 2494 t->SetLengthWord(length, F_CLOSURE_OBJ); 2495 for (; storeWords > 0; ) t->Set(--storeWords + sizeof(uintptr_t) / sizeof(PolyWord), *sp++); 2496 PolyObject* srcClosure = (*sp).w().AsObjPtr(); 2497 *(uintptr_t*)t = *(uintptr_t*)srcClosure; 2498 *sp = (PolyWord)t; 2499 break; 2500 } 2501 2502 default: Crash("Unknown extended instruction %x\n", pc[-1]); 2503 } 2504 2505 break; 2506 } 2507 2508 case INSTR_enterIntX86: 2509 // This is a no-op if we are already interpreting. 2510 pc += 3; break; 2511 2512 default: Crash("Unknown instruction %x\n", pc[-1]); 2513 2514 } /* switch */ 2515 } /* for */ 2516 return 0; 2517} /* MD_switch_to_poly */ 2518 2519void IntTaskData::GarbageCollect(ScanAddress *process) 2520{ 2521 TaskData::GarbageCollect(process); 2522 2523 overflowPacket = process->ScanObjectAddress(overflowPacket); 2524 dividePacket = process->ScanObjectAddress(dividePacket); 2525 2526 if (stack != 0) 2527 { 2528 StackSpace *stackSpace = stack; 2529 stackItem*stackPtr = this->taskSp; 2530 // The exception arg if any 2531 ScanStackAddress(process, this->exception_arg, stackSpace); 2532 2533 // Now the values on the stack. 2534 for (stackItem* q = stackPtr; q < (stackItem*)stack->top; q++) 2535 ScanStackAddress(process, *q, stack); 2536 } 2537} 2538 2539// Process a value within the stack. 2540void IntTaskData::ScanStackAddress(ScanAddress *process, stackItem& stackItem, StackSpace *stack) 2541{ 2542 // We may have return addresses on the stack which could look like 2543// tagged values. Check whether the value is in the code area before 2544// checking whether it is untagged. 2545 if (stackItem.codeAddr == SPECIAL_PC_END_THREAD/* 0 */) 2546 return; 2547#ifdef POLYML32IN64 2548 // In 32-in-64 return addresses always have the top 32 bits non-zero. 2549 if (stackItem.argValue < ((uintptr_t)1 << 32)) 2550 { 2551 // It's either a tagged integer or an object pointer. 2552 if (stackItem.w().IsDataPtr()) 2553 { 2554 PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); 2555 stackItem = val; 2556 } 2557 } 2558 else 2559 { 2560 // Could be a code address or a stack address. 2561 MemSpace* space = gMem.SpaceForAddress(stackItem.codeAddr - 1); 2562 if (space == 0 || space->spaceType != ST_CODE) return; 2563 PolyObject* obj = gMem.FindCodeObject(stackItem.codeAddr); 2564 ASSERT(obj != 0); 2565 // Process the address of the start. Don't update anything. 2566 process->ScanObjectAddress(obj); 2567 } 2568#else 2569 // The -1 here is because we may have a zero-sized cell in the last 2570 // word of a space. 2571 MemSpace* space = gMem.SpaceForAddress(stackItem.codeAddr - 1); 2572 if (space == 0) return; // In particular we may have one of the assembly code addresses. 2573 if (space->spaceType == ST_CODE) 2574 { 2575 PolyObject* obj = gMem.FindCodeObject(stackItem.codeAddr); 2576 // If it is actually an integer it might be outside a valid code object. 2577 if (obj == 0) 2578 { 2579 ASSERT(stackItem.w().IsTagged()); // It must be an integer 2580 } 2581 else // Process the address of the start. Don't update anything. 2582 process->ScanObjectAddress(obj); 2583 } 2584 else if (space->spaceType == ST_LOCAL && stackItem.w().IsDataPtr()) 2585 // Local values must be word addresses. 2586 { 2587 PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); 2588 stackItem = val; 2589 } 2590#endif 2591 2592} 2593 2594 2595// Copy a stack 2596void IntTaskData::CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) 2597{ 2598#ifdef POLYML32IN64 2599 old_length = old_length / 2; 2600 new_length = new_length / 2; 2601#endif 2602 /* Moves a stack, updating all references within the stack */ 2603 stackItem*old_base = (stackItem*)old_stack; 2604 stackItem*new_base = (stackItem*)new_stack; 2605 stackItem*old_top = old_base + old_length; 2606 2607 /* Calculate the offset of the new stack from the old. If the frame is 2608 being extended objects in the new frame will be further up the stack 2609 than in the old one. */ 2610 2611 uintptr_t offset = new_base - old_base + new_length - old_length; 2612 stackItem *oldSp = this->taskSp; 2613 this->taskSp = oldSp + offset; 2614 this->hr = this->hr + offset; 2615 2616 /* Skip the unused part of the stack. */ 2617 2618 uintptr_t i = oldSp - old_base; 2619 2620 ASSERT(i <= old_length); 2621 2622 i = old_length - i; 2623 2624 stackItem *old = oldSp; 2625 stackItem *newp = this->taskSp; 2626 2627 while (i--) 2628 { 2629 stackItem old_word = *old++; 2630 if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) 2631 old_word.stackAddr = old_word.stackAddr + offset; 2632 else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) 2633 { 2634 stackItem* addr = (stackItem*)old_word.w().AsStackAddr(); 2635 if (addr >= old_base && addr <= old_top) 2636 { 2637 addr += offset; 2638 old_word = PolyWord::FromStackAddr((PolyWord*)addr); 2639 } 2640 } 2641 *newp++ = old_word; 2642 } 2643 ASSERT(old == ((stackItem*)old_stack) + old_length); 2644 ASSERT(newp == ((stackItem*)new_stack) + new_length); 2645} 2646 2647void IntTaskData::EnterPolyCode() 2648/* Called from "main" to enter the code. */ 2649{ 2650 Handle hOriginal = this->saveVec.mark(); // Set this up for the IO calls. 2651 while (1) 2652 { 2653 this->saveVec.reset(hOriginal); // Remove old RTS arguments and results. 2654 2655 // Run the ML code and return with the function to call. 2656 this->inML = true; 2657 int ioFunction = SwitchToPoly(); 2658 this->inML = false; 2659 2660 try { 2661 switch (ioFunction) 2662 { 2663 case -1: 2664 // We've been interrupted. This usually involves simulating a 2665 // stack overflow so we could come here because of a genuine 2666 // stack overflow. 2667 // Previously this code was executed on every RTS call but there 2668 // were problems on Mac OS X at least with contention on schedLock. 2669 // Process any asynchronous events i.e. interrupts or kill 2670 processes->ProcessAsynchRequests(this); 2671 // Release and re-acquire use of the ML memory to allow another thread 2672 // to GC. 2673 processes->ThreadReleaseMLMemory(this); 2674 processes->ThreadUseMLMemory(this); 2675 break; 2676 2677 case -2: // A callback has returned. 2678 ASSERT(0); // Callbacks aren't implemented 2679 2680 default: 2681 Crash("Unknown io operation %d\n", ioFunction); 2682 } 2683 } 2684 catch (IOException &) { 2685 } 2686 2687 } 2688} 2689 2690// As far as possible we want locking and unlocking an ML mutex to be fast so 2691// we try to implement the code in the assembly code using appropriate 2692// interlocked instructions. That does mean that if we need to lock and 2693// unlock an ML mutex in this code we have to use the same, machine-dependent, 2694// code to do it. These are defaults that are used where there is no 2695// machine-specific code. 2696 2697static Handle ProcessAtomicDecrement(TaskData *taskData, Handle mutexp) 2698{ 2699 PLocker l(&mutexLock); 2700 PolyObject *p = DEREFHANDLE(mutexp); 2701 // A thread can only call this once so the values will be short 2702 PolyWord newValue = TAGGED(UNTAGGED(p->Get(0))-1); 2703 p->Set(0, newValue); 2704 return taskData->saveVec.push(newValue); 2705} 2706 2707// Release a mutex. We need to lock the mutex to ensure we don't 2708// reset it in the time between one of atomic operations reading 2709// and writing the mutex. 2710static Handle ProcessAtomicReset(TaskData *taskData, Handle mutexp) 2711{ 2712 PLocker l(&mutexLock); 2713 DEREFHANDLE(mutexp)->Set(0, TAGGED(0)); // Set this to released. 2714 return taskData->saveVec.push(TAGGED(0)); // Push the unit result 2715} 2716 2717Handle IntTaskData::AtomicDecrement(Handle mutexp) 2718{ 2719 return ProcessAtomicDecrement(this, mutexp); 2720} 2721 2722void IntTaskData::AtomicReset(Handle mutexp) 2723{ 2724 (void)ProcessAtomicReset(this, mutexp); 2725} 2726 2727bool IntTaskData::AddTimeProfileCount(SIGNALCONTEXT *context) 2728{ 2729 if (taskPc != 0) 2730 { 2731 // See if the PC we've got is an ML code address. 2732 MemSpace *space = gMem.SpaceForAddress(taskPc); 2733 if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) 2734 { 2735 incrementCountAsynch(taskPc); 2736 return true; 2737 } 2738 } 2739 return false; 2740} 2741 2742extern "C" { 2743 POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedGetAbiList(FirstArgument threadId); 2744 POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes); 2745 POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec); 2746 POLYEXTERNALSYMBOL POLYUNSIGNED PolyInterpretedEnterIntMode(); 2747} 2748 2749// FFI 2750#if (defined(HAVE_LIBFFI) && defined(HAVE_FFI_H)) 2751 2752#ifdef HAVE_ERRNO_H 2753#include <errno.h> 2754#endif 2755 2756#include <ffi.h> 2757 2758static struct _abiTable { const char* abiName; ffi_abi abiCode; } abiTable[] = 2759{ 2760 // Unfortunately the ABI entries are enums rather than #defines so we 2761 // can't test individual entries. 2762 #ifdef X86_WIN32 2763 {"sysv", FFI_SYSV}, 2764 {"stdcall", FFI_STDCALL}, 2765 {"thiscall", FFI_THISCALL}, 2766 {"fastcall", FFI_FASTCALL}, 2767 {"ms_cdecl", FFI_MS_CDECL}, 2768 #elif defined(X86_WIN64) 2769 {"win64", FFI_WIN64}, 2770 #elif defined(X86_64) || (defined (__x86_64__) && defined (X86_DARWIN)) 2771 {"unix64", FFI_UNIX64}, 2772 #elif defined(X86_ANY) 2773 {"sysv", FFI_SYSV}, 2774 #endif 2775 { "default", FFI_DEFAULT_ABI} 2776}; 2777 2778static Handle mkAbitab(TaskData* taskData, void*, char* p); 2779 2780static Handle toSysWord(TaskData* taskData, void* p) 2781{ 2782 return Make_sysword(taskData, (uintptr_t)p); 2783} 2784 2785// Convert the Poly type info into ffi_type values. 2786/* 2787 datatype cTypeForm = 2788 CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt 2789 | CTypeStruct of cType list | CTypeVoid 2790 withtype cType = { typeForm: cTypeForm, align: word, size: word } 2791*/ 2792static ffi_type* decodeType(PolyWord pType) 2793{ 2794 PolyWord typeForm = pType.AsObjPtr()->Get(2); 2795 PolyWord typeSize = pType.AsObjPtr()->Get(0); 2796 2797 if (typeForm.IsDataPtr()) 2798 { 2799 // Struct 2800 size_t size = typeSize.UnTaggedUnsigned(); 2801 unsigned short align = (unsigned short)pType.AsObjPtr()->Get(1).UnTaggedUnsigned(); 2802 unsigned nElems = 0; 2803 PolyWord listStart = typeForm.AsObjPtr()->Get(0); 2804 for (PolyWord p = listStart; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) 2805 nElems++; 2806 size_t space = sizeof(ffi_type); 2807 // Add space for the elements plus one extra for the zero terminator. 2808 space += (nElems + 1) * sizeof(ffi_type*); 2809 ffi_type* result = (ffi_type*)calloc(1, space); 2810 // Raise an exception rather than returning zero. 2811 if (result == 0) return 0; 2812 ffi_type** elem = (ffi_type**)(result + 1); 2813 result->size = size; 2814 result->alignment = align; 2815 result->type = FFI_TYPE_STRUCT; 2816 result->elements = elem; 2817 if (elem != 0) 2818 { 2819 for (PolyWord p = listStart; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) 2820 { 2821 PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; 2822 ffi_type* t = decodeType(e); 2823 if (t == 0) return 0; 2824 *elem++ = t; 2825 } 2826 *elem = 0; // Null terminator 2827 } 2828 return result; 2829 } 2830 else 2831 { 2832 switch (typeForm.UnTaggedUnsigned()) 2833 { 2834 case 0: 2835 { 2836 // Floating point 2837 if (typeSize.UnTaggedUnsigned() == ffi_type_float.size) 2838 return &ffi_type_float; 2839 else if (typeSize.UnTaggedUnsigned() == ffi_type_double.size) 2840 return &ffi_type_double; 2841 ASSERT(0); 2842 } 2843 case 1: // FFI type poiner 2844 return &ffi_type_pointer; 2845 case 2: // Signed integer. 2846 { 2847 switch (typeSize.UnTaggedUnsigned()) 2848 { 2849 case 1: return &ffi_type_sint8; 2850 case 2: return &ffi_type_sint16; 2851 case 4: return &ffi_type_sint32; 2852 case 8: return &ffi_type_sint64; 2853 default: ASSERT(0); 2854 } 2855 } 2856 case 3: // Unsigned integer. 2857 { 2858 switch (typeSize.UnTaggedUnsigned()) 2859 { 2860 case 1: return &ffi_type_uint8; 2861 case 2: return &ffi_type_uint16; 2862 case 4: return &ffi_type_uint32; 2863 case 8: return &ffi_type_uint64; 2864 default: ASSERT(0); 2865 } 2866 } 2867 case 4: // Void 2868 return &ffi_type_void; 2869 } 2870 ASSERT(0); 2871 } 2872 return 0; 2873} 2874 2875// Create a CIF. This contains all the types and some extra information. 2876// The arguments are the raw ML values. That does make this dependent on the 2877// representations used by the compiler. 2878// This mallocs space for the CIF and the types. The space is never freed. 2879// 2880POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) 2881{ 2882 TaskData* taskData = TaskData::FindTaskForId(threadId); 2883 ASSERT(taskData != 0); 2884 taskData->PreRTSCall(); 2885 Handle reset = taskData->saveVec.mark(); 2886 Handle result = 0; 2887 ffi_abi abi = (ffi_abi)get_C_ushort(taskData, abiValue); 2888 2889 try { 2890 unsigned nArgs = 0; 2891 for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) 2892 nArgs++; 2893 // Allocate space for the cif followed by the argument type vector 2894 size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*); 2895 ffi_cif* cif = (ffi_cif*)malloc(space); 2896 if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); 2897 ffi_type* rtype = decodeType(resultType); 2898 if (rtype == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); 2899 ffi_type** atypes = (ffi_type**)(cif + 1); 2900 // Copy the arguments types. 2901 ffi_type** at = atypes; 2902 for (PolyWord p = argTypes; !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) 2903 { 2904 PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; 2905 ffi_type *atype = decodeType(e); 2906 if (atype == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); 2907 *at++ = atype; 2908 } 2909 ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes); 2910 if (status == FFI_BAD_TYPEDEF) 2911 raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif"); 2912 else if (status == FFI_BAD_ABI) 2913 raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif"); 2914 else if (status != FFI_OK) 2915 raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif"); 2916 result = toSysWord(taskData, cif); 2917 } 2918 catch (...) {} // If an ML exception is raised 2919 2920 taskData->saveVec.reset(reset); 2921 taskData->PostRTSCall(); 2922 if (result == 0) return TAGGED(0).AsUnsigned(); 2923 else return result->Word().AsUnsigned(); 2924} 2925 2926// Call a function. 2927POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) 2928{ 2929 ffi_cif* cif = *(ffi_cif**)cifAddr.AsAddress(); 2930 void* f = *(void**)cFunAddr.AsAddress(); 2931 void* res = *(void**)resAddr.AsAddress(); 2932 void* arg = *(void**)argVec.AsAddress(); 2933 // Poly passes the arguments as values, effectively a single struct. 2934 // Libffi wants a vector of addresses. 2935 void** argVector = (void**)calloc(cif->nargs + 1, sizeof(void*)); 2936 unsigned n = 0; 2937 uintptr_t p = (uintptr_t)arg; 2938 while (n < cif->nargs) 2939 { 2940 uintptr_t align = cif->arg_types[n]->alignment; 2941 p = (p + align - 1) & (0-align); 2942 argVector[n] = (void*)p; 2943 p += cif->arg_types[n]->size; 2944 n++; 2945 } 2946 // The result area we have provided is only as big as required. 2947 // Libffi may need a larger area. 2948 if (cif->rtype->size < FFI_SIZEOF_ARG) 2949 { 2950 char result[FFI_SIZEOF_ARG]; 2951 ffi_call(cif, FFI_FN(f), &result, argVector); 2952 if (cif->rtype->type != FFI_TYPE_VOID) 2953 memcpy(res, result, cif->rtype->size); 2954 } 2955 else ffi_call(cif, FFI_FN(f), res, argVector); 2956 free(argVector); 2957 return TAGGED(0).AsUnsigned(); 2958} 2959 2960#else 2961// Libffi is not present. 2962 2963// A basic table so that the Foreign structure will compile 2964static struct _abiTable { const char* abiName; int abiCode; } abiTable[] = 2965{ 2966 { "default", 0} 2967}; 2968 2969// Don't raise an exception at this point so we can build calls. 2970POLYUNSIGNED PolyInterpretedCreateCIF(FirstArgument threadId, PolyWord abiValue, PolyWord resultType, PolyWord argTypes) 2971{ 2972 return TAGGED(0).AsUnsigned(); 2973} 2974 2975POLYUNSIGNED PolyInterpretedCallFunction(FirstArgument threadId, PolyWord cifAddr, PolyWord cFunAddr, PolyWord resAddr, PolyWord argVec) 2976{ 2977 TaskData* taskData = TaskData::FindTaskForId(threadId); 2978 try { 2979 raise_exception_string(taskData, EXC_foreign, "Foreign function calling is not available. Libffi is not installled."); 2980 } catch (...) {} // Handle the IOException 2981 return TAGGED(0).AsUnsigned(); 2982} 2983 2984#endif 2985 2986// Construct an entry in the ABI table. 2987static Handle mkAbitab(TaskData* taskData, void* arg, char* p) 2988{ 2989 struct _abiTable* ab = (struct _abiTable*)p; 2990 // Construct a pair of the string and the code 2991 Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName)); 2992 Handle code = Make_arbitrary_precision(taskData, ab->abiCode); 2993 Handle result = alloc_and_save(taskData, 2); 2994 result->WordP()->Set(0, name->Word()); 2995 result->WordP()->Set(1, code->Word()); 2996 return result; 2997} 2998 2999// Get ABI list. This is called once only before the basis library is built. 3000POLYUNSIGNED PolyInterpretedGetAbiList(FirstArgument threadId) 3001{ 3002 TaskData* taskData = TaskData::FindTaskForId(threadId); 3003 ASSERT(taskData != 0); 3004 taskData->PreRTSCall(); 3005 Handle reset = taskData->saveVec.mark(); 3006 Handle result = 0; 3007 3008 try { 3009 result = makeList(taskData, sizeof(abiTable) / sizeof(abiTable[0]), 3010 (char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab); 3011 } 3012 catch (...) {} // If an ML exception is raised 3013 3014 taskData->saveVec.reset(reset); 3015 taskData->PostRTSCall(); 3016 if (result == 0) return TAGGED(0).AsUnsigned(); 3017 else return result->Word().AsUnsigned(); 3018} 3019 3020// Do we require EnterInt instructions and if so for which architecture? 3021// 0 = > None; 1 => X86_32, 2 => X86_64. 3 => X86_32_in_64. 3022POLYUNSIGNED PolyInterpretedEnterIntMode() 3023{ 3024 return TAGGED(0).AsUnsigned(); 3025} 3026 3027static Interpreter interpreterObject; 3028 3029MachineDependent *machineDependent = &interpreterObject; 3030 3031// No machine-specific calls in the interpreter. 3032struct _entrypts machineSpecificEPT[] = 3033{ 3034 { "PolyInterpretedGetAbiList", (polyRTSFunction)&PolyInterpretedGetAbiList }, 3035 { "PolyInterpretedCreateCIF", (polyRTSFunction)&PolyInterpretedCreateCIF }, 3036 { "PolyInterpretedCallFunction", (polyRTSFunction)&PolyInterpretedCallFunction }, 3037 { "PolyInterpretedEnterIntMode", (polyRTSFunction)&PolyInterpretedEnterIntMode }, 3038 { NULL, NULL} // End of list. 3039}; 3040