Interpreter.c 44.7 KB
Newer Older
1
/* -----------------------------------------------------------------------------
2
 * Bytecode interpreter
3
 *
4
 * Copyright (c) The GHC Team, 1994-2002.
5 6
 * ---------------------------------------------------------------------------*/

7
#include "PosixSource.h"
8 9
#include "Rts.h"
#include "RtsAPI.h"
Simon Marlow's avatar
Simon Marlow committed
10 11 12 13
#include "rts/Bytecodes.h"

// internal headers
#include "sm/Storage.h"
Simon Marlow's avatar
Simon Marlow committed
14
#include "sm/Sanity.h"
15
#include "RtsUtils.h"
16 17
#include "Schedule.h"
#include "Updates.h"
18
#include "Prelude.h"
Simon Marlow's avatar
Simon Marlow committed
19
#include "Stable.h"
20 21
#include "Printer.h"
#include "Disassembler.h"
22
#include "Interpreter.h"
Simon Marlow's avatar
Simon Marlow committed
23
#include "ThreadPaused.h"
24
#include "Threads.h"
25

26 27 28 29 30
#include <string.h>     /* for memcpy */
#ifdef HAVE_ERRNO_H
#include <errno.h>
#endif

31 32 33
// When building the RTS in the non-dyn way on Windows, we don't
//	want declspec(__dllimport__) on the front of function prototypes
//	from libffi.
Ian Lynagh's avatar
Ian Lynagh committed
34 35
#if defined(mingw32_HOST_OS)
#if (defined(i386_HOST_ARCH) && !defined(__PIC__)) || defined(x86_64_HOST_ARCH)
36 37
# define LIBFFI_NOT_DLL
#endif
Ian Lynagh's avatar
Ian Lynagh committed
38
#endif
39

40
#include "ffi.h"
andy's avatar
andy committed
41

42
/* --------------------------------------------------------------------------
43
 * The bytecode interpreter
44 45
 * ------------------------------------------------------------------------*/

46 47 48 49 50 51
/* Gather stats about entry, opcode, opcode-pair frequencies.  For
   tuning the interpreter. */

/* #define INTERP_STATS */


52
/* Sp points to the lowest live word on the stack. */
53

Ian Lynagh's avatar
Ian Lynagh committed
54 55 56 57 58 59 60 61 62
#define BCO_NEXT         instrs[bciPtr++]
#define BCO_NEXT_32      (bciPtr += 2)
#define BCO_READ_NEXT_32 (BCO_NEXT_32, (((StgWord) instrs[bciPtr-2]) << 16) \
                                     + ( (StgWord) instrs[bciPtr-1]))
#define BCO_NEXT_64      (bciPtr += 4)
#define BCO_READ_NEXT_64 (BCO_NEXT_64, (((StgWord) instrs[bciPtr-4]) << 48) \
                                     + (((StgWord) instrs[bciPtr-3]) << 32) \
                                     + (((StgWord) instrs[bciPtr-2]) << 16) \
                                     + ( (StgWord) instrs[bciPtr-1]))
63 64
#if WORD_SIZE_IN_BITS == 32
#define BCO_NEXT_WORD BCO_NEXT_32
Ian Lynagh's avatar
Ian Lynagh committed
65
#define BCO_READ_NEXT_WORD BCO_READ_NEXT_32
66 67
#elif WORD_SIZE_IN_BITS == 64
#define BCO_NEXT_WORD BCO_NEXT_64
Ian Lynagh's avatar
Ian Lynagh committed
68
#define BCO_READ_NEXT_WORD BCO_READ_NEXT_64
69
#else
Ian Lynagh's avatar
Ian Lynagh committed
70
#error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
71
#endif
72
#define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_READ_NEXT_WORD : BCO_NEXT)
73

74
#define BCO_PTR(n)    (W_)ptrs[n]
75
#define BCO_LIT(n)    literals[n]
76

77
#define LOAD_STACK_POINTERS					\
78
    Sp = cap->r.rCurrentTSO->stackobj->sp;                      \
79
    /* We don't change this ... */				\
80
    SpLim = tso_SpLim(cap->r.rCurrentTSO);
81

82
#define SAVE_STACK_POINTERS			\
83
    ASSERT(Sp > SpLim); \
84
    cap->r.rCurrentTSO->stackobj->sp = Sp
85

86
#define RETURN_TO_SCHEDULER(todo,retcode)	\
87 88
   SAVE_STACK_POINTERS;				\
   cap->r.rCurrentTSO->what_next = (todo);	\
89
   threadPaused(cap,cap->r.rCurrentTSO);		\
90 91
   cap->r.rRet = (retcode);			\
   return cap;
92 93

#define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode)	\
94 95 96 97
   SAVE_STACK_POINTERS;					\
   cap->r.rCurrentTSO->what_next = (todo);		\
   cap->r.rRet = (retcode);				\
   return cap;
