object make_closure(object proc, object env) { object result; gc_tmp1 = proc; gc_tmp2 = env; result = make_heap_object(CLOSURE_TYPE, sizeof(struct closure_heap_structure)); CLOSURE_ENV(result) = gc_tmp2; CLOSURE_PROC(result) = gc_tmp1; return result; }
EVAL_INLINE lref_t apply(lref_t function, size_t argc, lref_t argv[], lref_t *env, lref_t *retval) { lref_t args[3]; if (SUBRP(function)) { return subr_apply(function, argc, argv, env, retval); } else if (CLOSUREP(function)) { lref_t c_code = CLOSURE_CODE(function); *env = extend_env(arg_list_from_buffer(argc, argv), CAR(c_code), CLOSURE_ENV(function)); return CDR(c_code); /* tail call */ } else if (argc > 0) { if (HASHP(function) || STRUCTUREP(function)) { args[0] = function; args[1] = argv[0]; args[2] = (argc > 1) ? argv[1] : NIL; *retval = lslot_ref(MAX2(argc + 1, 2), args); return NIL; } else if (SYMBOLP(function)) { if (HASHP(argv[0]) || STRUCTUREP(argv[0])) { args[0] = argv[0]; args[1] = function; args[2] = (argc > 1) ? argv[1] : NIL; *retval = lslot_ref(MAX2(argc + 1, 2), args); return NIL; } } } vmerror_wrong_type(function); return NIL; }
EVAL_INLINE lref_t apply(lref_t function, size_t argc, lref_t argv[], lref_t * env, lref_t * retval) { if (SUBRP(function)) return subr_apply(function, argc, argv, env, retval); if (CLOSUREP(function)) { lref_t c_code = CLOSURE_CODE(function); *env = extend_env(arg_list_from_buffer(argc, argv), CAR(c_code), CLOSURE_ENV(function)); return CDR(c_code); /* tail call */ } vmerror_wrong_type(function); return NIL; }
void garbage_collect(long min_space) { char *p; object **gcp; object *op; long i, max, count; int old_interrupt; if (*will_gc_hook) (*will_gc_hook)(); old_interrupt = enable_interrupts(0); /* switch heap space */ gc_count++; /* printf("[GC]\n"); */ heap += heap_size; if (heap >= max_heap) heap = min_memory; heap_pointer = heap; heap_end = heap + heap_size; /* migrate objects */ count = gc_root_stack_pointer - gc_root_stack_begin; migrate_object(gc_root_stack_buffer); if (FORWARDED_P(gc_root_stack_buffer)) gc_root_stack_buffer = FORWARDED_POINTER(gc_root_stack_buffer); gc_root_stack_begin = (object **)BUFFER_DATA(gc_root_stack_buffer); gc_root_stack_end = gc_root_stack_begin + GC_ROOT_STACK_MAX; gc_root_stack_pointer = gc_root_stack_begin + count; gcp = gc_root_stack_begin; for (i=0; i<count; i++) migrate_object(*gcp[i]); for (op = sp; op < stack_top; op++) migrate_object(*op); /* eliminate forwarding pointers */ gcp = gc_root_stack_begin; for (i=0; i<count; i++) { object o = *gcp[i]; if (FORWARDED_P(o)) *gcp[i] = FORWARDED_POINTER(o); } for (op = sp; op < stack_top; op++) { object o = *op; if (FORWARDED_P(o)) *op = FORWARDED_POINTER(o); } p = heap; while (p < heap_pointer) { object *q, obj, o; obj = (object)p; switch (POINTER_TYPE(obj)) { case PAIR_TYPE: o = CAR(obj); if (FORWARDED_P(o)) CAR(obj) = FORWARDED_POINTER(o); o = CDR(obj); if (FORWARDED_P(o)) CDR(obj) = FORWARDED_POINTER(o); break; case WEAK_TYPE: if (FORWARDED_P(WEAK_VALUE(obj))) { WEAK_BOUND(obj) = 1; } else { WEAK_BOUND(obj) = 0; migrate_object(WEAK_VALUE(obj)); } o = WEAK_VALUE(obj); if (FORWARDED_P(o)) WEAK_VALUE(obj) = FORWARDED_POINTER(o); break; case SYMBOL_TYPE: o = SYMBOL_VALUE(obj); if (FORWARDED_P(o)) SYMBOL_VALUE(obj) = FORWARDED_POINTER(o); break; case VECTOR_TYPE: max = VECTOR_LENGTH(obj); q = VECTOR_ELEMENTS(obj); for (i=0; i<max; i++) { o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o); } o = VECTOR_TAG(obj); if (FORWARDED_P(o)) VECTOR_TAG(obj) = FORWARDED_POINTER(o); break; case PROCEDURE_TYPE: o = PROC_MODULE(obj); if (FORWARDED_P(o)) PROC_MODULE(obj) = FORWARDED_POINTER(o); break; case FRAME_TYPE: o = FRAME_PREVIOUS(obj); if (FORWARDED_P(o)) FRAME_PREVIOUS(obj) = FORWARDED_POINTER(o); o = FRAME_ENV(obj); if (FORWARDED_P(o)) FRAME_ENV(obj) = FORWARDED_POINTER(o); max = (POINTER_LENGTH(obj) - sizeof(struct frame_heap_structure))/sizeof(long); q = FRAME_ELEMENTS(obj); for (i=0; i<max; i++) { o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o); } break; case CLOSURE_TYPE: o = CLOSURE_PROC(obj); if (FORWARDED_P(o)) CLOSURE_PROC(obj) = FORWARDED_POINTER(o); o = CLOSURE_ENV(obj); if (FORWARDED_P(o)) CLOSURE_ENV(obj) = FORWARDED_POINTER(o); break; case CONTINUATION_TYPE: o = CONTINUATION_FRAME(obj); if (FORWARDED_P(o)) CONTINUATION_FRAME(obj) = FORWARDED_POINTER(o); max = CONTINUATION_STACKSIZE(obj); q = CONTINUATION_STACK(obj); for (i=0; i<max; i++) { o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o); } break; case SYMBOLTABLE_TYPE: o = SYMBOLTABLE_MAPPINGS(obj); if (FORWARDED_P(o)) SYMBOLTABLE_MAPPINGS(obj) = FORWARDED_POINTER(o); break; case PORT_TYPE: o = PORT_BUFFER(obj); if (FORWARDED_P(o)) PORT_BUFFER(obj) = FORWARDED_POINTER(o); break; default: fatal_error("Unknown pointer type: heap.c#garbage_collect(): %p\n", obj); return; } p += POINTER_LENGTH(obj); } /* finalization of ports */ close_stale_ports(); fix_runtime_pointers(); /* Finish up */ enable_interrupts(old_interrupt); i = heap_size - (heap_pointer - heap); if (i < min_space) fatal_error("out of heap space: %d\n", i); if (*did_gc_hook) (*did_gc_hook)(); }
lref_t debug_print_object(lref_t obj, lref_t port, bool machine_readable) { _TCHAR buf[STACK_STRBUF_LEN]; if (DEBUG_FLAG(DF_PRINT_ADDRESSES)) scwritef("#@~c&=", port, obj); lref_t tmp; size_t ii; lref_t slots; const _TCHAR *fast_op_name; switch (TYPE(obj)) { case TC_NIL: WRITE_TEXT_CONSTANT(port, _T("()")); break; case TC_BOOLEAN: if (TRUEP(obj)) WRITE_TEXT_CONSTANT(port, _T("#t")); else WRITE_TEXT_CONSTANT(port, _T("#f")); break; case TC_CONS: write_char(port, _T('(')); debug_print_object(lcar(obj), port, machine_readable); for (tmp = lcdr(obj); CONSP(tmp); tmp = lcdr(tmp)) { write_char(port, _T(' ')); debug_print_object(lcar(tmp), port, machine_readable); } if (!NULLP(tmp)) { WRITE_TEXT_CONSTANT(port, _T(" . ")); debug_print_object(tmp, port, machine_readable); } write_char(port, _T(')')); break; case TC_FIXNUM: _sntprintf(buf, STACK_STRBUF_LEN, _T("%" SCAN_PRIiFIXNUM), FIXNM(obj)); write_text(port, buf, _tcslen(buf)); break; case TC_FLONUM: debug_print_flonum(obj, port, machine_readable); break; case TC_CHARACTER: if (machine_readable) { if (CHARV(obj) < CHARNAMECOUNT) scwritef(_T("#\\~cs"), port, charnames[(size_t) CHARV(obj)]); else if (CHARV(obj) >= CHAREXTENDED - 1) scwritef(_T("#\\<~cd>"), port, (int) CHARV(obj)); else scwritef(_T("#\\~cc"), port, (int) CHARV(obj)); } else scwritef(_T("~cc"), port, (int) CHARV(obj)); break; case TC_SYMBOL: if (NULLP(SYMBOL_HOME(obj))) { if (DEBUG_FLAG(DF_PRINT_FOR_DIFF)) scwritef("#:<uninterned-symbol>", port); else scwritef("#:~a@~c&", port, SYMBOL_PNAME(obj), obj); } else if (SYMBOL_HOME(obj) == interp.control_fields[VMCTRL_PACKAGE_KEYWORD]) scwritef(":~a", port, SYMBOL_PNAME(obj)); else { /* With only a minimal c-level package implementation, we * just assume every symbol is private. */ scwritef("~a::~a", port, SYMBOL_HOME(obj)->as.package.name, SYMBOL_PNAME(obj)); } break; case TC_VECTOR: WRITE_TEXT_CONSTANT(port, _T("[")); for (ii = 0; ii < obj->as.vector.dim; ii++) { debug_print_object(obj->as.vector.data[ii], port, true); if (ii + 1 < obj->as.vector.dim) write_char(port, _T(' ')); } write_char(port, _T(']')); break; case TC_STRUCTURE: WRITE_TEXT_CONSTANT(port, _T("#S(")); debug_print_object(CAR(STRUCTURE_LAYOUT(obj)), port, true); for (ii = 0, slots = CAR(CDR(STRUCTURE_LAYOUT(obj))); ii < STRUCTURE_DIM(obj); ii++, slots = CDR(slots)) { WRITE_TEXT_CONSTANT(port, _T(" ")); debug_print_object(CAR(CAR(slots)), port, true); WRITE_TEXT_CONSTANT(port, _T(" ")); debug_print_object(STRUCTURE_ELEM(obj, ii), port, true); } WRITE_TEXT_CONSTANT(port, _T(")")); break; case TC_STRING: debug_print_string(obj, port, machine_readable); break; case TC_HASH: debug_print_hash(obj, port, machine_readable); break; case TC_PACKAGE: scwritef("~u ~a", port, (lref_t) obj, obj->as.package.name); break; case TC_SUBR: scwritef("~u,~cd:~a", port, (lref_t) obj, SUBR_TYPE(obj), SUBR_NAME(obj)); break; case TC_CLOSURE: if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE)) scwritef("~u\n\tcode:~s\n\tenv:~s\n\tp-list:~s", port, (lref_t) obj, CLOSURE_CODE(obj), CLOSURE_ENV(obj), CLOSURE_PROPERTY_LIST(obj)); else scwritef("~u", port, (lref_t) obj); break; case TC_VALUES_TUPLE: scwritef("~u ~s", port, (lref_t) obj, obj->as.values_tuple.values); break; case TC_MACRO: if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE)) scwritef("~u ~s", port, (lref_t) obj, obj->as.macro.transformer); else scwritef("~u", port, (lref_t) obj); break; case TC_END_OF_FILE: scwritef("~u", port, (lref_t) obj); break; case TC_PORT: scwritef(_T("~u~cs~cs~cs ~cs ~s"), port, obj, PORT_INPUTP(obj) ? " (input)" : "", PORT_OUTPUTP(obj) ? " (output)" : "", BINARY_PORTP(obj) ? " (binary)" : "", PORT_CLASS(obj)->name, PORT_PINFO(obj)->port_name); break; case TC_FAST_OP: fast_op_name = fast_op_opcode_name(obj->header.opcode); if (fast_op_name) scwritef("#<FOP@~c&:~cs ~s ~s => ~s>", port, (lref_t) obj, fast_op_name, obj->as.fast_op.arg1, obj->as.fast_op.arg2, obj->as.fast_op.next); else scwritef("#<FOP@~c&:~cd ~s ~s => ~s>", port, (lref_t) obj, obj->header.opcode, obj->as.fast_op.arg1, obj->as.fast_op.arg2, obj->as.fast_op.next); break; case TC_FASL_READER: scwritef(_T("~u~s"), port, obj, FASL_READER_PORT(obj)); break; case TC_UNBOUND_MARKER: scwritef("#<UNBOUND-MARKER>", port); break; case TC_FREE_CELL: scwritef("#<FREE CELL -- Forget a call to gc_mark? ~c&>", port, obj); break; default: scwritef("#<INVALID OBJECT - UNKNOWN TYPE ~c&>", port, obj); } return port; }