int
lutex_wait (tagged_lutex_t tagged_queue_lutex, tagged_lutex_t tagged_mutex_lutex)
{
int ret;
struct lutex *queue_lutex = (struct lutex*) native_pointer(tagged_queue_lutex);
struct lutex *mutex_lutex = (struct lutex*) native_pointer(tagged_mutex_lutex);
ret = pthread_cond_wait(queue_lutex->condition_variable, mutex_lutex->mutex);
lutex_assert(ret == 0);
return ret;
}
int
lutex_destroy (tagged_lutex_t tagged_lutex)
{
struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
if (lutex->condition_variable) {
pthread_cond_destroy(lutex->condition_variable);
free(lutex->condition_variable);
lutex->condition_variable = NULL;
}
if (lutex->mutex) {
pthread_mutex_destroy(lutex->mutex);
free(lutex->mutex);
lutex->mutex = NULL;
}
if (lutex->mutexattr) {
pthread_mutexattr_destroy(lutex->mutexattr);
free(lutex->mutexattr);
lutex->mutexattr = NULL;
}
return 0;
}
static void
search_cmd(char **ptr)
{
static int lastval = 0, lastcount = 0;
static lispobj *start = 0, *end = 0;
int val, count;
lispobj *addr, obj;
if (more_p(ptr)) {
val = parse_number(ptr);
if (val < 0 || val > 0xff) {
printf("can only search for single bytes\n");
return;
}
if (more_p(ptr)) {
addr = (lispobj *)native_pointer((uword_t)parse_addr(ptr));
if (more_p(ptr)) {
count = parse_number(ptr);
}
else {
/* Specified value and address, but no count. Only one. */
count = -1;
}
}
else {
/* Specified a value, but no address, so search same range. */
addr = start;
count = lastcount;
}
}
else {
/* Specified nothing, search again for val. */
val = lastval;
addr = end;
count = lastcount;
}
lastval = val;
start = end = addr;
lastcount = count;
printf("searching for 0x%x at %p\n", val, (void*)(uword_t)end);
while (search_for_type(val, &end, &count)) {
printf("found 0x%x at %p:\n", val, (void*)(uword_t)end);
obj = *end;
addr = end;
end += 2;
if (widetag_of(obj) == SIMPLE_FUN_HEADER_WIDETAG) {
print((uword_t)addr | FUN_POINTER_LOWTAG);
} else if (other_immediate_lowtag_p(obj)) {
print((lispobj)addr | OTHER_POINTER_LOWTAG);
} else {
print((lispobj)addr);
}
if (count == -1) {
return;
}
}
}
static long compute_offset(os_context_t *context, lispobj code)
{
if (code == NIL)
return 0;
else {
uword_t code_start;
struct code *codeptr = (struct code *)native_pointer(code);
#ifdef LISP_FEATURE_HPPA
uword_t pc = *os_context_pc_addr(context) & ~3;
#else
uword_t pc = *os_context_pc_addr(context);
#endif
code_start = (uword_t)codeptr
+ HeaderValue(codeptr->header)*sizeof(lispobj);
if (pc < code_start)
return 0;
else {
uword_t offset = pc - code_start;
if (offset >= (uword_t)fixnum_value(codeptr->code_size))
return 0;
else
return make_fixnum(offset);
}
}
}
static struct code *
code_pointer(lispobj object)
{
lispobj *headerp, header;
int type, len;
headerp = (lispobj *) native_pointer(object);
header = *headerp;
type = widetag_of(header);
switch (type) {
case CODE_HEADER_WIDETAG:
break;
case RETURN_PC_HEADER_WIDETAG:
case SIMPLE_FUN_HEADER_WIDETAG:
len = HEADER_LENGTH(header);
if (len == 0)
headerp = NULL;
else
headerp -= len;
break;
default:
headerp = NULL;
}
return (struct code *) headerp;
}
int
lutex_wake (tagged_lutex_t tagged_lutex, int n)
{
int ret = 0;
struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
/* The lisp-side code passes N=2**29-1 for a broadcast. */
if (n >= ((1 << 29) - 1)) {
/* CONDITION-BROADCAST */
ret = pthread_cond_broadcast(lutex->condition_variable);
lutex_assert(ret == 0);
} else{
/* We're holding the condition variable mutex, so a thread
* we're waking can't re-enter the wait between to calls to
* pthread_cond_signal. Thus we'll wake N different threads,
* instead of the same thread N times.
*/
while (n--) {
ret = pthread_cond_signal(lutex->condition_variable);
lutex_assert(ret == 0);
}
}
return ret;
}
static void
call_info_from_context(struct call_info *info, os_context_t *context)
{
unsigned long pc;
info->interrupted = 1;
if (lowtag_of(*os_context_register_addr(context, reg_CODE))
== FUN_POINTER_LOWTAG) {
/* We tried to call a function, but crapped out before $CODE could
* be fixed up. Probably an undefined function. */
info->frame =
(struct call_frame *)(unsigned long)
(*os_context_register_addr(context, reg_OCFP));
info->lra = (lispobj)(*os_context_register_addr(context, reg_LRA));
info->code = code_pointer(info->lra);
pc = (unsigned long)native_pointer(info->lra);
}
else {
info->frame =
(struct call_frame *)(unsigned long)
(*os_context_register_addr(context, reg_CFP));
info->code =
code_pointer(*os_context_register_addr(context, reg_CODE));
info->lra = NIL;
pc = *os_context_pc_addr(context);
}
if (info->code != NULL)
info->pc = pc - (unsigned long) info->code -
#ifndef LISP_FEATURE_ALPHA
(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
#else
(HEADER_LENGTH(((struct code *)info->code)->header) * sizeof(lispobj));
#endif
else
static void *compute_pc(lispobj code_obj, int pc_offset)
{
struct code *code;
code = (struct code *)native_pointer(code_obj);
return (void *)((char *)code + HeaderValue(code->header)*sizeof(lispobj)
+ pc_offset);
}
static lispobj
trans_sap(lispobj object)
{
gc_assert(is_lisp_pointer(object));
enqueue_sap_pointer(((struct sap *)native_pointer(object))->pointer);
return copy_unboxed_object(object, 2);
}
static void
print_entry_name (lispobj name)
{
if (lowtag_of (name) == LIST_POINTER_LOWTAG) {
putchar('(');
while (name != NIL) {
struct cons *cons = (struct cons *) native_pointer(name);
print_entry_name(cons->car);
name = cons->cdr;
if (name != NIL)
putchar(' ');
}
putchar(')');
} else if (lowtag_of(name) == OTHER_POINTER_LOWTAG) {
lispobj *object = (lispobj *) native_pointer(name);
if (widetag_of(*object) == SYMBOL_HEADER_WIDETAG) {
struct symbol *symbol = (struct symbol *) object;
if (symbol->package != NIL) {
struct package *pkg
= (struct package *) native_pointer(symbol->package);
lispobj pkg_name = pkg->_name;
if (string_equal(native_pointer(pkg_name), "COMMON-LISP"))
;
else if (string_equal(native_pointer(pkg_name), "COMMON-LISP-USER")) {
fputs("CL-USER::", stdout);
}
else if (string_equal(native_pointer(pkg_name), "KEYWORD")) {
putchar(':');
} else {
print_string(native_pointer(pkg_name));
fputs("::", stdout);
}
}
print_string(native_pointer(symbol->name));
} else if (widetag_of(*object) == SIMPLE_BASE_STRING_WIDETAG
#ifdef SIMPLE_CHARACTER_STRING_WIDETAG
|| widetag_of(*object) == SIMPLE_CHARACTER_STRING_WIDETAG
#endif
) {
putchar('"');
print_string(object);
putchar('"');
} else {
printf("<??? type %d>", (int) widetag_of(*object));
}
} else {
printf("<??? lowtag %d>", (int) lowtag_of(name));
}
}
static void
print_entry_points (struct code *code)
{
lispobj function = code->entry_points;
while (function != NIL) {
struct simple_fun *header = (struct simple_fun *) native_pointer(function);
print_entry_name(header->name);
function = header->next;
if (function != NIL)
printf (", ");
}
}
int
lutex_trylock (tagged_lutex_t tagged_lutex)
{
int ret = 0;
struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
ret = pthread_mutex_trylock(lutex->mutex);
/* The mutex is locked */
if (ret == EDEADLK || ret == EBUSY)
return ret;
lutex_assert(ret == 0);
return ret;
}
int
lutex_unlock (tagged_lutex_t tagged_lutex)
{
int ret = 0;
struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
ret = thread_mutex_unlock(lutex->mutex);
/* Unlocking unlocked mutex would occur as:
* (with-mutex (mutex) (cond-wait cond mutex)) */
if (ret == EPERM)
return ret;
lutex_assert(ret == 0);
return ret;
}
void *handle_fun_end_breakpoint(os_context_t *context)
{
lispobj code, lra;
struct code *codeptr;
DX_ALLOC_SAP(context_sap, context);
fake_foreign_function_call(context);
#ifndef LISP_FEATURE_SB_SAFEPOINT
unblock_gc_signals(0, 0);
#endif
code = find_code(context);
codeptr = (struct code *)native_pointer(code);
#ifndef LISP_FEATURE_WIN32
/* Don't disallow recursive breakpoint traps. Otherwise, we can't
* use debugger breakpoints anywhere in here. */
thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
#endif
funcall3(StaticSymbolFunction(HANDLE_BREAKPOINT),
compute_offset(context, code),
code,
context_sap);
lra = codeptr->constants[REAL_LRA_SLOT];
#ifdef LISP_FEATURE_PPC
/* PPC now passes LRA objects in reg_LRA during return. Other
* platforms should as well, but haven't been fixed yet. */
*os_context_register_addr(context, reg_LRA) = lra;
#else
#ifdef reg_CODE
*os_context_register_addr(context, reg_CODE) = lra;
#endif
#endif
undo_fake_foreign_function_call(context);
#ifdef reg_LRA
return (void *)(lra-OTHER_POINTER_LOWTAG+sizeof(lispobj));
#else
return compute_pc(lra, fixnum_value(codeptr->constants[REAL_LRA_SLOT+1]));
#endif
}
int
lutex_lock (tagged_lutex_t tagged_lutex)
{
int ret = 0;
struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
ret = thread_mutex_lock(lutex->mutex);
/* The mutex is locked by the same thread.
*
* FIXME: Usually when POSIX says that "an error value is returned"
* it actually refers to errno...
*/
if (ret == EDEADLK)
return ret;
lutex_assert(ret == 0);
return ret;
}
int
lutex_init (tagged_lutex_t tagged_lutex)
{
int ret;
struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
lutex->mutexattr = malloc(sizeof(pthread_mutexattr_t));
lutex_assert(lutex->mutexattr != 0);
ret = pthread_mutexattr_init(lutex->mutexattr);
lutex_assert(ret == 0);
/* The default type of mutex is implementation dependent.
* We use PTHREAD_MUTEX_ERRORCHECK so that locking on mutexes
* locked by the same thread does not cause deadlocks. */
/* FIXME: pthread_mutexattr_settype is available on SUSv2 level
* implementations. Can be used without checking? */
ret = pthread_mutexattr_settype(lutex->mutexattr,
PTHREAD_MUTEX_ERRORCHECK);
lutex_assert(ret == 0);
lutex->mutex = malloc(sizeof(pthread_mutex_t));
lutex_assert(lutex->mutex != 0);
ret = pthread_mutex_init(lutex->mutex, lutex->mutexattr);
lutex_assert(ret == 0);
lutex->condition_variable = malloc(sizeof(pthread_cond_t));
lutex_assert(lutex->condition_variable != 0);
ret = pthread_cond_init(lutex->condition_variable, NULL);
lutex_assert(ret == 0);
ret = thread_mutex_lock(&lutex_register_lock); lutex_assert(ret == 0);
gencgc_register_lutex(lutex);
ret = thread_mutex_unlock(&lutex_register_lock); lutex_assert(ret == 0);
return ret;
}
struct compiled_debug_fun *
debug_function_from_pc (struct code* code, void *pc)
{
uword_t code_header_len = sizeof(lispobj) * HeaderValue(code->header);
uword_t offset
= (uword_t) pc - (uword_t) code - code_header_len;
struct compiled_debug_fun *df;
struct compiled_debug_info *di;
struct vector *v;
int i, len;
if (lowtag_of(code->debug_info) != INSTANCE_POINTER_LOWTAG)
return 0;
di = (struct compiled_debug_info *) native_pointer(code->debug_info);
v = (struct vector *) native_pointer(di->fun_map);
len = fixnum_value(v->length);
df = (struct compiled_debug_fun *) native_pointer(v->data[0]);
if (len == 1)
return df;
for (i = 1;; i += 2) {
unsigned next_pc;
if (i == len)
return ((struct compiled_debug_fun *) native_pointer(v->data[i - 1]));
if (offset >= (uword_t)fixnum_value(df->elsewhere_pc)) {
struct compiled_debug_fun *p
= ((struct compiled_debug_fun *) native_pointer(v->data[i + 1]));
next_pc = fixnum_value(p->elsewhere_pc);
} else
next_pc = fixnum_value(v->data[i]);
if (offset < next_pc)
return ((struct compiled_debug_fun *) native_pointer(v->data[i - 1]));
}
return NULL;
}