98 99


sof's avatar
sof committed
100
STATIC_INLINE StgPtr
101
allocate_NONUPD (Capability *cap, int n_words)
102
{
103
    return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
104 105
}

106 107
int rts_stop_next_breakpoint = 0;
int rts_stop_on_exception = 0;
108

109
#ifdef INTERP_STATS
110

111 112 113 114 115 116 117 118 119 120 121 122 123
/* Hacky stats, for tuning the interpreter ... */
int it_unknown_entries[N_CLOSURE_TYPES];
int it_total_unknown_entries;
int it_total_entries;

int it_retto_BCO;
int it_retto_UPDATE;
int it_retto_other;

int it_slides;
int it_insns;
int it_BCO_entries;

124 125
int it_ofreq[27];
int it_oofreq[27][27];
126 127
int it_lastopc;

128

129 130
#define INTERP_TICK(n) (n)++

131 132 133 134 135 136 137 138
void interp_startup ( void )
{
   int i, j;
   it_retto_BCO = it_retto_UPDATE = it_retto_other = 0;
   it_total_entries = it_total_unknown_entries = 0;
   for (i = 0; i < N_CLOSURE_TYPES; i++)
      it_unknown_entries[i] = 0;
   it_slides = it_insns = it_BCO_entries = 0;
139 140 141
   for (i = 0; i < 27; i++) it_ofreq[i] = 0;
   for (i = 0; i < 27; i++) 
     for (j = 0; j < 27; j++)
142 143 144 145 146 147 148
        it_oofreq[i][j] = 0;
   it_lastopc = 0;
}

void interp_shutdown ( void )
{
   int i, j, k, o_max, i_max, j_max;
149
   debugBelch("%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n",
150 151
                   it_retto_BCO + it_retto_UPDATE + it_retto_other,
                   it_retto_BCO, it_retto_UPDATE, it_retto_other );
152
   debugBelch("%d total entries, %d unknown entries \n", 
153 154 155
                   it_total_entries, it_total_unknown_entries);
   for (i = 0; i < N_CLOSURE_TYPES; i++) {
     if (it_unknown_entries[i] == 0) continue;
156
     debugBelch("   type %2d: unknown entries (%4.1f%%) == %d\n",
157 158 159 160
	     i, 100.0 * ((double)it_unknown_entries[i]) / 
                        ((double)it_total_unknown_entries),
             it_unknown_entries[i]);
   }
161
   debugBelch("%d insns, %d slides, %d BCO_entries\n", 
162
                   it_insns, it_slides, it_BCO_entries);
163
   for (i = 0; i < 27; i++) 
164
      debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
165 166 167 168

   for (k = 1; k < 20; k++) {
      o_max = 0;
      i_max = j_max = 0;
169 170
      for (i = 0; i < 27; i++) {
         for (j = 0; j < 27; j++) {
171 172 173 174 175 176 177
	    if (it_oofreq[i][j] > o_max) {
               o_max = it_oofreq[i][j];
	       i_max = i; j_max = j;
	    }
	 }
      }
      
178
      debugBelch("%d:  count (%4.1f%%) %6d   is %d then %d\n",
179 180 181 182 183 184 185
                k, ((double)o_max) * 100.0 / ((double)it_insns), o_max,
                   i_max, j_max );
      it_oofreq[i_max][j_max] = 0;

   }
}

186 187 188 189 190
#else // !INTERP_STATS

#define INTERP_TICK(n) /* nothing */

#endif
191

192 193 194 195 196 197 198 199 200
static StgWord app_ptrs_itbl[] = {
    (W_)&stg_ap_p_info,
    (W_)&stg_ap_pp_info,
    (W_)&stg_ap_ppp_info,
    (W_)&stg_ap_pppp_info,
    (W_)&stg_ap_ppppp_info,
    (W_)&stg_ap_pppppp_info,
};

201
HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint
202 203
                                // it is set in main/GHC.hs:runStmt

