Interpreter.c 44.2 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 34 35 36 37
// 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.
#if defined(mingw32_HOST_OS) && !defined(__PIC__)
# define LIBFFI_NOT_DLL
#endif

38
#include "ffi.h"
andy's avatar
andy committed
39

40
/* --------------------------------------------------------------------------
41
 * The bytecode interpreter
42 43
 * ------------------------------------------------------------------------*/

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

/* #define INTERP_STATS */


50
/* Sp points to the lowest live word on the stack. */
51

Ian Lynagh's avatar
Ian Lynagh committed
52 53 54 55 56 57 58 59 60
#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]))
61 62
#if WORD_SIZE_IN_BITS == 32
#define BCO_NEXT_WORD BCO_NEXT_32
Ian Lynagh's avatar
Ian Lynagh committed
63
#define BCO_READ_NEXT_WORD BCO_READ_NEXT_32
64 65
#elif WORD_SIZE_IN_BITS == 64
#define BCO_NEXT_WORD BCO_NEXT_64
Ian Lynagh's avatar
Ian Lynagh committed
66
#define BCO_READ_NEXT_WORD BCO_READ_NEXT_64
67
#else
Ian Lynagh's avatar
Ian Lynagh committed
68
#error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
69 70 71
#endif
#define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_NEXT_WORD : BCO_NEXT)

72
#define BCO_PTR(n)    (W_)ptrs[n]
73
#define BCO_LIT(n)    literals[n]
74

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

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

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

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


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

104 105
int rts_stop_next_breakpoint = 0;
int rts_stop_on_exception = 0;
106

107
#ifdef INTERP_STATS
108

109 110 111 112 113 114 115 116 117 118 119 120 121
/* 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;

122 123
int it_ofreq[27];
int it_oofreq[27][27];
124 125
int it_lastopc;

126

127 128
#define INTERP_TICK(n) (n)++

129 130 131 132 133 134 135 136
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;
137 138 139
   for (i = 0; i < 27; i++) it_ofreq[i] = 0;
   for (i = 0; i < 27; i++) 
     for (j = 0; j < 27; j++)
140 141 142 143 144 145 146
        it_oofreq[i][j] = 0;
   it_lastopc = 0;
}

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

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

   }
}

184 185 186 187 188
#else // !INTERP_STATS

#define INTERP_TICK(n) /* nothing */

#endif
189

190 191 192 193 194 195 196 197 198
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,
};

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

202
Capability *
203
interpretBCO (Capability* cap)
204
{
205 206 207 208
    // 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
209
    register StgClosure   *tagged_obj = 0, *obj;
210
    nat n, m;
211

212 213
    LOAD_STACK_POINTERS;

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

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

    // ------------------------------------------------------------------------
    // 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
247
	obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
	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:
264
    tagged_obj = (StgClosure*)Sp[0]; Sp++;
265 266

eval_obj:
267
    obj = UNTAG_CLOSURE(tagged_obj);
268 269 270
    INTERP_TICK(it_total_evals);

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

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

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

284
    switch ( get_itbl(obj)->type ) {
285

286 287 288 289
    case IND:
    case IND_PERM:
    case IND_STATIC:
    { 
290
	tagged_obj = ((StgInd*)obj)->indirectee;
291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
	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:
314
    {
315
	ASSERT(((StgBCO *)obj)->arity > 0);
316
	break;
317
    }
318 319 320 321 322 323 324 325 326 327 328 329

    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;
330
	    Sp[1] = (W_)tagged_obj;
331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
	    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;
	    SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
	    __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
350
	obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368
	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,
369
		 debugBelch("evaluating unknown closure -- yielding to sched\n"); 
370 371 372
		 printObj(obj);
	    );
	Sp -= 2;
373
	Sp[1] = (W_)tagged_obj;
374
	Sp[0] = (W_)&stg_enter_info;
375
	RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
376 377 378 379
    }
    }

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

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

396
    IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size));
397 398 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

    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.
