static void print_trace (void) { void *array[100]; size_t size; char **strings; size_t i; size = backtrace(array, sizeof(array)/sizeof(void *)); strings = backtrace_symbols(array, size); #ifdef _REENTRANT Sdprintf("on_alarm() Prolog-context [thread %d]:\n", PL_thread_self()); #else Sdprintf("on_alarm() Prolog-context:\n"); #endif PL_action(PL_ACTION_BACKTRACE, 3); Sdprintf("on_alarm() C-context:\n"); for(i = 0; i < size; i++) { if ( !strstr(strings[i], "checkData") ) Sdprintf("\t[%d] %s\n", i, strings[i]); } free(strings); }
static void initPaths() { char plp[MAXPATHLEN]; char *symbols = NULL; /* The executable */ if ( !(symbols = findExecutable(GD->cmdline.argv[0], plp)) || !(symbols = DeRefLink(symbols, plp)) ) symbols = GD->cmdline.argv[0]; #ifdef OS2 symbols = GD->cmdline.argv[0]; #endif DEBUG(2, Sdprintf("rc-module: %s\n", symbols)); systemDefaults.home = findHome(symbols); #ifdef __WIN32__ /* we want no module but the .EXE */ symbols = findExecutable(NULL, plp); DEBUG(2, Sdprintf("Executable: %s\n", symbols)); #endif GD->paths.executable = store_string(symbols); systemDefaults.startup = store_string(PrologPath(DEFSTARTUP, plp)); GD->options.systemInitFile = defaultSystemInitFile(GD->cmdline.argv[0]); #ifdef O_XOS if ( systemDefaults.home ) { char buf[MAXPATHLEN]; _xos_limited_os_filename(systemDefaults.home, buf); systemDefaults.home = store_string(buf); } #endif }
static void registerWakeup(Word name, Word value ARG_LD) { Word wake; Word tail = valTermRef(LD->attvar.tail); assert(gTop+6 <= gMax && tTop+4 <= tMax); wake = gTop; gTop += 4; wake[0] = FUNCTOR_wakeup3; wake[1] = needsRef(*name) ? makeRef(name) : *name; wake[2] = needsRef(*value) ? makeRef(value) : *value; wake[3] = ATOM_nil; if ( *tail ) { Word t; /* Non-empty list */ deRef2(tail, t); TrailAssignment(t); *t = consPtr(wake, TAG_COMPOUND|STG_GLOBAL); TrailAssignment(tail); /* on local stack! */ *tail = makeRef(wake+3); DEBUG(1, Sdprintf("appended to wakeup\n")); } else /* empty list */ { Word head = valTermRef(LD->attvar.head); assert(isVar(*head)); TrailAssignment(head); /* See (*) */ *head = consPtr(wake, TAG_COMPOUND|STG_GLOBAL); TrailAssignment(tail); *tail = makeRef(wake+3); LD->alerted |= ALERT_WAKEUP; DEBUG(1, Sdprintf("new wakeup\n")); } }
void assignAttVar(Word av, Word value ARG_LD) { Word a; assert(isAttVar(*av)); assert(!isRef(*value)); assert(gTop+7 <= gMax && tTop+6 <= tMax); DEBUG(1, Sdprintf("assignAttVar(%s)\n", vName(av))); if ( isAttVar(*value) ) { if ( value > av ) { Word tmp = av; av = value; value = tmp; } else if ( av == value ) return; } a = valPAttVar(*av); registerWakeup(a, value PASS_LD); TrailAssignment(av); if ( isAttVar(*value) ) { DEBUG(1, Sdprintf("Unifying two attvars\n")); *av = makeRef(value); } else *av = *value; return; }
int prolog_debug_from_string(const char *spec, int flag) { const char *end; while((end=strchr(spec, ','))) { if ( end-spec < MAX_TOPIC_LEN ) { char buf[MAX_TOPIC_LEN]; strncpy(buf, spec, end-spec); buf[end-spec] = EOS; if ( !prolog_debug_topic(buf, flag) ) { Sdprintf("ERROR: Unknown debug topic: %s\n", buf); PL_halt(1); } spec = end+1; } else { Sdprintf("ERROR: Invalid debug topic: %s\n", spec); } } if ( !prolog_debug_topic(spec, flag) ) { Sdprintf("ERROR: Unknown debug topic: %s\n", spec); PL_halt(1); } return TRUE; }
functor_t lookupFunctorDef(atom_t atom, size_t arity) { GET_LD int v; FunctorDef *table; int buckets; FunctorDef f, head; redo: acquire_functor_table(table, buckets); v = (int)pointerHashValue(atom, buckets); head = table[v]; DEBUG(9, Sdprintf("Lookup functor %s/%d = ", stringAtom(atom), arity)); for(f = table[v]; f; f = f->next) { if (atom == f->name && f->arity == arity) { DEBUG(9, Sdprintf("%p (old)\n", f)); if ( !FUNCTOR_IS_VALID(f->flags) ) { goto redo; } release_functor_table(); return f->functor; } } if ( functorDefTable->buckets * 2 < GD->statistics.functors ) { LOCK(); rehashFunctors(); UNLOCK(); } if ( !( head == table[v] && table == functorDefTable->table ) ) goto redo; f = (FunctorDef) allocHeapOrHalt(sizeof(struct functorDef)); f->functor = 0L; f->name = atom; f->arity = arity; f->flags = 0; f->next = table[v]; if ( !( COMPARE_AND_SWAP(&table[v], head, f) && table == functorDefTable->table) ) { PL_free(f); goto redo; } registerFunctor(f); ATOMIC_INC(&GD->statistics.functors); PL_register_atom(atom); DEBUG(9, Sdprintf("%p (new)\n", f)); release_functor_table(); return f->functor; }
int wrlock(rwlock *lock, int allow_readers) { int self = PL_thread_self(); if ( lock->writer == self ) /* recursive write lock, used for */ { lock->lock_level++; /* nested transactions */ return TRUE; } pthread_mutex_lock(&lock->mutex); if ( lock->writer == -1 && lock->readers == 0 ) { ok: lock->writer = self; lock->lock_level = 1; lock->allow_readers = allow_readers; pthread_mutex_unlock(&lock->mutex); DEBUG(3, Sdprintf("WRLOCK(%d): OK\n", self)); return TRUE; } if ( self < lock->thread_max && lock->read_by_thread[self] > 0 ) { DEBUG(1, Sdprintf("SELF(%d) has %d readers\n", self, lock->read_by_thread[self])); pthread_mutex_unlock(&lock->mutex); return permission_error("write", "rdf_db", "default", "Operation would deadlock"); } lock->waiting_writers++; DEBUG(3, Sdprintf("WRLOCK(%d): waiting ...\n", self)); for(;;) { int rc = pthread_cond_wait(&lock->wrcondvar, &lock->mutex); if ( rc == EINTR ) { if ( PL_handle_signals() < 0 ) { lock->waiting_writers--; pthread_mutex_unlock(&lock->mutex); return FALSE; } continue; } else if ( rc == 0 ) { if ( lock->writer == -1 && lock->readers == 0 ) { lock->waiting_writers--; goto ok; } } else { assert(0); /* TBD: OS errors */ } } }
static word pl_crash() { intptr_t *lp = NULL; Sdprintf("You asked for it ... Writing to address 0\n"); *lp = 5; Sdprintf("Oops, this doesn't appear to be a secure OS\n"); fail; }
int wrlock(rwlock *lock, int allow_readers) { int self = PL_thread_self(); if ( lock->writer == self ) /* recursive write lock, used for */ { lock->lock_level++; /* nested transactions */ return TRUE; } EnterCriticalSection(&lock->mutex); if ( lock->writer == -1 && lock->readers == 0 ) { ok: lock->writer = self; lock->lock_level = 1; lock->allow_readers = allow_readers; LeaveCriticalSection(&lock->mutex); DEBUG(3, Sdprintf("WRLOCK(%d): OK\n", self)); return TRUE; } if ( self < lock->thread_max && lock->read_by_thread[self] > 0 ) { LeaveCriticalSection(&lock->mutex); return permission_error("write", "rdf_db", "default", "Operation would deadlock"); } lock->waiting_writers++; DEBUG(3, Sdprintf("WRLOCK(%d): waiting ...\n", self)); for(;;) { int rc = win32_cond_wait(&lock->wrcondvar, &lock->mutex); if ( rc == WAIT_INTR ) { lock->waiting_writers--; LeaveCriticalSection(&lock->mutex); return FALSE; } else if ( rc == 0 ) { if ( lock->writer == -1 && lock->readers == 0 ) { lock->waiting_writers--; goto ok; } } else { assert(0); /* TBD: OS errors */ } } }
static DWORD dde_initialise(void) { GET_LD DWORD ddeInst; dde_init_constants(); if ( !(ddeInst=LD->os.dde_instance) ) { if ( DdeInitializeW(&ddeInst, (PFNCALLBACK)DdeCallback, APPCLASS_STANDARD|CBF_FAIL_ADVISES|CBF_FAIL_POKES| CBF_SKIP_REGISTRATIONS|CBF_SKIP_UNREGISTRATIONS, 0L) == DMLERR_NO_ERROR) { LD->os.dde_instance = ddeInst; #ifdef O_PLMT PL_thread_at_exit(dde_uninitialise, NULL, FALSE); #endif } else { dde_warning("initialise"); } DEBUG(1, Sdprintf("Thread %d: created ddeInst %d\n", PL_thread_self(), ddeInst)); } return ddeInst; }
static int Sclose_process(void *handle) { process_context *pc; int fd = process_fd(handle, &pc); if ( fd >= 0 ) { int which = (int)(uintptr_t)handle & 0x3; int rc; rc = (*Sfilefunctions.close)((void*)(uintptr_t)fd); pc->open_mask &= ~(1<<which); DEBUG(Sdprintf("Closing fd[%d]; mask = 0x%x\n", which, pc->open_mask)); if ( !pc->open_mask ) { int rcw = wait_for_process(pc); return rcw ? 0 : -1; } return rc; } return -1; }
static Code listSupervisor(Definition def) { if ( def->impl.clauses.number_of_clauses == 2 ) { ClauseRef cref[2]; word c[2]; int found = getClauses(def, cref, 2); if ( found == 2 && arg1Key(cref[0]->value.clause->codes, &c[0]) && arg1Key(cref[1]->value.clause->codes, &c[1]) && ( (c[0] == ATOM_nil && c[1] == FUNCTOR_dot2) || (c[1] == ATOM_nil && c[0] == FUNCTOR_dot2) ) ) { Code codes = allocCodes(3); DEBUG(1, Sdprintf("List supervisor for %s\n", predicateName(def))); codes[0] = encode(S_LIST); if ( c[0] == ATOM_nil ) { codes[1] = (code)cref[0]; codes[2] = (code)cref[1]; } else { codes[1] = (code)cref[1]; codes[2] = (code)cref[0]; } return codes; } } return NULL; }
static word unify_hdata(term_t t, HDDEDATA data) { BYTE buf[FASTBUFSIZE]; DWORD len; if ( !(len=DdeGetData(data, buf, sizeof(buf), 0)) ) return dde_warning("data handle"); DEBUG(1, Sdprintf("DdeGetData() returned %ld bytes\n", (long)len)); if ( len == sizeof(buf) ) { if ( (len=DdeGetData(data, NULL, 0, 0)) > 0 ) { LPBYTE b2; int rval; if ( !(b2 = malloc(len)) ) return PL_no_memory(); DdeGetData(data, b2, len, 0); rval = PL_unify_wchars(t, PL_ATOM, len/sizeof(wchar_t)-1, (wchar_t*)b2); free(b2); return rval; } return dde_warning("data handle"); } return PL_unify_wchars(t, PL_ATOM, len/sizeof(wchar_t)-1, (wchar_t*)buf); }
int PL_wait_for_console_input(void *handle) { BOOL rc; HANDLE hConsole = handle; for(;;) { rc = MsgWaitForMultipleObjects(1, &hConsole, FALSE, /* wait for either event */ INFINITE, QS_ALLINPUT); if ( rc == WAIT_OBJECT_0+1 ) { MSG msg; while( PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) ) { TranslateMessage(&msg); DispatchMessage(&msg); } } else if ( rc == WAIT_OBJECT_0 ) { return TRUE; } else { Sdprintf("MsgWaitForMultipleObjects(): 0x%x\n", rc); } } }
char * findExecutable(const char *module, char *exe) { int n; wchar_t wbuf[MAXPATHLEN]; HMODULE hmod; if ( module ) { if ( !(hmod = GetModuleHandle(module)) ) { hmod = GetModuleHandle("libswipl.dll"); DEBUG(0, Sdprintf("Warning: could not find module from \"%s\"\n" "Warning: Trying %s to find home\n", module, hmod ? "\"LIBPL.DLL\"" : "executable")); } } else hmod = NULL; if ( (n = GetModuleFileNameW(hmod, wbuf, MAXPATHLEN)) > 0 ) { wbuf[n] = EOS; return _xos_long_file_name_toA(wbuf, exe, MAXPATHLEN); } else if ( module ) { char buf[MAXPATHLEN]; PrologPath(module, buf, sizeof(buf)); strcpy(exe, buf); } else *exe = EOS; return exe; }
int currentOperator(Module m, atom_t name, int kind, int *type, int *priority) { operator *op; assert(kind >= OP_PREFIX && kind <= OP_POSTFIX); if ( !m ) m = MODULE_user; if ( (op = visibleOperator(m, name, kind)) ) { if ( op->priority[kind] > 0 ) { *type = op->type[kind]; *priority = op->priority[kind]; DEBUG(MSG_OPERATOR, Sdprintf("currentOperator(%s) --> %s %d\n", PL_atom_chars(name), PL_atom_chars(operatorTypeToAtom(*type)), *priority)); succeed; } } fail; }
static int defOperator(Module m, atom_t name, int type, int priority, int force) { GET_LD Symbol s; operator *op; int t = (type & OP_MASK); /* OP_PREFIX, ... */ DEBUG(7, Sdprintf(":- op(%d, %s, %s) in module %s\n", priority, PL_atom_chars(operatorTypeToAtom(type)), PL_atom_chars(name), PL_atom_chars(m->name))); assert(t>=OP_PREFIX && t<=OP_POSTFIX); if ( !force && !SYSTEM_MODE ) { if ( name == ATOM_comma || (name == ATOM_bar && ((t&OP_MASK) != OP_INFIX || (priority < 1001 && priority != 0))) ) { GET_LD atom_t action = (name == ATOM_comma ? ATOM_modify : ATOM_create); term_t t = PL_new_term_ref(); PL_put_atom(t, name); return PL_error(NULL, 0, NULL, ERR_PERMISSION, action, ATOM_operator, t); } } LOCK(); if ( !m->operators ) m->operators = newOperatorTable(8); if ( (s = lookupHTable(m->operators, (void *)name)) ) { op = s->value; } else if ( priority < 0 ) { UNLOCK(); /* already inherited: do not change */ return TRUE; } else { op = allocHeapOrHalt(sizeof(*op)); op->priority[OP_PREFIX] = -1; op->priority[OP_INFIX] = -1; op->priority[OP_POSTFIX] = -1; op->type[OP_PREFIX] = OP_INHERIT; op->type[OP_INFIX] = OP_INHERIT; op->type[OP_POSTFIX] = OP_INHERIT; } op->priority[t] = priority; op->type[t] = (priority >= 0 ? type : OP_INHERIT); if ( !s ) { PL_register_atom(name); addHTable(m->operators, (void *)name, op); } UNLOCK(); return TRUE; }
static int unify_hdata(term_t t, HDDEDATA data) { char buf[FASTBUFSIZE]; int len; if ( !(len=DdeGetData(data, buf, sizeof(buf)-1, 0)) ) return dde_warning("data handle"); DEBUG(0, Sdprintf("DdeGetData() returned %d bytes\n", len)); if ( len == sizeof(buf)-1 ) { if ( (len=DdeGetData(data, NULL, 0, 0)) > 0 ) { char *b2 = malloc(len+1); int rval; DdeGetData(data, b2, len, 0); b2[len] = 0; rval = PL_unify_atom_chars(t, b2); free(b2); return rval; } return dde_warning("data handle"); } buf[len] = 0; return PL_unify_atom_chars(t, buf); }
static void * mp_realloc(void *ptr, size_t oldsize, size_t newsize) { GET_LD mp_mem_header *oldmem, *newmem; if ( LD->gmp.persistent ) return realloc(ptr, newsize); oldmem = ((mp_mem_header*)ptr)-1; if ( TOO_BIG_GMP(newsize) || !(newmem = realloc(oldmem, sizeof(mp_mem_header)+newsize)) ) { gmp_too_big(); abortProlog(); PL_rethrow(); return NULL; /* make compiler happy */ } if ( oldmem != newmem ) /* re-link if moved */ { if ( newmem->prev ) newmem->prev->next = newmem; else LD->gmp.head = newmem; if ( newmem->next ) newmem->next->prev = newmem; else LD->gmp.tail = newmem; } GMP_LEAK_CHECK(LD->gmp.allocated -= oldsize; LD->gmp.allocated += newsize); DEBUG(9, Sdprintf("GMP: realloc %ld@%p --> %ld@%p\n", oldsize, ptr, newsize, &newmem[1])); return &newmem[1]; }
static void mp_free(void *ptr, size_t size) { GET_LD mp_mem_header *mem; if ( LD->gmp.persistent ) { free(ptr); return; } mem = ((mp_mem_header*)ptr)-1; if ( mem == LD->gmp.head ) { LD->gmp.head = LD->gmp.head->next; if ( LD->gmp.head ) LD->gmp.head->prev = NULL; else LD->gmp.tail = NULL; } else if ( mem == LD->gmp.tail ) { LD->gmp.tail = LD->gmp.tail->prev; LD->gmp.tail->next = NULL; } else { mem->prev->next = mem->next; mem->next->prev = mem->prev; } free(mem); DEBUG(9, Sdprintf("GMP: free: %ld@%p\n", size, ptr)); GMP_LEAK_CHECK(LD->gmp.allocated -= size); }
static void * mp_alloc(size_t bytes) { GET_LD mp_mem_header *mem; if ( LD->gmp.persistent ) return malloc(bytes); if ( TOO_BIG_GMP(bytes) || !(mem = malloc(sizeof(mp_mem_header)+bytes)) ) { gmp_too_big(); abortProlog(); PL_rethrow(); return NULL; /* make compiler happy */ } GMP_LEAK_CHECK(LD->gmp.allocated += bytes); mem->next = NULL; mem->context = LD->gmp.context; if ( LD->gmp.tail ) { mem->prev = LD->gmp.tail; LD->gmp.tail->next = mem; LD->gmp.tail = mem; } else { mem->prev = NULL; LD->gmp.head = LD->gmp.tail = mem; } DEBUG(9, Sdprintf("GMP: alloc %ld@%p\n", bytes, &mem[1])); return &mem[1]; }
Symbol addHTable(Table ht, void *name, void *value) { Symbol s; int v; LOCK_TABLE(ht); v = (int)pointerHashValue(name, ht->buckets); if ( lookupHTable(ht, name) ) { UNLOCK_TABLE(ht); return NULL; } s = allocHeapOrHalt(sizeof(struct symbol)); s->name = name; s->value = value; s->next = ht->entries[v]; ht->entries[v] = s; ht->size++; DEBUG(9, Sdprintf("addHTable(0x%x, 0x%x, 0x%x) --> size = %d\n", ht, name, value, ht->size)); if ( ht->buckets * 2 < ht->size && !ht->enumerators ) s = rehashHTable(ht, s); UNLOCK_TABLE(ht); DEBUG(1, checkHTable(ht)); return s; }
int outOfStack(void *stack, stack_overflow_action how) { GET_LD Stack s = stack; const char *msg = "unhandled stack overflow"; if ( LD->outofstack ) { Sdprintf("[Thread %d]: failed to recover from %s-overflow\n", PL_thread_self(), s->name); print_backtrace_named(msg); save_backtrace("crash"); print_backtrace_named("crash"); fatalError("Sorry, cannot continue"); return FALSE; /* NOTREACHED */ } save_backtrace(msg); LD->trim_stack_requested = TRUE; LD->exception.processing = TRUE; LD->outofstack = stack; switch(how) { case STACK_OVERFLOW_THROW: case STACK_OVERFLOW_RAISE: { fid_t fid; blockGC(0 PASS_LD); if ( (fid=PL_open_foreign_frame()) ) { PL_clearsig(SIG_GC); s->gced_size = 0; /* after handling, all is new */ if ( !PL_unify_term(LD->exception.tmp, PL_FUNCTOR, FUNCTOR_error2, PL_FUNCTOR, FUNCTOR_resource_error1, PL_ATOM, ATOM_stack, PL_CHARS, s->name) ) fatalError("Out of stack inside out-of-stack handler"); if ( how == STACK_OVERFLOW_THROW ) { PL_close_foreign_frame(fid); unblockGC(0 PASS_LD); PL_throw(LD->exception.tmp); warning("Out of %s stack while not in Prolog!?", s->name); assert(0); } else { PL_raise_exception(LD->exception.tmp); } PL_close_foreign_frame(fid); } unblockGC(0 PASS_LD); fail; } } assert(0); fail; }
static int chunked_close(void *handle) { chunked_context *ctx = handle; int rc = 0; DEBUG(1, Sdprintf("chunked_close() ...\n")); if ( (ctx->chunked_stream->flags & SIO_OUTPUT) ) { if ( Sfprintf(ctx->stream, "0\r\n\r\n") < 0 ) rc = -1; } ctx->stream->encoding = ctx->parent_encoding; if ( ctx->close_parent ) { IOSTREAM *parent = ctx->stream; int rc2; free_chunked_context(ctx); rc2 = Sclose(parent); if ( rc == 0 ) rc = rc2; } else { free_chunked_context(ctx); } return rc; }
int destroySourceFile(SourceFile sf) { DEBUG(MSG_SRCFILE, Sdprintf("Destroying source file %s\n", PL_atom_chars(sf->name))); clearSourceAdmin(sf); LOCK(); if ( sf->magic == SF_MAGIC ) { SourceFile f; sf->magic = SF_MAGIC_DESTROYING; f = deleteHTable(GD->files.table, (void*)sf->name); assert(f); PL_unregister_atom(sf->name); putSourceFileArray(sf->index, NULL); if ( GD->files.no_hole_before > sf->index ) GD->files.no_hole_before = sf->index; } UNLOCK(); unallocSourceFile(sf); return TRUE; }
static int gmp_too_big() { GET_LD DEBUG(1, Sdprintf("Signalling GMP overflow\n")); return (int)outOfStack((Stack)&LD->stacks.global, STACK_OVERFLOW_THROW); }
checkFunctors() { FunctorDef f; int n; for( n=0; n < functor_buckets; n++ ) { f = functorDefTable[n]; for( ;f ; f = f->next ) { if ( f->arity < 0 || f->arity > 10 ) /* debugging only ! */ Sdprintf("[ERROR: Functor %ld has dubious arity: %d]\n", f, f->arity); if ( !isArom(f->name) ) Sdprintf("[ERROR: Functor %ld has illegal name: %ld]\n", f, f->name); if ( !( f->next == (FunctorDef) NULL || inCore(f->next)) ) Sdprintf("[ERROR: Functor %ld has illegal next: %ld]\n", f, f->next); } } }
void assignAttVar(Word av, Word value, int flags ARG_LD) { Word a; mark m; assert(isAttVar(*av)); assert(!isRef(*value)); assert(gTop+8 <= gMax && tTop+6 <= tMax); DEBUG(CHK_SECURE, assert(on_attvar_chain(av))); DEBUG(1, Sdprintf("assignAttVar(%s)\n", vName(av))); if ( isAttVar(*value) ) { if ( value > av ) { Word tmp = av; av = value; value = tmp; } else if ( av == value ) return; } if( !(flags & ATT_ASSIGNONLY) ) { a = valPAttVar(*av); registerWakeup(av, a, value PASS_LD); } if ( (flags&ATT_WAKEBINDS) ) return; Mark(m); /* must be trailed, even if above last choice */ LD->mark_bar = NO_MARK_BAR; TrailAssignment(av); DiscardMark(m); if ( isAttVar(*value) ) { DEBUG(1, Sdprintf("Unifying two attvars\n")); *av = makeRef(value); } else if ( isVar(*value) ) { DEBUG(1, Sdprintf("Assigning attvar with plain var\n")); *av = makeRef(value); /* JW: Does this happen? */ } else *av = *value; return; }
static void script_argv(int argc, char **argv) { FILE *fd; int i; DEBUG(1, { for(i=0; i< argc; i++) Sdprintf("argv[%d] = '%s'\n", i, argv[i]); });
int exitTables(int status, void *arg) { (void)status; (void)arg; Sdprintf("hashstat: Anonymous tables: %d lookups using %d compares\n", lookups, cmps); return 0; }