204
Capability *
205
interpretBCO (Capability* cap)
206
{
207 208 209 210
    // Use of register here is primarily to make it clear to compilers
    // that these entities are non-aliasable.
    register StgPtr       Sp;    // local state -- stack pointer
    register StgPtr       SpLim; // local state -- stack lim pointer
211
    register StgClosure   *tagged_obj = 0, *obj;
212
    nat n, m;
213

214 215
    LOAD_STACK_POINTERS;

216 217 218
    cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
                           // goes to zero we must return to the scheduler.

219 220 221 222 223 224 225 226 227 228 229
    // ------------------------------------------------------------------------
    // Case 1:
    // 
    //       We have a closure to evaluate.  Stack looks like:
    //       
    //      	|   XXXX_info   |
    //      	+---------------+
    //       Sp |      -------------------> closure
    //      	+---------------+
    //       
    if (Sp[0] == (W_)&stg_enter_info) {
230 231
       Sp++;
       goto eval;
232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248
    }

    // ------------------------------------------------------------------------
    // Case 2:
    // 
    //       We have a BCO application to perform.  Stack looks like:
    //
    //      	|     ....      |
    //      	+---------------+
    //      	|     arg1      |
    //      	+---------------+
    //      	|     BCO       |
    //      	+---------------+
    //       Sp |   RET_BCO     |
    //      	+---------------+
    //       
    else if (Sp[0] == (W_)&stg_apply_interp_info) {
Simon Marlow's avatar
Simon Marlow committed
249
	obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
	Sp += 2;
	goto run_BCO_fun;
    }

    // ------------------------------------------------------------------------
    // Case 3:
    //
    //       We have an unboxed value to return.  See comment before
    //       do_return_unboxed, below.
    //
    else {
	goto do_return_unboxed;
    }

    // Evaluate the object on top of the stack.
eval:
266
    tagged_obj = (StgClosure*)Sp[0]; Sp++;
267 268

eval_obj:
269
    obj = UNTAG_CLOSURE(tagged_obj);
270 271 272
    INTERP_TICK(it_total_evals);

    IF_DEBUG(interpreter,
273
             debugBelch(
274
             "\n---------------------------------------------------------------\n");
275 276 277
             debugBelch("Evaluating: "); printObj(obj);
             debugBelch("Sp = %p\n", Sp);
             debugBelch("\n" );
278

279
             printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
280
             debugBelch("\n\n");
281
            );
282

283 284
//    IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
    IF_DEBUG(sanity,checkStackFrame(Sp));
285

286
    switch ( get_itbl(obj)->type ) {
287

288 289 290 291
    case IND:
    case IND_PERM:
    case IND_STATIC:
    { 
292
	tagged_obj = ((StgInd*)obj)->indirectee;
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315
	goto eval_obj;
    }
    
    case CONSTR:
    case CONSTR_1_0:
    case CONSTR_0_1:
    case CONSTR_2_0:
    case CONSTR_1_1:
    case CONSTR_0_2:
    case CONSTR_STATIC:
    case CONSTR_NOCAF_STATIC:
    case FUN:
    case FUN_1_0:
    case FUN_0_1:
    case FUN_2_0:
    case FUN_1_1:
    case FUN_0_2:
    case FUN_STATIC:
    case PAP:
	// already in WHNF
	break;
	
    case BCO:
316
    {
317
	ASSERT(((StgBCO *)obj)->arity > 0);
318
	break;
319
    }
320 321 322 323 324 325 326 327 328 329 330 331

    case AP:	/* Copied from stg_AP_entry. */
    {
	nat i, words;
	StgAP *ap;
	
	ap = (StgAP*)obj;
	words = ap->n_args;
	
	// Stack check
	if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
	    Sp -= 2;
332
	    Sp[1] = (W_)tagged_obj;
333 334 335 336 337 338 339 340 341
	    Sp[0] = (W_)&stg_enter_info;
	    RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
	}
	
	/* Ok; we're safe.  Party on.  Push an update frame. */
	Sp -= sizeofW(StgUpdateFrame);
	{
	    StgUpdateFrame *__frame;
	    __frame = (StgUpdateFrame *)Sp;
342
	    SET_INFO((StgClosure *)__frame, (StgInfoTable *)&stg_upd_frame_info);
343 344 345 346 347 348 349 350 351
	    __frame->updatee = (StgClosure *)(ap);
	}
	
	/* Reload the stack */
	Sp -= words;
	for (i=0; i < words; i++) {
	    Sp[i] = (W_)ap->payload[i];
	}

Simon Marlow's avatar
Simon Marlow committed
352
	obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370
	ASSERT(get_itbl(obj)->type == BCO);
	goto run_BCO_fun;
    }

    default:
#ifdef INTERP_STATS
    { 
	int j;
	
	j = get_itbl(obj)->type;
	ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
	it_unknown_entries[j]++;
	it_total_unknown_entries++;
    }
#endif
    {
	// Can't handle this object; yield to scheduler
	IF_DEBUG(interpreter,
371
		 debugBelch("evaluating unknown closure -- yielding to sched\n"); 
372 373 374
		 printObj(obj);
	    );
	Sp -= 2;
375
	Sp[1] = (W_)tagged_obj;
376
	Sp[0] = (W_)&stg_enter_info;
377
	RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
378 379 380 381
    }
    }

    // ------------------------------------------------------------------------
382
    // We now have an evaluated object (tagged_obj).  The next thing to
383 384
    // do is return it to the stack frame on top of the stack.
do_return:
385
    obj = UNTAG_CLOSURE(tagged_obj);