444 445 446 447 448 449 450 451
        //
        // 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.
452
	INTERP_TICK(it_retto_UPDATE);
453 454
        updateThunk(cap, cap->r.rCurrentTSO, 
                    ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
455 456 457 458 459 460 461 462 463
	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;
464 465
        // NB. return the untagged object; the bytecode expects it to
        // be untagged.  XXX this doesn't seem right.
466 467 468 469 470 471 472 473 474 475
	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,
476
		 debugBelch("returning to unknown frame -- yielding to sched\n"); 
477
                 printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
478 479
	    );
	Sp -= 2;
480
	Sp[1] = (W_)tagged_obj;
481
	Sp[0] = (W_)&stg_enter_info;
482
	RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
    }
    }

    // -------------------------------------------------------------------------
    // Returning an unboxed value.  The stack looks like this:
    //
    // 	  |     ....      |
    // 	  +---------------+
    // 	  |     fv2       |
    // 	  +---------------+
    // 	  |     fv1       |
    // 	  +---------------+
    // 	  |     BCO       |
    // 	  +---------------+
    // 	  | stg_ctoi_ret_ |
    // 	  +---------------+
    // 	  |    retval     |
    // 	  +---------------+
    // 	  |   XXXX_info   |
    // 	  +---------------+
    //
    // where XXXX_info is one of the stg_gc_unbx_r1_info family.
    //
    // 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;
	
	ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
		|| Sp[0] == (W_)&stg_gc_unpt_r1_info
		|| Sp[0] == (W_)&stg_gc_f1_info
		|| Sp[0] == (W_)&stg_gc_d1_info
		|| Sp[0] == (W_)&stg_gc_l1_info
		|| Sp[0] == (W_)&stg_gc_void_info // VoidRep
	    );

	// 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,
539
		     debugBelch("returning to unknown frame -- yielding to sched\n"); 
540 541
                     printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
                );
542
	    RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
543 544 545 546 547 548 549 550 551 552
	}
	}
    }
    // not reached.


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

do_apply:
553
    ASSERT(obj == UNTAG_CLOSURE(tagged_obj));
554 555 556 557 558 559 560 561
    // 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;
562
	    nat i, arity;
563 564 565 566

	    pap = (StgPAP *)obj;

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

571 572 573 574 575 576 577 578 579 580
            // 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);
            }

581 582 583 584 585 586 587 588 589 590 591
	    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++) {
592 593
		    Sp[(int)i-1] = Sp[i];
		    // ^^^^^ careful, i-1 might be negative, but i in unsigned
594 595 596 597 598 599 600 601
		}
		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
602
		obj = UNTAG_CLOSURE(pap->fun);
603 604 605 606 607 608 609
		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
610
		obj = UNTAG_CLOSURE(pap->fun);
611 612 613 614 615
		goto run_BCO_fun;
	    } 
	    else /* arity > n */ {
		// build a new PAP and return it.
		StgPAP *new_pap;
616
		new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
617 618 619 620 621 622 623 624 625 626
		SET_HDR(new_pap,&stg_PAP_info,CCCS);
		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];
		}
627
		tagged_obj = (StgClosure *)new_pap;
628 629 630 631 632 633
		Sp += m;
		goto do_return;
	    }
	}	    

	case BCO: {
634
	    nat arity, i;
635 636

	    Sp++;
637
	    arity = ((StgBCO *)obj)->arity;
638 639 640 641 642 643 644 645 646
	    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++) {
647 648
		    Sp[(int)i-1] = Sp[i];
		    // ^^^^^ careful, i-1 might be negative, but i in unsigned
649 650 651 652 653 654 655 656 657 658 659
		}
		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;
660
		nat i;
661
		pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
662 663 664 665 666 667 668
		SET_HDR(pap, &stg_PAP_info,CCCS);
		pap->arity = arity - n;
		pap->fun = obj;
		pap->n_args = m;
		for (i = 0; i < m; i++) {
		    pap->payload[i] = (StgClosure *)Sp[i];
		}
