Beispiel #1
0
static lref_t *find_matching_escape(lref_t *start_frame, lref_t tag)
{
     if (CURRENT_TIB()->escape_frame != NULL)
          start_frame = fstack_prev_frame(CURRENT_TIB()->escape_frame);

     dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: looking for escape tag ~a\n"), tag));

     for(lref_t *frame = start_frame; frame != NULL; frame = fstack_prev_frame(frame))
     {
          if (fstack_frame_type(frame) != FRAME_ESCAPE)
               continue;

          lref_t ftag = frame[FOFS_ESCAPE_TAG];

          dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: frame: ~c&, tag ~a\n"), frame, ftag));

          if (NULLP(ftag) || EQ(ftag, tag)) {
               return frame;
          }
     }

     dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: No escape frame for tag ~a\n"), tag));

     return NULL;
}
Beispiel #2
0
/* Frame stack
 *
 * The interpreter stack. This is used in a very similar fashion
 * to the traditional C stack, with CURRENT_TIB()->frame and
 * CURRENT_TIB()->fsp serving as base and stack pointers,
 * respectively.
 */
EVAL_INLINE void *fstack_alloca(size_t size)
{
     size = (size / sizeof(lref_t)) + 1;

     CURRENT_TIB()->fsp = CURRENT_TIB()->fsp - size;

     return (void *)(CURRENT_TIB()->fsp);
}
Beispiel #3
0
lref_t lifoplog_enable(lref_t enablep)
{
     lref_t prev = boolcons(CURRENT_TIB()->foplog_enable);

     CURRENT_TIB()->foplog_enable = TRUEP(enablep);

     return prev;
}
Beispiel #4
0
lref_t lifoplog_reset()
{
     for(int ii = 0; ii < FOPLOG_SIZE; ii++)
          CURRENT_TIB()->foplog[ii] = NIL;

     CURRENT_TIB()->foplog_index = 0;

     return NIL;
}
Beispiel #5
0
EVAL_INLINE void fstack_enter_frame(enum frame_type_t ft)
{
     CURRENT_TIB()->count_enter_frame++;

     fstack_push((lref_t)(CURRENT_TIB()->frame));

     CURRENT_TIB()->frame = CURRENT_TIB()->fsp;

     fstack_push((lref_t)ft);
}
Beispiel #6
0
EVAL_INLINE lref_t *fstack_enter_frame(enum frame_type_t ft, size_t slots)
{
     lref_t *prev_frame = CURRENT_TIB()->frame;
     lref_t *frame = CURRENT_TIB()->fsp - 1;

     CURRENT_TIB()->frame = frame;;
     CURRENT_TIB()->fsp = CURRENT_TIB()->frame - 1 - slots;

     frame[FOFS_LINK] = (lref_t)prev_frame;
     frame[FOFS_FTYPE] = (lref_t)ft;

     return frame;
}
Beispiel #7
0
lref_t lifoplog_snapshot()
{
     lref_t result = vectorcons(FOPLOG_SIZE, fixcons(-1));

     for(int ii = 0; ii < FOPLOG_SIZE; ii++)
          SET_VECTOR_ELEM(result, ii, CURRENT_TIB()->foplog[ii]);

     return result;
}
Beispiel #8
0
EVAL_INLINE jmp_buf *fstack_enter_catch_frame(lref_t tag, lref_t *escape_frame) {
     lref_t *frame = fstack_enter_frame(FRAME_ESCAPE, 3);

     frame[FOFS_ESCAPE_TAG] = tag;
     frame[FOFS_ESCAPE_FRAME] = (lref_t)CURRENT_TIB()->frame;
     frame[FOFS_ESCAPE_JMPBUF_PTR] = (lref_t)fstack_alloca(sizeof(jmp_buf));

     return (jmp_buf *)frame[FOFS_ESCAPE_JMPBUF_PTR];
}
Beispiel #9
0
lref_t topmost_primitive()
{
     for(lref_t *frame = CURRENT_TIB()->frame; frame != NULL; frame = fstack_prev_frame(frame))
     {
          if (fstack_frame_type(frame) == FRAME_SUBR)
               return frame[FOFS_SUBR_SUBR];
     }

     return NIL;
}
Beispiel #10
0
void unwind_stack_for_throw()
{
     for(lref_t *frame = CURRENT_TIB()->frame; frame != NULL; frame = fstack_prev_frame(frame))
     {
          if (fstack_frame_type(frame) == FRAME_UNWIND)
          {
               dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw invoking unwind, frame: ~c&\n"), frame));

               apply1(frame[FOFS_UNWIND_AFTER], 0, NULL);

               continue;
          }

          if (fstack_frame_type(frame) != FRAME_ESCAPE)
               continue;

          if (frame == CURRENT_TIB()->escape_frame)
          {
               jmp_buf *jmpbuf = (jmp_buf *)frame[FOFS_ESCAPE_JMPBUF_PTR];

               dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: longjmp to frame: ~c&, jmpbuf: ~c&\n"), frame, jmpbuf));

               CURRENT_TIB()->escape_frame = NULL;

               CURRENT_TIB()->frame = (lref_t *)frame[FOFS_ESCAPE_FRAME];
               CURRENT_TIB()->fsp = CURRENT_TIB()->frame + 1;

               longjmp(*jmpbuf, 1);
          }
     }
}
Beispiel #11
0
void unwind_stack_for_throw()
{
     for(lref_t *frame = CURRENT_TIB()->frame;
         frame != NULL;
         frame = fstack_prev_frame(frame))
     {
          if (fstack_frame_type(frame) == FRAME_UNWIND)
          {
               dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw invoking unwind : ~c&\n"), frame));

               apply1(frame[FOFS_UNWIND_AFTER], 0, NULL);

               continue;
          }

          if (fstack_frame_type(frame) != FRAME_ESCAPE)
               continue;

          if (frame == CURRENT_TIB()->escape_frame)
          {
               dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: setjmp (from fsp=~c&) to target frame: ~c&\n"), CURRENT_TIB()->fsp, frame));

               CURRENT_TIB()->escape_frame = NULL;

               CURRENT_TIB()->frame = (lref_t *)frame[FOFS_ESCAPE_FRAME];
               CURRENT_TIB()->fsp = CURRENT_TIB()->frame + 1;

               longjmp((struct __jmp_buf_tag *)frame[FOFS_ESCAPE_JMPBUF_PTR], 1);
          }
     }
}
Beispiel #12
0
lref_t ltime_apply0(lref_t fn)
{
     if (!PROCEDUREP(fn))
          vmerror_wrong_type_n(1, fn);

     flonum_t t = sys_runtime();
     flonum_t gc_t = interp.gc_total_run_time;
     size_t cells = interp.gc_total_cells_allocated;
     size_t fops = CURRENT_TIB()->count_fop;
     size_t frames = CURRENT_TIB()->count_enter_frame;

     lref_t argv[6];

     argv[0] = apply1(fn, 0, NULL);
     argv[1] = flocons(sys_runtime() - t);
     argv[2] = flocons(interp.gc_total_run_time - gc_t);
     argv[3] = fixcons(interp.gc_total_cells_allocated - cells);
     argv[4] = fixcons(CURRENT_TIB()->count_fop - fops);
     argv[5] = fixcons(CURRENT_TIB()->count_enter_frame - frames);

     return lvector(6, argv);
}
Beispiel #13
0
lref_t vmtrap(enum trap_type_t trap, enum vmt_options_t options, size_t argc, ...)
{
     assert((trap > 0) && (trap <= TRAP_LAST));
     assert(argc < ARG_BUF_LEN);

     dscwritef(DF_SHOW_TRAPS, (_T("; DEBUG: trap : ~cS\n"),
                               trap_type_name(trap)));

     lref_t handler = interp.trap_handlers[trap];

     if (!PROCEDUREP(handler))
     {
          if(!NULLP(handler))
               vmtrap_panic(trap, "bad trap handler");

          if (!(options & VMT_OPTIONAL_TRAP))
               vmtrap_panic(trap, "missing trap handler");

          return NIL;
     }

     lref_t retval = NIL;
     va_list args;

     va_start(args, argc);

     lref_t argv[ARG_BUF_LEN];

     argv[0] = fixcons(trap);
     argv[1] = fixcons((fixnum_t)CURRENT_TIB()->frame);
     for (size_t ii = 2; ii < argc + 2; ii++)
          argv[ii] = va_arg(args, lref_t);

     va_end(args);

     retval = apply1(handler, argc + 2, argv);

     if (options & VMT_HANDLER_MUST_ESCAPE)
          vmtrap_panic(trap, "trap handler must escape");

     return retval;
}
Beispiel #14
0
void scan_postmortem_dump()
{
#if 0
     lref_t oport = CURRENT_DEBUG_PORT();

     for(frame_t *frame = CURRENT_TIB()->frame;
         frame != NULL;
         frame = frame->prev_frame)
     {
          scwritef(_T("\n*** FRAME=~cd: "), oport, frame);

          switch (frame->type)
          {
          case FRAME_EVAL:
               scwritef(_T("eval > ~s in ~s\n"), oport, *frame->as.eval.form,
                        frame->as.eval.initial_form);
               break;

          case FRAME_ESCAPE:
               scwritef(_T("try > ~s\n"), oport, frame->as.escape.tag);
               break;

          case FRAME_UNWIND:
               scwritef(_T("unwind-protect >\n"), oport);
               break;

          case FRAME_SUBR:
               scwritef(_T("subr > ~s\n"), oport, frame->as.subr.subr);
               break;

          default:
               scwritef(_T("<< INVALID-FRAME-TYPE >>\n"), oport);
               break;
          }

          lflush_port(oport);
     }
#endif
}
Beispiel #15
0
void init0(int argc, _TCHAR * argv[], enum debug_flag_t initial_debug_flags)
{

     global_environment_asserts();

     previous_panic_handler = set_panic_handler(scan_panic_handler);

    /** Initialize the interpreter globals */
     memset(&interp, 0, sizeof(interp));

     /*  We need the debug flags pretty early on, so that we know how
      *  to set up debugger I/O. */
     interp.debug_flags = debug_flags_from_environment(initial_debug_flags);

     init_debugger_output();

     interp.init_load_file_count = 0;

     interp.intr_pending = VMINTR_NONE;
     interp.intr_masked = false;

     interp.launch_realtime = sys_runtime();

     interp.fasl_package_list = NIL;
     gc_protect(_T("fasl-package-list"), &interp.fasl_package_list, 1);

     /*  Statistics Counters */
     interp.gc_heap_segment_size = DEFAULT_HEAP_SEGMENT_SIZE;
     interp.gc_max_heap_segments = DEFAULT_MAX_HEAP_SEGMENTS;
     interp.gc_current_heap_segments = 0;
     interp.gc_heap_segments = NULL;

     interp.gc_total_cells_allocated = 0;

     interp.gc_malloc_bytes_threshold = (sizeof(struct lobject_t) * interp.gc_heap_segment_size);

     interp.gc_total_run_time = 0.0;
     interp.gc_start_time = 0.0;

     interp.thread.fsp = &(interp.thread.frame_stack[FRAME_STACK_SIZE]);
     interp.thread.frame = NULL;

     process_vm_arguments(argc, argv);

     if (interp.debug_flags != DF_NONE)
          dscwritef(DF_ALWAYS, ("; DEBUG: debug_flags=0x~cx\n", interp.debug_flags));

    /*** Create the gc heap and populate it with the standard objects */
     gc_initialize_heap();

     create_initial_packages();
     init_base_scheme_objects();
     init_stdio_ports();

     register_main_subrs();

     gc_protect(_T("handler-frames"), &(CURRENT_TIB()->handler_frames), 1);

     gc_protect(_T("frame-stack"), (struct lobject_t **)&(CURRENT_TIB()->frame_stack[0]), sizeof(CURRENT_TIB()->frame_stack) / sizeof(lref_t));

     accept_command_line_arguments(argc, argv);

     load_init_load_files();
}
Beispiel #16
0
static lref_t execute_fast_op(lref_t fop, lref_t env)
{
     lref_t retval = NIL;
     lref_t sym;
     lref_t binding;
     lref_t fn;
     lref_t args;
     size_t argc;
     lref_t argv[ARG_BUF_LEN];
     lref_t after;
     lref_t tag;
     lref_t cell;
     lref_t escape_retval;
     jmp_buf *jmpbuf;

     STACK_CHECK(&fop);
     _process_interrupts();

     fstack_enter_eval_frame(&fop, fop, env);

     while(!NULLP(fop)) {
          switch(fop->header.opcode)
          {
          case FOP_LITERAL:
               retval = fop->as.fast_op.arg1;
               fop = fop->as.fast_op.next;
               break;

          case FOP_GLOBAL_REF:
               sym = fop->as.fast_op.arg1;
               binding = SYMBOL_VCELL(sym);

               if (UNBOUND_MARKER_P(binding))
                    vmerror_unbound(sym);

               retval = binding;

               fop = fop->as.fast_op.next;
               break;

          case FOP_GLOBAL_SET:
               sym = fop->as.fast_op.arg1;
               binding = SYMBOL_VCELL(sym);

               if (UNBOUND_MARKER_P(binding))
                    vmerror_unbound(sym);

               SET_SYMBOL_VCELL(sym, retval);

               fop = fop->as.fast_op.next;
               break;

          case FOP_APPLY_GLOBAL:
               sym = fop->as.fast_op.arg1;
               fn = SYMBOL_VCELL(sym);

               if (UNBOUND_MARKER_P(fn))
                    vmerror_unbound(sym);

               argc = 0;
               args = fop->as.fast_op.arg2;

               while (CONSP(args)) {
                    if (argc >= ARG_BUF_LEN) {
                         vmerror_unsupported(_T("too many actual arguments"));
                         break;
                    }

                    argv[argc] = execute_fast_op(CAR(args), env);

                    args = CDR(args);
                    argc++;
               }

               if (!NULLP(args))
                    vmerror_arg_out_of_range(fop->as.fast_op.arg2,
                                             _T("bad formal argument list"));

               fop = apply(fn, argc, argv, &env, &retval);
               break;

          case FOP_APPLY:
               argc = 0;
               fn = execute_fast_op(fop->as.fast_op.arg1, env);
               args = fop->as.fast_op.arg2;

               while (CONSP(args)) {
                    if (argc >= ARG_BUF_LEN) {
                         vmerror_unsupported(_T("too many actual arguments"));
                         break;
                    }

                    argv[argc] = execute_fast_op(CAR(args), env);

                    args = CDR(args);
                    argc++;
               }

               if (!NULLP(args))
                    vmerror_arg_out_of_range(fop->as.fast_op.arg2,
                                             _T("bad formal argument list"));

               fop = apply(fn, argc, argv, &env, &retval);
               break;

          case FOP_IF_TRUE:
               if (TRUEP(retval))
                    fop = fop->as.fast_op.arg1;
               else
                    fop = fop->as.fast_op.arg2;
               break;

          case FOP_RETVAL:
               fop = fop->as.fast_op.next;
               break;

          case FOP_SEQUENCE:
               retval = execute_fast_op(fop->as.fast_op.arg1, env);

               fop = fop->as.fast_op.arg2;
               break;

          case FOP_THROW:
               tag = execute_fast_op(fop->as.fast_op.arg1, env);
               escape_retval = execute_fast_op(fop->as.fast_op.arg2, env);

               dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw ~a, retval = ~a\n"), tag, escape_retval));

               CURRENT_TIB()->escape_frame = find_matching_escape(CURRENT_TIB()->frame, tag);
               CURRENT_TIB()->escape_value = escape_retval;

               if (CURRENT_TIB()->escape_frame == NULL) {
                    /* If we don't find a matching catch for the throw, we have a
                     * problem and need to invoke a trap. */
                    vmtrap(TRAP_UNCAUGHT_THROW,
                           (enum vmt_options_t)(VMT_MANDATORY_TRAP | VMT_HANDLER_MUST_ESCAPE),
                           2, tag, escape_retval);
               }

               unwind_stack_for_throw();

               fop = fop->as.fast_op.next;
               break;

          case FOP_CATCH:
               tag = execute_fast_op(fop->as.fast_op.arg1, env);

               jmpbuf = fstack_enter_catch_frame(tag, CURRENT_TIB()->frame);

               dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: setjmp tag: ~a, frame: ~c&, jmpbuf: ~c&\n"), tag, CURRENT_TIB()->frame, jmpbuf));

               if (setjmp(*jmpbuf) == 0) {
                    retval = execute_fast_op(fop->as.fast_op.arg2, env);
               } else {
                    dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: catch, retval = ~a\n"), CURRENT_TIB()->escape_value));

                    retval = CURRENT_TIB()->escape_value;
                    CURRENT_TIB()->escape_value = NIL;
               }

               fstack_leave_frame();

               fop = fop->as.fast_op.next;
               break;

          case FOP_WITH_UNWIND_FN:
               fstack_enter_unwind_frame(execute_fast_op(fop->as.fast_op.arg1, env));

               retval = execute_fast_op(fop->as.fast_op.arg2, env);

               after = CURRENT_TIB()->frame[FOFS_UNWIND_AFTER];

               fstack_leave_frame();

               apply1(after, 0, NULL);

               fop = fop->as.fast_op.next;
               break;

          case FOP_CLOSURE:
               retval = lclosurecons(env,
                                     lcons(lcar(fop->as.fast_op.arg1),
                                           fop->as.fast_op.arg2),
                                     lcdr(fop->as.fast_op.arg1));
               fop = fop->as.fast_op.next;
               break;

          case FOP_CAR:
               retval = lcar(retval);
               fop = fop->as.fast_op.next;
               break;

          case FOP_CDR:
               retval = lcdr(retval);
               fop = fop->as.fast_op.next;
               break;

          case FOP_NOT:
               retval = boolcons(!TRUEP(retval));
               fop = fop->as.fast_op.next;
               break;

          case FOP_NULLP:
               retval = boolcons(NULLP(retval));
               fop = fop->as.fast_op.next;
               break;

          case FOP_EQP:
               retval = boolcons(EQ(execute_fast_op(fop->as.fast_op.arg1, env),
                                    execute_fast_op(fop->as.fast_op.arg2, env)));
               fop = fop->as.fast_op.next;
               break;

          case FOP_GET_ENV:
               retval = env;
               fop = fop->as.fast_op.next;
               break;

          case FOP_GLOBAL_DEF: // three args, third was genv, but currently unused
               retval = lidefine_global(fop->as.fast_op.arg1, fop->as.fast_op.arg2);
               fop = fop->as.fast_op.next;
               break;

          case FOP_GET_FSP:
               retval = fixcons((fixnum_t)CURRENT_TIB()->fsp);
               fop = fop->as.fast_op.next;
               break;

          case FOP_GET_FRAME:
               retval = fixcons((fixnum_t)CURRENT_TIB()->frame);
               fop = fop->as.fast_op.next;
               break;

          case FOP_GET_HFRAMES:
               retval = CURRENT_TIB()->handler_frames;
               fop = fop->as.fast_op.next;
               break;

          case FOP_SET_HFRAMES:
               CURRENT_TIB()->handler_frames = execute_fast_op(fop->as.fast_op.arg1, env);
               fop = fop->as.fast_op.next;
               break;

          case FOP_GLOBAL_PRESERVE_FRAME:
               sym = fop->as.fast_op.arg1;
               binding = SYMBOL_VCELL(sym);

               if (UNBOUND_MARKER_P(binding))
                    vmerror_unbound(sym);

               SET_SYMBOL_VCELL(sym, fixcons((fixnum_t)CURRENT_TIB()->frame));

               retval = execute_fast_op(fop->as.fast_op.arg2, env);
               fop = fop->as.fast_op.next;
               break;

          case FOP_STACK_BOUNDARY:
               sym = execute_fast_op(fop->as.fast_op.arg1, env);

               fstack_enter_boundary_frame(sym);

               retval = execute_fast_op(fop->as.fast_op.arg2, env);

               fstack_leave_frame();

               fop = fop->as.fast_op.next;
               break;

          case FOP_FAST_ENQUEUE_CELL:
               retval = execute_fast_op(fop->as.fast_op.arg2, env);

               cell = execute_fast_op(fop->as.fast_op.arg1, env);

               SET_CDR(CAR(retval), cell);
               SET_CAR(retval, cell);

               fop = fop->as.fast_op.next;
               break;

          case FOP_WHILE_TRUE:
               while(TRUEP(execute_fast_op(fop->as.fast_op.arg1, env))) {
                    retval = execute_fast_op(fop->as.fast_op.arg2, env);
               }
               fop = fop->as.fast_op.next;
               break;

          case FOP_LOCAL_REF_BY_INDEX:
               retval = lenvlookup_by_index(FIXNM(fop->as.fast_op.arg1),
                                            FIXNM(fop->as.fast_op.arg2),
                                            env);
               fop = fop->as.fast_op.next;
               break;

          case FOP_LOCAL_REF_RESTARG:
               retval = lenvlookup_restarg_by_index(FIXNM(fop->as.fast_op.arg1),
                                                    FIXNM(fop->as.fast_op.arg2),
                                                    env);
               fop = fop->as.fast_op.next;
               break;

          case FOP_LOCAL_SET_BY_INDEX:
               lenvlookup_set_by_index(FIXNM(fop->as.fast_op.arg1),
                                       FIXNM(fop->as.fast_op.arg2),
                                       env,
                                       retval);
               fop = fop->as.fast_op.next;
               break;

          default:
               panic("Unsupported fast-op");
          }
     }

     fstack_leave_frame();

     return retval;
}
Beispiel #17
0
EVAL_INLINE void fstack_push(lref_t val)
{
     *(--CURRENT_TIB()->fsp) = val;
}
Beispiel #18
0
EVAL_INLINE void fstack_leave_frame()
{
     CURRENT_TIB()->fsp = CURRENT_TIB()->frame + 1;
     CURRENT_TIB()->frame = *(lref_t **)(CURRENT_TIB()->frame);
}