386 387 388
    ASSERT(closure_HNF(obj));

    IF_DEBUG(interpreter,
389
             debugBelch(
390
             "\n---------------------------------------------------------------\n");
391 392 393
             debugBelch("Returning: "); printObj(obj);
             debugBelch("Sp = %p\n", Sp);
             debugBelch("\n" );
394
             printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
395
             debugBelch("\n\n");
396
            );
397

398
    IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size));
399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445

    switch (get_itbl((StgClosure *)Sp)->type) {

    case RET_SMALL: {
	const StgInfoTable *info;

	// NOTE: not using get_itbl().
	info = ((StgClosure *)Sp)->header.info;
	if (info == (StgInfoTable *)&stg_ap_v_info) {
	    n = 1; m = 0; goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_f_info) {
	    n = 1; m = 1; goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_d_info) {
	    n = 1; m = sizeofW(StgDouble); goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_l_info) {
	    n = 1; m = sizeofW(StgInt64); goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_n_info) {
	    n = 1; m = 1; goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_p_info) {
	    n = 1; m = 1; goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_pp_info) {
	    n = 2; m = 2; goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_ppp_info) {
	    n = 3; m = 3; goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_pppp_info) {
	    n = 4; m = 4; goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
	    n = 5; m = 5; goto do_apply;
	}
	if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
	    n = 6; m = 6; goto do_apply;
	}
	goto do_return_unrecognised;
    }

    case UPDATE_FRAME:
	// Returning to an update frame: do the update, pop the update
	// frame, and continue with the next stack frame.
446 447 448 449 450 451 452 453
        //
        // NB. we must update with the *tagged* pointer.  Some tags
        // are not optional, and if we omit the tag bits when updating
        // then bad things can happen (albeit very rarely).  See #1925.
        // What happened was an indirection was created with an
        // untagged pointer, and this untagged pointer was propagated
        // to a PAP by the GC, violating the invariant that PAPs
        // always contain a tagged pointer to the function.
454
	INTERP_TICK(it_retto_UPDATE);
455 456
        updateThunk(cap, cap->r.rCurrentTSO, 
                    ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
457 458 459 460 461 462 463 464 465
	Sp += sizeofW(StgUpdateFrame);
	goto do_return;

    case RET_BCO:
	// Returning to an interpreted continuation: put the object on
	// the stack, and start executing the BCO.
	INTERP_TICK(it_retto_BCO);
	Sp--;
	Sp[0] = (W_)obj;
466 467
        // NB. return the untagged object; the bytecode expects it to
        // be untagged.  XXX this doesn't seem right.
468 469 470 471 472 473 474 475 476 477
	obj = (StgClosure*)Sp[2];
	ASSERT(get_itbl(obj)->type == BCO);
	goto run_BCO_return;

    default:
    do_return_unrecognised:
    {
	// Can't handle this return address; yield to scheduler
	INTERP_TICK(it_retto_other);
	IF_DEBUG(interpreter,
478
		 debugBelch("returning to unknown frame -- yielding to sched\n"); 
479
                 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
480 481
	    );
	Sp -= 2;
482
	Sp[1] = (W_)tagged_obj;
483
	Sp[0] = (W_)&stg_enter_info;
484
	RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505
    }
    }

    // -------------------------------------------------------------------------
    // Returning an unboxed value.  The stack looks like this:
    //
    // 	  |     ....      |
    // 	  +---------------+
    // 	  |     fv2       |
    // 	  +---------------+
    // 	  |     fv1       |
    // 	  +---------------+
    // 	  |     BCO       |
    // 	  +---------------+
    // 	  | stg_ctoi_ret_ |
    // 	  +---------------+
    // 	  |    retval     |
    // 	  +---------------+
    // 	  |   XXXX_info   |
    // 	  +---------------+
    //
506
    // where XXXX_info is one of the stg_ret_*_info family.
507 508 509 510 511 512 513 514
    //
    // We're only interested in the case when the real return address
    // is a BCO; otherwise we'll return to the scheduler.

do_return_unboxed:
    { 
	int offset;
	
515 516 517 518 519 520
        ASSERT(    Sp[0] == (W_)&stg_ret_v_info
                || Sp[0] == (W_)&stg_ret_p_info
                || Sp[0] == (W_)&stg_ret_n_info
                || Sp[0] == (W_)&stg_ret_f_info
                || Sp[0] == (W_)&stg_ret_d_info
                || Sp[0] == (W_)&stg_ret_l_info
521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540
	    );

	// get the offset of the stg_ctoi_ret_XXX itbl
	offset = stack_frame_sizeW((StgClosure *)Sp);

	switch (get_itbl((StgClosure *)Sp+offset)->type) {

	case RET_BCO:
	    // Returning to an interpreted continuation: put the object on
	    // the stack, and start executing the BCO.
	    INTERP_TICK(it_retto_BCO);
	    obj = (StgClosure*)Sp[offset+1];
	    ASSERT(get_itbl(obj)->type == BCO);
	    goto run_BCO_return_unboxed;

	default:
	{
	    // Can't handle this return address; yield to scheduler
	    INTERP_TICK(it_retto_other);
	    IF_DEBUG(interpreter,
541
		     debugBelch("returning to unknown frame -- yielding to sched\n"); 
542 543
                     printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
                );
544
	    RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
545 546 547 548 549 550 551 552 553 554
	}
	}
    }
    // not reached.


    // -------------------------------------------------------------------------
    // Application...

