https://github.com/ghc/ghc/blob/master/rts/Interpreter.cSo safe, pure and functional.
/* Sp points to the lowest live word on the stack. */
#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]))
#define LOAD_STACK_POINTERS \
Sp = cap->r.rCurrentTSO->stackobj->sp; \
/* We don't change this ... */ \
SpLim = tso_SpLim(cap->r.rCurrentTSO);
#define SAVE_STACK_POINTERS \
cap->r.rCurrentTSO->stackobj->sp = Sp
#define RETURN_TO_SCHEDULER(todo,retcode) \
SAVE_STACK_POINTERS; \
cap->r.rCurrentTSO->what_next = (todo); \
threadPaused(cap,cap->r.rCurrentTSO); \
cap->r.rRet = (retcode); \
return cap;
#define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \
SAVE_STACK_POINTERS; \
cap->r.rCurrentTSO->what_next = (todo); \
cap->r.rRet = (retcode); \
return cap;
STATIC_INLINE StgPtr
allocate_NONUPD (Capability *cap, int n_words)
{
return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
}
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,
};
cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
// goes to zero we must return to the scheduler.
if (Sp[0] == (W_)&stg_enter_info) {
Sp++;
goto eval;
}
// 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) {
obj = UNTAG_CLOSURE((StgClosure *)Sp[1]);
Sp += 2;
goto run_BCO_fun;
}
else {
goto do_return_unboxed;
}
// Evaluate the object on top of the stack.
eval:
tagged_obj = (StgClosure*)Sp[0]; Sp++;
eval_obj:
obj = UNTAG_CLOSURE(tagged_obj);
INTERP_TICK(it_total_evals);
IF_DEBUG(interpreter,
debugBelch(
"\n---------------------------------------------------------------\n");
debugBelch("Evaluating: "); printObj(obj);
debugBelch("Sp = %p\n", Sp);
debugBelch("\n" );
printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
debugBelch("\n\n");
);
// IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
IF_DEBUG(sanity,checkStackFrame(Sp));
switch ( get_itbl(obj)->type ) {
case IND:
case IND_PERM:
case IND_STATIC:
{
tagged_obj = ((StgInd*)obj)->indirectee;
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:
{
ASSERT(((StgBCO *)obj)->arity > 0);
break;
}
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;
Sp[1] = (W_)tagged_obj;
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((StgClosure *)__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];
}
obj = UNTAG_CLOSURE((StgClosure*)ap->fun);
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,
debugBelch("evaluating unknown closure -- yielding to sched\n");
printObj(obj);
);
Sp -= 2;
Sp[1] = (W_)tagged_obj;
Sp[0] = (W_)&stg_enter_info;
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
}
}