static void ase_metric_prnt(Lisp_Object obj, Lisp_Object pcf, int unused) { EMOD_ASE_DEBUG_METR("m:0x%08x@0x%08x (rc:%d)\n", (unsigned int)(XASE_METRIC(obj)), (unsigned int)obj, 1); write_c_string("#<", pcf); print_internal(XDYNACAT_TYPE(obj), pcf, unused); { if (NILP(XASE_METRIC_LDIST(obj))) { write_hex_ptr(XASE_METRIC_DIST(obj),pcf); } else { Lisp_Object ldist = XASE_METRIC_LDIST(obj); if (SYMBOLP(ldist)) { Lisp_String *name = symbol_name(XSYMBOL(ldist)); write_fmt_string(pcf, " #'%s", string_data(name)); } else if (SUBRP(ldist)) { const char *name = subr_name(XSUBR(ldist)); write_fmt_string(pcf, " #'%s", name); } else { write_c_string(" #'(lambda ...)", pcf); } } } write_c_string(">", pcf); return; }
void VM::display_subr_profile() { scm_hashtable_t ht = m_heap->m_system_environment->variable; hashtable_rec_t* ht_datum = ht->datum; int n = ht_datum->capacity; printf("%36s: %12s %12s %12s %14s\n", "subr", "push", "load", "apply", "total"); for (int i = 0; i < n; i++) { if (SYMBOLP(ht_datum->elts[i])){ scm_symbol_t symbol = (scm_symbol_t)ht_datum->elts[i]; scm_gloc_t gloc = (scm_gloc_t)ht_datum->elts[n + i]; if (GLOCP(gloc)) { scm_subr_t subr = (scm_subr_t)gloc->value; if (SUBRP(subr)) { if (subr->c_push + subr->c_load + subr->c_apply != 0) { printf("%36s: %12llu %12llu %12llu %14llu\n", symbol->name, subr->c_push, subr->c_load, subr->c_apply, subr->c_push + subr->c_load + subr->c_apply); } } } } } }
static void store_function_docstring (Lisp_Object obj, ptrdiff_t offset) { /* Don't use indirect_function here, or defaliases will apply their docstrings to the base functions (Bug#2603). */ Lisp_Object fun = SYMBOLP (obj) ? XSYMBOL (obj)->function : obj; /* The type determines where the docstring is stored. */ /* Lisp_Subrs have a slot for it. */ if (SUBRP (fun)) { intptr_t negative_offset = - offset; XSUBR (fun)->doc = (char *) negative_offset; } /* If it's a lisp form, stick it in the form. */ else if (CONSP (fun)) { Lisp_Object tem; tem = XCAR (fun); if (EQ (tem, Qlambda) || EQ (tem, Qautoload) || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1))) { tem = Fcdr (Fcdr (fun)); if (CONSP (tem) && INTEGERP (XCAR (tem))) /* FIXME: This modifies typically pure hash-cons'd data, so its correctness is quite delicate. */ XSETCAR (tem, make_number (offset)); } else if (EQ (tem, Qmacro)) store_function_docstring (XCDR (fun), offset); } /* Bytecode objects sometimes have slots for it. */ else if (COMPILEDP (fun)) { /* This bytecode object must have a slot for the docstring, since we've found a docstring for it. */ if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING) ASET (fun, COMPILED_DOC_STRING, make_number (offset)); else { AUTO_STRING (format, "No docstring slot for %s"); CALLN (Fmessage, format, (SYMBOLP (obj) ? SYMBOL_NAME (obj) : build_string ("<anonymous>"))); } } }
static void store_function_docstring (Lisp_Object obj, EMACS_INT offset) /* Use EMACS_INT because we get offset from pointer subtraction. */ { /* Don't use indirect_function here, or defaliases will apply their docstrings to the base functions (Bug#2603). */ Lisp_Object fun = SYMBOLP (obj) ? XSYMBOL (obj)->function : obj; /* The type determines where the docstring is stored. */ /* Lisp_Subrs have a slot for it. */ if (SUBRP (fun)) { intptr_t negative_offset = - offset; XSUBR (fun)->doc = (char *) negative_offset; } /* If it's a lisp form, stick it in the form. */ else if (CONSP (fun)) { Lisp_Object tem; tem = XCAR (fun); if (EQ (tem, Qlambda) || EQ (tem, Qautoload) || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1))) { tem = Fcdr (Fcdr (fun)); if (CONSP (tem) && INTEGERP (XCAR (tem))) XSETCAR (tem, make_number (offset)); } else if (EQ (tem, Qmacro)) store_function_docstring (XCDR (fun), offset); } /* Bytecode objects sometimes have slots for it. */ else if (COMPILEDP (fun)) { /* This bytecode object must have a slot for the docstring, since we've found a docstring for it. */ if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING) ASET (fun, COMPILED_DOC_STRING, make_number (offset)); } }
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; }
static void fast_read_loader_application(lref_t reader, enum fasl_opcode_t opcode) { assert(FASL_READER_P(reader)); size_t argc = 0; lref_t argv[FAST_LOAD_STACK_DEPTH]; fast_read(reader, &argv[0], false); if (!(SUBRP(argv[0]) || CLOSUREP(argv[0]))) vmerror_fast_read(_T("Invalid function to apply"), reader, NIL); if (opcode == FASL_OP_LOADER_APPLYN) { lref_t ac; fast_read(reader, &ac, false); if (!FIXNUMP(ac)) vmerror_fast_read("Expected fixnum for loader application argc", reader, ac); argc = (size_t)FIXNM(ac); if (argc > FAST_LOAD_STACK_DEPTH) /* Assuming FAST_LOAD_STACK_DEPTH <= ARG_BUF_LEN - 2 */ vmerror_fast_read("Loader application, argc < FAST_LOAD_STACK_DEPTH", reader, ac); for(size_t ii = 0; ii < argc; ii++) argv[ii + 1] = fast_loader_stack_pop(reader); /* Fake a final NIL argument so that we can pass in the argv arguments * as scalars rather than as a list. */ argc++; argv[argc] = NIL; } else if (opcode != FASL_OP_LOADER_APPLY0) panic("invalid opcode in fast_read_loader_application"); dscwritef(DF_SHOW_FAST_LOAD_FORMS, (_T("; DEBUG: FASL applying ~s (argc=~cd)\n"), argv[0], argc)); FASL_READER_STREAM(reader)->accum = lapply(argc + 1, argv); }
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; }