do_apply:
555
    ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
556 557 558 559 560 561 562 563
    // we have a function to apply (obj), and n arguments taking up m
    // words on the stack.  The info table (stg_ap_pp_info or whatever)
    // is on top of the arguments on the stack.
    {
	switch (get_itbl(obj)->type) {

	case PAP: {
	    StgPAP *pap;
564
	    nat i, arity;
565 566 567 568

	    pap = (StgPAP *)obj;

	    // we only cope with PAPs whose function is a BCO
Simon Marlow's avatar
Simon Marlow committed
569
	    if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) {
570 571
		goto defer_apply_to_sched;
	    }
572

573 574 575 576 577 578 579 580 581 582
            // Stack check: we're about to unpack the PAP onto the
            // stack.  The (+1) is for the (arity < n) case, where we
            // also need space for an extra info pointer.
            if (Sp - (pap->n_args + 1) < SpLim) {
                Sp -= 2;
                Sp[1] = (W_)tagged_obj;
                Sp[0] = (W_)&stg_enter_info;
                RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
            }

583 584 585 586 587 588 589 590 591 592 593
	    Sp++;
	    arity = pap->arity;
	    ASSERT(arity > 0);
	    if (arity < n) {
		// n must be greater than 1, and the only kinds of
		// application we support with more than one argument
		// are all pointers...
		//
		// Shuffle the args for this function down, and put
		// the appropriate info table in the gap.
		for (i = 0; i < arity; i++) {
594 595
		    Sp[(int)i-1] = Sp[i];
		    // ^^^^^ careful, i-1 might be negative, but i in unsigned
596 597 598 599 600 601 602 603
		}
		Sp[arity-1] = app_ptrs_itbl[n-arity-1];
		Sp--;
		// unpack the PAP's arguments onto the stack
		Sp -= pap->n_args;
		for (i = 0; i < pap->n_args; i++) {
		    Sp[i] = (W_)pap->payload[i];
		}
Simon Marlow's avatar
Simon Marlow committed
604
		obj = UNTAG_CLOSURE(pap->fun);
605 606 607 608 609 610 611
		goto run_BCO_fun;
	    } 
	    else if (arity == n) {
		Sp -= pap->n_args;
		for (i = 0; i < pap->n_args; i++) {
		    Sp[i] = (W_)pap->payload[i];
		}
Simon Marlow's avatar
Simon Marlow committed
612
		obj = UNTAG_CLOSURE(pap->fun);
613 614 615 616 617
		goto run_BCO_fun;
	    } 
	    else /* arity > n */ {
		// build a new PAP and return it.
		StgPAP *new_pap;
618
		new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
619
                SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS);
620 621 622 623 624 625 626 627 628
		new_pap->arity = pap->arity - n;
		new_pap->n_args = pap->n_args + m;
		new_pap->fun = pap->fun;
		for (i = 0; i < pap->n_args; i++) {
		    new_pap->payload[i] = pap->payload[i];
		}
		for (i = 0; i < m; i++) {
		    new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
		}
629
		tagged_obj = (StgClosure *)new_pap;
630 631 632 633 634 635
		Sp += m;
		goto do_return;
	    }
	}	    

	case BCO: {
636
	    nat arity, i;
637 638

	    Sp++;
639
	    arity = ((StgBCO *)obj)->arity;
640 641 642 643 644 645 646 647 648
	    ASSERT(arity > 0);
	    if (arity < n) {
		// n must be greater than 1, and the only kinds of
		// application we support with more than one argument
		// are all pointers...
		//
		// Shuffle the args for this function down, and put
		// the appropriate info table in the gap.
		for (i = 0; i < arity; i++) {
649 650
		    Sp[(int)i-1] = Sp[i];
		    // ^^^^^ careful, i-1 might be negative, but i in unsigned
651 652 653 654 655 656 657 658 659 660 661
		}
		Sp[arity-1] = app_ptrs_itbl[n-arity-1];
		Sp--;
		goto run_BCO_fun;
	    } 
	    else if (arity == n) {
		goto run_BCO_fun;
	    }
	    else /* arity > n */ {
		// build a PAP and return it.
		StgPAP *pap;
662
		nat i;
663
		pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
664
                SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS);
665 666 667 668 669 670
		pap->arity = arity - n;
		pap->fun = obj;
		pap->n_args = m;
		for (i = 0; i < m; i++) {
		    pap->payload[i] = (StgClosure *)Sp[i];
		}
671
		tagged_obj = (StgClosure *)pap;
672 673 674 675 676 677 678 679 680
		Sp += m;
		goto do_return;
	    }
	}

	// No point in us applying machine-code functions
	default:
	defer_apply_to_sched:
	    Sp -= 2;