669
		tagged_obj = (StgClosure *)pap;
670 671 672 673 674 675 676 677 678
		Sp += m;
		goto do_return;
	    }
	}

	// No point in us applying machine-code functions
	default:
	defer_apply_to_sched:
	    Sp -= 2;
679
	    Sp[1] = (W_)tagged_obj;
680
	    Sp[0] = (W_)&stg_enter_info;
681
	    RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
682 683 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
    }

    // ------------------------------------------------------------------------
    // 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:

727

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

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

747 748 749 750 751 752 753 754 755 756 757 758
    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
759
    if (doYouWantToGC(cap)) {
760 761 762 763 764 765
	Sp -= 2; 
	Sp[1] = (W_)obj; 
	Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
	RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
    }
    
766 767
    // Stack check
    if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
768 769 770 771 772
	Sp -= 2; 
	Sp[1] = (W_)obj; 
	Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
	RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
    }
773

774 775 776 777 778 779 780
    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);
    {
781
	register int       bciPtr = 0; /* instruction pointer */
782
        register StgWord16 bci;
783
	register StgBCO*   bco        = (StgBCO*)obj;
784
	register StgWord16* instrs    = (StgWord16*)(bco->instrs->payload);
785 786
	register StgWord*  literals   = (StgWord*)(&bco->literals->payload[0]);
	register StgPtr*   ptrs       = (StgPtr*)(&bco->ptrs->payload[0]);
Ian Lynagh's avatar
Ian Lynagh committed
787
#ifdef DEBUG
788
	int bcoSize;
Ian Lynagh's avatar
Ian Lynagh committed
789 790 791 792
    bcoSize = BCO_READ_NEXT_WORD;
#else
    BCO_NEXT_WORD;
#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 = %d      ", 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_NEXT;  // 1st arg of break instruction
            arg2_array_index    = BCO_NEXT;  // 2nd arg of break instruction
            arg3_freeVars       = BCO_NEXT;  // 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 970 971 972 973 974 975 976 977
	    }
	}

	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: {
	    int o1 = BCO_NEXT;
	    Sp[-1] = BCO_PTR(o1);
	    Sp -= 1;
	    goto nextInsn;
	}

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

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

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

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

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

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

	case bci_PUSH_ALTS_V: {
	    int o_bco  = BCO_NEXT;
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 1068 1069 1070 1071
	    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;
	    int o_lits = BCO_NEXT;
	    int n_words = BCO_NEXT;
	    Sp -= n_words;
	    for (i = 0; i < n_words; i++) {
1072
		Sp[i] = (W_)BCO_LIT(o_lits+i);
1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090
	    }
	    goto nextInsn;
	}

	case bci_SLIDE: {
	    int n  = BCO_NEXT;
	    int by = BCO_NEXT;
	    /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
	    while(--n >= 0) {
		Sp[n+by] = Sp[n];
	    }
	    Sp += by;
	    INTERP_TICK(it_slides);
	    goto nextInsn;
	}

	case bci_ALLOC_AP: {
	    StgAP* ap; 
sof's avatar
sof committed
1091
	    int n_payload = BCO_NEXT;
1092
	    ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1093 1094 1095 1096 1097 1098 1099
	    Sp[-1] = (W_)ap;
	    ap->n_args = n_payload;
	    SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
	    Sp --;
	    goto nextInsn;
	}

1100 1101 1102
	case bci_ALLOC_AP_NOUPD: {
	    StgAP* ap; 
	    int n_payload = BCO_NEXT;
1103
	    ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
1104 1105 1106 1107 1108 1109 1110
	    Sp[-1] = (W_)ap;
	    ap->n_args = n_payload;
	    SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
	    Sp --;
	    goto nextInsn;
	}

1111 1112 1113
	case bci_ALLOC_PAP: {
	    StgPAP* pap; 
	    int arity = BCO_NEXT;
sof's avatar
sof committed
1114
	    int n_payload = BCO_NEXT;
1115
	    pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
1116 1117 1118