681
	    Sp[1] = (W_)tagged_obj;
682
	    Sp[0] = (W_)&stg_enter_info;
683
	    RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728
    }

    // ------------------------------------------------------------------------
    // Ok, we now have a bco (obj), and its arguments are all on the
    // stack.  We can start executing the byte codes.
    //
    // The stack is in one of two states.  First, if this BCO is a
    // function:
    //
    // 	  |     ....      |
    // 	  +---------------+
    // 	  |     arg2      |
    // 	  +---------------+
    // 	  |     arg1      |
    // 	  +---------------+
    //
    // Second, if this BCO is a continuation:
    //
    // 	  |     ....      |
    // 	  +---------------+
    // 	  |     fv2       |
    // 	  +---------------+
    // 	  |     fv1       |
    // 	  +---------------+
    // 	  |     BCO       |
    // 	  +---------------+
    // 	  | stg_ctoi_ret_ |
    // 	  +---------------+
    // 	  |    retval     |
    // 	  +---------------+
    // 
    // where retval is the value being returned to this continuation.
    // In the event of a stack check, heap check, or context switch,
    // we need to leave the stack in a sane state so the garbage
    // collector can find all the pointers.
    //
    //  (1) BCO is a function:  the BCO's bitmap describes the
    //      pointerhood of the arguments.
    //
    //  (2) BCO is a continuation: BCO's bitmap describes the
    //      pointerhood of the free variables.
    //
    // Sadly we have three different kinds of stack/heap/cswitch check
    // to do:

729

730 731
run_BCO_return:
    // Heap check
732
    if (doYouWantToGC(cap)) {
733 734 735
	Sp--; Sp[0] = (W_)&stg_enter_info;
	RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
    }
736 737
    // Stack checks aren't necessary at return points, the stack use
    // is aggregated into the enclosing function entry point.
738

739 740 741 742
    goto run_BCO;
    
run_BCO_return_unboxed:
    // Heap check
743
    if (doYouWantToGC(cap)) {
744 745
	RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
    }
746 747
    // Stack checks aren't necessary at return points, the stack use
    // is aggregated into the enclosing function entry point.
748

749 750 751 752 753 754 755 756 757 758 759 760
    goto run_BCO;
    
run_BCO_fun:
    IF_DEBUG(sanity,
	     Sp -= 2; 
	     Sp[1] = (W_)obj; 
	     Sp[0] = (W_)&stg_apply_interp_info;
	     checkStackChunk(Sp,SpLim);
	     Sp += 2;
	);

    // Heap check
761
    if (doYouWantToGC(cap)) {
762 763 764 765 766 767
	Sp -= 2; 
	Sp[1] = (W_)obj; 
	Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
	RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
    }
    
768 769
    // Stack check
    if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
770 771 772 773 774
	Sp -= 2; 
	Sp[1] = (W_)obj; 
	Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
	RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
    }
775

776 777 778 779 780 781 782
    goto run_BCO;
    
    // Now, actually interpret the BCO... (no returning to the
    // scheduler again until the stack is in an orderly state).
run_BCO:
    INTERP_TICK(it_BCO_entries);
    {
783
	register int       bciPtr = 0; /* instruction pointer */
784
        register StgWord16 bci;
785
	register StgBCO*   bco        = (StgBCO*)obj;
786
	register StgWord16* instrs    = (StgWord16*)(bco->instrs->payload);
787 788
	register StgWord*  literals   = (StgWord*)(&bco->literals->payload[0]);
	register StgPtr*   ptrs       = (StgPtr*)(&bco->ptrs->payload[0]);
Ian Lynagh's avatar
Ian Lynagh committed
789
#ifdef DEBUG
790
	int bcoSize;
791
        bcoSize = bco->instrs->bytes / sizeof(StgWord16);
Ian Lynagh's avatar
Ian Lynagh committed
792
#endif
793
	IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
794

795 796 797
#ifdef INTERP_STATS
	it_lastopc = 0; /* no opcode */
#endif
798

799
    nextInsn:
800
	ASSERT(bciPtr < bcoSize);
801 802
	IF_DEBUG(interpreter,
		 //if (do_print_stack) {
803
		 //debugBelch("\n-- BEGIN stack\n");
804
		 //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
805
		 //debugBelch("-- END stack\n\n");
806
		 //}
807
                 debugBelch("Sp = %p   pc = %-4d ", Sp, bciPtr);
808 809
		 disInstr(bco,bciPtr);
		 if (0) { int i;
810
		 debugBelch("\n");
811
		 for (i = 8; i >= 0; i--) {
812
		     debugBelch("%d  %p\n", i, (StgPtr)(*(Sp+i)));
813
		 }
814
		 debugBelch("\n");
815
		 }
816 817
		 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
	    );
818

819

820 821 822 823 824 825 826 827 828
	INTERP_TICK(it_insns);

#ifdef INTERP_STATS
	ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
	it_ofreq[ (int)instrs[bciPtr] ] ++;
	it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
	it_lastopc = (int)instrs[bciPtr];
#endif

829 830 831 832 833 834
	bci = BCO_NEXT;
    /* We use the high 8 bits for flags, only the highest of which is
     * currently allocated */
    ASSERT((bci & 0xFF00) == (bci & 0x8000));

    switch (bci & 0xFF) {
835

836 837 838 839 840
        /* check for a breakpoint on the beginning of a let binding */
        case bci_BRK_FUN: 
        {
            int arg1_brk_array, arg2_array_index, arg3_freeVars;
            StgArrWords *breakPoints;
841 842
            int returning_from_break;     // are we resuming execution from a breakpoint?
                                          //  if yes, then don't break this time around
843 844 845 846 847 848
            StgClosure *ioAction;         // the io action to run at a breakpoint

            StgAP_STACK *new_aps;         // a closure to save the top stack frame on the heap
            int i;
            int size_words;

849 850 851
            arg1_brk_array      = BCO_GET_LARGE_ARG;  // 1st arg of break instruction
            arg2_array_index    = BCO_NEXT;           // 2nd arg of break instruction
            arg3_freeVars       = BCO_GET_LARGE_ARG;  // 3rd arg of break instruction
852

853 854
            // check if we are returning from a breakpoint - this info
            // is stored in the flags field of the current TSO
855 856
            returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; 

857 858
            // if we are returning from a break then skip this section
            // and continue executing
859 860 861 862
            if (!returning_from_break)
            {
               breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);

863
               // stop the current thread if either the
864
               // "rts_stop_next_breakpoint" flag is true OR if the
865 866
               // breakpoint flag for this particular expression is
               // true
867
               if (rts_stop_next_breakpoint == rtsTrue || 
868
                   breakPoints->payload[arg2_array_index] == rtsTrue)
869
               {
870 871
                  // make sure we don't automatically stop at the
                  // next breakpoint
872
                  rts_stop_next_breakpoint = rtsFalse;
873 874 875 876 877

                  // allocate memory for a new AP_STACK, enough to
                  // store the top stack frame plus an
                  // stg_apply_interp_info pointer and a pointer to
                  // the BCO
878
                  size_words = BCO_BITMAP_SIZE(obj) + 2;
879
                  new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
880 881 882 883 884
                  SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM); 
                  new_aps->size = size_words;
                  new_aps->fun = &stg_dummy_ret_closure; 

                  // fill in the payload of the AP_STACK 
885 886
                  new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;
                  new_aps->payload[1] = (StgClosure *)obj;
887 888 889 890

                  // copy the contents of the top stack frame into the AP_STACK
                  for (i = 2; i < size_words; i++)
                  {
891
                     new_aps->payload[i] = (StgClosure *)Sp[i-2];
892 893
                  }

894
                  // prepare the stack so that we can call the
895
                  // rts_breakpoint_io_action and ensure that the stack is
896 897
                  // in a reasonable state for the GC and so that
                  // execution of this BCO can continue when we resume
898
                  ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
899 900 901
                  Sp -= 8;
                  Sp[7] = (W_)obj;
                  Sp[6] = (W_)&stg_apply_interp_info;
902 903 904 905
                  Sp[5] = (W_)new_aps;                 // the AP_STACK
                  Sp[4] = (W_)BCO_PTR(arg3_freeVars);  // the info about local vars of the breakpoint
                  Sp[3] = (W_)False_closure;            // True <=> a breakpoint
                  Sp[2] = (W_)&stg_ap_pppv_info;
906 907 908 909 910 911
                  Sp[1] = (W_)ioAction;                // apply the IO action to its two arguments above
                  Sp[0] = (W_)&stg_enter_info;         // get ready to run the IO action
                  // set the flag in the TSO to say that we are now
                  // stopping at a breakpoint so that when we resume
                  // we don't stop on the same breakpoint that we
                  // already stopped at just now
912 913
                  cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;

914 915 916
                  // stop this thread and return to the scheduler -
                  // eventually we will come back and the IO action on
                  // the top of the stack will be executed
917 918 919 920 921 922 923 924 925 926
                  RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
               }
            }
            // record that this thread is not stopped at a breakpoint anymore
            cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;

            // continue normal execution of the byte code instructions
	    goto nextInsn;
        }

927 928 929 930
	case bci_STKCHECK: {
	    // Explicit stack check at the beginning of a function
	    // *only* (stack checks in case alternatives are
	    // propagated to the enclosing function).
931
	    StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
932
	    if (Sp - stk_words_reqd < SpLim) {
933 934 935
		Sp -= 2; 
		Sp[1] = (W_)obj; 
		Sp[0] = (W_)&stg_apply_interp_info;
936
		RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
937 938
	    } else {
		goto nextInsn;
939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969
	    }
	}

	case bci_PUSH_L: {
	    int o1 = BCO_NEXT;
	    Sp[-1] = Sp[o1];
	    Sp--;
	    goto nextInsn;
	}

	case bci_PUSH_LL: {
	    int o1 = BCO_NEXT;
	    int o2 = BCO_NEXT;
	    Sp[-1] = Sp[o1];
	    Sp[-2] = Sp[o2];
	    Sp -= 2;
	    goto nextInsn;
	}

	case bci_PUSH_LLL: {
	    int o1 = BCO_NEXT;
	    int o2 = BCO_NEXT;
	    int o3 = BCO_NEXT;
	    Sp[-1] = Sp[o1];
	    Sp[-2] = Sp[o2];
	    Sp[-3] = Sp[o3];
	    Sp -= 3;
	    goto nextInsn;
	}

	case bci_PUSH_G: {
970
	    int o1 = BCO_GET_LARGE_ARG;
971 972 973 974 975 976
	    Sp[-1] = BCO_PTR(o1);
	    Sp -= 1;
	    goto nextInsn;
	}

	case bci_PUSH_ALTS: {
977
	    int o_bco  = BCO_GET_LARGE_ARG;
978
	    Sp[-2] = (W_)&stg_ctoi_R1p_info;
979 980 981 982 983 984
	    Sp[-1] = BCO_PTR(o_bco);
	    Sp -= 2;
	    goto nextInsn;
	}

	case bci_PUSH_ALTS_P: {
985
	    int o_bco  = BCO_GET_LARGE_ARG;
986
	    Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
987 988 989 990 991 992
	    Sp[-1] = BCO_PTR(o_bco);
	    Sp -= 2;
	    goto nextInsn;
	}

	case bci_PUSH_ALTS_N: {
993
	    int o_bco  = BCO_GET_LARGE_ARG;
994
	    Sp[-2] = (W_)&stg_ctoi_R1n_info;
995 996 997 998 999 1000
	    Sp[-1] = BCO_PTR(o_bco);
	    Sp -= 2;
	    goto nextInsn;
	}

	case bci_PUSH_ALTS_F: {
1001
	    int o_bco  = BCO_GET_LARGE_ARG;
1002
	    Sp[-2] = (W_)&stg_ctoi_F1_info;
1003 1004 1005 1006 1007 1008
	    Sp[-1] = BCO_PTR(o_bco);
	    Sp -= 2;
	    goto nextInsn;
	}

	case bci_PUSH_ALTS_D: {
1009
	    int o_bco  = BCO_GET_LARGE_ARG;
1010
	    Sp[-2] = (W_)&stg_ctoi_D1_info;
1011 1012 1013 1014 1015 1016
	    Sp[-1] = BCO_PTR(o_bco);
	    Sp -= 2;
	    goto nextInsn;
	}

	case bci_PUSH_ALTS_L: {
1017
	    int o_bco  = BCO_GET_LARGE_ARG;
1018
	    Sp[-2] = (W_)&stg_ctoi_L1_info;
1019 1020 1021 1022 1023 1024
	    Sp[-1] = BCO_PTR(o_bco);
	    Sp -= 2;
	    goto nextInsn;
	}

	case bci_PUSH_ALTS_V: {
1025
	    int o_bco  = BCO_GET_LARGE_ARG;
1026
	    Sp[-2] = (W_)&stg_ctoi_V_info;
1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067
	    Sp[-1] = BCO_PTR(o_bco);
	    Sp -= 2;
	    goto nextInsn;
	}

	case bci_PUSH_APPLY_N:
	    Sp--; Sp[0] = (W_)&stg_ap_n_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_V:
	    Sp--; Sp[0] = (W_)&stg_ap_v_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_F:
	    Sp--; Sp[0] = (W_)&stg_ap_f_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_D:
	    Sp--; Sp[0] = (W_)&stg_ap_d_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_L:
	    Sp--; Sp[0] = (W_)&stg_ap_l_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_P:
	    Sp--; Sp[0] = (W_)&stg_ap_p_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_PP:
	    Sp--; Sp[0] = (W_)&stg_ap_pp_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_PPP:
	    Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_PPPP:
	    Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_PPPPP:
	    Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
	    goto nextInsn;
	case bci_PUSH_APPLY_PPPPPP:
	    Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
	    goto nextInsn;
	    
	case bci_PUSH_UBX: {
	    int i;
1068
	    int o_lits = BCO_GET_LARGE_ARG;